MUMPS_5.4.1/0000775000175000017500000000000014102210531012713 5ustar jylexceljylexcelMUMPS_5.4.1/Makefile0000664000175000017500000000336014102210467014365 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # topdir = . libdir = $(topdir)/lib default: d .PHONY: default all s d c z prerequisites libseqneeded clean all: prerequisites cd src; $(MAKE) all cd examples; $(MAKE) all s: prerequisites cd src; $(MAKE) s cd examples; $(MAKE) s d: prerequisites cd src; $(MAKE) d cd examples; $(MAKE) d c: prerequisites cd src; $(MAKE) c cd examples; $(MAKE) c z: prerequisites cd src; $(MAKE) z cd examples; $(MAKE) z # Is Makefile.inc available ? Makefile.inc: @echo "######################################################################" @echo "# BEFORE COMPILING MUMPS, YOU MUST HAVE AN APPROPRIATE Makefile.inc" @echo "# FILE AVAILABLE. PLEASE CHECK THE DIRECTORY ./Make.inc FOR EXAMPLES" @echo "# OF Makefile.inc FILES, AND USE Make.inc/Makefile.inc.generic IF YOU" @echo "# NEED TO BUILD A NEW ONE. SEE ALSO THE README AND INSTALL FILES" @echo "######################################################################" @exit 1 include Makefile.inc prerequisites: Makefile.inc $(LIBSEQNEEDED) $(libdir)/libpord$(PLAT)$(LIBEXT) # dummy MPI library (sequential version) libseqneeded: (cd libseq; $(MAKE)) # Build the libpord.a library and copy it into $(topdir)/lib $(libdir)/libpord$(PLAT)$(LIBEXT): if [ "$(LPORDDIR)" != "" ] ; then \ cd $(LPORDDIR); \ $(MAKE) CC="$(CC)" CFLAGS="$(OPTC)" AR="$(AR)" RANLIB="$(RANLIB)" OUTC="$(OUTC)" LIBEXT=$(LIBEXT); \ fi; if [ "$(LPORDDIR)" != "" ] ; then \ cp $(LPORDDIR)/libpord$(LIBEXT) $@; \ fi; clean: (cd src; $(MAKE) clean) (cd examples; $(MAKE) clean) (cd $(libdir); $(RM) *$(PLAT)$(LIBEXT)) (cd libseq; $(MAKE) clean) if [ "$(LPORDDIR)" != "" ] ; then \ cd $(LPORDDIR); $(MAKE) realclean; \ fi; MUMPS_5.4.1/README0000664000175000017500000000405114102210467013603 0ustar jylexceljylexcel=========================================== MUMPS 5.4.1 =========================================== MUMPS 5.4.1 solves a sparse system of linear equations A x = b using Gaussian elimination. Please read this README file and the documentation (in ./doc/) for a complete list of functionalities. Documentation and publications related to MUMPS can also be found at http://mumps-solver.org/ For installation problems, bug reports, and to report your experience/feedback with the package, please subscribe to the MUMPS Users's mailing list. Please refer to INSTALL for installation instructions. Please refer to LICENSE for conditions of use the package. Contents of the distribution: ---------------------------- ChangeLog LICENSE CREDITS INSTALL README VERSION Makefile Make.inc/ doc/ src/ lib/ include/ libseq/ examples/ PORD/ MATLAB/ SCILAB/ doc contains the users' guide in pdf format. src contains the source files (for all arithmetics 's','d','c' or 'z') necessary to generate the MUMPS library. lib is the place where the MUMPS libraries libxmumps.a (x='s','d','c' or 'z') and the arith-independent library libmumps_common.a are generated. include contains xmumps_struc.h, xmumps_root.h and xmumps_c.h (where x is one of 'd','c','s','z' depending on the arithmetic desired), mumps_c_types.h and mumps_compat.h. The first two files must be available at compile time in order to use MUMPS from external FORTRAN programs. The three others for C programs. libseq contains a sequential MPI library used by the purely sequential version of MUMPS. examples contains illustrative test programs showing how MUMPS can be used. PORD contains the PORD package (not part of MUMPS) from University of Paderborn. See PORD/README for more info. MATLAB contains a MATLAB interface to the sequential version of MUMPS SCILAB contains a SCILAB interface to the sequential version of MUMPS (only tested with scilab version 4) MUMPS_5.4.1/Make.inc/0000775000175000017500000000000014102210467014350 5ustar jylexceljylexcelMUMPS_5.4.1/Make.inc/Makefile.SP.PAR0000664000175000017500000000750214102210467016756 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-Dparmetis #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSC = -Dpord ORDERINGSF = -WF,-Dpord LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpcc FC = mpxlf90 FL = mpxlf90 AR = ar vr RANLIB = ranlib LAPACK = /usr/local/pub/LAPACK/lapack.a #LAPACK = /usr/common/usg/LAPACK/3.0a/lapack_SP.a #LAPACK = /usr/local/lib/liblapack_cci.a SCALAP = -lpessl -lblacs INCPAR = # -I/usr/lpp/ppe.poe/include LIBPAR = $(SCALAP) $(LAPACK) # -L/usr/lpp/ppe.poe/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lessl LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = #Begin Optimization options OPTF = -WF,-DPESSL -WF,-DSP_ -O3 -qstrict -qmaxmem=-1 -Q -qfixed -qalign=4k -qarch=auto -qtune=auto -qcache=auto -q32 -bmaxdata:0x80000000 -B/usr/lib/ -tF OPTC = -O3 -qstrict -qarch=auto -qtune=auto -qcache=auto -Q=150 -s -qmaxmem=-1 -qcpluscmt -q32 -bmaxdata:0x80000000 OPTL = -O3 -qstrict -Q -qfixed -qalign=4k -q32 -bmaxdata:0x80000000 #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.WIN.MS-Intel.SEQ0000664000175000017500000000734014102210467020466 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # # We are grateful to Evgenii Rudnyi for his help and suggestions # regarding Windows installation. #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS, PATHMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #PATHSCOTCH = -LIBPATH:$(SCOTCHDIR)/lib #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = libscotch.lib libscotcherr.lib libesmumps.lib #LSCOTCH = libptscotch.lib libptscotcherr.lib libptesmumps.lib libscotch.lib LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ PATHPORD = -LIBPATH:$(LPORDDIR) LPORD = libpord.lib #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #PATHMETIS = -LIBPATH:$(LMETISDIR) #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = libmetis.lib #LMETIS = libparmetis.lib libmetis.lib # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) PATHORDERINGS = $(PATHMETIS) $(PATHPORD) $(PATHSCOTCH) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # For Windows #End orderings ######################################################################## ######################################################################## ################################################################################ PLAT = LIBEXT = .lib OUTC = -Fo OUTF = -Fo RM = /bin/rm -f CC = cl FC = ifort FL = ifort AR = lib -out: #RANLIB = ranlib RANLIB = echo INCSEQ = -I$(topdir)/libseq LIBSEQ = $(topdir)/libseq/libmpiseq.lib #LIBBLAS = -L/usr/lib/xmm/ -lf77blas -latlas #LIBBLAS = -L/local/BLAS -lblas LIBBLAS = mkl_intel_c.lib mkl_intel_thread.lib mkl_core.lib libiomp5md.lib #LIBOTHERS = -lpthread LIBOTHERS = -link $(PATHORDERINGS) #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -MD -Dintel_ -DGEMMT_AVAILABLE -fpp OPTL = OPTC = -O2 -MD #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.SGI.SEQ0000664000175000017500000000655414102210467017072 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = /usr/lib64/libcomplib.sgimath.so INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimization options OPTF = -Dsgi -O -OPT:Olimit=0 -mips4 -64 -align64 OPTL = -O -OPT:Olimit=0 -mips4 -64 -align64 OPTC = -O -OPT:Olimit=0 -mips4 -64 -align64 NOOPT = -Dsgi -mips4 -64 -align64 #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.SP.SEQ0000664000175000017500000000731314102210467016764 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-Dparmetis #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSC = -Dpord ORDERINGSF = -WF,-Dpord LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc FC = xlf90 FL = xlf90 AR = ar vr RANLIB = ranlib LAPACK = /usr/local/pub/LAPACK/lapack.a #LAPACK = /usr/common/usg/LAPACK/3.0a/lapack_SP.a #LAPACK = /usr/local/lib/liblapack_cci.a INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lessl LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = #Begin Optimization options OPTF = -WF,-DPESSL -WF,-DSP_ -O3 -qstrict -qmaxmem=-1 -Q -qfixed -qalign=4k -qarch=auto -qtune=auto -qcache=auto -q32 -bmaxdata:0x80000000 -B/usr/lib/ -tF OPTC = -O3 -qstrict -qarch=auto -qtune=auto -qcache=auto -Q=150 -s -qmaxmem=-1 -qcpluscmt -q32 -bmaxdata:0x80000000 OPTL = -O3 -qstrict -Q -qfixed -qalign=4k -q32 -bmaxdata:0x80000000 #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.NEC.PAR0000664000175000017500000000725614102210467017047 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = rm -f CC = mpincc FC = mpinfort FL = mpinfort AR = nar vr RANLIB = echo LAPACK = -llapack SCALAP = -lscalapack #INCPAR = LIBPAR = $(SCALAP) $(LAPACK) INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas_openmp LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ # # Inline basics # STRIP_TOPDIR = $(strip $(topdir)) MUMPS_INLINE_LIST = -finline-functions -finline-max-depth=5 -finline-max-function-size=500 # # Inline search on the whole directory # MUMPS_INLINE_LIST += -finline-directory=$(STRIP_TOPDIR)/src #Begin Optimization options OPTF = -O2 -DGEMMT_AVAILABLE -fpp -fopenmp -Wobsolescent -Wextension -Wall -Woverflow $(MUMPS_INLINE_LIST) OPTL = -O2 -fopenmp OPTC = -O2 -fopenmp -Wall #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.SP64.PAR0000664000175000017500000000742314102210467017132 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-Dparmetis #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSC = -Dpord ORDERINGSF = -WF,-Dpord LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpcc_r FC = mpxlf90_r FL = mpxlf90_r AR = ar -X64 vr RANLIB = ranlib LAPACK = /usr/local/pub/LAPACK/lapack.a #LAPACK = /usr/common/usg/LAPACK/3.0a/lapack_SP.a #LAPACK = /usr/local/lib/liblapack_cci.a SCALAP = -lpesslsmp -lblacssmp INCPAR = # -I/usr/lpp/ppe.poe/include LIBPAR = $(SCALAP) $(LAPACK) # -L/usr/lpp/ppe.poe/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lessl LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = #Begin Optimization options OPTF = -WF,-DPESSL -WF,-DSP_ -O3 -qstrict -qmaxmem=-1 -Q -qfixed -qalign=4k -qarch=auto -qtune=auto -qcache=auto -q64 -B/usr/lib/ -tF OPTC = -O3 -qstrict -qarch=auto -qtune=auto -qcache=auto -Q=150 -s -qmaxmem=-1 -qcpluscmt -q64 OPTL = -O3 -qstrict -Q -qfixed -qalign=4k -q64 #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.WIN.MS-G95.SEQ0000664000175000017500000000721514102210467017760 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # # We are grateful to Evgenii Rudnyi for his help and suggestions # regarding Windows installation. #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS, PATHMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #PATHSCOTCH = -LIBPATH:$(SCOTCHDIR)/lib #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = libscotch.lib libscotcherr.lib libesmumps.lib #LSCOTCH = libptscotch.lib libptscotcherr.lib libptesmumps.lib libscotch.lib LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ PATHPORD = -LIBPATH:$(LPORDDIR) LPORD = libpord.lib #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #PATHMETIS = -LIBPATH:$(LMETISDIR) #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = libmetis.lib #LMETIS = libparmetis.lib libmetis.lib # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) PATHORDERINGS = $(PATHMETIS) $(PATHPORD) $(PATHSCOTCH) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # For Windows #End orderings ######################################################################## ######################################################################## ################################################################################ PLAT = LIBEXT = .lib OUTC = -Fo OUTF = -o RM = /bin/rm -f CC = cl FC = g95 FL = cl AR = lib -out: RANLIB = echo INCSEQ = -I$(topdir)/libseq LIBSEQ = $(topdir)/libseq/libmpiseq.lib LIBBLAS = mkl_intel_c.lib mkl_intel_thread.lib mkl_core.lib libiomp5md.lib LIBOTHERS = libf95.lib libgcc.lib -link $(PATHORDERINGS) #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimization options OPTF = -O -i4 -fno-underscoring -fcase-upper OPTL = OPTC = -O2 -MD #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.FREEBSD10.PAR0000664000175000017500000000700114102210467017641 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o "" OUTF = -o "" RM = /bin/rm -f CC = cc FC = gfortran48 FL = gfortran48 # keep a space at the end if options have to be separated from lib name AR = ar -vr "" RANLIB = ranlib LAPACK = -llapack SCALAP = -lscalapack -lblacs INCPAR = -I/usr/local/include LIBPAR = $(SCALAP) $(LAPACK) -L/usr/local/lib -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options # uncomment -fopenmp in lines below to benefit from OpenMP OPTF = -O #-fopenmp OPTL = -O #-fopenmp OPTC = -O -I. #-fopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.INTEL.SEQ0000664000175000017500000000707314102210467017320 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = icc FC = ifort FL = ifort AR = ar vr #RANLIB = ranlib RANLIB = echo # Make this variable point to the path where the Intel MKL library is # installed. It is set to the default install directory for Intel MKL. MKLROOT=/opt/intel/mkl/lib/intel64 LAPACK = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -nofor_main -DBLR_MT -qopenmp -DGEMMT_AVAILABLE OPTL = -O -nofor_main -qopenmp OPTC = -O -qopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.G95.SEQ0000664000175000017500000000661214102210467017007 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = gcc FC = g95 FL = g95 AR = ar vr RANLIB = echo LAPACK =/usr/local/ATLAS/lib/Linux_P4SSE2/liblapack.a INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq #LIBBLAS = /usr/local/lib/libgoto_coppermine32p-r1.00.so LIBBLAS =/usr/local/ATLAS/lib/Linux_P4SSE2/libf77blas.a /usr/local/ATLAS/lib/Linux_P4SSE2/libatlas.a -lg2c LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimization options OPTF = -O -i4 OPTL = -O OPTC = -O #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.SGI.PAR0000664000175000017500000000673314102210467017063 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = /usr/lib64/libcomplib.sgimath.so SCALAP = -L/usr/lib64 -lscalapack64 -lmpiblacs64 INCPAR = -I/usr/include/ LIBPAR = $(SCALAP) $(LAPACK) -L/usr/lib64/ -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimization options OPTF = -Dsgi -O -OPT:Olimit=0 -mips4 -64 -align64 OPTL = -O -OPT:Olimit=0 -mips4 -64 -align64 OPTC = -O -OPT:Olimit=0 -mips4 -64 -align64 NOOPT = -Dsgi -mips4 -64 -align64 #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.debian.PAR0000664000175000017500000000363414102210467017660 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # # These settings for a PC under Debian/linux with standard packages : # metis (parmetis), scotch (ptscotch), openmpi, gfortran # packages installation: # apt-get install libmetis-dev libparmetis-dev libscotch-dev libptscotch-dev libatlas-base-dev openmpi-bin libopenmpi-dev liblapack-dev # Begin orderings LSCOTCHDIR = /usr/lib ISCOTCH = -I/usr/include/scotch #LSCOTCH = -L$(LSCOTCHDIR) -lptesmumps -lptscotch -lptscotcherr LSCOTCH = -L$(LSCOTCHDIR) -lesmumps -lscotch -lscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord LMETISDIR = /usr/lib #IMETIS = -I/usr/include/parmetis IMETIS = -I/usr/include/metis # LMETIS = -L$(LMETISDIR) -lparmetis -lmetis LMETIS = -L$(LMETISDIR) -lmetis # Corresponding variables reused later #ORDERINGSF = -Dmetis -Dpord -Dparmetis -Dscotch -Dptscotch ORDERINGSF = -Dmetis -Dpord -Dscotch ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # End orderings ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpicc FC = mpif90 FL = mpif90 AR = ar vr RANLIB = ranlib LAPACK = -llapack SCALAP = -lscalapack-openmpi -lblacs-openmpi INCPAR = # not needed with mpif90/mpicc: -I/usr/include/openmpi LIBPAR = $(SCALAP) $(LAPACK) # not needed with mpif90/mpicc: -lmpi_mpifh -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -fopenmp OPTL = -O -fopenmp OPTC = -O -fopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.FREEBSD10.SEQ0000664000175000017500000000663414102210467017662 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o "" OUTF = -o "" RM = /bin/rm -f CC = cc FC = gfortran48 FL = gfortran48 # keep a space at the end if options have to be separated from lib name AR = ar -vr "" RANLIB = ranlib LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options # uncomment -fopenmp in lines below to benefit from OpenMP OPTF = -O #-fopenmp OPTL = -O #-fopenmp OPTC = -O -I. #-fopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.SP64.SEQ0000664000175000017500000000722614102210467017141 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -WF,-Dscotch -WF,-Dmetis -WF,-Dpord -WF,-Dptscotch -WF,-Dparmetis #ORDERINGSC = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSC = -Dpord ORDERINGSF = -WF,-Dpord LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = cc_r FC = xlf90_r FL = xlf90_r AR = ar -X64 vr RANLIB = ranlib LAPACK = /usr/local/pub/LAPACK/lapack.a #LAPACK = /usr/common/usg/LAPACK/3.0a/lapack_SP.a #LAPACK = /usr/local/lib/liblapack_cci.a INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lessl LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = #Begin Optimization options OPTF = -WF,-DPESSL -WF,-DSP_ -O3 -qstrict -qmaxmem=-1 -Q -qfixed -qalign=4k -qarch=auto -qtune=auto -qcache=auto -q64 -B/usr/lib/ -tF OPTC = -O3 -qstrict -qarch=auto -qtune=auto -qcache=auto -Q=150 -s -qmaxmem=-1 -qcpluscmt -q64 OPTL = -O3 -qstrict -Q -qfixed -qalign=4k -q64 #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.inc.generic0000664000175000017500000001304014102210467020171 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # ################################################################################ # # Makefile.inc.generic # # This defines some parameters dependent on your platform; you should # look for the approriate file in the directory ./Make.inc/ and copy it # into a file called Makefile.inc. For example, from the MUMPS root # directory, use # "cp Make.inc/Makefile.inc.generic ./Makefile.inc" # (see the main README file for details) # # If you do not find any suitable Makefile in Makefile.inc, use this file: # "cp Make.inc/Makefile.inc.generic ./Makefile.inc" and modify it according # to the comments given below. If you manage to build MUMPS on a new platform, # and think that this could be useful to others, you may want to send us # the corresponding Makefile.inc file. # ################################################################################ ######################################################################## #Begin orderings # # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## # DEFINE HERE SOME COMMON COMMANDS, THE COMPILER NAMES, ETC... # PLAT : use it to add a default suffix to the generated libraries PLAT = # Library extension, + C and Fortran "-o" option # may be different under Windows LIBEXT = .a OUTC = -o OUTF = -o # RM : remove files RM = /bin/rm -f # CC : C compiler CC = cc # FC : Fortran 90 compiler FC = f90 # FL : Fortran linker FL = f90 # AR : Archive object in a library # keep a space at the end if options have to be separated from lib name AR = ar vr # RANLIB : generate index of an archive file # (optionnal use "RANLIB = echo" in case of problem) RANLIB = ranlib #RANLIB = echo # DEFINE HERE YOUR LAPACK LIBRARY LAPACK = -llapack # SCALAP should define the SCALAPACK and BLACS libraries. SCALAP = -lscalapack -lblacs # INCLUDE DIRECTORY FOR MPI INCPAR = -I/usr/include # LIBRARIES USED BY THE PARALLEL VERSION OF MUMPS: $(SCALAP) and MPI LIBPAR = $(SCALAP) $(LAPACK) -L/usr/lib -lmpi # The parallel version is not concerned by the next two lines. # They are related to the sequential library provided by MUMPS, # to use instead of ScaLAPACK and MPI. INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq # DEFINE HERE YOUR BLAS LIBRARY LIBBLAS = -lblas # DEFINE HERE YOUR PTHREAD LIBRARY LIBOTHERS = -lpthread # FORTRAN/C COMPATIBILITY: # Use: # -DAdd_ if your Fortran compiler adds an underscore at the end # of symbols, # -DAdd__ if your Fortran compiler adds 2 underscores, # # -DUPPER if your Fortran compiler uses uppercase symbols # # leave empty if your Fortran compiler does not change the symbols. # CDEFS = -DAdd_ #COMPILER OPTIONS OPTF = -O OPTC = -O -I. OPTL = -O # CHOOSE BETWEEN USING THE SEQUENTIAL OR THE PARALLEL VERSION. #Sequential: #INCS = $(INCSEQ) #LIBS = $(LIBSEQ) #LIBSEQNEEDED = libseqneeded #Parallel: INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.debian.SEQ0000664000175000017500000000335514102210467017666 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # # These settings for a PC under Debian/linux with standard packages : # metis (parmetis), scotch (ptscotch), openmpi, gfortran # packages installation: # apt-get install libmetis-dev libparmetis-dev libscotch-dev libptscotch-dev libatlas-base-dev openmpi-bin libopenmpi-dev liblapack-dev # Begin orderings LSCOTCHDIR = /usr/lib ISCOTCH = -I/usr/include/scotch #LSCOTCH = -L$(LSCOTCHDIR) -lptesmumps -lptscotch -lptscotcherr LSCOTCH = -L$(LSCOTCHDIR) -lesmumps -lscotch -lscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord LMETISDIR = /usr/lib #IMETIS = -I/usr/include/parmetis IMETIS = -I/usr/include/metis # LMETIS = -L$(LMETISDIR) -lparmetis -lmetis LMETIS = -L$(LMETISDIR) -lmetis # Corresponding variables reused later #ORDERINGSF = -Dmetis -Dpord -Dparmetis -Dscotch -Dptscotch ORDERINGSF = -Dmetis -Dpord -Dscotch ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) # End orderings ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = gcc FC = gfortran FL = gfortran AR = ar vr RANLIB = ranlib LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -fopenmp OPTL = -O -fopenmp OPTC = -O -fopenmp #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.SUN.PAR0000664000175000017500000000656314102210467017107 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o CPP = /lib/cpp -P -C RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = #included in SunPerf SCALAP = -ls3l -lhpcshm INCPAR = -I/opt/SUNWhpc/include LIBPAR = -L/opt/SUNWhpc/lib -R/opt/SUNWhpc/lib $(SCALAP) $(LAPACK) -lmpi INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lsunperf -lf77compat LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DSUN_ OPTL = -O OPTC = -O #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.G95.PAR0000664000175000017500000000725414102210467017004 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = gcc FC = g95 FL = g95 AR = ar vr RANLIB = echo LAPACK =/usr/local/ATLAS/lib/Linux_P4SSE2/liblapack.a SCALAP = /usr/local/SCALAPACK/libscalapack.a /usr/local/BLACS/LIB/blacsCinit_MPI-LINUX-0.a /usr/local/BLACS/LIB/blacsF77init_MPI-LINUX-0.a /usr/local/BLACS/LIB/blacs_MPI-LINUX-0.a INCPAR = -I/usr/local/mpich-1.2.7p1/include LIBPAR = $(SCALAP) $(LAPACK) -L/usr/local/mpich-1.2.7p1/lib -lfmpich -lmpich INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq #LIBBLAS = /usr/local/lib/libgoto_coppermine32p-r1.00.so LIBBLAS =/usr/local/ATLAS/lib/Linux_P4SSE2/libf77blas.a /usr/local/ATLAS/lib/Linux_P4SSE2/libatlas.a -lg2c LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd__ #Begin Optimization options OPTF = -O -i4 OPTL = -O OPTC = -O #End Optimization options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.inc.generic.SEQ0000664000175000017500000001233014102210467020621 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # ################################################################################ # # Makefile.inc.generic.SEQ # # Generic Makefile.inc for sequential (MPI free, Scalapack free) version # # # This defines some parameters dependent on your platform; you should # look for the approriate file in the directory ./Make.inc/ and copy it # into a file called Makefile.inc. For example, from the MUMPS root # directory, use # "cp Make.inc/Makefile.inc.generic.SEQ ./Makefile.inc" # (see the main README file for details) # # If you do not find any suitable Makefile in Makefile.inc, use this file: # "cp Make.inc/Makefile.inc.generic ./Makefile.inc" and modify it according # to the comments given below. If you manage to build MUMPS on a new platform, # and think that this could be useful to others, you may want to send us # the corresponding Makefile.inc file. # ################################################################################ ######################################################################## #Begin orderings # # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## # DEFINE HERE SOME COMMON COMMANDS, THE COMPILER NAMES, ETC... # PLAT : use it to add a default suffix to the generated libraries PLAT = # Library extension, + C and Fortran "-o" option # may be different under Windows LIBEXT = .a OUTC = -o OUTF = -o # RM : remove files RM = /bin/rm -f # CC : C compiler CC = cc # FC : Fortran 90 compiler FC = f90 # FL : Fortran linker FL = f90 # AR : Archive object in a library # keep a space at the end if options have to be separated from lib name AR = ar vr # RANLIB : generate index of an archive file # (optionnal use "RANLIB = echo" in case of problem) RANLIB = ranlib #RANLIB = echo # DEFINE HERE YOUR LAPACK LIBRARY LAPACK = -llapack # The next two lines should not be modified. They concern # the sequential library provided by MUMPS, to use instead # of ScaLAPACK and MPI. INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq # DEFINE HERE YOUR BLAS LIBRARY LIBBLAS = -lblas # DEFINE HERE YOUR PTHREAD LIBRARY LIBOTHERS = -lpthread # FORTRAN/C COMPATIBILITY: # Use: # -DAdd_ if your Fortran compiler adds an underscore at the end # of symbols, # -DAdd__ if your Fortran compiler adds 2 underscores, # # -DUPPER if your Fortran compiler uses uppercase symbols # # leave empty if your Fortran compiler does not change the symbols. # CDEFS = -DAdd_ #COMPILER OPTIONS OPTF = -O OPTC = -O -I. OPTL = -O #Sequential: INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.INTEL.PAR0000664000175000017500000000723114102210467017306 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = /bin/rm -f CC = mpiicc FC = mpiifort FL = mpiifort AR = ar vr #RANLIB = ranlib RANLIB = echo # Make this variable point to the path where the Intel MKL library is # installed. It is set to the default install directory for Intel MKL. MKLROOT=/opt/intel/mkl/lib/intel64 LAPACK = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core SCALAP = -L$(MKLROOT) -lmkl_scalapack_lp64 -lmkl_blacs_intelmpi_lp64 LIBPAR = $(SCALAP) $(LAPACK) INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -L$(MKLROOT) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -nofor_main -DBLR_MT -qopenmp -DGEMMT_AVAILABLE OPTL = -O -nofor_main -qopenmp OPTC = -O -qopenmp #End Optimized options INCS = $(INCPAR) LIBS = $(LIBPAR) LIBSEQNEEDED = MUMPS_5.4.1/Make.inc/Makefile.SUN.SEQ0000664000175000017500000000637314102210467017114 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ######################################################################## PLAT = LIBEXT = .a OUTC = -o OUTF = -o CPP = /lib/cpp -P -C RM = /bin/rm -f CC = cc FC = f90 FL = f90 AR = ar vr RANLIB = echo LAPACK = #included in SunPerf INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lsunperf -lf77compat LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ #Begin Optimized options OPTF = -O -DSUN_ OPTL = -O OPTC = -O #End Optimized options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/Make.inc/Makefile.NEC.SEQ0000664000175000017500000000721214102210467017045 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # #Begin orderings # NOTE that PORD is distributed within MUMPS by default. It is recommended to # install other orderings. For that, you need to obtain the corresponding package # and modify the variables below accordingly. # For example, to have Metis available within MUMPS: # 1/ download Metis and compile it # 2/ uncomment (suppress # in first column) lines # starting with LMETISDIR, LMETIS # 3/ add -Dmetis in line ORDERINGSF # ORDERINGSF = -Dpord -Dmetis # 4/ Compile and install MUMPS # make clean; make (to clean up previous installation) # # Metis/ParMetis and SCOTCH/PT-SCOTCH (ver 6.0 and later) orderings are recommended. # #SCOTCHDIR = ${HOME}/scotch_6.0 #ISCOTCH = -I$(SCOTCHDIR)/include # # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dscotch in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dptscotch in the ORDERINGSF variable below) #LSCOTCH = -L$(SCOTCHDIR)/lib -lesmumps -lscotch -lscotcherr #LSCOTCH = -L$(SCOTCHDIR)/lib -lptesmumps -lptscotch -lptscotcherr LPORDDIR = $(topdir)/PORD/lib/ IPORD = -I$(topdir)/PORD/include/ LPORD = -L$(LPORDDIR) -lpord #LMETISDIR = /opt/metis-5.1.0/build/Linux-x86_64/libmetis #IMETIS = /opt/metis-5.1.0/include # You have to choose one among the following two lines depending on # the type of analysis you want to perform. If you want to perform only # sequential analysis choose the first (remember to add -Dmetis in the ORDERINGSF # variable below); for both parallel and sequential analysis choose the second # line (remember to add -Dparmetis in the ORDERINGSF variable below) #LMETIS = -L$(LMETISDIR) -lmetis #LMETIS = -L$(LMETISDIR) -lparmetis -lmetis # The following variables will be used in the compilation process. # Please note that -Dptscotch and -Dparmetis imply -Dscotch and -Dmetis respectively. # If you want to use Metis 4.X or an older version, you should use -Dmetis4 instead of -Dmetis # or in addition with -Dparmetis (if you are using parmetis 3.X or older). #ORDERINGSF = -Dscotch -Dmetis -Dpord -Dptscotch -Dparmetis ORDERINGSF = -Dpord ORDERINGSC = $(ORDERINGSF) LORDERINGS = $(LMETIS) $(LPORD) $(LSCOTCH) IORDERINGSF = $(ISCOTCH) IORDERINGSC = $(IMETIS) $(IPORD) $(ISCOTCH) #End orderings ######################################################################## ################################################################################ PLAT = LIBEXT = .a OUTC = -o OUTF = -o RM = rm -f CC = ncc FC = nfort FL = nfort AR = nar vr RANLIB = echo LAPACK = -llapack INCSEQ = -I$(topdir)/libseq LIBSEQ = $(LAPACK) -L$(topdir)/libseq -lmpiseq LIBBLAS = -lblas_openmp LIBOTHERS = -lpthread #Preprocessor defs for calling Fortran from C (-DAdd_ or -DAdd__ or -DUPPER) CDEFS = -DAdd_ # # Inline basics # STRIP_TOPDIR = $(strip $(topdir)) MUMPS_INLINE_LIST = -finline-functions -finline-max-depth=5 -finline-max-function-size=500 # # Inline search on the whole directory # MUMPS_INLINE_LIST += -finline-directory=$(STRIP_TOPDIR)/src:$(STRIP_TOPDIR)/libseq #Begin Optimization options OPTF = -O2 -DGEMMT_AVAILABLE -fpp -fopenmp -Wobsolescent -Wextension -Wall -Woverflow $(MUMPS_INLINE_LIST) OPTL = -O2 -fopenmp OPTC = -O2 -fopenmp -Wall #End Optimization options INCS = $(INCSEQ) LIBS = $(LIBSEQ) LIBSEQNEEDED = libseqneeded MUMPS_5.4.1/CREDITS0000664000175000017500000000347014102210467013747 0ustar jylexceljylexcelThis version of MUMPS has been developed by employees of CERFACS, ENS Lyon, INPT(ENSEEIHT)-IRIT, Inria, Mumps Technologies and University of Bordeaux: Emmanuel Agullo, Patrick Amestoy, Maurice Bremond, Alfredo Buttari, Philippe Combes, Marie Durand, Aurelia Fevre, Abdou Guermouche, Guillaume Joslin, Jacko Koster, Jean-Yves L'Excellent, Theo Mary, Stephane Pralet, Chiara Puglisi, Francois-Henry Rouet, Wissam Sid-Lakhdar, Tzvetomila Slavova, Bora Ucar and Clement Weisbecker. Since January 2019, the MUMPS solver is maintained by Mumps Technologies (http://mumps-tech.com). We are grateful to Caroline Bousquet, Indranil Chowdhury, Christophe Daniel, Iain Duff, Vincent Espirat, Gilles Moreau, Gregoire Richard, Alexis Salzman, Miroslav Tuma and Christophe Voemel who have been contributing to this project. We are also grateful to Juergen Schulze for letting us distribute PORD developed at the University of Paderborn. We thank Eddy Caron for the administration of a server used on a daily basis for MUMPS. We want to thank the French ANR programme, the European community, Airbus Group-IW, Altair, CINES, EDF, EMGS, ESI Group, FFT, LBNL, LSTC, Michelin, SAFRAN, SAMTECH, Shell, Siemens, Total for their support. We also thank LBNL, LSTC, PARALLAB and the Rutherford Appleton Laboratory for research discussions that have certainly influenced this work. Finally we want to thank the institutions that have provided access to their parallel machines: Centre Informatique National de l'Enseignement Superieur (CINES), CERFACS, CALMIP ("Centre Interuniversitaire de Calcul" located in Toulouse), Federation Lyonnaise de Calcul Haute-Performance, Institut du Developpement et des Ressources en Informatique Scientifique (IDRIS), Lawrence Berkeley National Laboratory, Laboratoire de l'Informatique du Parallelisme, Inria, and PARALLAB. MUMPS_5.4.1/include/0000775000175000017500000000000014102210520014334 5ustar jylexceljylexcelMUMPS_5.4.1/include/cmumps_c.h0000664000175000017500000000727514102210474016336 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef CMUMPS_C_H #define CMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, CMUMPS_COMPLEX and CMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.4.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: CMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; CMUMPS_REAL cntl[15]; CMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; CMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; CMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; CMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ CMUMPS_REAL *colsca; CMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* RHS, solution, ouptput data and statistics */ CMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[80],infog[80]; CMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; CMUMPS_COMPLEX *schur; /* Internal parameters */ MUMPS_INT instance_number; CMUMPS_COMPLEX *wk_user; /* Version number: length=14 in FORTRAN + 1 for final \0 + 1 for alignment */ char version_number[MUMPS_VERSION_MAX_LEN + 1 + 1]; /* For out-of-core */ char ooc_tmpdir[256]; char ooc_prefix[64]; /* To save the matrix in matrix market format */ char write_problem[256]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[256]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; } CMUMPS_STRUC_C; void MUMPS_CALL cmumps_c( CMUMPS_STRUC_C * cmumps_par ); #ifdef __cplusplus } #endif #endif /* CMUMPS_C_H */ MUMPS_5.4.1/include/cmumps_struc.h0000664000175000017500000002676614102210520017252 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! INCLUDE 'cmumps_root.h' TYPE CMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input COMPLEX, DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN REAL, DIMENSION(:), POINTER :: COLSCA, ROWSCA, pad0 ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc COMPLEX, DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR COMPLEX, DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- COMPLEX, DIMENSION(:), POINTER :: RHS, REDRHS COMPLEX, DIMENSION(:), POINTER :: RHS_SPARSE COMPLEX, DIMENSION(:), POINTER :: SOL_loc COMPLEX, DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) REAL :: COST_SUBTREES REAL :: CNTL(15) REAL :: RINFO(40) REAL :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR COMPLEX, DIMENSION(:), POINTER :: SCHUR COMPLEX, DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! CMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=255) :: OOC_TMPDIR CHARACTER(LEN=63) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases COMPLEX, DIMENSION(:), POINTER :: S ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise INTEGER, DIMENSION(:), POINTER :: INTARR COMPLEX, DIMENSION(:), POINTER :: DBLARR ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_ROW LOGICAL :: POSINRHSCOMP_COL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_COL COMPLEX, DIMENSION(:), POINTER :: RHSCOMP ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU COMPLEX, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array REAL :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Root structure(internal) TYPE (CMUMPS_ROOT_STRUC) :: root ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore TYPE(CMUMPS_L0OMPFAC_T),DIMENSION(:),POINTER :: L0_OMP_FACTORS INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MPITOOMP_PROCS_MAP ! for RR on root REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE CMUMPS_STRUC MUMPS_5.4.1/include/zmumps_c.h0000664000175000017500000000727514102210474016365 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef ZMUMPS_C_H #define ZMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, ZMUMPS_COMPLEX and ZMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.4.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: ZMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; ZMUMPS_REAL cntl[15]; ZMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; ZMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; ZMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; ZMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ ZMUMPS_REAL *colsca; ZMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* RHS, solution, ouptput data and statistics */ ZMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[80],infog[80]; ZMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; ZMUMPS_COMPLEX *schur; /* Internal parameters */ MUMPS_INT instance_number; ZMUMPS_COMPLEX *wk_user; /* Version number: length=14 in FORTRAN + 1 for final \0 + 1 for alignment */ char version_number[MUMPS_VERSION_MAX_LEN + 1 + 1]; /* For out-of-core */ char ooc_tmpdir[256]; char ooc_prefix[64]; /* To save the matrix in matrix market format */ char write_problem[256]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[256]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; } ZMUMPS_STRUC_C; void MUMPS_CALL zmumps_c( ZMUMPS_STRUC_C * zmumps_par ); #ifdef __cplusplus } #endif #endif /* ZMUMPS_C_H */ MUMPS_5.4.1/include/mumps_c_types.h0000664000175000017500000000343014102210474017404 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_C_TYPES_H #define MUMPS_C_TYPES_H #include /* mumps_int_def.h will define either MUMPS_INTSIZE32 (default) or MUMPS_INTSIZE64 (if compilation is with -DINTSIZE64 to match Fortran -i8 or equivalent option). This allows one to test from an external code whether MUMPS_INT is 64bits or not */ #include "mumps_int_def.h" #ifdef MUMPS_INTSIZE64 #define MUMPS_INT int64_t #else #define MUMPS_INT int #endif #define MUMPS_INT8 int64_t #define SMUMPS_COMPLEX float #define SMUMPS_REAL float #define DMUMPS_COMPLEX double #define DMUMPS_REAL double /* Complex datatypes */ typedef struct {float r,i;} mumps_complex; typedef struct {double r,i;} mumps_double_complex; #define CMUMPS_COMPLEX mumps_complex #define CMUMPS_REAL float #define ZMUMPS_COMPLEX mumps_double_complex #define ZMUMPS_REAL double #ifndef mumps_ftnlen /* When passing a string, what is the type of the extra argument * passed by value ? */ # define mumps_ftnlen MUMPS_INT #endif #define MUMPS_ARITH_s 1 #define MUMPS_ARITH_d 2 #define MUMPS_ARITH_c 4 #define MUMPS_ARITH_z 8 #define MUMPS_ARITH_REAL ( MUMPS_ARITH_s | MUMPS_ARITH_d ) #define MUMPS_ARITH_CMPLX ( MUMPS_ARITH_c | MUMPS_ARITH_z ) #define MUMPS_ARITH_SINGLE ( MUMPS_ARITH_s | MUMPS_ARITH_c ) #define MUMPS_ARITH_DBL ( MUMPS_ARITH_d | MUMPS_ARITH_z ) #endif /* MUMPS_C_TYPES_H */ MUMPS_5.4.1/include/dmumps_struc.h0000664000175000017500000002727714102210520017251 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! INCLUDE 'dmumps_root.h' TYPE DMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input DOUBLE PRECISION, DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA, ROWSCA, pad0 ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR DOUBLE PRECISION, DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS, REDRHS DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_SPARSE DOUBLE PRECISION, DIMENSION(:), POINTER :: SOL_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) DOUBLE PRECISION :: COST_SUBTREES DOUBLE PRECISION :: CNTL(15) DOUBLE PRECISION :: RINFO(40) DOUBLE PRECISION :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR DOUBLE PRECISION, DIMENSION(:), POINTER :: SCHUR DOUBLE PRECISION, DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! DMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=255) :: OOC_TMPDIR CHARACTER(LEN=63) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases DOUBLE PRECISION, DIMENSION(:), POINTER :: S ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise INTEGER, DIMENSION(:), POINTER :: INTARR DOUBLE PRECISION, DIMENSION(:), POINTER :: DBLARR ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_ROW LOGICAL :: POSINRHSCOMP_COL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_COL DOUBLE PRECISION, DIMENSION(:), POINTER :: RHSCOMP ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU DOUBLE PRECISION, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array DOUBLE PRECISION :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Root structure(internal) TYPE (DMUMPS_ROOT_STRUC) :: root ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore TYPE(DMUMPS_L0OMPFAC_T),DIMENSION(:),POINTER :: L0_OMP_FACTORS INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MPITOOMP_PROCS_MAP ! for RR on root DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE DMUMPS_STRUC MUMPS_5.4.1/include/dmumps_root.h0000664000175000017500000000451714102210520017064 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! ! This file includes various internal datastructures ! passed through the main MUMPS structure between successive ! phases of the solver. The main one is root information for ! the multifrontal tree. TYPE DMUMPS_ROOT_STRUC SEQUENCE INTEGER :: MBLOCK, NBLOCK, NPROW, NPCOL INTEGER :: MYROW, MYCOL INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: RHS_NLOC INTEGER :: ROOT_SIZE, TOT_ROOT_SIZE ! descriptor for scalapack INTEGER, DIMENSION( 9 ) :: DESCRIPTOR INTEGER :: CNTXT_BLACS, LPIV, rootpad0 INTEGER, DIMENSION(:), POINTER :: RG2L_ROW INTEGER, DIMENSION(:), POINTER :: RG2L_COL INTEGER , DIMENSION(:), POINTER :: IPIV, rootpad1 ! Centralized master of root DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_CNTR_MASTER_ROOT ! Used to access Schur easily from root structure DOUBLE PRECISION, DIMENSION(:), POINTER :: SCHUR_POINTER ! for try_null_space preprocessing constant only: DOUBLE PRECISION, DIMENSION(:), POINTER :: QR_TAU, rootpad2 ! Fwd in facto: ! case of scalapack root: to store RHS in 2D block cyclic ! format compatible with root distribution DOUBLE PRECISION, DIMENSION(:,:), POINTER :: RHS_ROOT, rootpad ! for try_nullspace preprocessing constant only: DOUBLE PRECISION :: QR_RCOND, rootpad3 LOGICAL :: yes, gridinit_done ! for SVD on root (#define try_null_space) DOUBLE PRECISION, DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES,rootpad4 ! END TYPE DMUMPS_ROOT_STRUC ! multicore TYPE DMUMPS_L0OMPFAC_T SEQUENCE DOUBLE PRECISION, POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE DMUMPS_L0OMPFAC_T MUMPS_5.4.1/include/cmumps_root.h0000664000175000017500000000440114102210520017053 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! ! This file includes various internal datastructures ! passed through the main MUMPS structure between successive ! phases of the solver. The main one is root information for ! the multifrontal tree. TYPE CMUMPS_ROOT_STRUC SEQUENCE INTEGER :: MBLOCK, NBLOCK, NPROW, NPCOL INTEGER :: MYROW, MYCOL INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: RHS_NLOC INTEGER :: ROOT_SIZE, TOT_ROOT_SIZE ! descriptor for scalapack INTEGER, DIMENSION( 9 ) :: DESCRIPTOR INTEGER :: CNTXT_BLACS, LPIV, rootpad0 INTEGER, DIMENSION(:), POINTER :: RG2L_ROW INTEGER, DIMENSION(:), POINTER :: RG2L_COL INTEGER , DIMENSION(:), POINTER :: IPIV, rootpad1 ! Centralized master of root COMPLEX, DIMENSION(:), POINTER :: RHS_CNTR_MASTER_ROOT ! Used to access Schur easily from root structure COMPLEX, DIMENSION(:), POINTER :: SCHUR_POINTER ! for try_null_space preprocessing constant only: COMPLEX, DIMENSION(:), POINTER :: QR_TAU, rootpad2 ! Fwd in facto: ! case of scalapack root: to store RHS in 2D block cyclic ! format compatible with root distribution COMPLEX, DIMENSION(:,:), POINTER :: RHS_ROOT, rootpad ! for try_nullspace preprocessing constant only: REAL :: QR_RCOND, rootpad3 LOGICAL :: yes, gridinit_done ! for SVD on root (#define try_null_space) COMPLEX, DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES,rootpad4 ! END TYPE CMUMPS_ROOT_STRUC ! multicore TYPE CMUMPS_L0OMPFAC_T SEQUENCE COMPLEX, POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE CMUMPS_L0OMPFAC_T MUMPS_5.4.1/include/dmumps_c.h0000664000175000017500000000727514102210474016337 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef DMUMPS_C_H #define DMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, DMUMPS_COMPLEX and DMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.4.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: DMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; DMUMPS_REAL cntl[15]; DMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; DMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; DMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; DMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ DMUMPS_REAL *colsca; DMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* RHS, solution, ouptput data and statistics */ DMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[80],infog[80]; DMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; DMUMPS_COMPLEX *schur; /* Internal parameters */ MUMPS_INT instance_number; DMUMPS_COMPLEX *wk_user; /* Version number: length=14 in FORTRAN + 1 for final \0 + 1 for alignment */ char version_number[MUMPS_VERSION_MAX_LEN + 1 + 1]; /* For out-of-core */ char ooc_tmpdir[256]; char ooc_prefix[64]; /* To save the matrix in matrix market format */ char write_problem[256]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[256]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; } DMUMPS_STRUC_C; void MUMPS_CALL dmumps_c( DMUMPS_STRUC_C * dmumps_par ); #ifdef __cplusplus } #endif #endif /* DMUMPS_C_H */ MUMPS_5.4.1/include/smumps_c.h0000664000175000017500000000727514102210474016356 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Mostly written in march 2002 (JYL) */ #ifndef SMUMPS_C_H #define SMUMPS_C_H #ifdef __cplusplus extern "C" { #endif #include "mumps_compat.h" /* Next line defines MUMPS_INT, SMUMPS_COMPLEX and SMUMPS_REAL */ #include "mumps_c_types.h" #ifndef MUMPS_VERSION /* Protected in case headers of other arithmetics are included */ #define MUMPS_VERSION "5.4.1" #endif #ifndef MUMPS_VERSION_MAX_LEN #define MUMPS_VERSION_MAX_LEN 30 #endif /* * Definition of the (simplified) MUMPS C structure. * NB: SMUMPS_COMPLEX are REAL types in s and d arithmetics. */ typedef struct { MUMPS_INT sym, par, job; MUMPS_INT comm_fortran; /* Fortran communicator */ MUMPS_INT icntl[60]; MUMPS_INT keep[500]; SMUMPS_REAL cntl[15]; SMUMPS_REAL dkeep[230]; MUMPS_INT8 keep8[150]; MUMPS_INT n; MUMPS_INT nblk; MUMPS_INT nz_alloc; /* used in matlab interface to decide if we free + malloc when we have large variation */ /* Assembled entry */ MUMPS_INT nz; MUMPS_INT8 nnz; MUMPS_INT *irn; MUMPS_INT *jcn; SMUMPS_COMPLEX *a; /* Distributed entry */ MUMPS_INT nz_loc; MUMPS_INT8 nnz_loc; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; SMUMPS_COMPLEX *a_loc; /* Element entry */ MUMPS_INT nelt; MUMPS_INT *eltptr; MUMPS_INT *eltvar; SMUMPS_COMPLEX *a_elt; /* Matrix by blocks */ MUMPS_INT *blkptr; MUMPS_INT *blkvar; /* Ordering, if given by user */ MUMPS_INT *perm_in; /* Orderings returned to user */ MUMPS_INT *sym_perm; /* symmetric permutation */ MUMPS_INT *uns_perm; /* column permutation */ /* Scaling (inout but complicated) */ SMUMPS_REAL *colsca; SMUMPS_REAL *rowsca; MUMPS_INT colsca_from_mumps; MUMPS_INT rowsca_from_mumps; /* RHS, solution, ouptput data and statistics */ SMUMPS_COMPLEX *rhs, *redrhs, *rhs_sparse, *sol_loc, *rhs_loc; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc; MUMPS_INT nrhs, lrhs, lredrhs, nz_rhs, lsol_loc, nloc_rhs, lrhs_loc; MUMPS_INT schur_mloc, schur_nloc, schur_lld; MUMPS_INT mblock, nblock, nprow, npcol; MUMPS_INT info[80],infog[80]; SMUMPS_REAL rinfo[40], rinfog[40]; /* Null space */ MUMPS_INT deficiency; MUMPS_INT *pivnul_list; MUMPS_INT *mapping; /* Schur */ MUMPS_INT size_schur; MUMPS_INT *listvar_schur; SMUMPS_COMPLEX *schur; /* Internal parameters */ MUMPS_INT instance_number; SMUMPS_COMPLEX *wk_user; /* Version number: length=14 in FORTRAN + 1 for final \0 + 1 for alignment */ char version_number[MUMPS_VERSION_MAX_LEN + 1 + 1]; /* For out-of-core */ char ooc_tmpdir[256]; char ooc_prefix[64]; /* To save the matrix in matrix market format */ char write_problem[256]; MUMPS_INT lwk_user; /* For save/restore feature */ char save_dir[256]; char save_prefix[256]; /* Metis options */ MUMPS_INT metis_options[40]; } SMUMPS_STRUC_C; void MUMPS_CALL smumps_c( SMUMPS_STRUC_C * smumps_par ); #ifdef __cplusplus } #endif #endif /* SMUMPS_C_H */ MUMPS_5.4.1/include/zmumps_struc.h0000664000175000017500000002726214102210520017271 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! INCLUDE 'zmumps_root.h' TYPE ZMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input COMPLEX(kind=8), DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN DOUBLE PRECISION, DIMENSION(:), POINTER :: COLSCA, ROWSCA, pad0 ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc COMPLEX(kind=8), DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR COMPLEX(kind=8), DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS, REDRHS COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_SPARSE COMPLEX(kind=8), DIMENSION(:), POINTER :: SOL_loc COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) DOUBLE PRECISION :: COST_SUBTREES DOUBLE PRECISION :: CNTL(15) DOUBLE PRECISION :: RINFO(40) DOUBLE PRECISION :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR COMPLEX(kind=8), DIMENSION(:), POINTER :: SCHUR COMPLEX(kind=8), DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! ZMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=255) :: OOC_TMPDIR CHARACTER(LEN=63) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases COMPLEX(kind=8), DIMENSION(:), POINTER :: S ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise INTEGER, DIMENSION(:), POINTER :: INTARR COMPLEX(kind=8), DIMENSION(:), POINTER :: DBLARR ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_ROW LOGICAL :: POSINRHSCOMP_COL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_COL COMPLEX(kind=8), DIMENSION(:), POINTER :: RHSCOMP ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU COMPLEX(kind=8), DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array DOUBLE PRECISION :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Root structure(internal) TYPE (ZMUMPS_ROOT_STRUC) :: root ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore TYPE(ZMUMPS_L0OMPFAC_T),DIMENSION(:),POINTER :: L0_OMP_FACTORS INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MPITOOMP_PROCS_MAP ! for RR on root DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE ZMUMPS_STRUC MUMPS_5.4.1/include/smumps_root.h0000664000175000017500000000435714102210520017105 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! ! This file includes various internal datastructures ! passed through the main MUMPS structure between successive ! phases of the solver. The main one is root information for ! the multifrontal tree. TYPE SMUMPS_ROOT_STRUC SEQUENCE INTEGER :: MBLOCK, NBLOCK, NPROW, NPCOL INTEGER :: MYROW, MYCOL INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: RHS_NLOC INTEGER :: ROOT_SIZE, TOT_ROOT_SIZE ! descriptor for scalapack INTEGER, DIMENSION( 9 ) :: DESCRIPTOR INTEGER :: CNTXT_BLACS, LPIV, rootpad0 INTEGER, DIMENSION(:), POINTER :: RG2L_ROW INTEGER, DIMENSION(:), POINTER :: RG2L_COL INTEGER , DIMENSION(:), POINTER :: IPIV, rootpad1 ! Centralized master of root REAL, DIMENSION(:), POINTER :: RHS_CNTR_MASTER_ROOT ! Used to access Schur easily from root structure REAL, DIMENSION(:), POINTER :: SCHUR_POINTER ! for try_null_space preprocessing constant only: REAL, DIMENSION(:), POINTER :: QR_TAU, rootpad2 ! Fwd in facto: ! case of scalapack root: to store RHS in 2D block cyclic ! format compatible with root distribution REAL, DIMENSION(:,:), POINTER :: RHS_ROOT, rootpad ! for try_nullspace preprocessing constant only: REAL :: QR_RCOND, rootpad3 LOGICAL :: yes, gridinit_done ! for SVD on root (#define try_null_space) REAL, DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES,rootpad4 ! END TYPE SMUMPS_ROOT_STRUC ! multicore TYPE SMUMPS_L0OMPFAC_T SEQUENCE REAL, POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE SMUMPS_L0OMPFAC_T MUMPS_5.4.1/include/mumps_compat.h0000664000175000017500000000214414102210474017222 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Compatibility issues between various Windows versions */ #ifndef MUMPS_COMPAT_H #define MUMPS_COMPAT_H #if defined(_WIN32) && ! defined(__MINGW32__) # define MUMPS_WIN32 1 #endif #ifndef MUMPS_CALL # ifdef MUMPS_WIN32 /* Choose between next lines or modify according * to your Windows calling conventions: */ /* #define MUMPS_CALL */ /* #define MUMPS_CALL __stdcall */ /* #define MUMPS_CALL __declspec(dllexport) */ # define MUMPS_CALL # else # define MUMPS_CALL # endif #endif #if (__STDC_VERSION__ >= 199901L) # define MUMPS_INLINE static inline #else # define MUMPS_INLINE #endif #endif /* MUMPS_COMPAT_H */ MUMPS_5.4.1/include/smumps_struc.h0000664000175000017500000002671714102210520017266 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! INCLUDE 'smumps_root.h' TYPE SMUMPS_STRUC SEQUENCE ! ! This structure contains all parameters ! for the interface to the user, plus internal ! information from the solver ! ! ***************** ! INPUT PARAMETERS ! ***************** ! ----------------- ! MPI Communicator ! ----------------- INTEGER :: COMM ! ------------------ ! Problem definition ! ------------------ ! Solver (SYM=0 unsymmetric,SYM=1 symmetric Positive Definite, ! SYM=2 general symmetric) ! Type of parallelism (PAR=1 host working, PAR=0 host not working) INTEGER :: SYM, PAR INTEGER :: JOB ! -------------------- ! Order of Input matrix ! -------------------- INTEGER :: N ! ! ---------------------------------------- ! Assembled input matrix : User interface ! ---------------------------------------- INTEGER :: NZ ! Standard integer input + bwd. compat. INTEGER(8) :: NNZ ! 64-bit integer input REAL, DIMENSION(:), POINTER :: A INTEGER, DIMENSION(:), POINTER :: IRN, JCN REAL, DIMENSION(:), POINTER :: COLSCA, ROWSCA, pad0 ! ! ------------------------------------ ! Case of distributed assembled matrix ! matrix on entry: ! ------------------------------------ INTEGER :: NZ_loc ! Standard integer input + bwd. compat. INTEGER :: pad1 INTEGER(8) :: NNZ_loc ! 64-bit integer input INTEGER, DIMENSION(:), POINTER :: IRN_loc, JCN_loc REAL, DIMENSION(:), POINTER :: A_loc, pad2 ! ! ---------------------------------------- ! Unassembled input matrix: User interface ! ---------------------------------------- INTEGER :: NELT, pad3 INTEGER, DIMENSION(:), POINTER :: ELTPTR INTEGER, DIMENSION(:), POINTER :: ELTVAR REAL, DIMENSION(:), POINTER :: A_ELT, pad4 ! ! --------------------------------------------- ! Symmetric permutation : ! PERM_IN if given by user (optional) ! --------------------------------------------- INTEGER, DIMENSION(:), POINTER :: PERM_IN ! ! ---------------- ! Format by blocks ! ---------------- INTEGER :: NBLK, pad5 INTEGER, DIMENSION(:), POINTER :: BLKPTR INTEGER, DIMENSION(:), POINTER :: BLKVAR ! ! ****************** ! INPUT/OUTPUT data ! ****************** ! -------------------------------------------------------- ! RHS / SOL_loc ! ------------- ! right-hand side and solution ! ------------------------------------------------------- REAL, DIMENSION(:), POINTER :: RHS, REDRHS REAL, DIMENSION(:), POINTER :: RHS_SPARSE REAL, DIMENSION(:), POINTER :: SOL_loc REAL, DIMENSION(:), POINTER :: RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE INTEGER, DIMENSION(:), POINTER :: IRHS_PTR INTEGER, DIMENSION(:), POINTER :: ISOL_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc INTEGER :: LRHS, NRHS, NZ_RHS, Nloc_RHS, LRHS_loc, LREDRHS INTEGER :: LSOL_loc, pad6 ! ---------------------------- ! Control parameters, ! statistics and output data ! --------------------------- INTEGER :: ICNTL(60) INTEGER :: INFO(80) INTEGER :: INFOG(80) REAL :: COST_SUBTREES REAL :: CNTL(15) REAL :: RINFO(40) REAL :: RINFOG(40) ! The options array for metis/parmetis INTEGER :: METIS_OPTIONS(40) ! --------------------------------------------------------- ! Permutations computed during analysis: ! SYM_PERM: Symmetric permutation ! UNS_PERM: Column permutation (optional) ! --------------------------------------------------------- INTEGER, DIMENSION(:), POINTER :: SYM_PERM, UNS_PERM ! ! ----- ! Schur ! ----- INTEGER :: NPROW, NPCOL, MBLOCK, NBLOCK INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: SIZE_SCHUR REAL, DIMENSION(:), POINTER :: SCHUR REAL, DIMENSION(:), POINTER :: SCHUR_CINTERFACE INTEGER, DIMENSION(:), POINTER :: LISTVAR_SCHUR ! ------------------------------------- ! Case of distributed matrix on entry: ! SMUMPS potentially provides mapping ! ------------------------------------- INTEGER, DIMENSION(:), POINTER :: MAPPING ! -------------- ! Version number ! -------------- CHARACTER(LEN=30) :: VERSION_NUMBER ! ----------- ! Out-of-core ! ----------- CHARACTER(LEN=255) :: OOC_TMPDIR CHARACTER(LEN=63) :: OOC_PREFIX ! ------------------------------------------ ! Name of file to dump a matrix/rhs to disk ! ------------------------------------------ CHARACTER(LEN=255) :: WRITE_PROBLEM ! ----------- ! Save/Restore ! ----------- CHARACTER(LEN=255) :: SAVE_DIR CHARACTER(LEN=255) :: SAVE_PREFIX CHARACTER(LEN=7) :: pad7 ! ! ! ********************** ! INTERNAL Working data ! ********************* INTEGER(8) :: KEEP8(150), MAX_SURF_MASTER INTEGER :: INST_Number ! For MPI INTEGER :: COMM_NODES, MYID_NODES, COMM_LOAD INTEGER :: MYID, NPROCS, NSLAVES INTEGER :: ASS_IRECV ! IS is used for the factors + workspace for contrib. blocks INTEGER, DIMENSION(:), POINTER :: IS INTEGER :: KEEP(500) ! The following data/arrays are computed during the analysis ! phase and used during the factorization and solve phases. INTEGER :: LNA INTEGER :: NBSA INTEGER,POINTER,DIMENSION(:) :: STEP, NE_STEPS, ND_STEPS INTEGER,POINTER,DIMENSION(:) :: FRERE_STEPS, DAD_STEPS INTEGER,POINTER,DIMENSION(:) :: FILS, FRTPTR, FRTELT INTEGER(8),POINTER,DIMENSION(:) :: PTRAR INTEGER,POINTER,DIMENSION(:) :: NA, PROCNODE_STEPS ! Info for pruning tree INTEGER,POINTER,DIMENSION(:) :: Step2node ! PTLUST_S and PTRFAC are two pointer arrays computed during ! factorization and used by the solve INTEGER, DIMENSION(:), POINTER :: PTLUST_S INTEGER(8), DIMENSION(:), POINTER :: PTRFAC ! main real working arrays for factorization/solve phases REAL, DIMENSION(:), POINTER :: S ! Information on mapping INTEGER, DIMENSION(:), POINTER :: PROCNODE ! Input matrix ready for numerical assembly ! -arrowhead format in case of assembled matrix ! -element format otherwise INTEGER, DIMENSION(:), POINTER :: INTARR REAL, DIMENSION(:), POINTER :: DBLARR ! Element entry: internal data INTEGER :: NELT_loc, LELTVAR INTEGER, DIMENSION(:), POINTER :: ELTPROC ! Candidates and node partitionning INTEGER, DIMENSION(:,:), POINTER :: CANDIDATES INTEGER, DIMENSION(:), POINTER :: ISTEP_TO_INIV2 INTEGER, DIMENSION(:), POINTER :: FUTURE_NIV2 INTEGER, DIMENSION(:,:), POINTER :: TAB_POS_IN_PERE LOGICAL, DIMENSION(:), POINTER :: I_AM_CAND ! For heterogeneous architecture INTEGER, DIMENSION(:), POINTER :: MEM_DIST ! Compressed RHS INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_ROW LOGICAL :: POSINRHSCOMP_COL_ALLOC, pad11 INTEGER, DIMENSION(:), POINTER :: POSINRHSCOMP_COL REAL, DIMENSION(:), POINTER :: RHSCOMP ! Info on the subtrees to be used during factorization DOUBLE PRECISION, DIMENSION(:), POINTER :: MEM_SUBTREE DOUBLE PRECISION, DIMENSION(:), POINTER :: COST_TRAV INTEGER, DIMENSION(:), POINTER :: MY_ROOT_SBTR INTEGER, DIMENSION(:), POINTER :: MY_FIRST_LEAF INTEGER, DIMENSION(:), POINTER :: MY_NB_LEAF INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST INTEGER, DIMENSION(:), POINTER :: DEPTH_FIRST_SEQ INTEGER, DIMENSION(:), POINTER :: SBTR_ID INTEGER, DIMENSION(:), POINTER :: SCHED_DEP INTEGER, DIMENSION(:), POINTER :: SCHED_GRP INTEGER, DIMENSION(:), POINTER :: SCHED_SBTR INTEGER, DIMENSION(:), POINTER :: CROIX_MANU REAL, DIMENSION(:), POINTER :: WK_USER INTEGER :: NBSA_LOCAL INTEGER :: LWK_USER ! Internal control array REAL :: DKEEP(230) ! For simulating parallel out-of-core stack. DOUBLE PRECISION, DIMENSION(:),POINTER :: CB_SON_SIZE ! Instance number used/managed by the C/F77 interface INTEGER :: INSTANCE_NUMBER ! OOC management data that must persist from factorization to solve. INTEGER :: OOC_MAX_NB_NODES_FOR_ZONE INTEGER, DIMENSION(:,:), POINTER :: OOC_INODE_SEQUENCE INTEGER(8),DIMENSION(:,:), POINTER :: OOC_SIZE_OF_BLOCK INTEGER(8), DIMENSION(:,:), POINTER :: OOC_VADDR INTEGER,DIMENSION(:), POINTER :: OOC_TOTAL_NB_NODES INTEGER,DIMENSION(:), POINTER :: OOC_NB_FILES INTEGER :: OOC_NB_FILE_TYPE,pad12 INTEGER,DIMENSION(:), POINTER :: OOC_FILE_NAME_LENGTH CHARACTER,DIMENSION(:,:), POINTER :: OOC_FILE_NAMES ! Indices of nul pivots INTEGER,DIMENSION(:), POINTER :: PIVNUL_LIST ! Array needed to manage additionnal candidate processor INTEGER, DIMENSION(:,:), POINTER :: SUP_PROC, pad14 ! Lists of nodes where processors work. Built/used in solve phase. INTEGER, DIMENSION(:), POINTER :: IPTR_WORKING, WORKING ! Root structure(internal) TYPE (SMUMPS_ROOT_STRUC) :: root ! Low-rank INTEGER, POINTER, DIMENSION(:) :: LRGROUPS INTEGER :: NBGRP,pad13 ! Pointer encoding for FDM_F data CHARACTER, DIMENSION(:), POINTER :: FDM_F_ENCODING ! Pointer array encoding BLR factors pointers CHARACTER, DIMENSION(:), POINTER :: BLRARRAY_ENCODING ! Multicore TYPE(SMUMPS_L0OMPFAC_T),DIMENSION(:),POINTER :: L0_OMP_FACTORS INTEGER :: LPOOL_A_L0_OMP, LPOOL_B_L0_OMP INTEGER :: L_PHYS_L0_OMP INTEGER :: L_VIRT_L0_OMP INTEGER :: LL0_OMP_MAPPING, LL0_OMP_FACTORS INTEGER(8) :: THREAD_LA ! Estimates before L0_OMP INTEGER, DIMENSION(:,:), POINTER :: I4_L0_OMP INTEGER(8), DIMENSION(:,:), POINTER :: I8_L0_OMP ! Pool before L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_B_L0_OMP ! Pool after L0_OMP INTEGER, DIMENSION(:), POINTER :: IPOOL_A_L0_OMP ! Subtrees INTEGER, DIMENSION(:), POINTER :: PHYS_L0_OMP ! Amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP ! Mapping of amalgamated subtrees INTEGER, DIMENSION(:), POINTER :: VIRT_L0_OMP_MAPPING ! From heaviest to lowest subtree INTEGER, DIMENSION(:), POINTER :: PERM_L0_OMP ! To get leafs in global pool INTEGER, DIMENSION(:), POINTER :: PTR_LEAFS_L0_OMP ! Mapping of the subtree nodes INTEGER, DIMENSION(:), POINTER :: L0_OMP_MAPPING ! Mpi to omp - mumps agile INTEGER, DIMENSION(:), POINTER :: MPITOOMP_PROCS_MAP ! for RR on root REAL, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES INTEGER :: Deficiency, pad16 ! To know if OOC files are associated to a saved and so if they should be removed. LOGICAL :: ASSOCIATED_OOC_FILES END TYPE SMUMPS_STRUC MUMPS_5.4.1/include/zmumps_root.h0000664000175000017500000000451114102210520017104 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! ! This file includes various internal datastructures ! passed through the main MUMPS structure between successive ! phases of the solver. The main one is root information for ! the multifrontal tree. TYPE ZMUMPS_ROOT_STRUC SEQUENCE INTEGER :: MBLOCK, NBLOCK, NPROW, NPCOL INTEGER :: MYROW, MYCOL INTEGER :: SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER :: RHS_NLOC INTEGER :: ROOT_SIZE, TOT_ROOT_SIZE ! descriptor for scalapack INTEGER, DIMENSION( 9 ) :: DESCRIPTOR INTEGER :: CNTXT_BLACS, LPIV, rootpad0 INTEGER, DIMENSION(:), POINTER :: RG2L_ROW INTEGER, DIMENSION(:), POINTER :: RG2L_COL INTEGER , DIMENSION(:), POINTER :: IPIV, rootpad1 ! Centralized master of root COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_CNTR_MASTER_ROOT ! Used to access Schur easily from root structure COMPLEX(kind=8), DIMENSION(:), POINTER :: SCHUR_POINTER ! for try_null_space preprocessing constant only: COMPLEX(kind=8), DIMENSION(:), POINTER :: QR_TAU, rootpad2 ! Fwd in facto: ! case of scalapack root: to store RHS in 2D block cyclic ! format compatible with root distribution COMPLEX(kind=8), DIMENSION(:,:), POINTER :: RHS_ROOT, rootpad ! for try_nullspace preprocessing constant only: DOUBLE PRECISION :: QR_RCOND, rootpad3 LOGICAL :: yes, gridinit_done ! for SVD on root (#define try_null_space) COMPLEX(kind=8), DIMENSION(:,:), POINTER :: SVD_U, SVD_VT ! for RR on root (#define try_null_space) DOUBLE PRECISION, DIMENSION(:), POINTER :: SINGULAR_VALUES INTEGER :: NB_SINGULAR_VALUES,rootpad4 ! END TYPE ZMUMPS_ROOT_STRUC ! multicore TYPE ZMUMPS_L0OMPFAC_T SEQUENCE COMPLEX(kind=8), POINTER, DIMENSION(:) :: A INTEGER(8) :: LA END TYPE ZMUMPS_L0OMPFAC_T MUMPS_5.4.1/lib/0000775000175000017500000000000014102210467013471 5ustar jylexceljylexcelMUMPS_5.4.1/lib/README0000664000175000017500000000027714102210467014357 0ustar jylexceljylexcelAfter a successful build, this directory should contain the MUMPS libraries: - arithmetic-independent library: libmumps_common.a - aritmetic-dependent libraries: libxmumps.a, x=d, s, c, z MUMPS_5.4.1/SCILAB/0000775000175000017500000000000014102210473013655 5ustar jylexceljylexcelMUMPS_5.4.1/SCILAB/initmumps.sci0000664000175000017500000000071314102210473016403 0ustar jylexceljylexcelfunction id = initmumps() // // id = initmumps // it returns a default Scilab MUMPS mlist (structure) // id = mlist(["StructMumps";"SYM";"JOB";"ICNTL";"CNTL";"PERM_IN";"COLSCA";"ROWSCA";"RHS";"INFOG";"RINFOG";"VAR_SCHUR";"SCHUR";"INST";"SOL";"REDRHS";"PIVNUL_LIST";"SYM_PERM";"UNS_PERM";"TYPE"],0,-1,zeros(1,60)-9998,zeros(1,15)-9998,-9999,-9999,-9999,-9999,zeros(1,80)-9998,zeros(1,40)-9998,-9999,-9999,-9999,-9999,-9999,-9999,-9999,-9999,0); endfunction MUMPS_5.4.1/SCILAB/zmumps.sci0000664000175000017500000000515114102210473015712 0ustar jylexceljylexcelfunction id=zmumps(id,mat) //************************************************************************************************************** // [id] = zmumps(id,mat) // id is a structure (see details in initmumps.m and MUMPS documentation) // mat is an optional parameter if the job id.job = -1 or -2 // mat is a square sparse matrix // informations are return in id fields // // ************************************************************************************************************* if (typeof(id) ~= "StructMumps") then disp("Error. Please call initmumps first."); return; end arithtype=1; if id.JOB == -2 then if id.INST==-9999 then disp('Error. Uninitialized instance. MUMPS should be called with JOB=-1 first.'); return; end if id.TYPE ~= arithtype then disp('Error. You are trying to call z/d version on a d/z instance'); return; end // call the C routine zmumpsc zmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id = []; return; end if id.JOB == -1 then if id.INST~=-9999 then disp('Error. Already initialized instance.'); return; end // call the C routine zmumpsc [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = zmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schu; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE=arithtype; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl return; end if id.INST ==-9999 then disp('Uninitialized instance'); return; end // call the C routine zmumpsc if id.TYPE ~= arithtype then disp('You are trying to call z/d version on a d/z instance'); end [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = zmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS, mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if (id.JOB == 2|id.JOB==4|id.JOB==6) then if id.SYM == 0 then id.SCHUR=schu'; else id.SCHUR=triu(schu)+tril(schu',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl endfunction MUMPS_5.4.1/SCILAB/intmumpsc.c0000664000175000017500000005044614102210473016051 0ustar jylexceljylexcel#include "mex.h" #include "stack-c.h" #include "sci_gateway.h" #include #include #include #define MUMPS_ARITH_d 2 #define MUMPS_ARITH_z 8 #if MUMPS_ARITH == MUMPS_ARITH_z # include "zmumps_c.h" # define dmumps_c zmumps_c # define dmumps_par zmumps_par # define DMUMPS_STRUC_C ZMUMPS_STRUC_C # define DMUMPS_alloc ZMUMPS_alloc # define DMUMPS_free ZMUMPS_free # define double2 mumps_double_complex #elif MUMPS_ARITH == MUMPS_ARITH_d # include "dmumps_c.h" # define double2 double # define EXTRACT_CMPLX_FROM_C_TO_SCILAB EXTRACT_DOUBLE_FROM_C_TO_SCILAB # define EXTRACT_CMPLX_FROM_SCILAB_TOPTR EXTRACT_FROM_SCILAB_TOPTR #else # error "Only d and z arithmetics are supported" #endif #define nb_RHS 12 #define MYFREE(ptr)\ if(ptr){ \ free(ptr); \ ptr=0;} \ #define EXTRACT_FROM_SCILAB_TOPTR(it,ptr_scilab1,ptr_scilab2,mumpspointer,type,length)\ if(ptr_scilab1[0] != -9999){ \ free(mumpspointer); \ mumpspointer = (type *) malloc(length*sizeof(type)); \ for(i=0;iirn ); MYFREE( (*dmumps_par)->jcn ); MYFREE( (*dmumps_par)->a ); MYFREE( (*dmumps_par)->irn_loc ); MYFREE( (*dmumps_par)->jcn_loc ); MYFREE( (*dmumps_par)->a_loc ); MYFREE( (*dmumps_par)->eltptr ); MYFREE( (*dmumps_par)->eltvar ); MYFREE( (*dmumps_par)->a_elt ); MYFREE( (*dmumps_par)->perm_in ); MYFREE( (*dmumps_par)->colsca ); MYFREE( (*dmumps_par)->rowsca ); MYFREE( (*dmumps_par)->pivnul_list ); MYFREE( (*dmumps_par)->listvar_schur ); MYFREE( (*dmumps_par)->sym_perm ); MYFREE( (*dmumps_par)->uns_perm ); MYFREE( (*dmumps_par)->irhs_ptr); MYFREE( (*dmumps_par)->irhs_sparse); MYFREE( (*dmumps_par)->rhs_sparse); MYFREE( (*dmumps_par)->rhs); MYFREE( (*dmumps_par)->redrhs); MYFREE(*dmumps_par); } } void DMUMPS_alloc(DMUMPS_STRUC_C **dmumps_par){ *dmumps_par = (DMUMPS_STRUC_C *) malloc(sizeof(DMUMPS_STRUC_C)); (*dmumps_par)->irn = NULL; (*dmumps_par)->jcn = NULL; (*dmumps_par)->a = NULL; (*dmumps_par)->irn_loc = NULL; (*dmumps_par)->jcn_loc = NULL; (*dmumps_par)->a_loc = NULL; (*dmumps_par)->eltptr = NULL; (*dmumps_par)->eltvar = NULL; (*dmumps_par)->a_elt = NULL; (*dmumps_par)->perm_in = NULL; (*dmumps_par)->colsca = NULL; (*dmumps_par)->rowsca = NULL; (*dmumps_par)->rhs = NULL; (*dmumps_par)->redrhs = NULL; (*dmumps_par)->irhs_ptr = NULL; (*dmumps_par)->irhs_sparse = NULL; (*dmumps_par)->rhs_sparse = NULL; (*dmumps_par)->pivnul_list = NULL; (*dmumps_par)->listvar_schur = NULL; (*dmumps_par)->schur = NULL; (*dmumps_par)->sym_perm = NULL; (*dmumps_par)->uns_perm = NULL; } static int dmumpsc(char *fname){ /* RhsVar parameters */ int njob, mjob, ljob, mint, nint, lint, nsym, msym, lsym, nA, mA, nRHS, nREDRHS, mRHS,lRHS, liRHS; int mREDRHS,lREDRHS,liREDRHS; int nicntl, micntl, licntl, ncntl, mcntl, lcntl, nperm, mperm, lperm; int ncols, mcols, lcols, licols, nrows, mrows, lrows, lirows, ns_schu , ms_schu, ls_schu; int nv_schu, mv_schu, lv_schu, nschu, mschu, lschu; int type_rhs, mtype_rhs, ntype_rhs, ltype_rhs; /* LhsVar parameters */ int linfog, lrinfog, lrhsout,lrhsouti, linstout, lschurout, lschurouti, ldef; int lpivnul_list, lmapp, lsymperm, lunsperm; int one=1, temp1=80, temp2=40, temp3, temp4; int it, itRHS, itREDRHS; /* parameter for real/complex types */ int i,j,k1,k2, nb_in_row,netrue; int *ptr_int; double *ptr_double; double *ptr_scilab; #if MUMPS_ARITH == MUMPS_ARITH_z double * ptri_scilab; #endif /* Temporary length variables */ int len1, len2; /* Temporary pointers in stack */ int stkptr, stkptri; /* C pointer for input parameters */ int inst_address; int ne,inst; int *irn_in,*jcn_in; /* Variable for multiple and sparse RHS*/ int posrhs, posschur, nz_RHS,col_ind,k; int *irhs_ptr; int *irhs_sparse; double *rhs_sparse; #if MUMPS_ARITH == MUMPS_ARITH_z double *im_rhs_sparse; char * function_name="zmumpsc"; #else char * function_name="dmumpsc"; #endif SciSparse A; SciSparse RHS_SPARSE; DMUMPS_STRUC_C *dmumps_par; int dosolve=0; int donullspace=0; int doanal = 0; /* Check number of input parameters */ CheckRhs(11,12); /* Get job value. njob/mjob are the dimensions of variable job. */ GetRhsVar(2,"i",&mjob,&njob,&ljob); dosolve = (*istk(ljob) == 3 || *istk(ljob) == 5 ||*istk(ljob) == 6); doanal = (*istk(ljob) == 1 || *istk(ljob) == 4 || *istk(ljob) == 6); if(*istk(ljob) == -1){ DMUMPS_alloc(&dmumps_par); GetRhsVar(1,"i",&msym,&nsym,&lsym); dmumps_par->sym=*istk(lsym); dmumps_par->job = -1; dmumps_par->par = 1; dmumps_c(dmumps_par); dmumps_par->nz = -1; dmumps_par->nz_alloc=-1; it=1; }else{ /* Obtain pointer on instance */ GetRhsVar(10,"i",&mint,&nint,&lint); inst_address=*istk(lint); /* EXTRACT_FROM_SCILAB_TOVAL(INST,inst_address); */ ptr_int = (int *) inst_address; dmumps_par = (DMUMPS_STRUC_C *) ptr_int; if(*istk(ljob) == -2){ dmumps_par->job = -2; dmumps_c(dmumps_par); DMUMPS_free(&dmumps_par); }else{ /* Get the sparse matrix A */ GetRhsVar(12,"s",&mA,&nA,&A); if (nA != mA || mA<1 ){ Scierror(999,"%s: Bad dimensions for mat\n",function_name); return 0; } ne=A.nel; dmumps_par->n = nA; if(dmumps_par->sym != 0){ netrue = (nA+ne)/2; }else{ netrue = ne; } if(dmumps_par->nz_alloc < netrue ||dmumps_par->nz_alloc >= 2*netrue){ MYFREE(dmumps_par->jcn); MYFREE(dmumps_par->irn); MYFREE(dmumps_par->a); dmumps_par->jcn = (int*)malloc(netrue*sizeof(int)); dmumps_par->irn = (int*)malloc(netrue*sizeof(int)); dmumps_par->a = (double2 *) malloc(netrue*sizeof(double2)); dmumps_par->nz_alloc = netrue; } /* Check for symmetry in order to initialize only * lower triangle on entry to symmetric MUMPS code */ if ((dmumps_par->sym)==0){ /* * Unsymmetric case: * build irn from mnel for MUMPS format * mA : number of rows */ if(doanal){ for(i=0;ijcn)[i]=(A.icol)[i];} k1=0; for (k2=1;k2irn[k1]=k2; /* matrix indices start at 1 */ k1=k1+1; nb_in_row=nb_in_row+1; } } } #if MUMPS_ARITH == MUMPS_ARITH_z for(i=0;ia)[i]).r = (A.R)[i];} if(A.it == 1){ for(i=0;ia)[i]).i = (A.I)[i];} }else{ for(i=0;ia)[i]).i = 0.0;} } #else for(i=0;ia)[i]) = (A.R)[i];} #endif dmumps_par->nz = ne; } else{ /* symmetric case */ k1=0; i=0; for (k2=1;k2= (A.icol)[i]){ if(k1>=netrue){ Scierror(999,"%s: The matrix must be symmetric\n",function_name); return 0; } (dmumps_par->jcn)[k1]=(A.icol)[i]; (dmumps_par->irn)[k1]=k2; #if MUMPS_ARITH == MUMPS_ARITH_z (dmumps_par->a)[k1].r=(A.R)[i]; if(A.it == 1){ ((dmumps_par->a)[k1]).i = (A.I)[i];} else{ ((dmumps_par->a)[k1]).i = 0.0;} #else ((dmumps_par->a)[k1]) = (A.R)[i]; #endif k1=k1+1;} nb_in_row=nb_in_row+1; i=i+1; } } dmumps_par->nz = k1; } GetRhsVar(2,"i",&mjob,&njob,&ljob); dmumps_par->job=*istk(ljob); GetRhsVar(3,"i",&micntl,&nicntl,&licntl); EXTRACT_FROM_SCILAB_TOARR(istk(licntl),dmumps_par->icntl,int,60); GetRhsVar(4,"d",&mcntl,&ncntl,&lcntl); EXTRACT_FROM_SCILAB_TOARR(stk(lcntl),dmumps_par->cntl,double,15); GetRhsVar(5,"i",&mperm, &nperm, &lperm); EXTRACT_FROM_SCILAB_TOPTR(IT_NOT_USED,istk(lperm),istk(lperm),(dmumps_par->perm_in),int,nA); GetRhsCVar(6,"d",&it,&mcols,&ncols,&lcols,&licols); EXTRACT_FROM_SCILAB_TOPTR(it,stk(lcols),stk(licols),(dmumps_par->colsca),double2,nA); GetRhsCVar(7,"d",&it,&mrows,&nrows,&lrows,&lirows); EXTRACT_FROM_SCILAB_TOPTR(it,stk(lrows),stk(lirows),(dmumps_par->rowsca),double2,nA); /* * To follow the "spirit" of the Matlab/Scilab interfaces, treat case of null * space separately. In that case, we initialize lrhs and nrhs automatically, * allocate the space needed, and do not rely on what is provided by the user * in component RHS, that is not touched. * At the moment the user should not call the solution step combined * with the factorization step when he/she sets icntl[25] to a non-zero value. * Hence we suppose infog[28-1] is available and we can use it. * * For users of scilab/matlab, it would still be nice to be able to set ICNTL(25)=-1, * and use JOB=6. If we want to make this functionality available, we should * call separately job=2 and job=3 even if job=5 or 6 and set nrhs (and allocate * space correctly) between job=2 and job=3 calls to MUMPS. * */ if ( dmumps_par->icntl[25-1] == -1 && dmumps_par->infog[28-1] > 0) { dmumps_par->nrhs=dmumps_par->infog[28-1]; donullspace = dosolve; } else if ( dmumps_par->icntl[25-1] > 0 && dmumps_par->icntl[25-1] <= dmumps_par->infog[28-1] ) { dmumps_par->nrhs=1; donullspace = dosolve; } else { donullspace=0; } if (donullspace) { nRHS=dmumps_par->nrhs; dmumps_par->lrhs=dmumps_par->n; dmumps_par->rhs=(double2 *)malloc((dmumps_par->n)*(dmumps_par->nrhs)*sizeof(double2)); dmumps_par->icntl[19]=0; } else if(GetType(8)!=5){ /* Dense RHS */ GetRhsCVar(8,"d",&itRHS,&mRHS,&nRHS,&lRHS,&liRHS); if((!dosolve) || (stk(lRHS)[0]) == -9999){ /* Could be dangerous ? See comment in Matlab interface */ EXTRACT_CMPLX_FROM_SCILAB_TOPTR(itRHS,stk(lRHS),stk(liRHS),(dmumps_par->rhs),double2,one); }else{ dmumps_par->nrhs = nRHS; dmumps_par->lrhs = mRHS; if(mRHS!=nA){ Scierror(999,"%s: Incompatible number of rows in RHS\n",function_name); } dmumps_par->icntl[19]=0; EXTRACT_CMPLX_FROM_SCILAB_TOPTR(itRHS,stk(lRHS),stk(liRHS),(dmumps_par->rhs),double2,(nRHS*mRHS)); } }else{ /* Sparse RHS */ GetRhsVar(8,"s",&mRHS,&nRHS,&RHS_SPARSE); dmumps_par->icntl[19]=1; dmumps_par->nrhs = nRHS; dmumps_par->lrhs = mRHS; nz_RHS=RHS_SPARSE.nel; dmumps_par->nz_rhs=nz_RHS; irhs_ptr=(int*)malloc((nRHS+1)*sizeof(int)); dmumps_par->irhs_ptr=(int*)malloc((nRHS+1)*sizeof(int)); dmumps_par->irhs_sparse=(int*)malloc(nz_RHS*sizeof(int)); dmumps_par->rhs_sparse=(double2*)malloc(nz_RHS*sizeof(double2)); dmumps_par->rhs=(double2*)malloc((nRHS*mRHS)*sizeof(double2)); /* transform row-oriented sparse multiple rhs (scilab) * into column-oriented sparse multiple rhs (mumps) */ k=0; for(i=0;iirhs_ptr[i]=0;} for(i=1;iirhs_ptr)[col_ind])++; } } (dmumps_par->irhs_ptr)[0]=1; irhs_ptr[0]=(dmumps_par->irhs_ptr)[0]; for(i=1;iirhs_ptr)[i]=(dmumps_par->irhs_ptr)[i]+(dmumps_par->irhs_ptr)[i-1]; irhs_ptr[i]= (dmumps_par->irhs_ptr)[i]; } k=RHS_SPARSE.nel-1; for(i=mRHS;i>=1;i--){ for(j=0;j<(RHS_SPARSE.mnel)[i-1];j++){ col_ind=(RHS_SPARSE.icol)[k]; (dmumps_par->irhs_sparse)[irhs_ptr[col_ind]-2]=i; #if MUMPS_ARITH == MUMPS_ARITH_z if(RHS_SPARSE.it==1){ ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).r=RHS_SPARSE.R[k]; ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).i=RHS_SPARSE.I[k]; }else{ ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).r=RHS_SPARSE.R[k]; ((dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]).i=0.0; } #else (dmumps_par->rhs_sparse)[irhs_ptr[col_ind]-2]=RHS_SPARSE.R[k]; #endif k--; irhs_ptr[col_ind]=irhs_ptr[col_ind]-1; } } MYFREE(irhs_ptr); } GetRhsVar(9,"i",&nv_schu,&mv_schu,&lv_schu); dmumps_par-> size_schur=mv_schu; EXTRACT_FROM_SCILAB_TOPTR(IT_NOT_USED,istk(lv_schu),istk(lv_schu),(dmumps_par->listvar_schur),int,dmumps_par->size_schur); if(!dmumps_par->listvar_schur) dmumps_par->size_schur=0; if(dmumps_par->size_schur > 0){ MYFREE(dmumps_par->schur); if(!(dmumps_par->schur=(double2 *)malloc((dmumps_par->size_schur*dmumps_par->size_schur)*sizeof(double2)))){ Scierror(999,"%s: malloc Schur failed in intmumpsc.c\n",function_name); } dmumps_par->icntl[18]=1; }else{ dmumps_par->icntl[18]=0; } /* Reduced RHS */ if ( dmumps_par->size_schur > 0 && dosolve ) { if ( dmumps_par->icntl[26-1] == 2 ) { /* REDRHS is on input */ GetRhsCVar(11,"d",&itREDRHS,&mREDRHS,&nREDRHS,&lREDRHS,&liREDRHS); if (mREDRHS != dmumps_par->size_schur || nREDRHS != dmumps_par->nrhs ) { Scierror(999,"%s: bad dimensions for REDRHS\n"); } /* Fill dmumps_par->redrhs */ EXTRACT_CMPLX_FROM_SCILAB_TOPTR(itREDRHS,stk(lREDRHS),stk(liREDRHS),(dmumps_par->redrhs),double2,(nREDRHS*mREDRHS)); dmumps_par->lrhs=mREDRHS; } if ( dmumps_par->icntl[26-1] == 1 ) { /* REDRHS on output. Must be allocated before the call */ MYFREE(dmumps_par->redrhs); if(!(dmumps_par->redrhs=(double2 *)malloc((dmumps_par->size_schur*dmumps_par->nrhs)*sizeof(double2)))){ Scierror(999,"%s: malloc redrhs failed in intmumpsc.c\n",function_name); } } } /* call C interface to MUMPS */ dmumps_c(dmumps_par); } } if(*istk(ljob)==-2){ return 0; }else{ CheckLhs(11,11); EXTRACT_INT_FROM_C_TO_SCILAB(1,linfog,(dmumps_par->infog),one,temp1,one); EXTRACT_DOUBLE_FROM_C_TO_SCILAB(2,it,lrinfog,lrinfog,(dmumps_par->rinfog),one,temp2,one); if(dmumps_par->rhs && dosolve){ /* Just to know if solution step was called */ it =1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(3,it,lrhsout,lrhsouti,(dmumps_par->rhs),nA,nRHS,one); }else{ it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(3,it,lrhsout,lrhsouti,(dmumps_par->rhs),one,one,one); } ptr_int = (int *)dmumps_par; inst_address = (int) ptr_int; EXTRACT_INT_FROM_C_TO_SCILAB(4,linstout,&inst_address,one,one,one); temp4=dmumps_par->size_schur; if(temp4>0){ it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(5,it,lschurout,lschurouti,(dmumps_par->schur),temp4,temp4,one); }else{ it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(5,it,lschurout,lschurouti,(dmumps_par->schur),one,one,one); } /* REDRHS on output */ it=1; if ( dmumps_par->icntl[26-1]==1 && dmumps_par->size_schur > 0 && dosolve ) { len1=dmumps_par->size_schur; len2=dmumps_par->nrhs; } else { len1=1; len2=1; } it=1; EXTRACT_CMPLX_FROM_C_TO_SCILAB(6,it,stkptr,stkptri,(dmumps_par->redrhs),len1,len2,one) MYFREE(dmumps_par->redrhs); MYFREE(dmumps_par->schur); MYFREE(dmumps_par->irhs_ptr); MYFREE(dmumps_par->irhs_sparse); MYFREE(dmumps_par->rhs_sparse); MYFREE(dmumps_par->rhs); /* temp3=dmumps_par->deficiency;*/ temp3=dmumps_par->infog[27]; EXTRACT_INT_FROM_C_TO_SCILAB(7,lpivnul_list,(dmumps_par->pivnul_list),one,temp3,one); EXTRACT_INT_FROM_C_TO_SCILAB(8,lsymperm,(dmumps_par->sym_perm),one,nA,one); EXTRACT_INT_FROM_C_TO_SCILAB(9,lunsperm,(dmumps_par->uns_perm),one,nA,one); nicntl=60; EXTRACT_INT_FROM_C_TO_SCILAB(10,licntl,(dmumps_par->icntl),one,nicntl,one); ncntl=15; EXTRACT_DOUBLE_FROM_C_TO_SCILAB(11,it,lcntl,lcntl,(dmumps_par->cntl),one,ncntl,one); return 0; } } static GenericTable Tab[]={ #if MUMPS_ARITH == MUMPS_ARITH_z {(Myinterfun) sci_gateway, dmumpsc,"zmumpsc"} #else {(Myinterfun) sci_gateway, dmumpsc,"dmumpsc"} #endif }; #if MUMPS_ARITH == MUMPS_ARITH_z int C2F(scizmumps)() #else int C2F(scidmumps)() #endif {Rhs = Max(0, Rhs); (*(Tab[Fin-1].f))(Tab[Fin-1].name,Tab[Fin-1].F); return 0; } MUMPS_5.4.1/SCILAB/builder.sce0000664000175000017500000000524314102210473016003 0ustar jylexceljylexcel// $Id: builder_source.sce 7142 2011-03-22 23:45:59Z jylexcel $ //******************* VARIABLE PART TO COSTUMIZE ***************************// // -- MUMPS: MUMPS_DIR = home + "/MUMPS_5.4.1"; MUMPS_INC_DIR = MUMPS_DIR+"/include"; //path until dmumps_c.h and zmumps_c.h MUMPS_LIB_DIR = MUMPS_DIR+"/lib"; //path until libdmumps.a, libzmumps.a and libpord.a MUMPS_LIB = MUMPS_LIB_DIR+"/libmumps_common.a"; DMUMPS_LIB = MUMPS_LIB_DIR+"/libdmumps.a"; ZMUMPS_LIB = MUMPS_LIB_DIR+"/libzmumps.a"; LIB_MPISEQ = MUMPS_DIR+"/libseq/libmpiseq.a"; // -- SCILAB: Path to scilab routines SCI_DIR_INC = "/usr/include/scilab/"; // -- BLAS library, if not already included in Scilab: BLAS_LIB = ""; // -- ORDERINGS (should correspond to the ones defined MUMPS's Makefile.inc): PORD_LIB = MUMPS_LIB_DIR+"libpord.a"; METIS_LIB = HOME+"/metis-4.0/libmetis.a"; ORDERINGS_LIB = PORD_LIB+" "+METIS_LIB; // -- PTHREAD lib required by MUMPS versions > 4.6 PTHREAD_LIB="-lpthread"; // -- COMPILER FOR THE INTERFACE COMPILER_= "gcc -c -O -fPIC"; // -- FORTRAN RUNTIME LIBRARIES // -- g95 //FORT_LIB = "/usr/lib/libf95.a /usr/lib/libgcc.a"; // -- gfortran compiler FORT_LIB="/usr/lib/libgfortran.a"; // -- ifort compiler //FORT_LIB_DIR = "/opt/intel/fc/9.0/lib/"; //FORT_LIB = FORT_LIB_DIR+"libifcore.a"+" "+FORT_LIB_DIR+"libimf.a"+" "+FORT_LIB_DIR+"libguide.a"+" "+FORT_LIB_DIR+"libirc.a"; //**************************************************************************// //******************* DON't EDIT BELOW (Normally) **************************// //---- Build the Makefile fd=mopen("Makefile","w"); mfprintf(fd,"SCIDIRINC = %s\n",SCI_DIR_INC); mfprintf(fd,"MUMPSINCDIR = %s\n",MUMPS_INC_DIR); mfprintf(fd,"CC = %s\n", COMPILER_); mfprintf(fd,"all: intdmumpsc.o intzmumpsc.o\n"); mfprintf(fd,"intdmumpsc.o: intmumpsc.c\n"); mfprintf(fd,"\t$(CC) -o $@ $? -DMUMPS_ARITH=MUMPS_ARITH_d -I${MUMPSINCDIR} -I${SCIDIRINC}\n"); mfprintf(fd,"intzmumpsc.o: intmumpsc.c\n"); mfprintf(fd,"\t$(CC) -o $@ $? -DMUMPS_ARITH=MUMPS_ARITH_z -I${MUMPSINCDIR} -I${SCIDIRINC}\n"); mfprintf(fd,"clean:\n"); mfprintf(fd,"\trm *.o loader_inc.sce\n"); mclose(fd); //---- Compile unix("make"); //---- Build the Loader_inc.sce fd=mopen("loader_inc.sce","w"); mfprintf(fd,"objects = [ path+\""intzmumpsc.o\"" ; \n") mfprintf(fd," path+\""intdmumpsc.o\"" ; \n") mfprintf(fd," \""%s\"" ; \n",DMUMPS_LIB) mfprintf(fd," \""%s\"" ; \n",ZMUMPS_LIB) mfprintf(fd," \""%s\"" ; \n",ORDERINGS_LIB) mfprintf(fd," \""%s\"" ; \n",LIB_MPISEQ) mfprintf(fd," \""%s\"" ; \n",PORD_LIB) mfprintf(fd," \""%s\"" ; \n",METIS_LIB) mfprintf(fd," \""%s\"" ; \n",BLAS_LIB) mfprintf(fd," \""%s\"" ; \n",FORT_LIB) mfprintf(fd," \""%s\"" ]; \n",PTHREAD_LIB) mclose(fd); MUMPS_5.4.1/SCILAB/README0000664000175000017500000001165414102210473014544 0ustar jylexceljylexcelREADME ************************************************************************ * This SCILAB interface to MUMPS is provided to you free of charge * * and is part of the MUMPS package (see ../LICENSE for the * * conditions of use), http://mumps-solver.org * * * * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY * * EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. * * * * More information is available in the main MUMPS userguide and in: * * * * [2006] Aurelia Fevre, Jean-Yves L'Excellent and Stephane Pralet * * MATLAB and Scilab interfaces to MUMPS. LIP Report RR2006-06. * * Also available as an INRIA and an ENSEEIHT-IRIT Technical Report. * * * ************************************************************************ * * * IMPORTANT NOTICE: This interface does not include the most recent * * MUMPS features (e.g., entries of the inverse) and was * * only tested with Scilab 4 version. We plan to upgrade it * * in the future. * * * ************************************************************************ CONTENTS OF THE DIRECTORY: README : this file builder.sce : Scilab script to build the makefile, the loader_inc.sce and to compile intdmumpsc.c and intzmumps.c (to be executed once) intdmumpsc.c : C interface file to double precision version of MUMPS intzmumpsc.c : C interface file for double complex version of MUMPS loader.sce : installation script (to be executed each time scilab is launched) initmumps.sci : Scilab file for the initialisation of the mumps structure dmumps.sci : Scilab file for double precision version zmumps.sci : Scilab file for double complex version loader_inc.sce, Makefile, object files: Generated when executing the builder examples/ double_example.sce : file containing an example of using MUMPS in Scilab cmplx_example.sce : file containing an example of using MUMPS in Scilab, with a complex matrix schur_example.sce : file containing an example of using MUMPS in Scilab, with the schur option sparseRHS_example.sce : file containing an example of using MUMPS in Scilab, with a sparse multiple right hand side ex.sci : small sparse matrix used to run the examples ex2.sci : small sparse matrix used to run the schur_example ex_rhs.sci : small sparse right hand side used to run the examples *************************************************************************************** INSTALLATION : You need: 1- scilab version 3.x or 4.x (not tested with recent versions of scilab) 2- to have compiled/linked a sequential version of MUMPS with both double precision and double complex arithmetics ("make d" and "make z", or "make all") 3- to modify the paths in the builder.sce. In particular you will need to give the path to the runtime libraries of your FORTRAN 90 compiler. 4- to execute builder.sce and loader.sce by using the "exec" instruction within Scilab: exec('builder.sce'); exec('loader.sce'); SOME EXPLANATIONS: - Modifications of builder.sce In this file, you will find a variable part to customize. The following modifications have to be done after the installation of MUMPS, i.e., after having a working MUMPS library. o First, the paths until libmpiseq.a, libdmumpsc.a and libpord.a. If you have not installed these libraries in specific places, and assuming that you are using MUMPS version 4.5.5, the path should be: xxxx/MUMPS_4.5.5/Include/ xxxx/MUMPS_4.5.5/lib/ xxxx/MUMPS_4.5.5/libseq/ o Second, the C compiler with the flag for compilation only. For example: cc -c -O or gcc -c -O. o Finally, the harder part: you must define the libraries used by the Fortran compiler that was used to compile MUMPS. - Modifications of loader.sce The only thing to do in this file is to change the path DIR_SCIMUMPS; it has to be the path to Scilab files *************************************************************************************** LIMITATIONS: The behaviour of the interface strongly depends on the Fortran compilers and platform used. It has been tested on a limited set of these (for example, the g95 compiler with Scilab 3.0 and 3.1 under a Linux PC). This interface does not support MUMPS parallel versions, and has not been tested under Windows environments). MUMPS_5.4.1/SCILAB/examples/0000775000175000017500000000000014102210473015473 5ustar jylexceljylexcelMUMPS_5.4.1/SCILAB/examples/ex.sci0000664000175000017500000000022214102210473016603 0ustar jylexceljylexcela(1,2)=3.0; a(2,3)=-3.0; a(4,3)=2.0; a(5,5)=1.0; a(2,1)=3.0; a(1,1)=2.0; a(5,2)=4.0; a(3,4)=2.0; a(2,5)=6.0; a(3,2)=-1.0; a(1,3)=4.0; a(3,3)=1.0; MUMPS_5.4.1/SCILAB/examples/ex_rhs.sci0000664000175000017500000000007314102210473017463 0ustar jylexceljylexcelrhs(2,1)=3; rhs(5,1)=1; rhs(1,2)=8; rhs(2,2)=2; rhs(4,2)=3;MUMPS_5.4.1/SCILAB/examples/sparseRHS_example.sce0000664000175000017500000000200214102210473021546 0ustar jylexceljylexcel//A simple demo for the MUMPS interface, with the use of a sparse Right Hand Side //to run it, You just have to execute the instruction within Scilab // exec sparse_example.sce; //*********************** MATRIX INITIALISATION ***********************// // This matrix has to be a SciSparse, otherwise it won't work. exec('ex.sci'); //voir pour les speyes mat=sparse(a); // Right Hand side setting exec('ex_rhs.sci'); RHS = sparse(rhs); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=dmumps(id); id.RHS=RHS; //******************** CALL TO MUMPS FOR RESOLUTION ********************// job=6; id.JOB=job; [id]=dmumps(id,mat); // verification of the solution solution=id.SOL; norm_res=norm(mat*solution-RHS,'inf'); write(%io(2),norm_res); //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=dmumps(id); t=timer() MUMPS_5.4.1/SCILAB/examples/cmplx_example.sce0000664000175000017500000000173314102210473021031 0ustar jylexceljylexcel//A simple demo for the MUMPS interface //to run it, You just have to execute the instruction within Scilab // exec cmplx_example.sce; //*********************** MATRIX INITIALISATION ***********************// // This matrix has to be a SciSparse, otherwise it won't work. exec('ex.sci'); //voir pour les speyes n=size(a,1); mat=sparse(a)+%i*speye(n,n); // Right Hand side setting RHS = ones(n,1); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=zmumps(id); id.RHS=RHS; //******************** CALL TO MUMPS FOR RESOLUTION ********************// job=6; id.JOB=job; [id]=zmumps(id,mat); // verification of the solution solution=id.SOL; norm_res=norm(mat*solution-RHS,'inf'); write(%io(2),norm_res); //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=zmumps(id); t=timer() MUMPS_5.4.1/SCILAB/examples/schur_example.sce0000664000175000017500000000317514102210473021034 0ustar jylexceljylexcel//A simple demo for the MUMPS interface, with the return of the schur complement //to run it, You just have to execute the instruction within Scilab // exec sparse_example.sce; //*********************** MATRIX INITIALISATION ***********************// n=10; mat=sprand(n,n,.5)+speye(n,n); size_schur=3; // Right Hand side setting RHS = ones(n,1); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=dmumps(id); id.RHS=RHS; id.VAR_SCHUR = [n-size_schur+1:n]; //******************** CALL TO MUMPS FOR RESOLUTION ON INTERNAL PROBLEM ************// job=6; id.JOB=job; [id]=dmumps(id,mat); // verification of the solution solution=id.SOL; norm1=norm(mat(1:n-size_schur,1:n-size_schur)*solution(1:n-size_schur) - ones(n-size_schur,1),'inf'); if norm1> 10^(-9) then write(%io(2),'WARNING: solution on internal problem may not be OK'); else write(%io(2),'SOLUTION on internal problem ok'); end //******************* TRY REDUCED RHS FUNCTIONALITY **************// id.JOB=3; id.ICNTL(26)=1; // Forward [id]=dmumps(id,mat); // Solve the problem on the Schur complement id.REDRHS=id.SCHUR \ id.REDRHS; // and reinject it to MUMPS id.ICNTL(26)=2; [id]=dmumps(id,mat); solution=id.SOL; norm1=norm(mat*solution-RHS,'inf') if norm1> 10^(-9) then write(%io(2),'WARNING: solution on complete problem may not be OK'); else write(%io(2),'SOLUTION on complete problem ok'); end //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=dmumps(id); t=timer() MUMPS_5.4.1/SCILAB/examples/double_example.sce0000664000175000017500000000166214102210473021161 0ustar jylexceljylexcel//A simple demo for the MUMPS interface //to run it, You just have to execute the instruction within Scilab // exec double_example.sce; //*********************** MATRIX INITIALISATION ***********************// // This matrix has to be a SciSparse, otherwise it won't work. exec('ex.sci'); mat=sparse(a); // Right Hand side setting RHS = ones(size(mat,1),1); //****************** Initialisation of the Scilab MUMPS structure ******************// timer(); [id]=initmumps(); //Here Job=-1, the next call will only initialise the C and Fortran structure [id]=dmumps(id); id.RHS=RHS; //******************** CALL TO MUMPS FOR RESOLUTION ********************// job=6; id.JOB=job; [id]=dmumps(id,mat); // verification of the solution solution=id.SOL; norm_res=norm(mat*solution-RHS,'inf'); write(%io(2),norm_res); //****************** DESTRUCTION OF THE MUMPS INSTANCE ******************// job=-2; id.JOB=job; [id]=dmumps(id); t=timer() MUMPS_5.4.1/SCILAB/Help/0000775000175000017500000000000014102210473014545 5ustar jylexceljylexcelMUMPS_5.4.1/SCILAB/Help/help_initmumps.xml0000664000175000017500000000230214102210473020321 0ustar jylexceljylexcel eng initmumps Mumps interface's function Initialisation of the mumps structure [id]=initmumps() id : a structure (mlist)

This function initializes a MUMPS structure to its default components, so that the structure can then be used in subsequent calls to dmumps or zmumps

dmumps zmumps

http://graal.ens-lyon.fr/MUMPS/ http://www.enseeiht.fr/apo/MUMPS/

MUMPS_5.4.1/SCILAB/Help/help_dmumps.html0000664000175000017500000001603514102210473017755 0ustar jylexceljylexcel dmumps
MUMPS interface function

dmumps - call to MUMPS

Calling Sequence

[id]=dmumps (id [,mat])

Input Parameters

  • mat : sparse matrix which has to be provided as the second argument of dmumps if id.JOB is strictly larger than 0.
  • id.SYM : controls the matrix type (symmetric positive definite, symmetric indefinite or unsymmetric) and it has do be initialized by the user before the initialization phase of MUMPS (see id.JOB). Its value is set to 0 after the call of initmumps.
  • id.JOB : defines the action that will be realized by MUMPS: initialize, analyze and/or factorize and/or solve and release MUMPS internal C/Fortran data. It has to be set by the user before any call to MUMPS (except after a call to initmumps, which sets its value to -1).
  • id.ICNTL and id.CNTL : define control parameters that can be set after the initialization call (id.JOB = -1). See Section ``Control parameters'' of the MUMPS user's guide for more details. If the user does not modify an entry in id.ICNTL then MUMPS uses the default parameter. For example, if the user wants to use the AMD ordering, he/she should set id.ICNTL(7) = 0. Note that the following parameters are inhibited because they are automatically set within the interface: id.ICNTL(19) which controls the Schur complement option and id.ICNTL(20) which controls the format of the right-hand side. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1.
  • id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1.
  • id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details)
  • id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL.
  • id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details).
  • id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details.

Output Parameters

  • id.SCHUR : if id.VAR_SCHUR is provided of size SIZE_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE_SCHUR,SIZE_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it.
  • id.REDRHS (output parameter only if ICNTL(26)=1 and id.VAR_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details.
  • id.INFOG and id.RINFOG : information parameters (see Section ``Information parameters'' of the MUMPS user's guide ).
  • id.SYM_PERM : corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs.
  • id.UNS_PERM : column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ).
  • id.SOL : dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries.

Internal Parameters

  • id.INST: (MUMPS reserved component) MUMPS internal parameter.
  • id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision).

    • Description

    The function dmumps solves systems of linear equations of the form Ax = b where A is square sparse matrix and b is a dense or sparse vector or matrix. The solver MUMPS is used and we refer the user to the MUMPS User's Guide for full details. Before the first call to dmumps, a call to initmumps must have been done: 

         [id]=initmumps();

    Examples

    // this is a small linear system
// whose solution is [1;2;3;4;5]
A = sparse( [ 2  3  4  0  0;
              3  0  -3  0  6; 
              0 -1 1  2  0; 
              0  0  2  0  0; 
              0  4  0  0  1] );
b = [20 ; 24; 9; 6; 13];

// initialization of the MUMPS structure (here job=-1) 
id=initmumps();
[id]=dmumps(id);
id.RHS=b;

// call to MUMPS for the resolution
id.JOB=6;
[id]=dmumps(id,A);
x=id.SOL
norm(A*x-b)

// Destruction of the MUMPS instance
id.JOB=-2;
[id]=dmumps(id);

   
   See also the examples provided in the directory "examples" that
   comes with the distribution of this interface.

    See Also

    initmumps,  zmumps,  

    References

    http://graal.ens-lyon.fr/MUMPS/

    http://www.enseeiht.fr/apo/MUMPS/

    MUMPS_5.4.1/SCILAB/Help/help_initmumps.html0000664000175000017500000000175214102210473020475 0ustar jylexceljylexcel initmumps
    Mumps interface's function

    initmumps - Initialisation of the mumps structure

    Calling Sequence

    [id]=initmumps()

    Parameters

    • id : a structure (mlist)

    Description

    This function initializes a MUMPS structure to its default components, so that the structure can then be used in subsequent calls to dmumps or zmumps

    See Also

    dmumps,  zmumps,  

    References

    http://graal.ens-lyon.fr/MUMPS/http://www.enseeiht.fr/apo/MUMPS/

    MUMPS_5.4.1/SCILAB/Help/manrev.dtd0000664000175000017500000000514214102210473016534 0ustar jylexceljylexcel MUMPS_5.4.1/SCILAB/Help/help_dmumps.xml0000664000175000017500000002074514102210473017614 0ustar jylexceljylexcel eng dmumps MUMPS interface function call to MUMPS [id]=dmumps (id [,mat]) mat : sparse matrix which has to be provided as the second argument of dmumps if id.JOB is strictly larger than 0. id.SYM : controls the matrix type (symmetric positive definite, symmetric indefinite or unsymmetric) and it has do be initialized by the user before the initialization phase of MUMPS (see id.JOB). Its value is set to 0 after the call of initmumps. id.JOB : defines the action that will be realized by MUMPS: initialize, analyze and/or factorize and/or solve and release MUMPS internal C/Fortran data. It has to be set by the user before any call to MUMPS (except after a call to initmumps, which sets its value to -1). id.ICNTL and id.CNTL : define control parameters that can be set after the initialization call (id.JOB = -1). See Section ``Control parameters'' of the MUMPS user's guide for more details. If the user does not modify an entry in id.ICNTL then MUMPS uses the default parameter. For example, if the user wants to use the AMD ordering, he/she should set id.ICNTL(7) = 0. Note that the following parameters are inhibited because they are automatically set within the interface: id.ICNTL(19) which controls the Schur complement option and id.ICNTL(20) which controls the format of the right-hand side. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1. id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1. id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details) id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL. id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.SCHUR : if id.VAR_SCHUR is provided of size SIZE_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE_SCHUR,SIZE_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it. id.REDRHS (output parameter only if ICNTL(26)=1 and id.VAR_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.INFOG and id.RINFOG : information parameters (see Section ``Information parameters'' of the MUMPS user's guide ). id.SYM_PERM : corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs. id.UNS_PERM : column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ). id.SOL : dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries.
    id.INST: (MUMPS reserved component) MUMPS internal parameter. id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision).

    The function dmumps solves systems of linear equations of the form Ax = b where A is square sparse matrix and b is a dense or sparse vector or matrix. The solver MUMPS is used and we refer the user to the MUMPS User's Guide for full details. Before the first call to dmumps, a call to initmumps must have been done:

    See also the examples provided in the directory "examples" that comes with the distribution of this interface. initmumps zmumps

    http://graal.ens-lyon.fr/MUMPS/

    http://www.enseeiht.fr/apo/MUMPS/

    MUMPS_5.4.1/SCILAB/Help/whatis.htm0000664000175000017500000000076314102210473016564 0ustar jylexceljylexcel Interface to the MUMPS package
    dmumps - sparse direct solver (MUMPS), double precision artithmetic
    zmumps - sparse direct solver (MUMPS), double complex artithmetic
    initmumps - initialisation routine for MUMPS
    MUMPS_5.4.1/SCILAB/Help/help_zmumps.html0000664000175000017500000001603514102210473020003 0ustar jylexceljylexcel zmumps
    MUMPS interface function

    zmumps - call to MUMPS

    Calling Sequence

    [id]=zmumps (id [,mat])

    Input Parameters

    • mat : sparse matrix which has to be provided as the second argument of zmumps if id.JOB is strictly larger than 0.
    • id.SYM : controls the matrix type (symmetric positive definite, symmetric indefinite or unsymmetric) and it has do be initialized by the user before the initialization phase of MUMPS (see id.JOB). Its value is set to 0 after the call of initmumps.
    • id.JOB : defines the action that will be realized by MUMPS: initialize, analyze and/or factorize and/or solve and release MUMPS internal C/Fortran data. It has to be set by the user before any call to MUMPS (except after a call to initmumps, which sets its value to -1).
    • id.ICNTL and id.CNTL : define control parameters that can be set after the initialization call (id.JOB = -1). See Section ``Control parameters'' of the MUMPS user's guide for more details. If the user does not modify an entry in id.ICNTL then MUMPS uses the default parameter. For example, if the user wants to use the AMD ordering, he/she should set id.ICNTL(7) = 0. Note that the following parameters are inhibited because they are automatically set within the interface: id.ICNTL(19) which controls the Schur complement option and id.ICNTL(20) which controls the format of the right-hand side. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1.
    • id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1.
    • id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details)
    • id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL.
    • id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details).
    • id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details.

    Output Parameters

    • id.SCHUR : if id.VAR_SCHUR is provided of size SIZE_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE_SCHUR,SIZE_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it.
    • id.REDRHS (output parameter only if ICNTL(26)=1 and id.VAR_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details.
    • id.INFOG and id.RINFOG : information parameters (see Section ``Information parameters'' of the MUMPS user's guide ).
    • id.SYM_PERM : corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs.
    • id.UNS_PERM : column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ).
    • id.SOL : dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries.

    Internal Parameters

  • id.INST: (MUMPS reserved component) MUMPS internal parameter.
  • id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision).

    • Description

    The function zmumps solves systems of linear equations of the form Ax = b where A is square sparse matrix and b is a dense or sparse vector or matrix. The solver MUMPS is used and we refer the user to the MUMPS User's Guide for full details. Before the first call to zmumps, a call to initmumps must have been done: 

         [id]=initmumps();

    Examples

    // this is a small linear system
// whose solution is [1;2;3;4;5]
A = sparse( [ 2  3  4  0  0;
              3  0  -3  0  6; 
              0 -1 1  2  0; 
              0  0  2  0  0; 
              0  4  0  0  1] );
b = [20 ; 24; 9; 6; 13];

// initialization of the MUMPS structure (here job=-1) 
id=initmumps();
[id]=zmumps(id);
id.RHS=b;

// call to MUMPS for the resolution
id.JOB=6;
[id]=zmumps(id,A);
x=id.SOL
norm(A*x-b)

// Destruction of the MUMPS instance
id.JOB=-2;
[id]=zmumps(id);

   
   See also the examples provided in the directory "examples" that
   comes with the distribution of this interface.

    See Also

    initmumps,  dmumps,  

    References

    http://graal.ens-lyon.fr/MUMPS/

    http://www.enseeiht.fr/apo/MUMPS/

    MUMPS_5.4.1/SCILAB/Help/help_zmumps.xml0000664000175000017500000002074514102210473017642 0ustar jylexceljylexcel eng zmumps MUMPS interface function call to MUMPS [id]=zmumps (id [,mat]) mat : sparse matrix which has to be provided as the second argument of zmumps if id.JOB is strictly larger than 0. id.SYM : controls the matrix type (symmetric positive definite, symmetric indefinite or unsymmetric) and it has do be initialized by the user before the initialization phase of MUMPS (see id.JOB). Its value is set to 0 after the call of initmumps. id.JOB : defines the action that will be realized by MUMPS: initialize, analyze and/or factorize and/or solve and release MUMPS internal C/Fortran data. It has to be set by the user before any call to MUMPS (except after a call to initmumps, which sets its value to -1). id.ICNTL and id.CNTL : define control parameters that can be set after the initialization call (id.JOB = -1). See Section ``Control parameters'' of the MUMPS user's guide for more details. If the user does not modify an entry in id.ICNTL then MUMPS uses the default parameter. For example, if the user wants to use the AMD ordering, he/she should set id.ICNTL(7) = 0. Note that the following parameters are inhibited because they are automatically set within the interface: id.ICNTL(19) which controls the Schur complement option and id.ICNTL(20) which controls the format of the right-hand side. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1. id.PERM_IN : corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1. id.COLSCA and id.ROWSCA : are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details) id.RHS : defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL. id.VAR_SCHUR : corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). id.REDRHS (input parameter only if id.VAR_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.SCHUR : if id.VAR_SCHUR is provided of size SIZE_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE_SCHUR,SIZE_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it. id.REDRHS (output parameter only if ICNTL(26)=1 and id.VAR_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details. id.INFOG and id.RINFOG : information parameters (see Section ``Information parameters'' of the MUMPS user's guide ). id.SYM_PERM : corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs. id.UNS_PERM : column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ). id.SOL : dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries.
    id.INST: (MUMPS reserved component) MUMPS internal parameter. id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision).

    The function zmumps solves systems of linear equations of the form Ax = b where A is square sparse matrix and b is a dense or sparse vector or matrix. The solver MUMPS is used and we refer the user to the MUMPS User's Guide for full details. Before the first call to zmumps, a call to initmumps must have been done:

    See also the examples provided in the directory "examples" that comes with the distribution of this interface. initmumps dmumps

    http://graal.ens-lyon.fr/MUMPS/

    http://www.enseeiht.fr/apo/MUMPS/

    MUMPS_5.4.1/SCILAB/dmumps.sci0000664000175000017500000000515114102210473015664 0ustar jylexceljylexcelfunction id=dmumps(id,mat) //************************************************************************************************************** // [id] = dmumps(id,mat) // id is a structure (see details in initmumps.m and MUMPS documentation) // mat is an optional parameter if the job id.job = -1 or -2 // mat is a square sparse matrix // informations are return in id fields // // ************************************************************************************************************* if (typeof(id) ~= "StructMumps") then disp("Error. Please call initmumps first."); return; end arithtype=1; if id.JOB == -2 then if id.INST==-9999 then disp('Error. Uninitialized instance. MUMPS should be called with JOB=-1 first.'); return; end if id.TYPE ~= arithtype then disp('Error. You are trying to call z/d version on a d/z instance'); return; end // call the C routine dmumpsc dmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id = []; return; end if id.JOB == -1 then if id.INST~=-9999 then disp('Error. Already initialized instance.'); return; end // call the C routine dmumpsc [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = dmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schu; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE=arithtype; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl return; end if id.INST ==-9999 then disp('Uninitialized instance'); return; end // call the C routine dmumpsc if id.TYPE ~= arithtype then disp('You are trying to call z/d version on a d/z instance'); end [inform,rinform,sol,inst,schu,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl] = dmumpsc(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS, mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if (id.JOB == 2|id.JOB==4|id.JOB==6) then if id.SYM == 0 then id.SCHUR=schu'; else id.SCHUR=triu(schu)+tril(schu',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; clear inform rinform sol inst schu redrhs pivnul_list sym_perm uns_perm icntl cntl endfunction MUMPS_5.4.1/SCILAB/loader.sce0000664000175000017500000000144414102210473015622 0ustar jylexceljylexcelpath= get_absolute_file_path('loader.sce'); exec(path+"/loader_inc.sce"); functions1 = ["dmumpsc"]; functions2 = ["zmumpsc"]; entrypoint1 = "scidmumps"; entrypoint2 = "scizmumps"; addinter(objects,entrypoint1,functions1) num_interface = floor(funptr("dmumpsc")/100); intppty(num_interface) addinter(objects,entrypoint2,functions2) num_interface = floor(funptr("zmumpsc")/100); intppty(num_interface) [units,typs,nams]=file(); clear units typs for k=size(nams,'*'):-1:1 l=strindex(nams(k),'loader.sce'); if l<>[] then DIR_SCIMUMPS = part(nams(k),1:l($)-1); break end end DIR_SCIMUMPS_DEM=DIR_SCIMUMPS+ "examples/"; getf(DIR_SCIMUMPS+"initmumps.sci") getf(DIR_SCIMUMPS+"dmumps.sci") getf(DIR_SCIMUMPS+"zmumps.sci") add_help_chapter("Interface to the MUMPS package",path+"Help"); MUMPS_5.4.1/src/0000775000175000017500000000000014102210526013506 5ustar jylexceljylexcelMUMPS_5.4.1/src/cfac_distrib_ELT.F0000664000175000017500000004657614102210523016754 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) COMPLEX ELTVAL_LOC( LDBLARR ) COMPLEX A( LA ) TYPE(CMUMPS_STRUC) :: id TYPE(CMUMPS_ROOT_STRUC) :: root INTEGER numroc EXTERNAL numroc INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER INODE INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) COMPLEX VAL COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI COMPLEX, DIMENSION( :, : ), ALLOCATABLE :: BUFR COMPLEX, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 INTEGER, DIMENSION( : ), ALLOCATABLE, TARGET :: RG2LALLOC INTEGER, DIMENSION( : ), POINTER :: RG2L MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF IF (KEEP(46) .eq. 0 ) THEN ALLOCATE( RG2LALLOC( N ), stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = N GOTO 100 END IF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2LALLOC( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO RG2L => RG2LALLOC ELSE RG2L => root%RG2L_ROW END IF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL CMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL CMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL CMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in CMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL CMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_COMPLEX, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_COMPLEX, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL CMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL CMUMPS_ARROW_FILL_SEND_BUF( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL CMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE root%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) IF (KEEP(38).ne.0) THEN IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_ELT_DISTRIB SUBROUTINE CMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) COMPLEX ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(real(BUFR(1,I))+0.5E0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_COMPLEX, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = cmplx( NBRECR + SIZER, kind=kind(BUFR) ) END IF END DO RETURN END SUBROUTINE CMUMPS_ELT_FILL_BUF SUBROUTINE CMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE CMUMPS_MAXELT_SIZE SUBROUTINE CMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) COMPLEX ELTVAL( SIZER ) COMPLEX SELTVAL( LSELTVAL ) REAL ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE CMUMPS_SCALE_ELEMENT MUMPS_5.4.1/src/carrowheads.F0000664000175000017500000010171714102210523016123 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id ) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ) INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER(8) :: IPTRI, IPTRR EARLYT3ROOTINS = KEEP(200) .EQ. 0 TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP8(26) = 0_8 KEEP8(27) = 0_8 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1, INIV2)+1,INIV2 ) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( & ( (ITYPE .EQ. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF (EARLYT3ROOTINS) THEN ELSE KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ENDIF ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0_8 KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP8(27) > 0 ) THEN ALLOCATE( id%INTARR( KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SET_IERROR(KEEP8(27),id%INFO(2)) RETURN END IF ELSE ALLOCATE( id%INTARR( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 1 RETURN END IF END IF IPTRI = 1_8 IPTRR = 1_8 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ELSE IF ( ITYPE .eq. 3) THEN IF ( EARLYT3ROOTINS ) THEN PTRAIW(I)=0 PTRARW(I)=0 ELSE NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = int(PTRAIW( I )) NROW = 0 id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3, 8) IPTRR = IPTRR + int(NCOL + NROW + 1, 8) ELSE PTRAIW(I) = 0_8 PTRARW(I) = 0_8 END IF END DO IF ( IPTRI - 1_8 .NE. KEEP8(27) ) THEN WRITE(*,*) 'Error 1 in ana_arrowheads', & ' IPTRI - 1, KEEP8(27)=', IPTRI - 1, KEEP8(27) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1_8 .NE. KEEP8(26) ) THEN WRITE(*,*) 'Error 2 in ana_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE CMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE CMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, LINTARR, DBLARR, LDBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) !$ USE OMP_LIB USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) COMPLEX ASPK(NZ) REAL COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER RG2L( N ), FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER LP, SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) COMPLEX :: DBLARR( LDBLARR ) COMPLEX :: A( LA ) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI COMPLEX, DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT COMPLEX VAL INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER INODE, ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating IW4' CALL MUMPS_ABORT() END IF DO I = 1, N I1 = PTRAIW( I ) IA = PTRARW( I ) IF ( IA .GT. 0 ) THEN DBLARR( IA ) = ZERO IW4( I, 1 ) = INTARR( I1 ) IW4( I, 2 ) = -INTARR( I1 + 1 ) INTARR( I1 + 2 ) = I END IF END DO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFI' CALL MUMPS_ABORT() END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFR' CALL MUMPS_ABORT() END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA, ISHIFT, IS1, IS, IAS, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L(JSEND) JPOSROOT = RG2L(IARR) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE WRITE(*,*) MYID,':INTERNAL Error: root arrowhead ' WRITE(*,*) MYID,':is not belonging to me. IARR,JARR=' & ,IARR,JARR CALL MUMPS_ABORT() END IF ELSE IF ( IARR .GE. 0 ) THEN IF ( IARR .eq. JARR ) THEN IA = PTRARW( IARR ) DBLARR( IA ) = DBLARR( IA ) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = int(INTARR(IS1) + IW4(IARR,2),8) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS1 + ISHIFT + 2_8) = JARR DBLARR(PTRARW(IARR)+ISHIFT) = VAL END IF ELSE IARR = -IARR ISHIFT = int(PTRAIW(IARR)+IW4(IARR,1)+2,8) INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+int(IW4(IARR,1),8) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) & CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN CALL CMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL CMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF IF ( KEEP( 46 ) .NE. 0 ) DEALLOCATE( IW4 ) IF (NBUFS.GT.0) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) ENDIF RETURN END SUBROUTINE CMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE CMUMPS_ARROW_FILL_SEND_BUF(ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER ISEND, JSEND, DEST, NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) COMPLEX BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP COMPLEX VAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST) CALL MPI_SEND(BUFI(1,DEST),TAILLE_SENDI, & MPI_INTEGER, & DEST, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST), TAILLE_SENDR, & MPI_COMPLEX, DEST, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST) = 0 ENDIF IREQ = BUFI(1,DEST) + 1 BUFI(1,DEST) = IREQ BUFI( IREQ * 2, DEST ) = ISEND BUFI( IREQ * 2 + 1, DEST ) = JSEND BUFR( IREQ, DEST ) = VAL RETURN END SUBROUTINE CMUMPS_ARROW_FILL_SEND_BUF SUBROUTINE CMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) COMPLEX BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_COMPLEX, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE CMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) COMPLEX DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT COMPLEX cswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP cswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = cswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL CMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL CMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE CMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE CMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, PTRAIW, PTRARW, & KEEP, KEEP8, MYID, COMM, NBRECORDS, & A, LA, root, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, INFO1, INFO2 & ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW(N) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS COMPLEX A( LA ) INTEGER INFO1, INFO2 COMPLEX DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER, POINTER, DIMENSION(:) :: BUFI COMPLEX, POINTER, DIMENSION(:) :: BUFR INTEGER, POINTER, DIMENSION(:,:) :: IW4 LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: I18, IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE COMPLEX VAL COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER numroc EXTERNAL numroc TYPE_PARALL = KEEP(46) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS * 2 + 1 WRITE(*,*) MYID,': Could not allocate BUFI: goto 500' GOTO 500 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS WRITE(*,*) MYID,': Could not allocate BUFR: goto 500' GOTO 500 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = 2 * N WRITE(*,*) MYID,': Could not allocate IW4: goto 500' GOTO 500 END IF IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. DO I=1,N I18 = PTRAIW(I) IA8 = PTRARW(I) IF (IA8.GT.0_8) THEN DBLARR(IA8) = ZERO IW4(I,1) = INTARR(I18) IW4(I,2) = -INTARR(I18+1_8) INTARR(I18+2)=I ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT + int(JLOCROOT - 1,8) & * int(LOCAL_M,8) & + int(ILOCROOT - 1,8)) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( IW4 ) 500 CONTINUE KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE CMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N COMPLEX :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) COMPLEX, PARAMETER :: ZERO = (0.0E0,0.0E0) INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_SET_TO_ZERO SUBROUTINE CMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA COMPLEX, INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL CMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL CMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL CMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE CMUMPS_SET_ROOT_TO_ZERO SUBROUTINE CMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: numroc LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE CMUMPS_GET_ROOT_INFO MUMPS_5.4.1/src/slr_type.F0000664000175000017500000000476414102210521015464 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE REAL,POINTER,DIMENSION(:,:) :: Q => null() REAL,POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: MEM IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) IF(associated(LRB_OUT%R)) MEM = MEM + size(LRB_OUT%R) ELSE IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) ENDIF !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - int(MEM,8) !$OMP END ATOMIC IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE SMUMPS_LR_TYPE MUMPS_5.4.1/src/ana_omp_m.F0000664000175000017500000000131214102210475015543 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_ANA_OMP_RETURN() #if defined(BLR_MT) #if ! defined(_OPENMP) COMPILATION FAILURE: -DBLR_MT requires compilation with openmp Please modify Makefile.inc and do 'make clean; make' #endif #endif RETURN END SUBROUTINE MUMPS_ANA_OMP_RETURN MUMPS_5.4.1/src/cfac_process_root2son.F0000664000175000017500000003203314102210523020112 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & CMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER I, LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, & LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV LIST_NELIM_ROW = IOLDPS + H_INODE + NPIV LIST_NELIM_COL = LIST_NELIM_ROW + NFRONT IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in CMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NELIM_LOCAL = NELIM_ROOT DO I=1, NELIM root%RG2L_ROW(IW(LIST_NELIM_ROW)) = NELIM_LOCAL root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_ROW = LIST_NELIM_ROW + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) IF (IFLAG.LT.0 ) RETURN ENDIF IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) PTRFAC(STEP(INODE))=POSELT IF ( TYPE_SON .eq. 1 ) THEN NBROW = NFRONT - NPIV ELSE NBROW = NELIM END IF IF ( TYPE_SON .eq. 1 .OR. KEEP(50).EQ.0) THEN LDA = NFRONT ELSE LDA = NPIV+NBROW ENDIF CALL CMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL CMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL CMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in CMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) LIST_NELIM_COL = IOLDPS + H_INODE + NROW + NPIV NELIM_LOCAL = NELIM_ROOT DO I = 1, NELIM root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL root%RG2L_ROW(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL CMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_ROOT2SON MUMPS_5.4.1/src/sfac_front_LDLT_type2.F0000664000175000017500000010511014102210521017674 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE SMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_FAC_FRONT_TYPE2_AUX_M USE SMUMPS_OOC USE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M !$ USE OMP_LIB USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_BUF, ONLY : SMUMPS_BUF_TEST IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) REAL A( LA ) REAL UU, SEUIL TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG REAL UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV REAL , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL SMUMPS_BDC_ERROR LOGICAL STATICMODE REAL SEUIL_LOC REAL GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV REAL ONE PARAMETER (ONE = 1.0E0) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0E0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1)) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8)-1 CALL SMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0E0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : SMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 490 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL SMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ CALL SMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR-NPIV CALL SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL SMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL SMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in SMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.2) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL SMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL SMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL SMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG = IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF & ( & (KEEP(486).EQ.2) & ) & THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8(68) = max(KEEP8(69), KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 490 ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC2_LDLT SUBROUTINE SMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE INTEGER, INTENT(IN) :: LPN_LIST INTEGER, INTENT(IN) :: PIVNUL_LIST(LPN_LIST) INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS REAL, INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K REAL ONE PARAMETER (ONE = 1.0E0) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE SMUMPS_RESET_TO_ONE END MODULE SMUMPS_FAC2_LDLT_M MUMPS_5.4.1/src/dfac_type3_symmetrize.F0000664000175000017500000001375214102210522020132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID DOUBLE PRECISION BUF( BLOCK_SIZE * BLOCK_SIZE ) DOUBLE PRECISION A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL DMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL DMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL DMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL DMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE DMUMPS_SYMMETRIZE SUBROUTINE DMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM DOUBLE PRECISION BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_DOUBLE_PRECISION, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE DMUMPS_SEND_BLOCK SUBROUTINE DMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE DOUBLE PRECISION BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_DOUBLE_PRECISION, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL dcopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE DMUMPS_RECV_BLOCK SUBROUTINE DMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA DOUBLE PRECISION A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE DMUMPS_TRANS_DIAG SUBROUTINE DMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD DOUBLE PRECISION A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE DMUMPS_TRANSPO MUMPS_5.4.1/src/dfac_mem_dynamic.F0000664000175000017500000005254514102210523017064 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE DMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST DOUBLE PRECISION, INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_F2003) DOUBLE PRECISION, POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #else DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( DMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL DMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE DMUMPS_DM_SET_DYNPTR SUBROUTINE DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (DMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION DMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); DMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); DMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); DMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during DMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION DMUMPS_DM_ISBAND LOGICAL FUNCTION DMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) DMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION DMUMPS_DM_IS_DYNAMIC SUBROUTINE DMUMPS_DM_FAC_UPD_DYN_MEMCNTS & ( MEM_COUNT_ALLOCATED, ATOMIC_UPDATES, KEEP8, & IFLAG, IERROR, K69UPD_ARG ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_ALLOCATED INTEGER(8), INTENT(INOUT) :: KEEP8(150) LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER, INTENT(INOUT) :: IFLAG, IERROR LOGICAL, INTENT(IN), OPTIONAL :: K69UPD_ARG LOGICAL K69UPD INTEGER(8) :: KEEP8TMPCOPY K69UPD = .TRUE. IF (present(K69UPD_ARG)) THEN IF ( .NOT. K69UPD_ARG ) THEN K69UPD = .FALSE. ENDIF ENDIF IF (MEM_COUNT_ALLOCATED.GT.0) THEN IF (ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP8(73)) ENDIF IF ( KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8TMPCOPY-KEEP8(75)), IERROR) ENDIF IF ( K69UPD ) THEN IF ( ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8(68) = max(KEEP8(69), KEEP8(68)) ENDIF ENDIF ELSE IF (ATOMIC_UPDATES) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC IF ( K69UPD ) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC ENDIF ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED IF ( K69UPD ) THEN KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_DM_FAC_UPD_DYN_MEMCNTS SUBROUTINE DMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE DMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE DMUMPS_LOAD, ONLY : DMUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS DOUBLE PRECISION, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 DOUBLE PRECISION, DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. DMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in DMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL DMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in DMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL DMUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL DMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST DOUBLE PRECISION, DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in DMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL DMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL DMUMPS_DM_FREE_BLOCK( TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE DMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE DMUMPS_STATIC_PTR_M, ONLY : DMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_F2003) DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(out) :: CBPTR #else DOUBLE PRECISION, DIMENSION(:), POINTER :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL DMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL DMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE DMUMPS_DM_SET_PTR SUBROUTINE DMUMPS_DM_FREE_BLOCK( DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE DOUBLE PRECISION, POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY DEALLOCATE(DYNPTR) NULLIFY(DYNPTR) CALL DMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY) RETURN END SUBROUTINE DMUMPS_DM_FREE_BLOCK END MODULE DMUMPS_DYNAMIC_MEMORY_M SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL DMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE DMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS DOUBLE PRECISION, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL DMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE DMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.4.1/src/csol_omp_m.F0000664000175000017500000000076614102210524015753 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SOL_L0OMP_M END MODULE CMUMPS_SOL_L0OMP_M MUMPS_5.4.1/src/mumps_pord.h0000664000175000017500000000351114102210474016046 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_PORD_H #define MUMPS_PORD_H #include "mumps_common.h" #define MUMPS_PORD_INTSIZE \ F_SYMBOL(pord_intsize,PORD_INTSIZE) void MUMPS_CALL MUMPS_PORD_INTSIZE(MUMPS_INT *pord_intsize); #if defined(pord) #include MUMPS_INT mumps_pord( PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, PORD_INT * ); #define MUMPS_PORDF \ F_SYMBOL(pordf,PORDF) #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa ); #else void MUMPS_CALL MUMPS_PORDF( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa ); #endif MUMPS_INT mumps_pord_wnd( PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, PORD_INT *, PORD_INT * ); #define MUMPS_PORDF_WND \ F_SYMBOL(pordf_wnd,PORDF_WND) #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa, MUMPS_INT8 *totw ); #else void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa, MUMPS_INT *totw ); #endif #endif /*PORD*/ #endif /* MUMPS_PORD_H */ MUMPS_5.4.1/src/ssol_distrhs.F0000664000175000017500000005403714102210521016341 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSCOMP, LD_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE SMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size REAL, INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSCOMP, LD_RHSCOMP INTEGER, INTENT(IN) :: POSINRHSCOMP_FWD(N) REAL, INTENT(OUT) :: RHSCOMP(LD_RHSCOMP, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND REAL, ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI REAL, ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV REAL, PARAMETER :: ZERO = 0.0E0 !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ENDIF NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL SMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSCOMP), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in SMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSCOMP ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSCOMP,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSCOMP TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL SMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL SMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL SMUMPS_DR_TRY_RECV() CALL SMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL SMUMPS_DR_TRY_RECV() CALL SMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL SMUMPS_DR_TRY_FREE_SEND() ENDDO CALL SMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE SMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE SMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE SMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_REAL, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL SMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE SMUMPS_DR_TRY_RECV SUBROUTINE SMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) REAL, INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in SMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSCOMP=POSINRHSCOMP_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSCOMP IF ( .NOT. TOUCHED(IRHSCOMP) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSCOMP=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS IRHSCOMP=BUFRECI_ARG(I) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K) + & BUFRECR_ARG(I,K) ENDDO ENDDO !$OMP END PARALLEL DO DO I = 1, NBRECORDS IRHSCOMP = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE SMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE SMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSCOMP INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in SMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT)* & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE SMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE SMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DR_GET_NEW_BUF SUBROUTINE SMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DR_TRY_FREE_SEND SUBROUTINE SMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in SMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL SMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) * & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_REAL, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_DR_TRY_SEND SUBROUTINE SMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSCOMP ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSCOMP > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSCOMP IF ( .NOT. TOUCHED(IFS) ) THEN RHSCOMP( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_DR_EMPTY_ROWS END SUBROUTINE SMUMPS_SCATTER_DIST_RHS SUBROUTINE SMUMPS_SOL_INIT_IRHS_loc(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in SMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%ICNTL(20).EQ.10) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_BUILD_IRHS_loc(id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE SMUMPS_SOL_INIT_IRHS_loc MUMPS_5.4.1/src/csol_aux.F0000664000175000017500000013275114102210523015440 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE CMUMPS_FREETOPSO SUBROUTINE CMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE CMUMPS_COMPSO SUBROUTINE CMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER N, I, J, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8) KEEP8(150) INTEGER IRN(NZ8), ICN(NZ8) COMPLEX A(NZ8) REAL Z(N) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SOL_X SUBROUTINE CMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX, INTENT(IN) :: A(NZ8) REAL, INTENT(IN) :: COLSCA(N) REAL, INTENT(OUT) :: Z(N) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER :: I, J INTEGER(8) :: K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_SCAL_X SUBROUTINE CMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX, INTENT(IN) :: A(NZ8), RHS(N), X(N) REAL, INTENT(OUT) :: W(N) COMPLEX, INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 COMPLEX D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SOL_Y SUBROUTINE CMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N REAL, intent(in) :: W(N) COMPLEX, intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE CMUMPS_SOL_MULR SUBROUTINE CMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX W(N), X(N) REAL, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, real, sign INTEGER CMUMPS_IXAMAX EXTERNAL CMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN REAL TEMP SAVE ITER, J, JLAST, JUMP COMPLEX ZERO, ONE PARAMETER( ZERO = (0.0E0,0.0E0) ) PARAMETER( ONE = (1.0E0,0.0E0) ) REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / real(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = cmplx( sign(RONE,real(X(I))), kind=kind(X)) IW(I) = nint(real(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = CMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, real(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = cmplx( sign(RONE, real(X(I))), kind=kind(X) ) IW(I) = nint(real(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = CMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = cmplx(ALTSGN * (RONE + real(I - 1) / real(N - 1)), & kind=kind(X)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0E0 * TEMP / real(3 * N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE CMUMPS_SOL_B SUBROUTINE CMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX, INTENT(IN) :: ASPK( NZ8 ) COMPLEX, INTENT(IN) :: LHS( N ), WRHS( N ) COMPLEX, INTENT(OUT):: RHS( N ) REAL, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: DZERO = 0.0E0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_QD2 SUBROUTINE CMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX A_ELT(NA_ELT8) COMPLEX LHS( N ), WRHS( N ), RHS( N ) REAL W(N) CALL CMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL CMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE CMUMPS_ELTQD2 SUBROUTINE CMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX A_ELT(NA_ELT8) REAL TEMP REAL W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SOL_X_ELT SUBROUTINE CMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL COLSCA(N) COMPLEX A_ELT(NA_ELT8) REAL W(N) REAL TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SOL_SCALX_ELT SUBROUTINE CMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) COMPLEX A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) REAL W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR REAL ZERO COMPLEX TEMP REAL TEMP2 PARAMETER( ZERO = 0.0E0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE CMUMPS_ELTYD SUBROUTINE CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE CMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR COMPLEX A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=CMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL CMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE CMUMPS_BUILD_MAPPING_INFO(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(CMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE CMUMPS_BUILD_MAPPING_INFO SUBROUTINE CMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) COMPLEX RHS(N) COMPLEX X(N), Y(N) REAL R_W(N,2) COMPLEX C_W(N) INTEGER LP, NOITER LOGICAL TESTConv REAL OMEGA(2) REAL ARRET INTEGER, intent(in) :: GRAIN REAL, PARAMETER :: CGCE=0.2E0 REAL, PARAMETER :: CTAU=1.0E3 INTEGER I, IMAX REAL OM1, OM2, DXMAX REAL TAU, DD REAL OLDOMG(2) REAL, PARAMETER :: ZERO=0.0E0 REAL, PARAMETER :: ONE=1.0E0 INTEGER CMUMPS_IXAMAX INTRINSIC abs, max SAVE OM1, OLDOMG IMAX = CMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * real(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE CMUMPS_SOL_OMEGA SUBROUTINE CMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) COMPLEX RHS(N) COMPLEX X(N), Y(N) REAL D(N) REAL R_W(N,2) COMPLEX C_W(N) INTEGER LP REAL COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX REAL ERX, DXMAX REAL DXIMAX REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 INTEGER CMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = CMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = CMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL CMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL CMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL CMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL CMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE CMUMPS_SOL_LCOND SUBROUTINE CMUMPS_SOL_CPY_FS2RHSCOMP( JBDEB, JBFIN, NBROWS, & KEEP, RHSCOMP, NRHS, LRHSCOMP, FIRST_ROW_RHSCOMP, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSCOMP INTEGER :: FIRST_ROW_RHSCOMP INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LD_W, FIRST_ROW_W COMPLEX :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSCOMP(FIRST_ROW_RHSCOMP+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_SOL_CPY_FS2RHSCOMP SUBROUTINE CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSCOMP INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) COMPLEX :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSCOMP(IPOSINRHSCOMP,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_SOL_BWD_GTHR SUBROUTINE CMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) COMPLEX RES(N),LHS(N) COMPLEX WRHS(N) REAL W(N) REAL RESMAX,RESL2,XNORM, SCLNRM REAL ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0E0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (MAX-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (MAX-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (MAX-NORM)=',1PD9.2) RETURN END SUBROUTINE CMUMPS_SOL_Q SUBROUTINE CMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE CMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ctrsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE CMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY COMPLEX, INTENT(IN) :: A(LA) COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX, INTENT(IN) :: COEF_Y COMPLEX ALPHA, ZERO, ONE PARAMETER (ZERO=(0.0E0,0.0E0), ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL cgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL cgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE CMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE CMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) USE CMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) COMPLEX, INTENT(IN) :: WCB( LWCB ), A( LA ) COMPLEX, INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: TempNROW, J1, J3, PANEL_SIZE, TYPEF INTEGER :: IPOSINRHSCOMP, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 COMPLEX :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL TYPEF= TYPEF_U ENDIF PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE CMUMPS_SOLVE_LD_AND_RELOAD SUBROUTINE CMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) REAL, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_REAL, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_SCALING_LOC MUMPS_5.4.1/src/slr_core.F0000664000175000017500000022200414102210525015424 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE SMUMPS_LR_CORE USE MUMPS_LR_COMMON USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & LRSTATUS, N, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: N INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(N) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok REAL :: ZERO PARAMETER (ZERO = 0.0D0) INTEGER(8) :: KEEP8TMPCOPY, KEEP873COPY LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS) MINSIZE = int(IBCKSZ2 / 2) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE SMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J REAL, POINTER :: LR_BLOCK_PTR(:,:) REAL :: ONE, MONE, ZERO REAL :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL strsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL strsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'SMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL sscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB, LorU) END SUBROUTINE SMUMPS_LRTRSM SUBROUTINE SMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in SMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) REAL, intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT REAL, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER REAL, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS REAL :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE SMUMPS_LRGEMM_SCALING SUBROUTINE SMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT REAL, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL, intent(in) :: TOLEPS REAL :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ REAL, intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 REAL, POINTER, DIMENSION(:,:) :: XY_YZ REAL, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y REAL, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ REAL, EXTERNAL ::snrm2 REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL sgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for sorgqr CALL sorgqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL sgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL SMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL sgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL sgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in SMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL sgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL sgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL sgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE SMUMPS_LRGEMM4 SUBROUTINE SMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL sgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE SMUMPS_DECOMPRESS_ACC SUBROUTINE SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT REAL, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO) BUILDQ = (RANK.LE.MAXRANK) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & SMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE SMUMPS_COMPRESS_FR_UPDATES SUBROUTINE SMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) REAL, ALLOCATABLE, DIMENSION(:,:), TARGET :: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL SMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO) BUILDQ2 = (RANK2.LE.MAXRANK) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL SMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & SMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE SMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE SMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in SMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL SMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in SMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'SMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE SMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE SMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE :: RWORK_RRQR(:) REAL, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) REAL, ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL sgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL sgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL SMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL sgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL sorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL sgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & SMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE SMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE SMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in SMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE SMUMPS_GET_LUA_ORDER SUBROUTINE SMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER REAL :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C REAL, ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST REAL :: ONE, ZERO PARAMETER (ONE = 1.0E0) PARAMETER (ZERO = 0.0D0) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL SMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if defined(BLR_MT) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in SMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL sgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if defined(BLR_MT) !$OMP END DO !$OMP END PARALLEL #endif CALL SMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in SMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL SMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, & MTK405=KEEP(405)) ENDIF END SUBROUTINE SMUMPS_BLR_ASM_NIV1 END MODULE SMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE SMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT REAL :: TOLEPS INTEGER :: JPVT(*) REAL :: RWORK(*) REAL :: A(LDA,*), TAU(*) REAL :: WORK(LDW,*) REAL :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK REAL :: TEMP, TEMP2, TOL3Z REAL :: AKK REAL, PARAMETER :: RZERO=0.0E+0, RONE=1.0E+0 REAL :: ZERO REAL :: ONE PARAMETER ( ONE = 1.0E+0 ) PARAMETER ( ZERO = 0.0E+0 ) REAL :: slamch INTEGER :: ilaenv, isamax EXTERNAL :: isamax, slamch EXTERNAL sgeqrf, sormqr, xerbla EXTERNAL ilaenv EXTERNAL sgemm, sgemv, slarfg, sswap REAL, EXTERNAL :: snrm2 INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in SMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = snrm2( M, A( 1, J ), 1 ) RWORK( J ) = snrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = snrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = snrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(slamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + ISAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + isamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 RETURN END IF IF (RK.GT.MAXRANK) THEN RANK = RK INFO = RK RETURN END IF IF( PVT.NE.RK ) THEN CALL sswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL sswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL sswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN CALL sgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL slarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL slarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL sgemv( 'Transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL sgemv( 'Transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL sgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN C CALL sgemv( 'No Transpose', N-RK, K, -ONE, F( K+1, 1 ), CALL sgemv( 'No Transpose', N-RK, K, -ONE, WORK( K+1,2 ), & LDW, & A( RK, OFFSET+1 ), LDA, ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = REAL( LSTICC ) RWORK( N+J ) = REAL( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL sgemm( 'No transpose', 'Transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = snrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = snrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK RETURN 999 FORMAT ('On entry to SMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE SMUMPS_TRUNCATED_RRQR MUMPS_5.4.1/src/dfac_b.F0000664000175000017500000003756714102210522015031 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & DMUMPS_LBUF, INTARR, DBLARR, root, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS & ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_FAC_UPD_DYN_MEMCNTS USE DMUMPS_LOAD USE DMUMPS_BUF, ONLY : DMUMPS_BUF_ALLOC_CB, DMUMPS_BUF_DEALL_CB USE DMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS DOUBLE PRECISION RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: DMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) DOUBLE PRECISION CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok DOUBLE PRECISION UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK DOUBLE PRECISION ZERO, ONE DATA ZERO /0.0D0/ DATA ONE /1.0D0/ INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN DOUBLE PRECISION :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR DOUBLE PRECISION, TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = cmplx(1.0D0,0.0D0, kind=kind(1.0D0)) IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL DMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) CALL DMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 KEEP8(67) = LRLUS IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error DMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN ALLOCATE(S_IS_POINTERS%A(LA), stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) KEEP8(23)=0_8 ELSE KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL DMUMPS_BUF_ALLOC_CB( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (DMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in DMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) DEALLOCATE(S_IS_POINTERS%A); NULLIFY(S_IS_POINTERS%A) END IF ENDIF IW_DUMMY = .FALSE. A_DUMMY = .FALSE. IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL DMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), & NFSIZ,FILS,STEP,FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), & ITLOC, RHS_MUMPS, POOL, LPOOL, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF CALL DMUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = dble(OPASS) RINFO(3) = dble(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL DMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = dble(KEEP8(31)*int(KEEP(35),8))/1D6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF IF (KEEP(50) .NE. 0) THEN WRITE(MPRINT,99984) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99984 FORMAT (' --- (12) Number of negative pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE DMUMPS_FAC_B SUBROUTINE DMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, & MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) USE DMUMPS_LOAD USE DMUMPS_OOC USE DMUMPS_FAC_ASM_MASTER_M USE DMUMPS_FAC_ASM_MASTER_ELT_M USE DMUMPS_FAC1_LDLT_M USE DMUMPS_FAC2_LDLT_M USE DMUMPS_FAC1_LU_M USE DMUMPS_FAC2_LU_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_FAC_PAR_M, ONLY : DMUMPS_FAC_PAR IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA DOUBLE PRECISION :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(N) CALL DMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root, PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) RETURN END SUBROUTINE DMUMPS_FAC_PAR_I MUMPS_5.4.1/src/cmumps_iXamax.F0000664000175000017500000000536114102210523016432 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION CMUMPS_IXAMAX(N,X,INCX,GRAIN) !$ USE OMP_LIB IMPLICIT NONE COMPLEX, intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN REAL ABSMAX INTEGER :: I INTEGER(8) :: IX !$ INTEGER :: NOMP, CHUNK !$ INTEGER :: IMAX !$ REAL :: XMAX, VALABS !$ REAL, PARAMETER :: RZERO = 0.0E0 !$ NOMP = OMP_GET_MAX_THREADS() CMUMPS_IXAMAX = 0 IF ( N.LT.1 ) RETURN CMUMPS_IXAMAX = 1 IF ( N.EQ.1 .OR. INCX.LE.0 ) RETURN !$ IF (NOMP.GT.1 .AND. N.GE.GRAIN*2) THEN !$ IF ( INCX.EQ.1 ) THEN !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX) !$OMP& FIRSTPRIVATE(N, CHUNK) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ VALABS = abs(X(I)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ CMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX, IX) !$OMP& FIRSTPRIVATE(N, CHUNK, INCX) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ IX = 1 + int((I-1),8)*int(INCX,8) !$ VALABS = abs(X(IX)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ CMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ENDIF !$ ELSE IF ( INCX.EQ.1 ) THEN ABSMAX = abs(X(1)) DO I = 2, N IF ( abs(X(I)) .LE. ABSMAX ) CYCLE CMUMPS_IXAMAX = I ABSMAX = abs(X(I)) ENDDO ELSE IX = 1 ABSMAX = abs(X(1)) IX = IX + INCX DO I = 2, N IF ( abs(X(IX)).LE.ABSMAX ) GOTO 5 CMUMPS_IXAMAX = I ABSMAX = abs(X(IX)) 5 IX = IX + INCX ENDDO ENDIF !$ ENDIF RETURN END FUNCTION CMUMPS_IXAMAX MUMPS_5.4.1/src/dfac_process_end_facto_slave.F0000664000175000017500000002640614102210522021450 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE DMUMPS_LR_DATA_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL DMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL DMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL DMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL DMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL DMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in DMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE DMUMPS_END_FACTO_SLAVE MUMPS_5.4.1/src/dfac_process_blfac_slave.F0000664000175000017500000005230014102210522020565 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_FAC_LR USE DMUMPS_LR_DATA_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR USE DMUMPS_FAC_FRONT_AUX_M, & ONLY : DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if defined(BLR_MT) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: UDYNAMIC DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) DYNAMIC = .FALSE. POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) IF ( NPIV .LE. 0 ) THEN NPIV = - NPIV WRITE(*,*) MYID,':error, received negative NPIV in BLFAC' CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOLU, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL DMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL DMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL DMUMPS_TREAT_DESCBAND(INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL DMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL DMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC) THEN CALL dgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL dgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL DMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL DMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (COMPRESS_CB) THEN CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL DMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL DMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.4.1/src/cfac_mem_free_block_cb.F0000664000175000017500000000600014102210523020157 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE CMUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER IPOSSHIFT INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL CMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE CMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.4.1/src/mumps_scotch.h0000664000175000017500000000433314102210474016370 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SCOTCH_H #define MUMPS_SCOTCH_H #include "mumps_common.h" #if defined(scotch) || defined(ptscotch) #include "scotch.h" #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv prototype with 64-bit integers weights of nodes in the graph are used on entry (nv) */ MUMPS_INT esmumpsv( const MUMPS_INT n, const MUMPS_INT iwlen, MUMPS_INT * const pe, const MUMPS_INT pfree, MUMPS_INT * const len, MUMPS_INT * const iw, MUMPS_INT * const nv, MUMPS_INT * const elen, MUMPS_INT * const last); #endif /* esmumps prototype with standard integers (weights of nodes not used on entry) */ MUMPS_INT esmumps( const MUMPS_INT n, const MUMPS_INT iwlen, MUMPS_INT * const pe, const MUMPS_INT pfree, MUMPS_INT * const len, MUMPS_INT * const iw, MUMPS_INT * const nv, MUMPS_INT * const elen, MUMPS_INT * const last); #define MUMPS_SCOTCH \ F_SYMBOL(scotch,SCOTCH) void MUMPS_CALL MUMPS_SCOTCH( const MUMPS_INT * const n, const MUMPS_INT * const iwlen, MUMPS_INT * const petab, const MUMPS_INT * const pfree, MUMPS_INT * const lentab, MUMPS_INT * const iwtab, MUMPS_INT * const nvtab, MUMPS_INT * const elentab, MUMPS_INT * const lasttab, MUMPS_INT * const ncmpa, MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ); #endif /*scotch or ptscotch*/ #if defined(ptscotch) #include "mpi.h" #include "ptscotch.h" #define MUMPS_DGRAPHINIT \ F_SYMBOL(dgraphinit,DGRAPHINIT) void MUMPS_CALL MUMPS_DGRAPHINIT(SCOTCH_Dgraph *graphptr, MPI_Fint *comm, MPI_Fint *ierr); #endif /*ptscotch*/ #endif MUMPS_5.4.1/src/sooc_panel_piv.F0000664000175000017500000002770014102210525016622 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE SMUMPS_OOC). INTEGER FUNCTION SMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF SMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION SMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE SMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) REAL THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL sswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE SMUMPS_PERMUTE_PANEL SUBROUTINE SMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine SMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE SMUMPS_GET_OOC_PERM_PTR SUBROUTINE SMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: SMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE SMUMPS_OOC_PP_SET_PTR SUBROUTINE SMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE SMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE SMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE SMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE SMUMPS_OOC ! To call SMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / SMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / SMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE SMUMPS_OOC_GET_PP_SIZES SUBROUTINE SMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the SMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.4.1/src/csol_lr.F0000664000175000017500000007045614102210524015264 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SOL_LR USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE CMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSCOMP INTEGER, INTENT(IN) :: IW(LIW), POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN COMPLEX, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX, INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NELIM_GLOBAL, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in CMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT NELIM_GLOBAL = & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(NPARTSASS+1) & - BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(NPARTSASS+1) DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL CMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL cgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL cgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL cgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL cgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL cgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL cgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL CMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL CMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE CMUMPS_SOL_FWD_LR_SU SUBROUTINE CMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN COMPLEX, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in CMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL CMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ELSE CALL CMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_SOL_SLAVE_LR_U SUBROUTINE CMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB COMPLEX, ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok, CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & CMUMPS_SOL_FWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL cgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL cgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL cgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif RETURN END SUBROUTINE CMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE CMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: IPOSINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX, INTENT(INOUT) :: WCB(LWCB) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR, PCBINRHSCOMP INTEGER(8) :: PCB_LAST, PWCB INTEGER :: IPIV_PANEL COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in CMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PCBINRHSCOMP= IPOSINRHSCOMP + NPIV_GLOBAL PCB_LAST = PTWCB + int(LIELL ,8) PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) CYCLE NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSCOMP + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF CALL CMUMPS_SOL_BWD_BLR_UPDATE ( & RHSCOMP, int(LRHSCOMP,8), NRHS, LRHSCOMP, & int(IPOSINRHSCOMP,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSCOMP(IPIV_PANEL,JBDEB),LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL cgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL cgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL CMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) ENDDO RETURN END SUBROUTINE CMUMPS_SOL_BWD_LR_SU SUBROUTINE CMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB COMPLEX, ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK COMPLEX, ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK,allocok,CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & CMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, !$OMP& POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL cgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL cgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL cgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL cgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL cgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call caxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call caxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE CMUMPS_SOL_BWD_BLR_UPDATE END MODULE CMUMPS_SOL_LR SUBROUTINE CMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSCOMP, LRHSCOMP, NRHS, & PPIVINRHSCOMP, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWC COMPLEX, INTENT(IN) :: DIAG(LDIAG) COMPLEX, INTENT(INOUT) :: W(LWC) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LDAJ COMPLEX ONE PARAMETER ( ONE=(1.0E0,0.0E0) ) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL ctrsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), & LRHSCOMP) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL ctrsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), LRHSCOMP) END IF RETURN END SUBROUTINE CMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.4.1/src/zfac_distrib_distentry.F0000664000175000017500000010074614102210524020373 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE ZMUMPS_BUILD_MAPPING SUBROUTINE ZMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (ZMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR COMPLEX(kind=8) DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTRAIW( N ), PTRARW( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, COMM, NBRECORDS INTEGER(8) :: LA INTEGER SLAVEF INTEGER ISTEP_TO_INIV2(KEEP(71)) INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) COMPLEX(kind=8) A( LA ) TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I INTEGER(8) :: I18, IA8 INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX(kind=8) VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER(8) :: IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 INFO(2) = N * 2 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO I = 1, N I18 = PTRAIW( I ) IA8 = PTRARW( I ) IF ( IA8 .GT. 0_8 ) THEN DBLARR( IA8 ) = ZERO IW4( I, 1 ) = INTARR( I18 ) IW4( I, 2 ) = -INTARR( I18 + 1_8 ) INTARR( I18 + 2_8 ) = I END IF END DO EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA8, ISHIFT, IIW8, IS18, IS8, IAS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) INTARR(IS18+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,2) = IW4(IARR,2) - 1 ELSE ISHIFT = IW4(IARR,1) INTARR(PTRAIW(IARR)+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,1) = IW4(IARR,1) - 1 IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L_ROW(JSEND) JPOSROOT = root%RG2L_ROW(IARR ) ELSE IPOSROOT = root%RG2L_ROW(IARR ) JPOSROOT = root%RG2L_ROW(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JSEND IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ELSE IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JSEND IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ENDIF DEST=MASTER_NODE CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .GE. 0) THEN CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP, KEEP8 ) ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST = -3 CALL ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, &BUFI, BUFR, BUFRECI, BUFRECR, &NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, &SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, &N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, &PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, &IW4(1,1), root, KEEP,KEEP8 ) DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_DOUBLE_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN END SUBROUTINE ZMUMPS_REDISTRIBUTION SUBROUTINE ZMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, N, & PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV, LOCAL_M, LOCAL_N INTEGER(8) :: LINTARR, LDBLARR INTEGER(8) :: LA, PTR_ROOT INTEGER BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) INTEGER BUFRECI( NBRECORDS * 2 + 1 ) INTEGER IREQI(SLAVEF), IREQR(SLAVEF), IACT(SLAVEF) INTEGER IW4( N, 2 ) INTEGER(8) PTRAIW( N ), PTRARW( N ) INTEGER PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR( LINTARR ) COMPLEX(kind=8) DBLARR( LDBLARR ), A( LA ) LOGICAL SEND_ACTIVE(SLAVEF) COMPLEX(kind=8) BUFR( NBRECORDS, 2, SLAVEF ) COMPLEX(kind=8) BUFRECR( NBRECORDS ) COMPLEX(kind=8) VAL INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R, MSGSOU LOGICAL FLAG, SEND_LOCAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( DEST .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST + 1 IEND = DEST + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_COMPLEX, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF ELSE CALL MPI_WAIT( IREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. END IF END DO IF ( ISLAVE - 1 .ne. MYID ) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, ARR_INT, COMM, & IREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFR(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_R, & MPI_DOUBLE_COMPLEX, ISLAVE - 1, ARR_REAL, COMM, & IREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. ELSE SEND_LOCAL = .TRUE. END IF IACT( ISLAVE ) = 3 - IACT( ISLAVE ) BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 END IF IF ( DEST .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL ZMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE ZMUMPS_DIST_FILL_BUFFER SUBROUTINE ZMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) COMPLEX(kind=8) BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8) :: PTRAIW( N ), PTRARW( N ) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA COMPLEX(kind=8) A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS COMPLEX(kind=8) VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.4.1/src/sfac_process_master2.F0000664000175000017500000001626214102210521017726 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE SMUMPS_LOAD USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_REAL, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_REAL, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL SMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_MASTER2 MUMPS_5.4.1/src/sana_LDLT_preprocess.F0000664000175000017500000007141314102210521017624 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE SMUMPS_SET_CONSTRAINTS SUBROUTINE SMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE SMUMPS_EXPAND_PERMUTATION SUBROUTINE SMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST INTRINSIC nint MP = ICNTL(2) IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE SMUMPS_LDLT_COMPRESS SUBROUTINE SMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) REAL :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 REAL :: BEST_SCORE,CUR_VAL,TMP,VAL REAL INITSCORE, SMUMPS_UPDATESCORE, & SMUMPS_UPDATE_INVERSE, SMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM REAL ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0E0, ONE = 1.0E0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = SMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & SMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = SMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & SMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = SMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = SMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = SMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = SMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE SMUMPS_SYM_MWM FUNCTION SMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE REAL SMUMPS_UPDATESCORE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN SMUMPS_UPDATESCORE = A+B ELSE SMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION SMUMPS_UPDATESCORE FUNCTION SMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE REAL SMUMPS_UPDATE_INVERSE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN SMUMPS_UPDATE_INVERSE = A-B ELSE SMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION SMUMPS_UPDATE_INVERSE FUNCTION SMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE REAL SMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) REAL VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER SMUMPS_METRIC2x2 = real(INTER) / real(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN SMUMPS_METRIC2x2 = real(L1+L2-2) SMUMPS_METRIC2x2 = -(SMUMPS_METRIC2x2**2)/2.0E0 ELSE IF(MERGE .EQ. 1) THEN SMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L1-2) ELSE IF(MERGE .EQ. 2) THEN SMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L2-2) ELSE SMUMPS_METRIC2x2 = - real(L1-2) * real(L2-2) ENDIF ELSE SMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE SMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE SMUMPS_EXPAND_PERM_SCHUR SUBROUTINE SMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0E0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE SMUMPS_GNEW_SCHUR SUBROUTINE SMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_GET_PERM_FROM_PE SUBROUTINE SMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE SMUMPS_GET_ELIM_TREE MUMPS_5.4.1/src/zsol_fwd_aux.F0000664000175000017500000011712314102210525016325 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) USE ZMUMPS_OOC USE ZMUMPS_SOL_LR, ONLY: ZMUMPS_SOL_SLAVE_LR_U USE ZMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) COMPLEX(kind=8) WCB( LWCB ), A( LA ) COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NRHS ) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSCOMP INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG !$ LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_DOUBLE_COMPLEX, COMM, IERR ) DO I = 1, LONG IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(IWCB(I))) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 ZMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_DOUBLE_COMPLEX, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_DOUBLE_COMPLEX, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL ZMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL ZMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in ZMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE ZMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE ZMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE ZMUMPS_SOL_LR USE ZMUMPS_OOC USE ZMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS COMPLEX(kind=8) WCB( LWCB ), A( LA ) INTEGER(8) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP COMPLEX(kind=8) RHSCOMP(LRHSCOMP, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL zgemv, ztrsv, zgemm, ztrsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE COMPLEX(kind=8) ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSCOMPLASTFSDYN !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) ERROR_WAS_BROADCASTED = .FALSE. DUMMY(1)=1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN LDADIAG = NPIV ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IFR_ini8 = IFR8 !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(IFR8,JJ) IF(OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in ZMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL ZMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP(1, JBDEB), LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL ZMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL ztrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL ztrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL ztrsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL zgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL ZMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE CALL ZMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( KEEP(50) .eq. 0 ) THEN APOS1 = APOS + int(NPIV,8) * int(LIELL,8) ELSE APOS1 = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL ZMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN CALL ZMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSCOMPLASTFSDYN = 0 ELSE IPOSINRHSCOMPLASTFSDYN = & abs(POSINRHSCOMP_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSCOMP_FWD( IW(J3+I) )) .GT. & IPOSINRHSCOMPLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN IF (.NOT. CBINITZERO) THEN WRITE(*,*) ' Internal error 3 in ZMUMPS_SOLVE_NODE_FWD', & CBINITZERO, INODE, NUPDATE, NUPDATE_NONCRITICAL CALL MUMPS_ABORT() ENDIF DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) !$OMP CRITICAL(ZMUMPS_RHSCOMP_CRI) DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO !$OMP END CRITICAL(ZMUMPS_RHSCOMP_CRI) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL ZMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) COMPLEX(kind=8) WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSCOMP, POSINRHSCOMP_FWD(N) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL ZMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE ZMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP, LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSCOMP, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSCOMP_FWD( N ), IW( LIW ) COMPLEX(kind=8), INTENT( INOUT ) :: RHSCOMP( LRHSCOMP, NRHS_B ) COMPLEX(kind=8), INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) DOUBLE PRECISION :: DKEEP(150) INTEGER, PARAMETER :: ZERO = (0.0D0,0.0D0) INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSCOMP INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' !$ LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP(IPOSINRHSCOMP,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( CBINITZERO ) THEN !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) !$OMP PARALLEL DO COLLAPSE(2) IF ( OMP_FLAG ) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_RHSCOMP_TO_WCB MUMPS_5.4.1/src/dana_aux_par.F0000664000175000017500000030335414102210522016243 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_PARALLEL_ANALYSIS USE DMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS INCLUDE 'mpif.h' PUBLIC DMUMPS_ANA_F_PAR INTERFACE DMUMPS_ANA_F_PAR MODULE PROCEDURE DMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, COMM_NODES, NPROCS, NSLAVES, MYID INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER :: N, COMM INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK CONTAINS SUBROUTINE DMUMPS_ANA_F_PAR(id, WORK1, WORK2, NFSIZ, FILS, & FRERE) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER :: NFSIZ(:), FILS(:), FRERE(:) TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: IPE(:), NV(:), & NE(:), NA(:), NODE(:), & ND(:), SUBORD(:), NAMALG(:), & IPS(:), CUMUL(:), & SAVEIRN(:), SAVEJCN(:) INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG LOGICAL :: SPLITROOT INTEGER(8), PARAMETER :: K79REF=12000000_8 INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) DOUBLE PRECISION :: TIMEB nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) ord%PERMTAB => WORK1(1 : id%N) ord%PERITAB => WORK1(id%N+1 : 2*id%N) ord%TREETAB => WORK1(2*id%N+1 : 3*id%N) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_SET_PAR_ORD(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) CALL DMUMPS_DO_PAR_ORD(id, ord, WORK2) IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(*,'(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(id%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL DMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:id%N) NE => WORK1(id%N+1 : 2*id%N) NA => WORK1(2*id%N+1 : 3*id%N) NODE => WORK2(1 : id%N ) ND => WORK2(id%N+1 : 2*id%N) SUBORD => WORK2(2*id%N+1 : 3*id%N) NAMALG => WORK2(3*id%N+1 : 4*id%N) CALL MUMPS_REALLOC(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL DMUMPS_ANA_LNEW(id%N, IPE(1), NV(1), IPS(1), NE(1), & NA(1), NFSIZ(1), NODE(1), id%INFOG(6), FILS(1), FRERE(1), & ND(1), NEMIN, SUBORD(1), id%KEEP(60), id%KEEP(20), & id%KEEP(38), NAMALG(1), id%KEEP(104), CUMUL(1), & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%NSLAVES, & id%KEEP(250).EQ.1, .FALSE., IDUMMY, LIDUMMY) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL DMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(id%N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL DMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2)) & id%KEEP(210)=0 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0)) & id%KEEP(210)=1 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0)) & id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN IDUMMY(1) = -1 CALL DMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), SPLITROOT, & MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = (((id%ICNTL(13).GT.0) .AND. & (id%NSLAVES.GT.id%ICNTL(13))) .OR. & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL DMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF END IF RETURN END SUBROUTINE DMUMPS_ANA_F_PAR SUBROUTINE DMUMPS_SET_PAR_ORD(id, ord) TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29) CALL MPI_BCAST( id%KEEP(245), 1, & MPI_INTEGER, 0, id%COMM, IERR ) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(245) .EQ. 0) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) id%KEEP(245) = 1 IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, & ord%COMM_NODES, IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to ParMETIS.")') id%KEEP(245) = 2 RETURN #endif id%INFO(1) = -38 id%INFOG(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP, & '("No parallel ordering tools available.")') WRITE(LP, & '("Please install PT-SCOTCH or ParMETIS.")') END IF RETURN ELSE IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, ord%COMM_NODES, & IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF END SUBROUTINE DMUMPS_SET_PAR_ORD SUBROUTINE DMUMPS_DO_PAR_ORD(id, ord, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) CALL DMUMPS_PTSCOTCH_ORD(id, ord, WORK) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) CALL DMUMPS_PARMETIS_ORD(id, ord, WORK) if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_NODES, IERR) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF RETURN END SUBROUTINE DMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_PARMETIS_ORD(id, ord, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IERR=0 IF(size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL DMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:id%N) CALL MUMPS_REALLOC(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_BUILD_TREE(ord) ord%N = id%N ord%COMM = id%COMM RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE DMUMPS_PARMETIS_ORD #endif #if defined(ptscotch) SUBROUTINE DMUMPS_PTSCOTCH_ORD(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF (size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside DMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) BASE = id%NPROCS-id%NSLAVES BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL DMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL DMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 CALL MUMPS_REALLOC(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) END IF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = id%N ord%COMM = id%COMM CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) RETURN 11 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE DMUMPS_PTSCOTCH_ORD #endif FUNCTION DMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: DMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(DMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF DMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN DMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN DMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = id%N END IF DO I=1, ANODE WEIGHT = ord%NW(LIST(I)) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT END DO I = ord%SON(BIG) DO WEIGHT = ord%NW(I) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT IF(ord%BROTHER(I) .EQ. -1) EXIT I = ord%BROTHER(I) END DO TOPROWS = ord%TOPNODES(2)+ord%RANGTAB(BIG+1)-ord%RANGTAB(BIG) SUBMEM = 7 *id%N HOSTMEM = 12*id%N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/id%N) IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN DMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE DMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION DMUMPS_STOP_DESCENT FUNCTION DMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: DMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR DMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE DMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN DMUMPS_CNT_KIDS = DMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION DMUMPS_CNT_KIDS SUBROUTINE DMUMPS_GET_SUBTREES(ord, id) IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(DMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok LOGICAL :: SD NNODES = ord%NSLAVES CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. DMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL DMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL DMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = DMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = DMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL DMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL DMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL DMUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL DMUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(46) .EQ. 1) THEN BASE = 0 ELSE ord%FIRST(1) = 0 ord%LAST(1) = -1 BASE = 1 END IF DO I=1, ANODE CURR = LIST(I) ND = CURR IF(ord%SON(ND) .NE. -1) THEN ND = ord%SON(ND) DO IF((ord%SON(ND) .EQ. -1) .AND. & (ord%BROTHER(ND).EQ.-1)) THEN EXIT ELSE IF(ord%BROTHER(ND) .EQ. -1) THEN ND = ord%SON(ND) ELSE ND = ord%BROTHER(ND) END IF END DO END IF ord%FIRST(BASE+I) = ord%RANGTAB(ND) ord%LAST(BASE+I) = ord%RANGTAB(CURR+1)-1 END DO DO I=ANODE+1, id%NSLAVES ord%FIRST(BASE+I) = id%N+1 ord%LAST(BASE+I) = id%N END DO DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE DMUMPS_GET_SUBTREES SUBROUTINE DMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(size(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in DMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : id%N) ELEN => WORK( id%N+1 : 2*id%N) LENG => WORK(2*id%N+1 : 3*id%N) PERM => WORK(3*id%N+1 : 4*id%N) END IF CALL DMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1 : 2*id%N) CALL DMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = id%N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(dble(TMP)*1.10D0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), & HIDX, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, id%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(id%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, id%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, id%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL DMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL DMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & id%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & id%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & id%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & id%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, id%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, id%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE DMUMPS_PARSYMFACT SUBROUTINE DMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE DMUMPS_MAKE_LOC_IDX SUBROUTINE DMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE DMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in DMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE DMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), SDISPL(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : id%N) LENG => WORK(id%N+1 : 2*id%N) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*id%N id%KEEP8(126) = id%KEEP8(127)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END DO CALL DMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, id%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(id%N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL DMUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL DMUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE DMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE DMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & SDISPL(:), HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : id%N) HALO_MAP => WORK(id%N+1 : 2*id%N) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END IF END DO CALL DMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, id%N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, id%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE DMUMPS_BUILD_LOC_GRAPH SUBROUTINE DMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in DMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in DMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in DMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in DMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in DMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE DMUMPS_SEND_BUF SUBROUTINE DMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE DMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE DMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE DMUMPS_BUILD_TREE SUBROUTINE DMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, TYPE) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(id%N/ord%NSLAVES,8) DO I=1, ord%NSLAVES FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NSLAVES) = MAX(LAST(BASE+ord%NSLAVES), id%N) DO I = ord%NSLAVES+1, id%NSLAVES+1 FIRST(BASE+I) = id%N+1 LAST (BASE+I) = id%N END DO ELSE IF (TYPE.EQ.2) THEN TMP => WORK(1:id%N) NZ_ROW => WORK(id%N+1:2*id%N) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MPI_ALLREDUCE(TMP(1), NZ_ROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NSLAVES,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, id%N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((id%N-I).EQ.(ord%NSLAVES-P-1)) .OR. & (I.EQ.id%N) & ) THEN P = P+1 IF(P.EQ.ord%NSLAVES) THEN FIRST(BASE+P) = F LAST(BASE+P) = id%N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = id%N+1 LAST(BASE+J) = id%N END DO END IF RETURN END SUBROUTINE DMUMPS_GRAPH_DIST #endif SUBROUTINE DMUMPS_MERGESWAP(N, L, A1, A2) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A1(:), A2(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A1(LP) A1(LP) = A1(I) A1(I) = ISWAP ISWAP = A2(LP) A2(LP) = A2(I) A2(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE DMUMPS_MERGESWAP #if defined(DETERMINISTIC_PARALLEL_GRAPH) SUBROUTINE DMUMPS_MERGESWAP1(N, L, A) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A(LP) A(LP) = A(I) A(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE DMUMPS_MERGESWAP1 #endif SUBROUTINE DMUMPS_MERGESORT(N, K, L) INTEGER :: N INTEGER :: K(:), L(0:) INTEGER :: P, Q, S, T CONTINUE L(0) = 1 T = N + 1 DO P = 1,N - 1 IF (K(P) <= K(P+1)) THEN L(P) = P + 1 ELSE L(T) = - (P+1) T = P END IF END DO L(T) = 0 L(N) = 0 IF (L(N+1) == 0) THEN RETURN ELSE L(N+1) = iabs(L(N+1)) END IF 200 CONTINUE S = 0 T = N+1 P = L(S) Q = L(T) IF(Q .EQ. 0) RETURN 300 CONTINUE IF(K(P) .GT. K(Q)) GOTO 600 CONTINUE L(S) = sign(P,L(S)) S = P P = L(P) IF (P .GT. 0) GOTO 300 CONTINUE L(S) = Q S = T DO T = Q Q = L(Q) IF (Q .LE. 0) EXIT END DO GOTO 800 600 CONTINUE L(S) = sign(Q, L(S)) S = Q Q = L(Q) IF (Q .GT. 0) GOTO 300 CONTINUE L(S) = P S = T DO T = P P = L(P) IF (P .LE. 0) EXIT END DO 800 CONTINUE P = -P Q = -Q IF(Q.EQ.0) THEN L(S) = sign(P, L(S)) L(T) = 0 GOTO 200 END IF GOTO 300 END SUBROUTINE DMUMPS_MERGESORT FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:) #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8) IF (id%KEEP(10).EQ.1) THEN CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(DMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) BASEVAL_I8 = int(BASEVAL,8) VERTLOCNBR_I8 = int(VERTLOCNBR,8) ENDIF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.4.1/src/sana_lr.F0000664000175000017500000020100014102210521015220 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_ANA_LR USE SMUMPS_LR_CORE USE SMUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) NBGROUPS_KWAY = MAX(NINT(real(NV)/real(GROUP_SIZE2)),1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB (NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR REAL :: COMPRESS_RATIO #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) COMPRESS_RATIO= real(NVEXPANDED)/real(NV) NBGROUPS_KWAY = MAX(NINT(real(NVEXPANDED)/real(GROUP_SIZE2)),1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN INTEGER :: PARTS(:) INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBGROUPS) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO NBGROUPS = NBGROUPS + NPARTS !$OMP END CRITICAL(lrgrouping_cri) SEP = NEWSEP DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(real(IPE(N+1)-1_8)/real(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE SMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, MAXFRONT INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL SMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE SMUMPS_LR_GROUPING SUBROUTINE SMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL SMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE SMUMPS_LR_GROUPING_NEW SUBROUTINE SMUMPS_AB_LR_GROUPING(N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, MYID, COMM) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, COMM TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE REAL :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 501 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP ATOMIC WRITE IERROR = 3*N ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IF (MAPCOL(NODE).NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = real(NVEXPANDED)/real(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(real(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE SMUMPS_AB_LR_GROUPING SUBROUTINE SMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, & COMM, MYID, NPROCS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE REAL :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 501 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = real(NVEXPANDED)/real(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(real(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO 498 CONTINUE !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE SMUMPS_AB_LR_MPI_GROUPING END MODULE SMUMPS_ANA_LR MUMPS_5.4.1/src/dana_LDLT_preprocess.F0000664000175000017500000007163314102210522017612 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE DMUMPS_SET_CONSTRAINTS SUBROUTINE DMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE DMUMPS_EXPAND_PERMUTATION SUBROUTINE DMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST INTRINSIC nint MP = ICNTL(2) IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE DMUMPS_LDLT_COMPRESS SUBROUTINE DMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) DOUBLE PRECISION :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 DOUBLE PRECISION :: BEST_SCORE,CUR_VAL,TMP,VAL DOUBLE PRECISION INITSCORE, DMUMPS_UPDATESCORE, & DMUMPS_UPDATE_INVERSE, DMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM DOUBLE PRECISION ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = DMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & DMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = DMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = DMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = DMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = DMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE DMUMPS_SYM_MWM FUNCTION DMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_UPDATESCORE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN DMUMPS_UPDATESCORE = A+B ELSE DMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION DMUMPS_UPDATESCORE FUNCTION DMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_UPDATE_INVERSE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN DMUMPS_UPDATE_INVERSE = A-B ELSE DMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION DMUMPS_UPDATE_INVERSE FUNCTION DMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE DOUBLE PRECISION DMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) DOUBLE PRECISION VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER DMUMPS_METRIC2x2 = dble(INTER) / dble(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN DMUMPS_METRIC2x2 = dble(L1+L2-2) DMUMPS_METRIC2x2 = -(DMUMPS_METRIC2x2**2)/2.0D0 ELSE IF(MERGE .EQ. 1) THEN DMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L1-2) ELSE IF(MERGE .EQ. 2) THEN DMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L2-2) ELSE DMUMPS_METRIC2x2 = - dble(L1-2) * dble(L2-2) ENDIF ELSE DMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE DMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE DMUMPS_EXPAND_PERM_SCHUR SUBROUTINE DMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0D0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE DMUMPS_GNEW_SCHUR SUBROUTINE DMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_GET_PERM_FROM_PE SUBROUTINE DMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE DMUMPS_GET_ELIM_TREE MUMPS_5.4.1/src/dfac_determinant.F0000664000175000017500000001776614102210522017121 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: PIV DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE DMUMPS_UPDATEDETER SUBROUTINE DMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: PIV DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE DMUMPS_UPDATEDETER_SCALING SUBROUTINE DMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) DOUBLE PRECISION, intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL DMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL DMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE DMUMPS_GETDETER2D SUBROUTINE DMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS DOUBLE PRECISION, intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN DOUBLE PRECISION,intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL DMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP DOUBLE PRECISION :: INV(2) DOUBLE PRECISION :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_DOUBLE_PRECISION, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(DMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=dble(NEXP_IN) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE DMUMPS_DETER_REDUCTION SUBROUTINE DMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif DOUBLE PRECISION, INTENT(IN) :: INV ( 2 * NEL ) DOUBLE PRECISION, INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL DMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = dble(TMPEXPINOUT) ENDDO RETURN END SUBROUTINE DMUMPS_DETERREDUCE_FUNC SUBROUTINE DMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE DMUMPS_DETER_SQUARE SUBROUTINE DMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=1.0D0/DETER NEXP=-NEXP RETURN END SUBROUTINE DMUMPS_DETER_SCALING_INVERSE SUBROUTINE DMUMPS_DETER_SIGN_PERM(DETER, N, VISITED, PERM) IMPLICIT NONE DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: VISITED(N) INTEGER, intent(in) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (VISITED(I) .GT. N) THEN VISITED(I)=VISITED(I)-N-N-1 CYCLE ENDIF J = PERM(I) DO WHILE (J.NE.I) VISITED(J) = VISITED(J) + N + N + 1 K = K + 1 J = PERM(J) ENDDO ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE DMUMPS_DETER_SIGN_PERM SUBROUTINE DMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE DMUMPS_FAC_FRONT_AUX_M, & ONLY : DMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) DOUBLE PRECISION, intent(in) :: A(*) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DOUBLE PRECISION :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE DMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.4.1/src/zfac_process_band.F0000664000175000017500000002621114102210524017262 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE ZMUMPS_LOAD USE ZMUMPS_LR_DATA_M, ONLY: ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_RECU = BUFR( 8 ) LRSTATUS = BUFR( 9 ) ESTIM_NFS4FATHER_ATSON = BUFR(10) IBUFR = 11 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL ZMUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_RECU + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_RECU + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) CALL ZMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_RECU : & IBUFR + NSLAVES_RECU + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) THEN write(6,*) " Internal error in ZMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_RECU ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL ZMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE ZMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL ZMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_TREAT_DESCBAND MUMPS_5.4.1/src/zmumps_lr_data_m.F0000664000175000017500000036633714102210525017173 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_LR_DATA_M USE ZMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: ZMUMPS_BLR_END_FRONT, ZMUMPS_BLR_INIT_MODULE, & ZMUMPS_BLR_END_MODULE, ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_INIT, & ZMUMPS_BLR_SAVE_PANEL_LORU, ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & ZMUMPS_BLR_SAVE_BEGS_BLR_C, ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & ZMUMPS_BLR_DEC_AND_RETRIEVE_L, ZMUMPS_BLR_RETRIEVE_PANEL_LORU, & ZMUMPS_BLR_DEC_AND_TRYFREE_L, ZMUMPS_BLR_TRY_FREE_PANEL, & ZMUMPS_BLR_FREE_CB_LRB, ZMUMPS_BLR_FREE_ALL_PANELS, & ZMUMPS_BLR_SAVE_CB_LRB, & ZMUMPS_BLR_RETRIEVE_CB_LRB, ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & ZMUMPS_BLR_SAVE_BEGS_BLR_DYN, ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & ZMUMPS_BLR_RETRIEVE_NB_PANELS, ZMUMPS_BLR_EMPTY_PANEL_LORU, & ZMUMPS_BLR_SAVE_NFS4FATHER, ZMUMPS_BLR_RETRIEVE_NFS4FATHER, & ZMUMPS_BLR_SAVE_M_ARRAY, ZMUMPS_BLR_RETRIEVE_M_ARRAY, & ZMUMPS_BLR_FREE_M_ARRAY & , ZMUMPS_BLR_STRUC_TO_MOD, ZMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if ! defined(MUMPS_F2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , ZMUMPS_BLR_SAVE_DIAG_BLOCK, ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK & , ZMUMPS_SAVE_RESTORE_BLR TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type COMPLEX(kind=8), POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) CONTAINS SUBROUTINE ZMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_INIT_MODULE SUBROUTINE ZMUMPS_BLR_END_MODULE(INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP LOGICAL :: IS_FIXME_ALREADY_PRINTED IS_FIXME_ALREADY_PRINTED = .FALSE. IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL ZMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) ELSE CALL ZMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_END_MODULE SUBROUTINE ZMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_MOD_TO_STRUC SUBROUTINE ZMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE ZMUMPS_BLR_STRUC_TO_MOD SUBROUTINE ZMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_INIT_FRONT SUBROUTINE ZMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in ZMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in ZMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_INIT SUBROUTINE ZMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & "NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN IF (NEEDS_THREAD_SAFETY) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ELSE KEEP8(71) = KEEP8(71) - MEM_FREED KEEP8(73) = KEEP8(73) - MEM_FREED KEEP8(69) = KEEP8(69) - MEM_FREED ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), KEEP8) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_END_FRONT SUBROUTINE ZMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE ZMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_CB_LRB SUBROUTINE ZMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D ) COMPLEX(kind=8),POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE ZMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE ZMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in ZMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 RETURN END SUBROUTINE ZMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION ZMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF ZMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in ZMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF ZMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION ZMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE ZMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in ZMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) COMPLEX(kind=8), POINTER, INTENT(OUT) :: THEBLOCK(:) #else COMPLEX(kind=8), POINTER :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE ZMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE ZMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE ZMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE ZMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE ZMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE ZMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #else DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE ZMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE ZMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE ZMUMPS_BLR_FREE_M_ARRAY SUBROUTINE ZMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 CALL ZMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8) RETURN END SUBROUTINE ZMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE ZMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE ZMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in ZMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in ZMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) CALL DEALLOC_LRB(THELRB,KEEP8) ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE ZMUMPS_BLR_FREE_CB_LRB SUBROUTINE ZMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if((trim(mode).EQ."memory_save").OR.(trim(mode).EQ."save")) then call ZMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(trim(mode).EQ."memory_save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL ZMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL ZMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call ZMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_STRUC_T PARAMETER (NBVARIABLES_BLR_STRUC_T = 15) CHARACTER(len=30), dimension(NBVARIABLES_BLR_STRUC_T):: & VARIABLES_BLR_STRUC_T CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords,Local_NbRecords INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 VARIABLES_BLR_STRUC_T(1)="IsSYM" VARIABLES_BLR_STRUC_T(2)="IsT2" VARIABLES_BLR_STRUC_T(3)="IsSLAVE" VARIABLES_BLR_STRUC_T(4)="PANELS_L" VARIABLES_BLR_STRUC_T(5)="PANELS_U" VARIABLES_BLR_STRUC_T(6)="CB_LRB" VARIABLES_BLR_STRUC_T(7)="BEGS_BLR_STATIC" VARIABLES_BLR_STRUC_T(8)="BEGS_BLR_DYNAMIC" VARIABLES_BLR_STRUC_T(9)="BEGS_BLR_L" VARIABLES_BLR_STRUC_T(10)="BEGS_BLR_COL" VARIABLES_BLR_STRUC_T(11)="NB_ACCESSES_INIT" VARIABLES_BLR_STRUC_T(12)="NB_PANELS" VARIABLES_BLR_STRUC_T(13)="DIAG_BLOCKS" VARIABLES_BLR_STRUC_T(14)="NFS4FATHER" VARIABLES_BLR_STRUC_T(15)="M_ARRAY" SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T TMP_STRING = VARIABLES_BLR_STRUC_T(i1) SELECT CASE(TMP_STRING) CASE("IsSYM") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsT2") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsSLAVE") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_STATIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_DYNAMIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_L") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_COL") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_ACCESSES_INIT") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_PANELS") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("PANELS_L") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE("PANELS_U") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE("CB_LRB") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"memory_save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"restore" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE("DIAG_BLOCKS") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL ZMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL ZMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE("NFS4FATHER") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("M_ARRAY") if(trim(mode).EQ."restore") then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE ZMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_LRB_TYPE PARAMETER (NBVARIABLES_LRB_TYPE = 6) CHARACTER(len=30), dimension(NBVARIABLES_LRB_TYPE):: & VARIABLES_LRB_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_LRB_TYPE(1)="Q" VARIABLES_LRB_TYPE(2)="R" VARIABLES_LRB_TYPE(3)="K" VARIABLES_LRB_TYPE(4)="M" VARIABLES_LRB_TYPE(5)="N" VARIABLES_LRB_TYPE(6)="ISLR" SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE TMP_STRING = VARIABLES_LRB_TYPE(i1) SELECT CASE(TMP_STRING) CASE("Q") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("R") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("K") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("M") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("N") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("ISLR") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_LRB SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_PANEL_TYPE PARAMETER (NBVARIABLES_BLR_PANEL_TYPE = 2) CHARACTER(len=30), dimension(NBVARIABLES_BLR_PANEL_TYPE):: & VARIABLES_BLR_PANEL_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords,Local_NbRecords INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL VARIABLES_BLR_PANEL_TYPE(1)="NB_ACCESSES_LEFT" VARIABLES_BLR_PANEL_TYPE(2)="LRB_PANEL" SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE TMP_STRING = VARIABLES_BLR_PANEL_TYPE(i1) SELECT CASE(TMP_STRING) CASE("NB_ACCESSES_LEFT") NbRecords_BLR_PANEL_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE("LRB_PANEL") if(trim(mode).EQ."memory_save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL ZMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE ZMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_DIAG_BLOCK_TYPE PARAMETER (NBVARIABLES_DIAG_BLOCK_TYPE = 1) CHARACTER(len=30), dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & VARIABLES_DIAG_BLOCK_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_DIAG_BLOCK_TYPE(1)="DIAG_BLOCK" SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE TMP_STRING = VARIABLES_DIAG_BLOCK_TYPE(i1) SELECT CASE(TMP_STRING) CASE("DIAG_BLOCK") NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(trim(mode).EQ."restore") then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_DIAG_BLOCK END MODULE ZMUMPS_LR_DATA_M MUMPS_5.4.1/src/sfac_scalings_simScale_util.F0000664000175000017500000011755214102210525021303 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) C IMPLICIT NONE EXTERNAL SMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(SMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL SMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL SMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif C WE FIRST ZERO OUT DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE SMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: MYID, NUMPROCS, M, N, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C [ROW/COL]PARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: ROWPARTVEC(M) INTEGER, INTENT(IN) :: COLPARTVEC(N) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C INUMMYR < M and INUMMYC < N (CPA or <= ??) C INUMMYR holds the number of rows allocated to me C or non empty on my proc C INUMMYC idem with columns INTEGER INUMMYR, INUMMYC C C INTERNAL working array INTEGER IWRK(IWSZ) C C Local variables INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 INUMMYC = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED C INUMMYR first counts number of rows affected to me C (that will be centralized on MYID) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IC = JCN_loc(I8) IR = IRN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) THEN IWRK(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO C RETURN END SUBROUTINE SMUMPS_FINDNUMMYROWCOL SUBROUTINE SMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER(8) :: NZ_loc INTEGER MYID, NUMPROCS, M, N INTEGER INUMMYR, INUMMYC, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = M IF(N > MAXMN) MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE SMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION SMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL EPS C LOCAL VARS INTEGER I, IID REAL RONE PARAMETER(RONE=1.0E0) SMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN SMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION SMUMPS_CHK1LOC INTEGER FUNCTION SMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL EPS C LOCAL VARS INTEGER I REAL RONE PARAMETER(RONE=1.0E0) SMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN SMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION SMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION SMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ REAL DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) REAL EPS INTEGER COMM EXTERNAL SMUMPS_CHK1LOC INTEGER SMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = SMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = SMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) SMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION SMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C REAL FUNCTION SMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ) C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I, IIND REAL ERRMAX INTRINSIC abs ERRMAX = -RONE DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO SMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION SMUMPS_ERRSCALOC REAL FUNCTION SMUMPS_ERRSCA1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I REAL ERRMAX1 INTRINSIC abs ERRMAX1 = -RONE DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO SMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION SMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND REAL RZERO PARAMETER(RZERO=0.0E0) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND) = D(IIND)/sqrt(TMPD(IIND)) ENDDO RETURN END SUBROUTINE SMUMPS_UPDATESCALE SUBROUTINE SMUMPS_UPSCALE1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I REAL RZERO PARAMETER(RZERO=0.0E0) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO RETURN END SUBROUTINE SMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL VAL C LOCAL VARS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE SMUMPS_INITREALLST C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_INVLIST(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) C LOCALS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0E0/D(IIND) ENDDO RETURN END SUBROUTINE SMUMPS_INVLIST C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_INITREAL(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL VAL C LOCAL VARS INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE SMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ REAL TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I REAL DZERO PARAMETER(DZERO=0.0E0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE SMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE SMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX hold col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE SMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE SMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE SMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_DOCOMM1N SUBROUTINE SMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL SMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc INTEGER, INTENT(IN) :: ISZ, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(SMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL SMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL SMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 IWRK(2*IC-1) = IWRK(2*IC-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_CREATEPARTVECSYM SUBROUTINE SMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE SMUMPS_NUMVOLSNDRCVSYM SUBROUTINE SMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC).EQ.0) THEN IWRK(IC)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C THE SMAME THING APPLIES FOR COLS C No need to do anything C RETURN END SUBROUTINE SMUMPS_FINDNUMMYROWCOLSYM INTEGER FUNCTION SMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ REAL D(N) INTEGER INDXR(INDXRSZ) REAL EPS INTEGER COMM EXTERNAL SMUMPS_CHK1LOC INTEGER SMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = SMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) SMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION SMUMPS_CHKCONVGLOSYM SUBROUTINE SMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE SMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE SMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE SMUMPS_SETUPCOMMSSYM MUMPS_5.4.1/src/mumps_print_defined.F0000664000175000017500000000405614102210475017660 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_PRINT_IF_DEFINED(MPG) IMPLICIT NONE INTEGER, INTENT(IN) :: MPG IF (MPG.LE.0) RETURN write(MPG,*) "=================================================" #if defined(ZERO_TRIANGLE) write(MPG,*) "MUMPS compiled with option -DZERO_TRIANGLE" #endif #if defined(GEMMT_AVAILABLE) write(MPG, *) "MUMPS compiled with option -DGEMMT_AVAILABLE" #endif #if defined(DETERMINISTIC_PARALLEL_GRAPH) write(MPG,*) "MUMPS compiled with option" & ," -DDETERMINISTIC_PARALLEL_GRAPH" #endif #if defined(metis) write(MPG,*) "MUMPS compiled with option -Dmetis" #endif #if defined(metis4) write(MPG,*) "MUMPS compiled with option -Dmetis4" #endif #if defined(MUMPS_F2003) write(MPG,*) "MUMPS compiled with option -DMUMPS_F2003" #endif #if defined(OLD_OOC_NOPANEL) write(MPG,*) "MUMPS compiled with option -DOLD_OOC_NOPANEL" #endif #if defined(parmetis) write(MPG,*) "MUMPS compiled with option -Dparmetis" #endif #if defined(parmetis3) write(MPG,*) "MUMPS compiled with option -Dparmetis3" #endif #if defined(ptscotch) write(MPG,*) "MUMPS compiled with option -Dptscotch" #endif #if defined(scotch) write(MPG,*) "MUMPS compiled with option -Dscotch" #endif #if defined(MUMPS_USE_BLAS2) write(MPG,*) "MUMPS compiled with option -DMUMPS_USE_BLAS2" #endif #if defined(BLR_MT) write(MPG,*) "MUMPS compiled with option -DBLR_MT" #endif #if defined(NODYNAMICCB) write(MPG,*) "MUMPS compiled with option -DNODYNAMICCB" #endif write(MPG,*) "=================================================" RETURN END SUBROUTINE MUMPS_PRINT_IF_DEFINED MUMPS_5.4.1/src/sana_mtrans.F0000664000175000017500000007651214102210525016135 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE SMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) REAL CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0E0 CNTL(2) = 0.0E0 DO 20 I = 3,NCNTL CNTL(I) = 0.0E0 20 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSI SUBROUTINE SMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) REAL :: A(NE) REAL :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 REAL CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX REAL ZERO,MINONE,ONE PARAMETER (ZERO=0.0E0,MINONE=-1.0E0,ONE=1.0E0) INTRINSIC abs,min EXTERNAL SMUMPS_MTRANSD, SMUMPS_MTRANSE, & SMUMPS_MTRANSF, SMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL SMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL SMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL SMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL SMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSB SUBROUTINE SMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE SMUMPS_MTRANSD SUBROUTINE SMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) REAL DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE SMUMPS_MTRANSE SUBROUTINE SMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE SMUMPS_MTRANSF SUBROUTINE SMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) REAL :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) REAL SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE SMUMPS_MTRANSQ SUBROUTINE SMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) REAL, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S REAL :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSR SUBROUTINE SMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) REAL A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 REAL :: BVAL,BMIN,BMAX EXTERNAL SMUMPS_MTRANSQ,SMUMPS_MTRANSU,SMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL SMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0E0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001E0 * BMAX ENDIF BVAL = 0.0E0 BMIN = 0.0E0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL SMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL SMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL SMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSS C SUBROUTINE SMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSU C SUBROUTINE SMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) REAL A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP REAL :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD REAL :: ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) EXTERNAL SMUMPS_MTRANSD, SMUMPS_MTRANSE, & SMUMPS_MTRANSF, SMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL SMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL SMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL SMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL SMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSW SUBROUTINE SMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 EXTERNAL SMUMPS_MTRANSX DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 1000 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL SMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE SMUMPS_MTRANSZ SUBROUTINE SMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K DO 10 J = 1,N CW(J) = 0 10 CONTINUE K = 0 DO 20 I = 1,M IF (IPERM(I).EQ.0) THEN K = K + 1 RW(K) = I ELSE J = IPERM(I) CW(J) = I ENDIF 20 CONTINUE K = 0 DO 30 J = 1,N IF (CW(J).NE.0) GO TO 30 K = K + 1 I = RW(K) IPERM(I) = -J 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = -J 40 CONTINUE RETURN END SUBROUTINE SMUMPS_MTRANSX MUMPS_5.4.1/src/dfac_front_LDLT_type2.F0000664000175000017500000010542414102210523017667 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE DMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_FAC_FRONT_TYPE2_AUX_M USE DMUMPS_OOC USE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M !$ USE OMP_LIB USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_BUF, ONLY : DMUMPS_BUF_TEST IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) DOUBLE PRECISION A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV DOUBLE PRECISION , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL DMUMPS_BDC_ERROR LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC DOUBLE PRECISION GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1)) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8)-1 CALL DMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0D0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : DMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 490 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL DMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ CALL DMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR-NPIV CALL DMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL DMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL DMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in DMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.2) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL DMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL DMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL DMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL DMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG = IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF & ( & (KEEP(486).EQ.2) & ) & THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8(68) = max(KEEP8(69), KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 490 ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC2_LDLT SUBROUTINE DMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE INTEGER, INTENT(IN) :: LPN_LIST INTEGER, INTENT(IN) :: PIVNUL_LIST(LPN_LIST) INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS DOUBLE PRECISION, INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE DMUMPS_RESET_TO_ONE END MODULE DMUMPS_FAC2_LDLT_M MUMPS_5.4.1/src/cana_dist_m.F0000664000175000017500000015505714102210523016070 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE CMUMPS_ANA_LR, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) REAL UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) REAL OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR REAL OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB INTEGER(8):: MAXTEMPCB_LR INTEGER :: NB_BLR LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER NBouter_MIN INCLUDE 'mumps_headers.h' INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int, real INTEGER CMUMPS_OOC_GET_PANEL_SIZE EXTERNAL CMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0E0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(488)) IF (KEEP(66).NE.0.AND.SLAVEF.GT.1) THEN IF ( KEEP(50).EQ.0 ) THEN NBouter_MIN = ceiling & ( & (dble(KEEP(59))*dble(KEEP(108))*dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ELSE NBouter_MIN = ceiling & ( & ( max (dble(KEEP(108))*dble(KEEP(108)), & dble(KEEP(59))*dble(KEEP(108)/2) & ) & *dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ENDIF NBouter_MIN = max (NBouter_MIN, 4) LKJIB_FR = min(KEEP(108)/NBouter_MIN, 4321) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXTEMPCB_LR = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in CMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF CALL COMPUTE_BLR_VCS(KEEP(472), NB_BLR, KEEP(488), NELIM) IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0_8 ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NBCOLFAC=NFR ELSE NBCOLFAC=NELIM ENDIF PANEL_SIZE = CMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU_CURRENT = int(NBCOLFAC,8)*int(NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0 ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max0(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF (KEEP(50).NE.0.AND.UPDATE.AND.LEVEL.EQ.1) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + & int(NELIM,8)*int(NCB,8) ENDIF IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR+ & NRLADU_CURRENT_MISSING) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+MAXTEMPCB_LR) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in CMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in CMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPSA_LOC, KEEP(50), NFR, & NFR, ROOT_NPROW, ROOT_NPCOL, MYID ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + dble(OPS_NODE) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (UPDATE .AND. LEVEL.EQ.2 .AND. .NOT. MASTER) THEN NRLNEC = & max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & 2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXTEMPCB_LR = max(MAXTEMPCB_LR,LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in CMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in CMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max0(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) SBUF_RECOLD = max(int(SBUFR_FR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = real(OPS_SBTR_LOC) OPSA = real(OPSA_LOC) RETURN END SUBROUTINE CMUMPS_ANA_DISTM MUMPS_5.4.1/src/cfac_process_blocfacto_LDLT.F0000664000175000017500000013325114102210523021104 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE CMUMPS_LOAD USE CMUMPS_BUF USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_FAC_LR USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR USE CMUMPS_FAC_FRONT_AUX_M, & ONLY : CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 COMPLEX MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW, DEST INTEGER ICT11 INTEGER(8) LPOS, LPOS2, DPOS, UPOS INTEGER (8) IPOS, KPOS INTEGER I, IPIV, FPERE, NSLAVES_TOT, & NSLAVES_FOLLOW, NB_BLOC_FAC INTEGER IPOSK, JPOSK, NPIVSENT, Block, IROW, BLSIZE INTEGER allocok, TO_UPDATE_CPT_END COMPLEX, DIMENSION(:), ALLOCATABLE :: UIP21K, BLFCTDYN INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW, PIVDYN LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNPIVBLFCT LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ, SHIFT INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) XSIZE = KEEP(IXSZ) KEEP_BEGS_BLR_LS =.FALSE. KEEP_BEGS_BLR_COL =.FALSE. KEEP_BLR_LS =.FALSE. IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) LD_BLOCFACTO = max(NCOL,1) ENDIF IF (LR_ACTIVATED) THEN DYNPIVBLFCT = .TRUE. ELSE DYNPIVBLFCT = .FALSE. ENDIF IF ( .NOT. DYNPIVBLFCT ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL CMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(PIVDYN(max(1,NPIV)),BLFCTDYN(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR PIVDYN and BLFCTDYN IN ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PIVDYN, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLFCTDYN, int(LA_BLOCFACTO), & MPI_COMPLEX, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_COMPLEX, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL CMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL CMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF ( LASTBL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF ( NPIV1 + NCOL .NE. NASS1 ) THEN WRITE(*,*) 'SymBLFC Error: NPIV1 + NCOL .NE. NASS1 :', & NPIV1,NCOL,NASS1 CALL MUMPS_ABORT() END IF ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNPIVBLFCT) THEN PIVI = abs(PIVDYN(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL cswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (.NOT.LR_ACTIVATED) THEN ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF ELSE ALLOCATE( UIP21K( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * 1 GOTO 700 END IF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNPIVBLFCT) THEN CALL ctrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & BLFCTDYN, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ELSE CALL ctrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ENDIF ENDIF IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A_PTR(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN LPOS = POSELT + int(NPIV1,8) IF (DYNPIVBLFCT) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNPIVBLFCT) THEN PIVI = PIVDYN(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNPIVBLFCT) THEN A11 = ONE/BLFCTDYN(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL cscal( NROW1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNPIVBLFCT) THEN A11 = BLFCTDYN(POSPV1) A22 = BLFCTDYN(POSPV2) A12 = BLFCTDYN(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = BLFCTDYN(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0) THEN CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_LS = NPARTSCB ENDIF call MAX_CLUSTER(BEGS_BLR_LM,NB_BLR_LM+1,MAXI_CLUSTER_LM) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN IF (NPARTSASS_MASTER.GT.NPARTSASS_COL) THEN ENDIF SHIFT = NPARTSASS_COL-NPARTSASS_MASTER ALLOCATE(BEGS_BLR_COL_TMP(size(BEGS_BLR_COL)-SHIFT), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL)-SHIFT GOTO 700 END IF DO II= 1, size(BEGS_BLR_COL)-SHIFT BEGS_BLR_COL_TMP (II) = BEGS_BLR_COL(II+SHIFT) ENDDO BEGS_BLR_COL_TMP(1) = 1 DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL+NELIM) ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT=0 IF (NSLAVES_PREC.GT.0) THEN NB_ACCESSES_INIT=NSLAVES_PREC+1 ENDIF IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNPIVBLFCT) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(BLFCTDYN, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & PIVDYN, OFFSET_IW=1) ELSE CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL CMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & BLFCTDYN, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (DYNPIVBLFCT) THEN CALL CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & BLFCTDYN, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & PIVDYN, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, 0, NPARTSCB, 'V') CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL-NPIV.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN UPOS = int(NPIV+1,8) CALL cgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA, BLFCTDYN(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL cgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL cgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL cgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL cgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL CMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ)) IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN) ) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNPIVBLFCT) THEN CALL CMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFCTDYN, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & PIVDYN, MAXI_CLUSTER, & IERR ) ELSE CALL CMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) ENDIF IF (IERR .EQ. -1 ) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & CMUMPS_PROCESS_SYM_BLOCFACTO" WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1 IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 .AND. NSLAVES_PREC.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8) ENDIF IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN)) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) THEN DEALLOCATE( UIP21K ) ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL CMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF IF (COMPRESS_CB) THEN NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "CMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL CMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV+NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1+NPIV, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL CMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (NPIV.GT.0) THEN IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN CALL DEALLOC_BLR_PANEL (BLR_LS, NB_BLR_LS, KEEP8) IF (associated(BLR_LS)) DEALLOCATE(BLR_LS) ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.4.1/src/mumps_io_err.h0000664000175000017500000000317614102210474016370 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include "mumps_common.h" #include "mumps_c_types.h" #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) # include #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) extern pthread_mutex_t err_mutex; #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ /* Exported functions */ #define MUMPS_LOW_LEVEL_INIT_ERR_STR \ F_SYMBOL(low_level_init_err_str,LOW_LEVEL_INIT_ERR_STR) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_ERR_STR( MUMPS_INT *dim, char *err_str, mumps_ftnlen l1 ); /* Export an error to the Fortran layer Returns mumps_errno for convenience */ MUMPS_INT mumps_io_error(MUMPS_INT mumps_errno, const char* desc); /* Export a system error to the Fortran layer (errno must be set) Returns mumps_errno for convenience */ MUMPS_INT mumps_io_sys_error(MUMPS_INT mumps_errno, const char* desc); #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) MUMPS_INT mumps_io_init_err_lock(); MUMPS_INT mumps_io_destroy_err_lock(); MUMPS_INT mumps_check_error_th(); MUMPS_INLINE MUMPS_INT mumps_io_protect_err(); MUMPS_INLINE MUMPS_INT mumps_io_unprotect_err(); #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ MUMPS_5.4.1/src/sfac_root_parallel.F0000664000175000017500000001703314102210521017447 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE SMUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( SMUMPS_ROOT_STRUC ) :: root INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK REAL WK( LWK ) INTEGER KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR REAL A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP REAL, INTENT(INOUT) :: DET_MANT INTEGER IOLDPS INTEGER(8) :: IAPOS DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER LOCAL_M, LOCAL_N, LPIV, IERR, allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE INCLUDE 'mumps_headers.h' EXTERNAL numroc INTEGER numroc IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL SMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL SMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL psgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pspotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL SMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in SMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL SMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL SMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & root%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF RETURN END SUBROUTINE SMUMPS_FACTO_ROOT MUMPS_5.4.1/src/zfac_scalings.F0000664000175000017500000002763414102210524016435 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) COMPLEX(kind=8), INTENT(IN) :: ASPK(NZ8) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER LWK_REAL COMPLEX(kind=8) WK(LWK8) DOUBLE PRECISION WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I LOGICAL PROK DOUBLE PRECISION ONE PARAMETER( ONE = 1.0D0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROK) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROK) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROK) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL ZMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN CALL ZMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL ZMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 410 INFO(1) = -5 INFO(2) = 5*N-LWK_REAL IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_A SUBROUTINE ZMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX(kind=8) VAL(NZ8) DOUBLE PRECISION RNOR(N),CNOR(N) DOUBLE PRECISION COLSCA(N),ROWSCA(N) DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE ZMUMPS_ROWCOL SUBROUTINE ZMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX(kind=8), INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION, INTENT(OUT) :: CNOR(N) DOUBLE PRECISION, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE ZMUMPS_FAC_Y SUBROUTINE ZMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX(kind=8) , INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT DOUBLE PRECISION :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE ZMUMPS_FAC_V SUBROUTINE ZMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8) VAL(NZ8) DOUBLE PRECISION RNOR(N) DOUBLE PRECISION ROWSCA(N) INTEGER MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE ZMUMPS_FAC_X SUBROUTINE ZMUMPS_ANORMINF( id, ANORMINF, LSCAL ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE(ZMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL INTEGER, DIMENSION (:), POINTER :: KEEP,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE COMPLEX(kind=8) DUMMY(1) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0) DOUBLE PRECISION, ALLOCATABLE :: SUMR(:), SUMR_LOC(:) INTEGER :: allocok, MTYPE, I INFO =>id%INFO KEEP =>id%KEEP KEEP8 =>id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN ALLOCATE( SUMR( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL ZMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL ZMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1), KEEP8(1), & id%COLSCA(1)) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL ZMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, KEEP(1),KEEP8(1) ) ELSE CALL ZMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL ZMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL ZMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1)) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = dble(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE ZMUMPS_ANORMINF MUMPS_5.4.1/src/darrowheads.F0000664000175000017500000010221414102210522016114 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id ) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ) INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER(8) :: IPTRI, IPTRR EARLYT3ROOTINS = KEEP(200) .EQ. 0 TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP8(26) = 0_8 KEEP8(27) = 0_8 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1, INIV2)+1,INIV2 ) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( & ( (ITYPE .EQ. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF (EARLYT3ROOTINS) THEN ELSE KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ENDIF ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0_8 KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP8(27) > 0 ) THEN ALLOCATE( id%INTARR( KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SET_IERROR(KEEP8(27),id%INFO(2)) RETURN END IF ELSE ALLOCATE( id%INTARR( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 1 RETURN END IF END IF IPTRI = 1_8 IPTRR = 1_8 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ELSE IF ( ITYPE .eq. 3) THEN IF ( EARLYT3ROOTINS ) THEN PTRAIW(I)=0 PTRARW(I)=0 ELSE NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = int(PTRAIW( I )) NROW = 0 id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3, 8) IPTRR = IPTRR + int(NCOL + NROW + 1, 8) ELSE PTRAIW(I) = 0_8 PTRARW(I) = 0_8 END IF END DO IF ( IPTRI - 1_8 .NE. KEEP8(27) ) THEN WRITE(*,*) 'Error 1 in ana_arrowheads', & ' IPTRI - 1, KEEP8(27)=', IPTRI - 1, KEEP8(27) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1_8 .NE. KEEP8(26) ) THEN WRITE(*,*) 'Error 2 in ana_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE DMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE DMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, LINTARR, DBLARR, LDBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) !$ USE OMP_LIB USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION ASPK(NZ) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER RG2L( N ), FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER LP, SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) DOUBLE PRECISION :: DBLARR( LDBLARR ) DOUBLE PRECISION :: A( LA ) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT DOUBLE PRECISION VAL INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER INODE, ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating IW4' CALL MUMPS_ABORT() END IF DO I = 1, N I1 = PTRAIW( I ) IA = PTRARW( I ) IF ( IA .GT. 0 ) THEN DBLARR( IA ) = ZERO IW4( I, 1 ) = INTARR( I1 ) IW4( I, 2 ) = -INTARR( I1 + 1 ) INTARR( I1 + 2 ) = I END IF END DO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFI' CALL MUMPS_ABORT() END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFR' CALL MUMPS_ABORT() END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA, ISHIFT, IS1, IS, IAS, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L(JSEND) JPOSROOT = RG2L(IARR) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE WRITE(*,*) MYID,':INTERNAL Error: root arrowhead ' WRITE(*,*) MYID,':is not belonging to me. IARR,JARR=' & ,IARR,JARR CALL MUMPS_ABORT() END IF ELSE IF ( IARR .GE. 0 ) THEN IF ( IARR .eq. JARR ) THEN IA = PTRARW( IARR ) DBLARR( IA ) = DBLARR( IA ) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = int(INTARR(IS1) + IW4(IARR,2),8) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS1 + ISHIFT + 2_8) = JARR DBLARR(PTRARW(IARR)+ISHIFT) = VAL END IF ELSE IARR = -IARR ISHIFT = int(PTRAIW(IARR)+IW4(IARR,1)+2,8) INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+int(IW4(IARR,1),8) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) & CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN CALL DMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL DMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF IF ( KEEP( 46 ) .NE. 0 ) DEALLOCATE( IW4 ) IF (NBUFS.GT.0) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) ENDIF RETURN END SUBROUTINE DMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF(ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER ISEND, JSEND, DEST, NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) DOUBLE PRECISION BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP DOUBLE PRECISION VAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST) CALL MPI_SEND(BUFI(1,DEST),TAILLE_SENDI, & MPI_INTEGER, & DEST, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST), TAILLE_SENDR, & MPI_DOUBLE_PRECISION, DEST, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST) = 0 ENDIF IREQ = BUFI(1,DEST) + 1 BUFI(1,DEST) = IREQ BUFI( IREQ * 2, DEST ) = ISEND BUFI( IREQ * 2 + 1, DEST ) = JSEND BUFR( IREQ, DEST ) = VAL RETURN END SUBROUTINE DMUMPS_ARROW_FILL_SEND_BUF SUBROUTINE DMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) DOUBLE PRECISION BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_DOUBLE_PRECISION, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE DMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) DOUBLE PRECISION DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT DOUBLE PRECISION dswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP dswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = dswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL DMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL DMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE DMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE DMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, PTRAIW, PTRARW, & KEEP, KEEP8, MYID, COMM, NBRECORDS, & A, LA, root, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, INFO1, INFO2 & ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW(N) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS DOUBLE PRECISION A( LA ) INTEGER INFO1, INFO2 DOUBLE PRECISION DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER, POINTER, DIMENSION(:) :: BUFI DOUBLE PRECISION, POINTER, DIMENSION(:) :: BUFR INTEGER, POINTER, DIMENSION(:,:) :: IW4 LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: I18, IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE DOUBLE PRECISION VAL DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER numroc EXTERNAL numroc TYPE_PARALL = KEEP(46) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS * 2 + 1 WRITE(*,*) MYID,': Could not allocate BUFI: goto 500' GOTO 500 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS WRITE(*,*) MYID,': Could not allocate BUFR: goto 500' GOTO 500 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = 2 * N WRITE(*,*) MYID,': Could not allocate IW4: goto 500' GOTO 500 END IF IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. DO I=1,N I18 = PTRAIW(I) IA8 = PTRARW(I) IF (IA8.GT.0_8) THEN DBLARR(IA8) = ZERO IW4(I,1) = INTARR(I18) IW4(I,2) = -INTARR(I18+1_8) INTARR(I18+2)=I ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_DOUBLE_PRECISION, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT + int(JLOCROOT - 1,8) & * int(LOCAL_M,8) & + int(ILOCROOT - 1,8)) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( IW4 ) 500 CONTINUE KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE DMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N DOUBLE PRECISION :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_SET_TO_ZERO SUBROUTINE DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION, INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL DMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL DMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL DMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE DMUMPS_SET_ROOT_TO_ZERO SUBROUTINE DMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: numroc LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE DMUMPS_GET_ROOT_INFO MUMPS_5.4.1/src/zfac_lastrtnelind.F0000664000175000017500000001766014102210524017333 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL ZMUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'ZMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL ZMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL ZMUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'ZMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ELSE CALL ZMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL ZMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_LAST_RTNELIND MUMPS_5.4.1/src/fac_ibct_data_m.F0000664000175000017500000000105514102210475016660 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FAC_IBCT_DATA_M IMPLICIT NONE INTEGER :: IBC_TMP END MODULE MUMPS_FAC_IBCT_DATA_M MUMPS_5.4.1/src/zsol_driver.F0000664000175000017500000070465514102210526016200 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOLVE_DRIVER(id) USE ZMUMPS_STRUC_DEF USE ZMUMPS_SOL_ES C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C C C USE ZMUMPS_BUF USE ZMUMPS_OOC USE MUMPS_MEMORY_MOD USE ZMUMPS_LR_DATA_M, only : ZMUMPS_BLR_STRUC_TO_MOD & , ZMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC USE ZMUMPS_SAVE_RESTORE IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE ZMUMPS_SIZE_IN_STRUCT( id, NB_INT,NB_CMPLX,NB_CHAR ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE ZMUMPS_SIZE_IN_STRUCT SUBROUTINE ZMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE ZMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (ZMUMPS_STRUC), TARGET :: id C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,IPERM,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8, LWCB8_SOL_C C buffer sizes INTEGER ZMUMPS_LBUF, ZMUMPS_LBUF_INT INTEGER(8) :: ZMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS C true if ZMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_allocated COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSCOMP_FWD, & PTR_POSINRHSCOMP_BWD COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR_RHS INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ COMPLEX(kind=8) ONE COMPLEX(kind=8) ZERO PARAMETER( ONE = (1.0D0,0.0D0) ) PARAMETER( ZERO = (0.0D0,0.0D0) ) DOUBLE PRECISION RZERO, RONE PARAMETER( RZERO = 0.0D0, RONE = 1.0D0 ) C C RHS_IR is internal to ZMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_IR COMPLEX(kind=8), DIMENSION(:), POINTER :: WORK_WCB COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C COMPLEX(kind=8), ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK COMPLEX(kind=8), ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) DOUBLE PRECISION, ALLOCATABLE :: R_Y(:), D(:) DOUBLE PRECISION, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSCOMP, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS DOUBLE PRECISION, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS DOUBLE PRECISION, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs adn solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*S(ISTW3) C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D2) **(-1)] x0 and so x0= D2*y0 is modified C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2ATD1 D1-1 x0 = D2b0 C b(sca) = D2 * b0 = COLSCA*S(ISTW3) C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS we need C scaling information on each processor C type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data_sol, scaling_data_dr C To scale on the fly during GATHER SOLUTION DOUBLE PRECISION, DIMENSION(:), POINTER :: PT_SCALING DOUBLE PRECISION, TARGET :: Dummy_SCAL(1) C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG DOUBLE PRECISION ARRET COMPLEX(kind=8) C_DUMMY(1) DOUBLE PRECISION R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) COMPLEX(kind=8), TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IPT_RHS_ROOT INTEGER(8) :: IBEG, IBEG_RHSCOMP, KDEC, IBEG_loc, IBEG_REDRHS INTEGER LD_RHSCOMP, NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8 INTEGER(8) K16_8, ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSCOMP LOGICAL :: BUILD_RHSMAPINFO LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER(8) :: FILE_SIZE,STRUC_SIZE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation IRHS_PTR_COPY => IDUMMY_TARGET IRHS_PTR_COPY_ALLOCATED = .FALSE. IRHS_SPARSE_COPY => IDUMMY_TARGET IRHS_SPARSE_COPY_ALLOCATED=.FALSE. RHS_SPARSE_COPY => CDUMMY_TARGET RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO C ASPK =>id%A C COLSCA =>id%COLSCA C ROWSCA =>id%ROWSCA RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) K16_8 = int(KEEP(16), 8) NBENT_RHSCOMP = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSCOMP =-152525_8 ! Should not be used BUILD_POSINRHSCOMP = .TRUE. IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C Not needed anymore (since new version of gather) C LD_RHSCOMP = max(KEEP(89),1) ! at the nb of pivots eliminated on ! that proc LD_RHSCOMP = 1 NB_FS_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Compute the number of integers and nb of reals in the structure CALL ZMUMPS_SIZE_IN_STRUCT (id, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 + NB_CHAR NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok CALL ZMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== C The checks below used to be in ZMUMPS_DRIVER. It is much better C to have them here in ZMUMPS_SOL_DRIVER because this enables C more flexibility in the management of priorities between various C checks. IF (id%MYID .EQ. MASTER) THEN c subroutine only because called at facto and solve CALL ZMUMPS_SET_K221(id) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN C -- input RHS is indeed stored in REDRHS and RHSCOMP id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and RHSCOMP id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (KEEP(248) .EQ. -1) THEN C V0 distributed RHS: no ES id%KEEP(235) = 0 ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0)) THEN C In the context of null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( (id%KEEP(221).EQ.1 ).AND.(id%KEEP(235).NE.0) ) THEN C -- Do not permute RHS with REDRHS for the time being id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0D0 id%DKEEP(113)=0.0D0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0D0 id%DKEEP(120)=0.0D0 id%DKEEP(121)=0.0D0 id%DKEEP(115)=0.0D0 id%DKEEP(116)=0.0D0 id%DKEEP(122)=0.0D0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0D0 id%DKEEP(118)=0.0D0 id%DKEEP(119)=0.0D0 id%DKEEP(123)=0.0D0 id%DKEEP(124)=0.0D0 id%DKEEP(125)=0.0D0 id%DKEEP(126)=0.0D0 id%DKEEP(127)=0.0D0 id%DKEEP(128:134)=0.0D0 id%DKEEP(140:153)=0.0D0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN C RHS must be of size N on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL ZMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C Check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)=-47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1) THEN C ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL ZMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( I_AM_SLAVE ) THEN C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc < id%KEEP(89) ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF (id%KEEP(89) .NE. 0) THEN IF ( .not. associated(id%ISOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 ENDIF IF ( .not. associated(id%SOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 ENDIF IF (size(id%ISOL_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_F2003) IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(id%KEEP(89),8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+id%KEEP(89)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ENDIF ENDIF IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF IF (I_AM_SLAVE .AND. id%KEEP(248).EQ.-1) THEN CALL ZMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & id%INFO) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to ZMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF IF (I_AM_SLAVE .AND. ICNTL21.EQ.1 .AND. & KEEP(248) .EQ. -1) THEN ! Dist RHS and dist solution IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN IF (id%KEEP(89).GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks (REDRHS), depending on KEEP(221) CALL ZMUMPS_CHECK_REDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ==================================== C Process case of NZ_RHS = 0 with C sparse RHS and General Sparse (NOT A-1) C ----------------------------------- IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN C CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (id%NZ_RHS.EQ.0) THEN C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL ZMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , .FALSE., IDUMMY(1), 1 & ) DO J=1, id%NRHS DO I=1, KEEP(89) id%SOL_loc((J-1)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF ENDIF IF (ICNTL21.NE.1) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN C write(6,*) " NZ_RHS is zero " WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== ENDIF ! test NZ_RHS.EQ.0 C -------- ENDIF ! (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF NB_BYTES = NB_BYTES + NBT*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT * K34_8 C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN CALL ZMUMPS_BUILD_MAPPING_INFO(id) END IF END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) & CALL ZMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS does IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSCOMP on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. C IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(id%root%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)*int(NBRHS,8) C C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor. Note that we are C inside a block "IF (I_AM_SLAVE)" WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (id%LWK_USER.EQ.0) THEN ITMP8 = 0_8 ELSE IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ! jump to propinfo ! (S is used in between and not allocated) ! NO COMM must occur then before next propinfo ! it happens in Mila's code but only with ! KEEP(209) > 0 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF C KEEP8(24) holds the size of WK_USER provided by user. C MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN C Avoid the use of "size(id%S)" because it returns C a default integer that may overflow. Also "size(id%S,kind=8)" C will only be available with Fortran 2003 compilers. MAXS = KEEP8(23) ELSE ! S not allocated and WK_USER not provided ==> must be in OOC IF (KEEP(201).EQ.0) THEN ! incore WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' C IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C --- end of OOC case ENDIF C -- end of id%S already associated ENDIF C C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE C MAXS has normally be dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL ZMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL ZMUMPS_OOC_INIT_SOLVE(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in ZMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in ZMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL ZMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== C LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. C FORBID ERROR ANALYSIS AND ITERATIVE REFINEMENT C if there are options that are not compatible IF (KEEP(111).NE.0) THEN C IF WE RETURN A NULL SPACE BASIS or compute entries in A-1 C of Fwd in facto C -When only one columns of A-1 is requested then C we could try to reactivate IR even if C -code need be updated C -accuracy could be # when one or more columns are requested IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN C Forbid error analysis and iterative refinement C in case of reduced rhs/solution IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN C Forbid error analysis and iterative refinement if C the solution is distributed or C in the case where nrhs > 1 IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN C Forbid error analysis and iterative refinement C in case of distributed RHS IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF C -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( id%MYID .eq. MASTER ) THEN IF (MAT_ALLOC.EQ.0) THEN POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL21,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(35),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety C Note that IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(MSG_MAX_BYTES_SOLVE),8)) THEN INFO(1) = -18 INFO(2) = ( huge(MSG_MAX_BYTES_SOLVE) - & ( 16 + 4 + KEEP(133) ) ) / & ( KEEP(133) * KEEP(35) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for ZMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE #if defined(MPI_TO_K_OMPP) #endif C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for ZMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(35) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for ZMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ ZMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL ZMUMPS_BUF_ALLOC_SMALL_BUF( ZMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = ZMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (ZMUMPS_LBUF) C using integer8 in ZMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C ZMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... ZMUMPS_LBUF_8 = min(ZMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously ZMUMPS_LBUF_8 = max(ZMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) ZMUMPS_LBUF_8 = ZMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. ZMUMPS_LBUF_8 = min(ZMUMPS_LBUF_8, & int(huge(ZMUMPS_LBUF),8) & - 10_8*int(KEEP(34),8) & ) ZMUMPS_LBUF = int(ZMUMPS_LBUF_8, kind(ZMUMPS_LBUF)) CALL ZMUMPS_BUF_ALLOC_CB( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = ZMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSCOMP must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C POSINRHSCOMP_ROW/COL are meaningful and could even be reused IF (.NOT.associated(id%POSINRHSCOMP_ROW) ) ! .OR. ! & .NOT.(id%POSINRHSCOMP_COL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%POSINRHSCOMP_COL_ALLOC) THEN C POSINRHSCOMP_COL that is kept from C previous call to solve must then (already) C point to id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW ENDIF ELSE C ---------------------- C Allocate POSINRHSCOMP_ROW/COL C ---------------------- C The size of POSINRHSCOMP arrays C does not depend on the block of RHS C POSINRHSCOMP_ROW/COL are initialized in the loop of RHS IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) ENDIF ALLOCATE (id%POSINRHSCOMP_ROW(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C IF ((KEEP(50).EQ.0).OR.KEEP(237).NE.0) THEN ALLOCATE (id%POSINRHSCOMP_COL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%POSINRHSCOMP_COL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_COL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate POSINRHSCOMP_COL id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after reduced RHS C -- we have to keep "old" RHSCOMP IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (ZMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in ZMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to ZMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(SRW3),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine ZMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in ZMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before theC C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) ) ) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSCOMP to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF IF (LSCAL .AND. id%KEEP(248).EQ.-1) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL ZMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(id%KEEP(89)), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=id%KEEP(89) GOTO 38 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF ENDIF ! LSCAL IF ( I_AM_SLAVE ) THEN C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL ZMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF ENDIF ! I_AM_SLAVE IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C ---------------------------- C Preparation for reduced RHS C ---------------------------- IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL ZMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL ZMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within ZMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in ZMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN c - In case of NS/A-1 we may want to permute RHS c - for NS thus is to apply permutation to PIVNUL_LIST * - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL ZMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C ============================== C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_LOC) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * ZMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSCOMP to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C ====================== IF (KEEP(248)==1) THEN C ====================== C C Sparse RHS format ( A-1 or sparse input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IRHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ELSE IRHS_SPARSE_COPY = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C if scaling is on or if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one; it might be C modified if scaling is on (one first entry in each col is scaled) RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) THEN C -- Columns are not contiguous and need be copied one by one C -- This need not be done if scaling is on because it C -- will done and scaled later. IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IF (COLSIZE .EQ. 0) CYCLE RHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C ----- ENDIF ! ============ KEEP(248)==1 C ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) IF (IERR.GT.0) THEN WRITE (*,*)'NOT OK FOR ALLOC PTR ON SLAVES' call MUMPS_ABORT() ENDIF ENDIF ENDIF C C ========================================================= C INITIALIZE POSINRHSCOMP_ROW/COL, RHSCOMP and related data C For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= IF ( I_AM_SLAVE ) THEN C -------------------------------------------------- C If I am involved in the solve and if C either C no null space comput (keep(111)=0) and sparse rhs C or C null space computation C then C compute POSINRHSCOMP C endif C C Fwd in facto: in this case only POSINRHSCOMP need be computed C C (POSINRHSCOMP_ROW/COL indirection arrays should C have been allocated once outside loop) C Compute size of RHSCOMP since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize POSINRHSCOMP_ROW/COL C C Note that LD_RHSCOMP and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSCOMP is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE POSINRHSCOMP_ROW/COL C ------------------------------- C IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSCOMP was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSCOMP would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, we do not C need to compute POSINRHSCOMP BUILD_POSINRHSCOMP = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSCOMP C ------------------------ IF (BUILD_POSINRHSCOMP) THEN C -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSCOMP for next iteration in loop C C general case only POSINRHSCOMP is computed BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSCOMP to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSCOMP C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C POSINRHSCOMP_ROW will allow to find the (row) index of a C zero in RHSCOMP before calling ZMUMPS_SOL_S. Then C ZMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSCOMP MTYPE_LOC = 1 ! (no transpose) C BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSCOMP = .TRUE. ENDIF ENDIF C -- compute POSINRHSCOMP LIW_PASSED=max(1,LIW) IF (KEEP(237).EQ.0) THEN CALL ZMUMPS_BUILD_POSINRHSCOMP( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW_PASSED, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & NBENT_RHSCOMP, NB_FS_RHSCOMP_TOT ) NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT ELSE CALL ZMUMPS_BUILD_POSINRHSCOMP_AM1( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK,PERM_RHS, size(PERM_RHS) , JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_RHSCOMP_F, NB_FS_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1) THEN C C Prepare symbolic data for sends. C For the moment: MAP_RHS_loc C CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%POSINRHSCOMP_ROW(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN IF (KEEP(221).EQ.1) THEN C we need to save the reduced RHS for all RHS to perform C later the backward phase with an updated reduced RHS C thus we allocate NRHS_NONEMPTY columns in one shot. C Note that RHSCOMP might have been allocated in previous block C and RHSCOMP has been deallocated previous to entering loop on RHS IF (.not. associated(id%RHSCOMP)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSCOMP will not change in the loop C and can be used to dimension RHSCOMP C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. LD_RHSCOMP = max(NBENT_RHSCOMP,1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(id%NRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSCOMP (case of RHSCOMP allocated at each block of RHS) C ------------------ C RHSCOMP allocated per block of maximum size NBRHS LD_RHSCOMP = max(NBENT_RHSCOMP, LD_RHSCOMP) C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSCOMP)) THEN IF ( (id%KEEP8(25).LT.int(LD_RHSCOMP,8)*int(NBRHS,8)) & .OR. (KEEP(235).NE.0).OR.(KEEP(237).NE.0) ) THEN ! deallocate and reallocate if: ! _larger array needed ! OR ! _exploit sparsity/A-1: since size of RHSCOMP ! is expected to vary much in these cases ! this should improve locality NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF IF (.not. associated(id%RHSCOMP)) THEN LD_RHSCOMP = max(NBENT_RHSCOMP, 1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(NBRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF (KEEP(221).EQ.2) THEN C RHSCOMP has been allocated (call with KEEP(221).EQ.1) C even in the case fwd in facto ! Not correct: LD_RHSCOMP = LENRHSCOMP/id%NRHS_NONEMPTY LD_RHSCOMP = int(id%KEEP8(25)/int(id%NRHS,8)) ENDIF C C Shift on RHSCOMP C IF ( KEEP(221).EQ.0 ) THEN C -- RHSCOMP reused in the loop IBEG_RHSCOMP= 1_8 ELSE C Initialize IBEG_RHSCOMP C IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in ZMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF C C RHS is set to scaled right hand side C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL ZMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_DOUBLE_COMPLEX, & MASTER, id%COMM, IERR) ENDIF C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSCOMP. C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1_8:int(NBRHS_EFF,8)*int(LD_RHSCOMP,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSCOMP to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSCOMP = id%POSINRHSCOMP_ROW(J) C IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_F) C & .AND.(IPOSRHSCOMP.GT.0) ) THEN IF (IPOSRHSCOMP.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc C Note that : C In first entry in column C we have and MUST have already scaled value of diagonal. C This need have been done on master because we do not C have scaling arrays available on slaves. C Furthermore we know that only one entry is C needed the diagonal entry (for the forward with A-1). C id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8)+ & int(IPOSRHSCOMP,8)) = & RHS_SPARSE_COPY(IPOS) ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- reset to zero RHSCOMP for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(LD_RHSCOMP,8) + & IBEG_RHSCOMP - 1_8 id%RHSCOMP(KDEC+1_8:KDEC+NBENT_RHSCOMP) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSCOMP = id%POSINRHSCOMP_ROW(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSCOMP, we can compare to KEEP(89) C to know if RHSCOMP should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSCOMP so we compare to C NB_FS_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to ZMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C ZMUMPS_RHS must be passed to C ZMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSCOMP to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHSCOMP,8) id%RHSCOMP(KDEC+1_8:KDEC+int(LD_RHSCOMP,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%POSINRHSCOMP_ROW(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = & cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) ELSE ! Symmetric: always set to one id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to ZMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSCOMP need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 C ------------------------------------------- C Reserve space at the end of WORK_WCB on the C master of the root node. It will be used to C store the reduced RHS. C ------------------------------------------- IF ( I_AM_SLAVE ) THEN LWCB8_SOL_C = LWCB8 IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_F2003) LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT,kind=8) # else LPTR_RHS_ROOT = int(size(id%root%RHS_CNTR_MASTER_ROOT),8) # endif ELSE C Otherwise, we use workspace in WCB LPTR_RHS_ROOT = int(NBRHS_EFF,8) * int(SIZE_ROOT,8) IPT_RHS_ROOT = LWCB8 - LPTR_RHS_ROOT + 1_8 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 IPT_RHS_ROOT = LWCB8 ! Will be passed, but not accessed PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN C C --- Normal case : we do not exploit sparsity of the RHS C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) PRUNED_SIZE_LOADED = 0_8 ! From ZMUMPS_SOL_ES module CALL ZMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, IS(1), & LIW_PASSED, WORK_WCB(1), LWCB8_SOL_C, IWCB, LIWCB, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), FROM_PP, & id%STEP(1), id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), & id%PTLUST_S(1), id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, & LIWK_PTRACB, id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1), & KEEP8(1), id%DKEEP(1), id%COMM_NODES, id%MYID, id%MYID_NODES, & BUFR(1), LBUFR, LBUFR_BYTES, id%ISTEP_TO_INIV2(1), & id%TAB_POS_IN_PERE(1,1), IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, & MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1) & , 1, 1, 1, 1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & , 1, 1, NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) ELSE C Exploit sparsity of the RHS (all cases) C Remark that JBEG_RHS is already initialized C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) CALL ZMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED,IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,MTYPE,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1),LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1,PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP, id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, JBEG_RHS, id%Step2node(1), & id%KEEP(28),IRHS_SPARSE_COPY(1),IRHS_PTR_COPY(1), size(PERM_RHS), & PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT,NBSPARSE_LOC,PTR_RHS_BOUNDS(1),LPTR_RHS_BOUNDS & ) ENDIF ! end of exploit sparsity (pruning nodes of the tree) END IF C ----------------- C End of slave code C ----------------- C C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_COMPLEX, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ====== END OF REDUCED RHS (Fwd only performed) ====== C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (ZMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (MTYPE.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL ZMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_COL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL ZMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%POSINRHSCOMP_COL(1), id%N, NB_FS_RHSCOMP_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN CALL ZMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & NBRHS_EFF, id%POSINRHSCOMP_COL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, & id%STEP(1), scaling_data_sol, LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal ERROR 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0D0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0D0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call ZMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL ZMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL ZMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = dble(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. C Test of convergence should be made IF (( id%MYID .eq. MASTER ).AND.(ICNTL10.GT.0)) THEN TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0D0) THEN ARRET = sqrt(epsilon(0.0D0)) END IF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL ZMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL ZMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL ZMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL ZMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL ZMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+TIMEEA1 ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL ZMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in ZMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL ZMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=TIMEIT ELSE C IR has been requested id%DKEEP(114)=TIMEIT - id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL ZMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL ZMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_COMPLEX, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL ZMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL ZMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL ZMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL ZMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL ZMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+TIMELCOND IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N WRITE(*,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min0(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min0(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO C DO WHILE (BEG_RHS.LE.id%NRHS) C ========================== C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 CYCLE ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSCOMP and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP(int(JBEG_NEW -1,8)*int(LD_RHSCOMP,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=TIME3 id%DKEEP(113)=TIMEC2 id%DKEEP(115)=TIMESCATTER2 id%DKEEP(116)=TIMEGATHER2 id%DKEEP(122)=TIMECOPYSCALE2 C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL ZMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL ZMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL ZMUMPS_BUF_DEALL_CB( IERR ) CALL ZMUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN C Free local scaling arrays NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF C Free memory until next call to ZMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be saved and is used C in incore to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN C OOC: free space for S that was allocated NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) ENDIF IF (KEEP(221).NE.1) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time to copy/scale dist. solution=',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12 & ) 151 FORMAT (' --- (25) =',I12) 152 FORMAT (' --- (26) =',I12) 153 FORMAT (' --- (32) =',I12) 160 FORMAT (' RHS'/(1X,1P,5D14.6)) 170 FORMAT (/' ERROR ANALYSIS' ) 240 FORMAT (1X, A42,I4) 270 FORMAT (//' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 131 FORMAT (/' END ITERATIVE REFINEMENT ') 141 FORMAT(1X, A52,I4) CONTAINS SUBROUTINE ZMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS #if defined(MUMPS_F2003) INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) COMPLEX(kind=8), INTENT( IN ), POINTER :: idRHS_loc (:) #else INTEGER, POINTER :: idIRHS_loc (:) COMPLEX(kind=8), POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_F2003) IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #else IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN C (Warning: this assumes that size(idRHS_loc) C does not overflow) #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_CHECK_DISTRHS SUBROUTINE ZMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of ZMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C POSINRHSCOMP_ROW is with respect to the C original linear system (transposed or not) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL ENDIF LIW_PASSED = max( LIW, 1 ) CALL ZMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 1, & PTR_POSINRHSCOMP_FWD(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_COL ELSE PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_ROW ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL ZMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP,PTR_POSINRHSCOMP_FWD(1),PTR_POSINRHSCOMP_BWD(1), & 1,1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C ZMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (SOLVET.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) C Solution computed during ZMUMPS_SOL_C has been stored C in id%RHSCOMP and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), ! RHSCOMP not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL ZMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & PTR_POSINRHSCOMP_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE ZMUMPS_PP_SOLVE END SUBROUTINE ZMUMPS_SOLVE_DRIVER MUMPS_5.4.1/src/smumps_config_file.F0000664000175000017500000000103314102210522017456 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE SMUMPS_CONFIG_FILE_RETURN MUMPS_5.4.1/src/dmumps_driver.F0000664000175000017500000030333414102210525016502 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for DMUMPS C (MPI based code) C =========================== C SUBROUTINE DMUMPS( id ) USE DMUMPS_OOC USE MUMPS_MEMORY_MOD USE DMUMPS_STRUC_DEF USE DMUMPS_STATIC_PTR_M ! For Schur pointer USE DMUMPS_SAVE_RESTORE C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C C P. Amestoy, J.-Y. L'Excellent, G. Moreau, On exploiting sparsity of C multiple right-hand sides in sparse direct solvers, C SIAM Journal on Scientific Computing, volume 41, number 2, C pages A269-A291 (2019) C C G. Moreau, PhD Thesis, ENS-Lyon, University of Lyon, C On the solution phase of direct methods for sparse linear systems C with multiple sparse right-hand sides, December 10th, 2018 C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C Performance and scalability of the block low-rank multifrontal C factorization on multicore architectures, C ACM Transactions on Mathematical Software (2018) C C T. Mary, PhD Thesis, University of Toulouse, C Block Low-Rank multifrontal solvers: complexity, performance, and C scalability, November 2017. C C S. de la Kethulle de Ryhove, P. Jaysaval and D.V. Shantsev, C P. R. Amestoy, J.-Y. L'Excellent and T. Mary, C Large-scale 3D EM modeling with a Block Low-Rank MUMPS solver, C Geophysical Journal International, volume 209, number 3, C pages 1558-1571 (2017) . C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C On the complexity of the Block Low-Rank multifrontal factorization, C SIAM Journal on Scientific Computing, volume 39, C number 4, pages A1710-A1740 (2017). C C P. Amestoy, R. Brossier, A. Buttari, J.-Y. L'Excellent, T. Mary, C L. Metivier, A. Miniussi, and S. Operto. C Fast 3D frequency-domain full waveform inversion with a parallel C Block Low-Rank multifrontal direct solver: application to OBC data C from the North Sea, Geophysics, 81(6):R363--R383, (2016). C C P. Amestoy, C. Ashcraft, O. Boiteau, A. Buttari, J.-Y. L'Excellent, C and C. Weisbecker. C Improving multifrontal methods by means of block low-rank representations. C SIAM Journal on Scientific Computing, 37(3):A1451--A1474 (2015). C C W. M. Sid-Lakhdar, PhD Thesis from Universite de Lyon prepared at ENS Lyon, C Scaling the solution of large sparse linear systems using multifrontal C methods on hybrid shared-distributed memory architectures (2014). C C P. Amestoy, J.-Y. L'Excellent, W. Sid-Lakhdar, C Characterizing asynchronous broadcast trees for multifrontal factorizations, C Workshop on Combinatorial Scientific Computing, C Lyon, France, July 21-23 (2014). C C P. Amestoy, J.-Y. L'Excellent, F.-H. Rouet, W. Sid-Lakhdar, C Modeling 1D distributed-memory dense kernels for an asynchronous C multifrontal sparse solver, High-Performance Computing for Computational C Science, VECPAR 2014, Eugene, Oregon, USA, June 30 - July 3 (2014). C C J.-Y. L'Excellent and W. M. Sid-Lakhdar, C Introduction of shared-memory parallelism in a distributed-memroy C multifrontal solver, Parallel Computing (40):3-4, pages 34-46 (2014). C C C. Weisbecker, PhD Thesis supported by EDF, INPT-IRIT, C Improving multifrontal solvers by means of algebraic block low-rank C representations (2013). C C E. Agullo, P. Amestoy, A. Buttari, A. Guermouche, G. Joslin, J.-Y. C L'Excellent, X. S. Li, A. Napov, F.-H. Rouet, M. Sid-Lakhdar, S. Wang, C. C Weisbecker, I. Yamazaki, C Recent Advances in Sparse Direct Solvers, 22nd Conference on Structural C Mechanics in Reactor Technology, San Francisco (2013). C C P. Amestoy, A. Buttari, G. Joslin, J.-Y. L'Excellent, W. Sid-Lakhdar, C. C Weisbecker, M. Forzan, C. Pozza, R. Perrin, V. Pellissier, C Shared memory parallelism and low-rank approximation techniques applied C applied to direct solvers in FEM simulation in IEEE Transactions on C Magnetics, IEEE, Special issue, Compumag 2013 (2013). C C L. Boucher, P. Amestoy, A, Buttari, F.-H. Rouet and M. Chauvin, C INTEGRAL/SPI data segmentation to retrieve sources intensity variations, C Astronomy & Astrophysics, Article 52, 20 pages, C http://dx.doi.org/10.1051/0004-6361/201219605 (2013). C C F.-H. Rouet, PhD thesis from INPT, Toulouse, France, C Memory and Performance issues in parallel multifrontal factorization and C triangular solutions with sparse right-hand sides (2014). C C J.-Y. L'Excellent, Habilitation thesis from ENS Lyon, C Multifrontal methods: Parallelism, Memory Usage and Numerical C Aspects (2012). C C P. Amestoy, I.S. Duff, J.-Y. L'Excellent, Y. Robert, F.H. Rouet C and B. Ucar, On computing inverse entries of a sparse matrix in C an out-of-core environment, C SIAM J. on Scientific Computing Vol. 34 N. 4, p. 1975-1999 (2012). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C The Multifrontal Method, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C MUMPS, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Agullo, Guermouche and L'Excellent, Reducing the {I/O} Volume in C Sparse Out-of-core Multifrontal Methods}, SIAM SISC, Vol 31, Nb. 6, C 4774-4794 (2010). C C Amestoy, Duff, Guermouche, Slavova, Analysis of the Solution Phase of a C Parallel Multifrontal Approach, Parallel Computing, Vol. 36, 3--15 (2010). C C Tzvetomila Slavova, PhD from INPT prepared at CERFACS, C Parallel triangular solution in the out-of-core multifrontal approach C for solving large sparse linear systems, available as CERFACS C Report TH/PA/09/59 (2009). C C Agullo, Guermouche and L'Excellent, A Parallel Out-of-core Multifrontal C Method: Storage of Factors on Disk and Analysis of Models for an C Out-of-core Active Memory, Parallel Computing, Special Issue on Parallel C Matrix Algorithms, Vol. 34, Nb 6-8, 296--317 (2008). C C Emmanuel Agullo, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C On the Out-of-core Factorization of Large Sparse Matrices (Nov 2008). C C Amestoy, Duff, Ruiz, and Ucar, "A parallel C matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, (Jan 2008). C C Guermouche and L'Excellent, Constructing Memory-minimizing Schedules C for Multifrontal Methods, ACM TOMS, Vol. 32, Nb. 1, 17--32 (2006). C C Amestoy, Guermouche, L'Excellent, and Pralet, C Hybrid scheduling for the parallel solution C of linear systems. Vol 32 (2), pp 136-156 (2006). C C Stephane Pralet, PhD from INPT prepared at CERFACS, C Constrained orderings and scheduling for parallel sparse linear algebra, C available as CERFACS technical report, TH/PA/04/105, (Sept 2004). C C Abdou Guermouche, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C Etude et optimisation du comportement memoire dans les methodes paralleles C de factorisation de matrices creuses (2004). C C Guermouche, L'Excellent and Utard, Impact of Reordering on the Memory of a C Multifrontal Solver, Parallel Computing, Vol. 29, Nb. 9, 1191--1218 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Impact of the Implementation C of MPI Point-to-Point Communications on the Performance of Two General C Sparse Solvers, Parallel Computing, Vol. 29, Nb 7, 833--847 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Analysis and Comparison of C Two General Sparse Solvers for Distributed Memory Computers, ACM TOMS, C Vol. 27, Nb 4, 388--421 (2001). C C Amestoy, Duff, Koster and L'Excellent (2001), C A fully asynchronous multifrontal solver using distributed dynamic C scheduling, SIAM Journal of Matrix Analysis and Applications, C Vol 23, No 1, pp 15-41 (2001). C C Amestoy, Duff and L'Excellent (2000), C Multifrontal parallel distributed symmetric and unsymmetric solvers, C Comput. Methods in Appl. Mech. Eng., 184, 501-520 (2000) C C Amestoy, Duff and L'Excellent (1998), C Parallelisation de la factorisation LU de matrices C creuses non-symmetriques pour des architectures a memoire distribuee, C Calculateurs Paralleles Reseaux et systemes repartis, C Vol 10(5), 509-520 (1998). C C PARASOL Deliverable D2.1d (final report), C DMUMPS Version 3.1, A MUltifrontal Massively Parallel Solver, C PARASOL project, EU ESPRIT IV LTR project 20160, (June 1999). C C Jacko Koster, PhD from INPT prepared at CERFACS, On the parallel solution C and the reordering of unsymmetric sparse linear systems (1997). C C Vincent Espirat, Master's thesis from INPT(ENSEEIHT)-IRIT, Developpement C d'une approche multifrontale pour machines a memoire distribuee et C reseau heterogene de stations de travail (1996). C C Patrick Amestoy, PhD from INPT prepared at CERFACS, Factorization of large C sparse matrices based on a multifrontal approach in a multiprocessor C environment, Available as CERFACS report TH/PA/91/2 (1991). C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine DMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine DMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of DMUMPS_STRUC, which may then be altered before C subsequent calls to DMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE DMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE DMUMPS_CHECK_DENSE_RHS SUBROUTINE DMUMPS_ANA_DRIVER( id ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id END SUBROUTINE DMUMPS_ANA_DRIVER SUBROUTINE DMUMPS_FAC_DRIVER( id ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id END SUBROUTINE DMUMPS_FAC_DRIVER SUBROUTINE DMUMPS_SOLVE_DRIVER( id ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id END SUBROUTINE DMUMPS_SOLVE_DRIVER SUBROUTINE DMUMPS_PRINT_ICNTL(id, LP) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE DMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (DMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a DOUBLE PRECISION array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a DOUBLE PRECISION array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are DOUBLE PRECISION C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF C Initialize id%MYID now because it is C required by MUMPS_PROPINFO. id%MYID C used to be initialized inside DMUMPS_INI_DRIVER, C leading to an uninitialized access here. CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN C C If there was an error, then initialization C was already called and we can rely on the null C or non null value of the pointers related to OOC C stuff. C We use DMUMPS_CLEAN_OOC_DATA that should work even C on the master. Note that KEEP(201) was also C initialized in a previous call to Mumps. C C If DMUMPS_END_DRIVER or DMUMPS_FAC_DRIVER is called after C this error, then DMUMPS_CLEAN_OOC_DATA will be called C a second time, though. C IF (id%KEEP(201).GT.0) THEN CALL DMUMPS_CLEAN_OOC_DATA(id, IERR) ENDIF GOTO 499 ENDIF C ---------------------------------------- C Initialization DMUMPS_INI_DRIVER C ---------------------------------------- C - Default values for ICNTL, KEEP,KEEP8, CNTL C - Attach emission buffer for buffered Send C - Nullify pointers in the structure C - Get rank and size of the communicator C ---------------------------------------- CALL DMUMPS_INI_DRIVER( id ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN C ------------------------------------- C Deallocation of the instance id C ------------------------------------- id%KEEP(40)= -2 - 456789 CALL DMUMPS_END_DRIVER( id ) GOTO 500 END IF C C TIMINGS: for JOBS different from -1 and -2, C we measure TIMETOTAL: C IF (id%MYID.EQ.MASTER) THEN id%DKEEP(70)=0.0D0 CALL MUMPS_SECDEB(TIMETOTAL) ENDIF C C---------------------------------------------------------------- C C JOB = 7 : SAVE THE INSTANCE C C JOB = 8 : RESTORE THE INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. 7 .OR. JOB .EQ. 8 ) THEN IF( JOB.EQ.8 .AND. OLDJOB.NE.-1) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 IF ( JOB .EQ. 7 ) THEN IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL DMUMPS_SAVE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in save structure driver= ', TIMEG END IF ENDIF ELSE IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL DMUMPS_RESTORE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in restore structure driver= ' & , TIMEG ENDIF END IF ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C JOB = -3 : REMOVE SAVED INSTANCE C C---------------------------------------------------------------- C IF (JOB .EQ. -3) THEN CALL DMUMPS_REMOVE_SAVED(id) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF IF (JOB.EQ.9) THEN C Check that factorization was performed IF ( OLDJOB .LT. 2 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ELSE CALL DMUMPS_SOL_INIT_IRHS_loc(id) ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C MAIN DRIVER C OTHER VALUES OF JOB : 1 to 6 C C---------------------------------------------------------------- CALL MUMPS_MEMORY_SET_DATA_SIZES() IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF C C Propagate possible error to all nodes CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 C C Print ICNTL and KEEP C IF (PROK) CALL DMUMPS_PRINT_ICNTL(id, MP) C----------------------------------------------------------------------- C C CHECK SEQUENCE C C----------------------------------------------------------------------- IF ( LANA ) THEN IF ( PROKG .AND. OLDJOB .EQ. -1 ) THEN C Print compilation options at first call to analysis CALL MUMPS_PRINT_IF_DEFINED(MPG) ENDIF C C User wants to perform analysis. Previous value of C JOB must be -1, 1, 2 or 3. C IF ( OLDJOB .EQ. 0 .OR. OLDJOB .GT. 3 .OR. OLDJOB .LT. -1 ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( OLDJOB .GE. 2 ) THEN C ----------------------------------------- C Previous step was factorization or solve. C As analysis is now performed, deallocate C at least some big arrays from facto. C ----------------------------------------- IF (associated(id%IS)) THEN DEALLOCATE (id%IS) NULLIFY (id%IS) END IF IF (associated(id%S)) THEN DEALLOCATE (id%S) NULLIFY (id%S) END IF END IF END IF IF ( LFACTO ) THEN C ------------------------------------ C User wants to perform factorization. C Analysis must have been performed. C ------------------------------------ IF ( OLDJOB .LT. 1 .and. .NOT. LANA ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN C ------------------------------- C User wants to perform solve. C Facto must have been performed. C ------------------------------- IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF C ------------------------------------------ C Permute JCN on entry to JOB if no analysis C to be performed and IRN/JCN are needed. C (facto: arrowheads + solve: iterative C refinement and error analysis) C ------------------------------------------ #if ! defined (LARGEMATRICES) NOERRORBEFOREPERM =.TRUE. UNS_PERM_DONE=.FALSE. IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF ( id%JOB .EQ. 2 .OR. id%JOB .EQ. 5 .OR. & (id%JOB .EQ. 3 .AND. (id%ICNTL(10) .NE.0 .OR. & id%ICNTL(11).NE. 0))) THEN UNS_PERM_DONE = .TRUE. ALLOCATE(UNS_PERM_INV(id%N),stat=IERR) IF (IERR .GT. 0) THEN C -------------------------------- C Exit with an error. C We are not able to permute C JCN correctly after a MAX-TRANS C permutation resulting from a C previous call to DMUMPS. C -------------------------------- id%INFO(1)=-13 id%INFO(2)=id%N IF (LPOK) WRITE(LP,99993) GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I8 = 1_8, id%KEEP8(28) J = id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 * ********* * MaxTrans-Analysis-Distri, Scale-Arrowhead-factorize, and * Solve-IR-Error_Analysis (depending on the value of JOB) ********* * C IF ( LANA ) THEN C----------------------------------------------------- C- C- ANALYSIS : Max-Trans, Analysis, Distribution C- C----------------------------------------------------- C C Few checks + allocations C C IS : will be allocated on the slaves later C PROCNODE : on the master only, C because slave does not know N yet. C Will be allocated in analysis for the slave. C C For assembled entry: C IRN, JCN : check that they have been allocated by the C user on the master, and if their size is adequate C C For element entry: C ELTPTR, ELTVAR : check that they have been allocated by the C user on the master, and if their size is adequate C ---------------------------- C Reset KEEP(40) to -1 for the C case where an error occurs C ---------------------------- id%KEEP(40)=-1 -456789 C IF (id%MYID.EQ.MASTER) THEN C Check N, [N]NZ, NELT IF ((id%N.LE.0).OR.((id%N+id%N+id%N)/3.NE.id%N)) THEN id%INFO(1) = -16 id%INFO(2) = id%N GOTO 100 END IF IF (id%ICNTL(5).NE.1) THEN C Assembled input IF (id%ICNTL(18) .LT. 1 .OR. id%ICNTL(18) .GT. 3) THEN C Centralized input IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) GOTO 100 ENDIF ENDIF ELSE C Element entry: check NELT on the master IF (id%NELT .LE. 0) THEN id%INFO(1) = -24 id%INFO(2) = id%NELT GOTO 100 ENDIF ENDIF C -- initialize values of respectively C icntl(6), (7) and (12) to not done/chosen id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 C --------------------------------------- C Element entry: allocate ELTPROC(1:NELT) C --------------------------------------- IF ( id%ICNTL(5) .EQ. 1 ) THEN ! Elemental matrix IF ( associated( id%ELTPROC ) ) & DEALLOCATE( id%ELTPROC ) ALLOCATE( id%ELTPROC(id%NELT), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%NELT IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array ELTPROC' GOTO 100 END IF END IF C --------------------------------------------------- C Assembled centralized entry: check input parameters C IRN/JCN C Element entry: check input parameters ELTPTR/ELTVAR C --------------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! Assembled matrix id%KEEP8(30)=0_8 IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available before f2002. One can C still check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: IRN/JCN badly allocated.' END IF ELSE IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE id%LELTVAR = id%ELTPTR( id%NELT+1 ) - 1 IF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE C If no error, we compute KEEP8(30) (formerly NA_ELT), C required for DMUMPS_MAX_MEM already in analysis, and C then later during facto to check the size of A_ELT id%KEEP8(30) = 0_8 IF ( id%KEEP(50) .EQ. 0 ) THEN C Unsymmetric elements (but symmetric structure) DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + int(J,8) * int(J,8) ENDDO ELSE C Symmetric elements DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + & (int(J,8) *int(J+1,8))/2_8 ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 C ----------------------------------------- C Call analysis procedure DMUMPS_ANA_DRIVER C ----------------------------------------- IF (id%MYID .eq. MASTER) THEN id%DKEEP(71)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C ------------------------------------------------- C Set scaling option for analysis in KEEP(52) C (ICNTL(8) only defined on host at analysis phase) C ------------------------------------------------- IF (id%MYID.EQ.MASTER) THEN C{ id%KEEP(52) = id%ICNTL(8) C Out-of-range values => automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after DMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL DMUMPS_ANA_DRIVER( id ) C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL DMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL DMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_F2003) ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_F2003) IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #else IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL DMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ------------------------ C If Schur has been asked C for, scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with Schur)' END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: This scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: Scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of DMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL DMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks CALL DMUMPS_SET_K221(id) CALL DMUMPS_CHECK_REDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in DMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C DMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ C & id%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL DMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(id%root%SCHUR_NLOC-1,8)+ & int(id%root%SCHUR_MLOC,8)) CALL DMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < id%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & id%root%SCHUR_MLOC id%INFO(1)=-30 id%INFO(2)=id%SCHUR_LLD ELSE IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF (size(id%SCHUR) < & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) THEN IF (LP.GT.0) THEN write(LP,'(A)') & ' SCHUR allocated but too small' write(LP,*) id%MYID, ' : Size Schur=', & size(id%SCHUR), & ' SCHUR_LLD= ', id%SCHUR_LLD, & ' SCHUR_MLOC=', id%root%SCHUR_NLOC, & ' SCHUR_NLOC=', id%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within DMUMPS here. id%root%SCHUR_LLD=id%SCHUR_LLD IF (id%root%SCHUR_NLOC==0) THEN ALLOCATE(id%root%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE id%root%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure DMUMPS_FAC_DRIVER C ----------------------------------------------- CALL DMUMPS_FAC_DRIVER(id) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C id%root%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (id%root%yes) THEN IF (id%root%SCHUR_NLOC==0) THEN DEALLOCATE(id%root%SCHUR_POINTER) NULLIFY(id%root%SCHUR_POINTER) ELSE NULLIFY(id%root%SCHUR_POINTER) ENDIF ENDIF ENDIF C root%RG2L_ROW and root%RG2L_COL C are not used outside of the facto IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver= ', TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C Free id%S if facto failed if (associated(id%S)) then DEALLOCATE(id%S) NULLIFY(id%S) endif GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure DMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL DMUMPS_SOLVE_DRIVER(id) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL DMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to DMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO ENDIF END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL DMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = TIMETOTAL ENDIF ENDIF *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN CALL DMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=dble(id%KEEP8(55))/1D6 id%RINFO(8)=dble(id%KEEP8(56))/1D6 id%RINFOG(17)=dble(id%KEEP8(57))/1D6 id%RINFOG(18)=dble(id%KEEP8(58))/1D6 ENDIF !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from DMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from DMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM DMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE DMUMPS * SUBROUTINE DMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE DMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE DMUMPS_PRINT_ICNTL (id, LP) USE DMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL DOUBLE PRECISION, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Null pivot detection threshold =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE DMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE DMUMPS_PRINT_KEEP(id, LP) USE DMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (DMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).NE.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) KEEP(12) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),KEEP(248),ICNTL(21) WRITE (LP,993) KEEP(12) END SELECT ENDIF 980 FORMAT (/'******INTERNAL VALUE OF PARAMETERS (ICNTL/KEEP)****'/) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=Off, >0=ON) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) END SUBROUTINE DMUMPS_PRINT_KEEP SUBROUTINE DMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_F2003) & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #else C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE DMUMPS_CHECK_DENSE_RHS C SUBROUTINE DMUMPS_SET_K221(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C Constraint: must be called before DMUMPS_CHECK_REDRHS. C Can be called at factorization or solve phase C TYPE (DMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).ne.0 .and. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).ne.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE DMUMPS_SET_K221 C SUBROUTINE DMUMPS_CHECK_REDRHS(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)=1 is C forbidden in case of fwd in facto. C TYPE (DMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID .EQ. MASTER) THEN IF ( id%KEEP(221) == 1 .or. id%KEEP(221) == 2 ) THEN IF (id%KEEP(221) == 2 .and. id%JOB == 2) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF (id%KEEP(221) == 1 .and. id%KEEP(252) == 1 & .and. id%JOB == 3) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) ENDIF IF ( id%KEEP(60).eq. 0 .or. id%SIZE_SCHUR.EQ.0 ) THEN id%INFO(1)=-33 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF ( .NOT. associated( id%REDRHS)) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ELSE IF (id%NRHS.EQ.1) THEN IF (size(id%REDRHS) < id%SIZE_SCHUR ) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ELSE IF (id%LREDRHS < id%SIZE_SCHUR) THEN id%INFO(1)=-34 id%INFO(2)=id%LREDRHS GOTO 333 ELSE IF & (size(id%REDRHS)< & id%NRHS*id%LREDRHS-id%LREDRHS+id%SIZE_SCHUR) & THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ENDIF ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE DMUMPS_CHECK_REDRHS MUMPS_5.4.1/src/mumps_type_size.F0000664000175000017500000000117214102210475017055 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_GET_INT_DBL_SIZES( IS, DS ) INTEGER IS, DS #if defined(t3e) IS = 8 DS = 16 #else IS = 4 DS = 8 #endif END SUBROUTINE MUMPS_GET_INT_DBL_SIZES MUMPS_5.4.1/src/zfac_process_contrib_type1.F0000664000175000017500000001172014102210524021137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_NODE MUMPS_5.4.1/src/cfac_determinant.F0000664000175000017500000002007514102210523017104 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE COMPLEX, intent(in) :: PIV COMPLEX, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP REAL R_PART, C_PART INTEGER NEXP_LOC DETER=DETER*PIV R_PART=real(DETER) C_PART=aimag(DETER) NEXP_LOC = exponent(abs(R_PART)+abs(C_PART)) NEXP = NEXP + NEXP_LOC R_PART=scale(R_PART, -NEXP_LOC) C_PART=scale(C_PART, -NEXP_LOC) DETER=cmplx(R_PART,C_PART,kind=kind(DETER)) RETURN END SUBROUTINE CMUMPS_UPDATEDETER SUBROUTINE CMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE REAL, intent(in) :: PIV REAL, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE CMUMPS_UPDATEDETER_SCALING SUBROUTINE CMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP COMPLEX, intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX, intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL CMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL CMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE CMUMPS_GETDETER2D SUBROUTINE CMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS COMPLEX, intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN COMPLEX,intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL CMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP COMPLEX :: INV(2) COMPLEX :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_COMPLEX, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(CMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=cmplx(NEXP_IN,kind=kind(INV)) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE CMUMPS_DETER_REDUCTION SUBROUTINE CMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif COMPLEX, INTENT(IN) :: INV ( 2 * NEL ) COMPLEX, INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL CMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = cmplx(TMPEXPINOUT,kind=kind(INOUTV)) ENDDO RETURN END SUBROUTINE CMUMPS_DETERREDUCE_FUNC SUBROUTINE CMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP COMPLEX, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE CMUMPS_DETER_SQUARE SUBROUTINE CMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=1.0E0/DETER NEXP=-NEXP RETURN END SUBROUTINE CMUMPS_DETER_SCALING_INVERSE SUBROUTINE CMUMPS_DETER_SIGN_PERM(DETER, N, VISITED, PERM) IMPLICIT NONE COMPLEX, intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: VISITED(N) INTEGER, intent(in) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (VISITED(I) .GT. N) THEN VISITED(I)=VISITED(I)-N-N-1 CYCLE ENDIF J = PERM(I) DO WHILE (J.NE.I) VISITED(J) = VISITED(J) + N + N + 1 K = K + 1 J = PERM(J) ENDDO ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE CMUMPS_DETER_SIGN_PERM SUBROUTINE CMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE CMUMPS_FAC_FRONT_AUX_M, & ONLY : CMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX, intent(in) :: A(*) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K REAL :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE CMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.4.1/src/sfac_process_contrib_type3.F0000664000175000017500000002504314102210521021132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE SMUMPS_LOAD USE SMUMPS_OOC USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC ) :: root INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF REAL A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW INCLUDE 'mpif.h' INTEGER IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI INTEGER(8) :: LREQA, POS_ROOT INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF INTEGER NSUPCOL_EFF INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NSUPROW, NSUPCOL, BBPCBP INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISON, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPCOL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BBPCBP, 1, MPI_INTEGER, & COMM, IERR ) IF (BBPCBP .EQ. 1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF IROOT = KEEP( 38 ) IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR. & PTLUST( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL SMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in SMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_REAL, COMM, IERR ) OPASSW = OPASSW + LREQA CALL SMUMPS_ASS_ROOT( root, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in SMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_REAL, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL SMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL SMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & root%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.4.1/src/cfac_front_aux.F0000664000175000017500000024736014102210524016610 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE CMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) REAL UU, SEUIL COMPLEX A(LA) INTEGER IW(LIW) REAL, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR REAL AMROW REAL RMAX COMPLEX SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER CMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK, K360 K360 = KEEP(360) NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX)) ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = CMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 IF (KEEP(351).EQ.1) THEN J1_ini = J1 !$ CHUNK = max(K360/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO ENDIF END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE CMUMPS_FAC_H SUBROUTINE CMUMPS_FAC_M(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,XSIZE) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB,IBEG_BLOCK INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) COMPLEX VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER LKJIT, XSIZE COMPLEX ONE, ALPHA INTEGER NPIV,JROW2 INTEGER NEL2,NPIVP1,KROW,NEL INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IF (NASS.LT.LKJIT) THEN IW(IOLDPS+3+XSIZE) = NASS ELSE IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NEL2 = JROW2 - NPIVP1 IF (NEL2.EQ.0) THEN IF (JROW2.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 IW(IOLDPS+3+XSIZE) = min0(JROW2+LKJIB,NASS) IBEG_BLOCK = NPIVP1+1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 CALL cgeru(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) ENDIF RETURN END SUBROUTINE CMUMPS_FAC_M SUBROUTINE CMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) COMPLEX ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) REAL, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 COMPLEX, PARAMETER :: ONE=(1.0E0,0.0E0) #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, K360, CHUNK NOMP = OMP_GET_MAX_THREADS() K360 = KEEP(360) #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.K360) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(K360/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.2) THEN MAXFROMN = 0.0E0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_FAC_N SUBROUTINE CMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K405 .EQ. 1 ) THEN IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 ENDIF IF ( K427_OUT .GT. 99 ) K427_OUT = 0 IF ( K427_OUT .LT. -100 ) K427_OUT = -1 RETURN END SUBROUTINE CMUMPS_FAC_PT_SETLOCK427 SUBROUTINE CMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE CMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & CMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC COMPLEX A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL ctrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL ctrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL cgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL cgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_P SUBROUTINE CMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL ctrsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL cgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE CMUMPS_FAC_T SUBROUTINE CMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE CMUMPS_BUF #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL ctrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ctrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL cgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL cgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL ctrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ctrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL cgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL cgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL CMUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL ctrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL cgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_SQ SUBROUTINE CMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT COMPLEX, intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 COMPLEX :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL cgeru(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL cgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ SUBROUTINE CMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE CMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) COMPLEX, intent(inout) :: A(LA) REAL, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv REAL :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL CMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IS_MAXFROMN_AVAIL = .FALSE. 120 CALL CMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL CMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL CMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE CMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST,LPN_LIST, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW REAL, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, intent(in) :: LPN_LIST INTEGER, intent(inout) :: PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' COMPLEX SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) REAL RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV INTEGER(8) :: APOSMAX, APOSROW REAL :: RMAX_NORELAX REAL PIVNUL COMPLEX FIXA, CSEUIL INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER CMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0E0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK,K361 #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() K361 = KEEP(361) #endif PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) IDIAG = APOS CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF (real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = CMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) IF ((J2-J1).GE.K361) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(IDIAG)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(real(FIXA).GT.RZERO) THEN IF(real(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_I SUBROUTINE CMUMPS_FAC_I_LDLT & ( NFRONT,NASS,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE COMPLEX A(LA) REAL UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled REAL, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP REAL RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV REAL RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW REAL MAXPIV REAL PIVNUL COMPLEX FIXA, CSEUIL COMPLEX PIVOT,DETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max COMPLEX ZERO, ONE PARAMETER( ZERO = (0.0E0,0.0E0) ) PARAMETER( ONE = (1.0E0,1.0E0) ) REAL RZERO,RONE PARAMETER(RZERO=0.0E0, RONE=1.0E0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(real(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 IF (SEUIL.GT.RZERO) THEN IF (sqrt(abs(DETPIV)) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE CMUMPS_FAC_I_LDLT SUBROUTINE CMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX VALPIV REAL :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL COMPLEX ONE, ZERO COMPLEX A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, IBEG, IEND INTEGER(8) :: JJ, K1, K2, IROW INTEGER(8) :: ROW_SHIFT, JJ_LOC, IBEG_LOC, IEND_LOC COMPLEX SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX INCLUDE 'mumps_headers.h' PARAMETER(ONE = (1.0E0,0.0E0), & ZERO = (0.0E0,0.0E0)) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0E0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 IF (NEL2 > 0) THEN IF (.NOT. IS_MAX_USEFUL) THEN DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ELSE IS_MAXFROMM_AVAIL = .TRUE. DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMM=max( MAXFROMM,abs(A(K1POS+1_8)) ) DO JJ = 2_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ENDIF ENDIF NCB1 = LAST_ROW - IEND_BLOCK IF (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0E0 !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (NCB1-NVSCHUR_K253>300) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL ccopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL ccopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & real(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ_LDLT SUBROUTINE CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE COMPLEX ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL ctrsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL CMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL cgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IEND_BLOCK,8) CALL cgemm( 'N','N', IROW + Block - IEND_BLOCK - 1, & Block, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL cgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL cgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_SQ_LDLT SUBROUTINE CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP COMPLEX A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 COMPLEX SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL cswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL cswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL cswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL cswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SWAP_LDLT SUBROUTINE CMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY COMPLEX :: ONE PARAMETER (ONE=(1.0E0,0.0E0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL ccopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL ccopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE CMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE CMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY COMPLEX :: ONE PARAMETER (ONE=(1.0E0,0.0E0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE CMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE CMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE CMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA COMPLEX A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2 COMPLEX ONE, ALPHA, BETA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL ctrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL CMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL cgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL CMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL cgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG,LAST_CALL ) IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL cgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL CMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL cgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE CMUMPS_FAC_T_LDLT SUBROUTINE CMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN CMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE CMUMPS_STORE_PERMINFO SUBROUTINE CMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE REAL, INTENT(IN) :: DIAG REAL, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT END MODULE CMUMPS_FAC_FRONT_AUX_M MUMPS_5.4.1/src/zlr_core.F0000664000175000017500000022444014102210526015442 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE ZMUMPS_LR_CORE USE MUMPS_LR_COMMON USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & LRSTATUS, N, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: N INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(N) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok COMPLEX(kind=8) :: ZERO PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER(8) :: KEEP8TMPCOPY, KEEP873COPY LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS) MINSIZE = int(IBCKSZ2 / 2) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE ZMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J COMPLEX(kind=8), POINTER :: LR_BLOCK_PTR(:,:) COMPLEX(kind=8) :: ONE, MONE, ZERO COMPLEX(kind=8) :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL ztrsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL ztrsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'ZMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL zscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB, LorU) END SUBROUTINE ZMUMPS_LRTRSM SUBROUTINE ZMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in ZMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT COMPLEX(kind=8), INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER COMPLEX(kind=8), intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS COMPLEX(kind=8) :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE ZMUMPS_LRGEMM_SCALING SUBROUTINE ZMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT COMPLEX(kind=8), INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION, intent(in) :: TOLEPS COMPLEX(kind=8) :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ COMPLEX(kind=8), intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: XY_YZ COMPLEX(kind=8), ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ DOUBLE PRECISION, EXTERNAL ::dznrm2 COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL zgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for zungqr CALL zungqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL zgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL ZMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL zgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL zgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in ZMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL zgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL zgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL zgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE ZMUMPS_LRGEMM4 SUBROUTINE ZMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL zgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE ZMUMPS_DECOMPRESS_ACC SUBROUTINE ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO) BUILDQ = (RANK.LE.MAXRANK) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & ZMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE ZMUMPS_COMPRESS_FR_UPDATES SUBROUTINE ZMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:), TARGET :: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL ZMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO) BUILDQ2 = (RANK2.LE.MAXRANK) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL ZMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & ZMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE ZMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE ZMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in ZMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL ZMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in ZMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'ZMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE ZMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE ZMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX(kind=8), ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL zgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL zgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL ZMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL zgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL zungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL zgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & ZMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE ZMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE ZMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in ZMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE ZMUMPS_GET_LUA_ORDER SUBROUTINE ZMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER COMPLEX(kind=8) :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C COMPLEX(kind=8), ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST COMPLEX(kind=8) :: ONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL ZMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if defined(BLR_MT) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in ZMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL zgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if defined(BLR_MT) !$OMP END DO !$OMP END PARALLEL #endif CALL ZMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in ZMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL ZMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, & MTK405=KEEP(405)) ENDIF END SUBROUTINE ZMUMPS_BLR_ASM_NIV1 END MODULE ZMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE ZMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT DOUBLE PRECISION :: TOLEPS INTEGER :: JPVT(*) DOUBLE PRECISION :: RWORK(*) COMPLEX(kind=8) :: A(LDA,*), TAU(*) COMPLEX(kind=8) :: WORK(LDW,*) DOUBLE PRECISION :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK DOUBLE PRECISION :: TEMP, TEMP2, TOL3Z COMPLEX(kind=8) :: AKK DOUBLE PRECISION, PARAMETER :: RZERO=0.0D+0, RONE=1.0D+0 COMPLEX(kind=8) :: ZERO COMPLEX(kind=8) :: ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) DOUBLE PRECISION :: dlamch INTEGER :: ilaenv, idamax EXTERNAL :: idamax, dlamch EXTERNAL zgeqrf, zunmqr, xerbla EXTERNAL ilaenv EXTERNAL zgemm, zgemv, zlarfg, zswap DOUBLE PRECISION, EXTERNAL :: dznrm2 DOUBLE PRECISION, EXTERNAL :: dnrm2 INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in ZMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = dznrm2( M, A( 1, J ), 1 ) RWORK( J ) = dznrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = dnrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = dnrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(dlamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + IDAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + idamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 RETURN END IF IF (RK.GT.MAXRANK) THEN RANK = RK INFO = RK RETURN END IF IF( PVT.NE.RK ) THEN CALL zswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL zswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL zswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN DO J = 1, K-1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J+1 ) = CONJG( WORK( K, J+1 ) ) END DO CALL zgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) DO J = 1, K - 1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J + 1 ) = CONJG( WORK( K, J + 1 ) ) END DO END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL zlarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL zlarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL zgemv( 'Conjugate transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL zgemv( 'Conjugate transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL zgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN CALL zgemm( 'No transpose', 'Conjugate transpose', & 1, N-RK, C & K, -ONE, A( RK, OFFSET+1 ), LDA, F( K+1, 1 ), LDF, & K, -ONE, A( RK, OFFSET+1 ), LDA, WORK( K+1,2 ), LDW, & ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = dble( LSTICC ) RWORK( N+J ) = dble( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL zgemm( 'No transpose', 'Conjugate transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = dznrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = dznrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK RETURN 999 FORMAT ('On entry to ZMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE ZMUMPS_TRUNCATED_RRQR MUMPS_5.4.1/src/dfac_sispointers_m.F0000664000175000017500000000152314102210525017470 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C DMUMPS_FAC_DRIVER and DMUMPS_FAC_B C ---------------------------------- TYPE S_IS_POINTERS_T DOUBLE PRECISION, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE S_IS_POINTERS_T END MODULE DMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.4.1/src/cfac_mem_stack.F0000664000175000017500000005502414102210523016537 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) COMPLEX A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR, MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR, & MUMPS_ROOTSSARBR LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 INPLACE = .FALSE. MIN_SPACE_IN_PLACE = 0_8 IOLDPS = PTLUST_S(STEP(INODE)) INTSIZ = IW(IOLDPS+XXI) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS + 1+KEEP(IXSZ)) NMAXNPIV = max(NPIV, NMAXNPIV) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in CMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL CMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL CMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL CMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL CMUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL CMUMPS_PROCESS_RTNELIND( root, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL CMUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL CMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL CMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & CMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & CMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL CMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL CMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL CMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL CMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL CMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I = 1, NCBROW_PREVIOUSLY_MOVED*NPIV A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) CALL CMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL CMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE CMUMPS_FAC_STACK MUMPS_5.4.1/src/zfac_scalings_simScale_util.F0000664000175000017500000012063614102210526021310 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) C IMPLICIT NONE EXTERNAL ZMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(ZMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif C WE FIRST ZERO OUT DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE ZMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: MYID, NUMPROCS, M, N, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C [ROW/COL]PARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: ROWPARTVEC(M) INTEGER, INTENT(IN) :: COLPARTVEC(N) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C INUMMYR < M and INUMMYC < N (CPA or <= ??) C INUMMYR holds the number of rows allocated to me C or non empty on my proc C INUMMYC idem with columns INTEGER INUMMYR, INUMMYC C C INTERNAL working array INTEGER IWRK(IWSZ) C C Local variables INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 INUMMYC = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED C INUMMYR first counts number of rows affected to me C (that will be centralized on MYID) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IC = JCN_loc(I8) IR = IRN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) THEN IWRK(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO C RETURN END SUBROUTINE ZMUMPS_FINDNUMMYROWCOL SUBROUTINE ZMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER(8) :: NZ_loc INTEGER MYID, NUMPROCS, M, N INTEGER INUMMYR, INUMMYC, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = M IF(N > MAXMN) MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE ZMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION ZMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I, IID DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) ZMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN ZMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION ZMUMPS_CHK1LOC INTEGER FUNCTION ZMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) ZMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN ZMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION ZMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION ZMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ DOUBLE PRECISION DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL ZMUMPS_CHK1LOC INTEGER ZMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = ZMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = ZMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) ZMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION ZMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C DOUBLE PRECISION FUNCTION ZMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ) C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I, IIND DOUBLE PRECISION ERRMAX INTRINSIC abs ERRMAX = -RONE DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO ZMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION ZMUMPS_ERRSCALOC DOUBLE PRECISION FUNCTION ZMUMPS_ERRSCA1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I DOUBLE PRECISION ERRMAX1 INTRINSIC abs ERRMAX1 = -RONE DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO ZMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION ZMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND) = D(IIND)/sqrt(TMPD(IIND)) ENDDO RETURN END SUBROUTINE ZMUMPS_UPDATESCALE SUBROUTINE ZMUMPS_UPSCALE1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO RETURN END SUBROUTINE ZMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE ZMUMPS_INITREALLST C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_INVLIST(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) C LOCALS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0D0/D(IIND) ENDDO RETURN END SUBROUTINE ZMUMPS_INVLIST C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_INITREAL(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE ZMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ DOUBLE PRECISION TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE ZMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE ZMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX hold col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE ZMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE ZMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE ZMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_DOCOMM1N SUBROUTINE ZMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL ZMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc INTEGER, INTENT(IN) :: ISZ, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(ZMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL ZMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 IWRK(2*IC-1) = IWRK(2*IC-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_CREATEPARTVECSYM SUBROUTINE ZMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE ZMUMPS_NUMVOLSNDRCVSYM SUBROUTINE ZMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC).EQ.0) THEN IWRK(IC)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C THE SMAME THING APPLIES FOR COLS C No need to do anything C RETURN END SUBROUTINE ZMUMPS_FINDNUMMYROWCOLSYM INTEGER FUNCTION ZMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ DOUBLE PRECISION D(N) INTEGER INDXR(INDXRSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL ZMUMPS_CHK1LOC INTEGER ZMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = ZMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) ZMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION ZMUMPS_CHKCONVGLOSYM SUBROUTINE ZMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE ZMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE ZMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE ZMUMPS_SETUPCOMMSSYM MUMPS_5.4.1/src/dana_dist_m.F0000664000175000017500000015512314102210522016062 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE DMUMPS_ANA_LR, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) DOUBLE PRECISION UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) DOUBLE PRECISION OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR DOUBLE PRECISION OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB INTEGER(8):: MAXTEMPCB_LR INTEGER :: NB_BLR LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER NBouter_MIN INCLUDE 'mumps_headers.h' INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int, real INTEGER DMUMPS_OOC_GET_PANEL_SIZE EXTERNAL DMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0D0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(488)) IF (KEEP(66).NE.0.AND.SLAVEF.GT.1) THEN IF ( KEEP(50).EQ.0 ) THEN NBouter_MIN = ceiling & ( & (dble(KEEP(59))*dble(KEEP(108))*dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ELSE NBouter_MIN = ceiling & ( & ( max (dble(KEEP(108))*dble(KEEP(108)), & dble(KEEP(59))*dble(KEEP(108)/2) & ) & *dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ENDIF NBouter_MIN = max (NBouter_MIN, 4) LKJIB_FR = min(KEEP(108)/NBouter_MIN, 4321) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXTEMPCB_LR = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in DMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF CALL COMPUTE_BLR_VCS(KEEP(472), NB_BLR, KEEP(488), NELIM) IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = DMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0_8 ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NBCOLFAC=NFR ELSE NBCOLFAC=NELIM ENDIF PANEL_SIZE = DMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU_CURRENT = int(NBCOLFAC,8)*int(NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0 ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max0(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF (KEEP(50).NE.0.AND.UPDATE.AND.LEVEL.EQ.1) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + & int(NELIM,8)*int(NCB,8) ENDIF IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR+ & NRLADU_CURRENT_MISSING) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+MAXTEMPCB_LR) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in DMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in DMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPSA_LOC, KEEP(50), NFR, & NFR, ROOT_NPROW, ROOT_NPCOL, MYID ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + dble(OPS_NODE) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (UPDATE .AND. LEVEL.EQ.2 .AND. .NOT. MASTER) THEN NRLNEC = & max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & 2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXTEMPCB_LR = max(MAXTEMPCB_LR,LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in DMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in DMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max0(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) SBUF_RECOLD = max(int(SBUFR_FR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = dble(OPS_SBTR_LOC) OPSA = dble(OPSA_LOC) RETURN END SUBROUTINE DMUMPS_ANA_DISTM MUMPS_5.4.1/src/sfac_front_type2_aux.F0000664000175000017500000007057514102210521017752 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE SMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE SMUMPS_FAC_FRONT_AUX_M IMPLICIT NONE INTEGER SIZEDIAG_ORIG REAL DIAG_ORIG(SIZEDIAG_ORIG) REAL GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA REAL A(LA) REAL UU, UULOC, SEUIL REAL CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF REAL RMAX,AMAX,TMAX,RMAX_NORELAX REAL MAXPIV, ABS_PIVOT REAL RMAX_NOSLAVE, TMAX_NOSLAVE REAL PIVOT,DETPIV REAL ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK REAL :: GROWTH, RSWOP REAL :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 REAL ZERO, ONE PARAMETER( ZERO = 0.0E0 ) PARAMETER( ONE = 1.0E0 ) REAL PIVNUL, VALTMP REAL FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L REAL GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (ABS_PIVOT.EQ.RZERO) GO TO 630 IF (PIVOT.LT.RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0E10*RMAX, sqrt(huge(RMAX))/1.0E8) A(POSPV1) = VALTMP ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN IF (A(POSPV1).LT.RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1,real(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL SMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE SMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED REAL VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 REAL ONE, ALPHA REAL ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 REAL SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO=0.0E0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL scopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL scopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_BLOCK, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_TYPE USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTBL REAL A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(N) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in SMUMPS_SEND_FACTORED_BLK ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_BLOCK + 1 NCOL = LDA_FS - IBEG_BLOCK + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) IF (IBEG_BLOCK > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_BLOCK-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL SMUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTBL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL SMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, & NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_SEND_FACTORED_BLK END MODULE SMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.4.1/src/sfac_type3_symmetrize.F0000664000175000017500000001361214102210521020143 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID REAL BUF( BLOCK_SIZE * BLOCK_SIZE ) REAL A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL SMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL SMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL SMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL SMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE SMUMPS_SYMMETRIZE SUBROUTINE SMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM REAL BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_REAL, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE SMUMPS_SEND_BLOCK SUBROUTINE SMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE REAL BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_REAL, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL scopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE SMUMPS_RECV_BLOCK SUBROUTINE SMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA REAL A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE SMUMPS_TRANS_DIAG SUBROUTINE SMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD REAL A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE SMUMPS_TRANSPO MUMPS_5.4.1/src/sfac_determinant.F0000664000175000017500000001742214102210521017124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE REAL, intent(in) :: PIV REAL, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE SMUMPS_UPDATEDETER SUBROUTINE SMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE REAL, intent(in) :: PIV REAL, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE SMUMPS_UPDATEDETER_SCALING SUBROUTINE SMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) REAL, intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL SMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL SMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE SMUMPS_GETDETER2D SUBROUTINE SMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS REAL, intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN REAL,intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL SMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP REAL :: INV(2) REAL :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_REAL, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(SMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=real(NEXP_IN) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE SMUMPS_DETER_REDUCTION SUBROUTINE SMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif REAL, INTENT(IN) :: INV ( 2 * NEL ) REAL, INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL SMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = real(TMPEXPINOUT) ENDDO RETURN END SUBROUTINE SMUMPS_DETERREDUCE_FUNC SUBROUTINE SMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE SMUMPS_DETER_SQUARE SUBROUTINE SMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP REAL, intent (inout) :: DETER DETER=1.0E0/DETER NEXP=-NEXP RETURN END SUBROUTINE SMUMPS_DETER_SCALING_INVERSE SUBROUTINE SMUMPS_DETER_SIGN_PERM(DETER, N, VISITED, PERM) IMPLICIT NONE REAL, intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: VISITED(N) INTEGER, intent(in) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (VISITED(I) .GT. N) THEN VISITED(I)=VISITED(I)-N-N-1 CYCLE ENDIF J = PERM(I) DO WHILE (J.NE.I) VISITED(J) = VISITED(J) + N + N + 1 K = K + 1 J = PERM(J) ENDDO ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE SMUMPS_DETER_SIGN_PERM SUBROUTINE SMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE SMUMPS_FAC_FRONT_AUX_M, & ONLY : SMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) REAL, intent(in) :: A(*) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K REAL :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE SMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.4.1/src/mumps_version.F0000664000175000017500000000145714102210475016535 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SET_VERSION( VERSION_STR ) IMPLICIT NONE CHARACTER(LEN=*) :: VERSION_STR CHARACTER(LEN=*) :: V; PARAMETER (V = "5.4.1" ) IF ( len(V) .GT. 30 ) THEN WRITE(*,*) "Version string too long ( >30 characters )" CALL MUMPS_ABORT() END IF VERSION_STR = V RETURN END SUBROUTINE MUMPS_SET_VERSION MUMPS_5.4.1/src/drank_revealing.F0000664000175000017500000001072314102210522016747 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 RETURN END SUBROUTINE DMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE DMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE DMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE DMUMPS_RR_INIT_POINTERS(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) id NULLIFY(id%root%QR_TAU) NULLIFY(id%root%SVD_U) NULLIFY(id%root%SVD_VT) NULLIFY(id%root%SINGULAR_VALUES) RETURN END SUBROUTINE DMUMPS_RR_INIT_POINTERS SUBROUTINE DMUMPS_RR_FREE_POINTERS(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) id IF (associated(id%root%QR_TAU)) THEN DEALLOCATE(id%root%QR_TAU) NULLIFY(id%root%QR_TAU) ENDIF IF (associated(id%root%SVD_U)) THEN DEALLOCATE(id%root%SVD_U) NULLIFY(id%root%SVD_U) ENDIF IF (associated(id%root%SVD_VT)) THEN DEALLOCATE(id%root%SVD_VT) NULLIFY(id%root%SVD_VT) ENDIF IF (associated(id%root%SINGULAR_VALUES)) THEN DEALLOCATE(id%root%SINGULAR_VALUES) NULLIFY(id%root%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE DMUMPS_RR_FREE_POINTERS MUMPS_5.4.1/src/cmumps_config_file.F0000664000175000017500000000103314102210524017440 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE CMUMPS_CONFIG_FILE_RETURN MUMPS_5.4.1/src/dsol_root_parallel.F0000664000175000017500000000742514102210522017501 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT DOUBLE PRECISION RHS_SEQ( SIZE_ROOT *NRHS) DOUBLE PRECISION A( LOCAL_M, LOCAL_N ) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS DOUBLE PRECISION, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR EXTERNAL numroc INTEGER numroc INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = numroc(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL DMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL DMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) RETURN END SUBROUTINE DMUMPS_ROOT_SOLVE SUBROUTINE DMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) DOUBLE PRECISION, intent (in) :: A( LOCAL_M, LOCAL_N ) DOUBLE PRECISION, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL pdgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL pdgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pdpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE DMUMPS_SOLVE_2D_BCYCLIC MUMPS_5.4.1/src/cfac_front_LDLT_type2.F0000664000175000017500000010516214102210524017666 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE CMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_FAC_FRONT_TYPE2_AUX_M USE CMUMPS_OOC USE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M !$ USE OMP_LIB USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_BUF, ONLY : CMUMPS_BUF_TEST IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) COMPLEX A( LA ) REAL UU, SEUIL TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG REAL UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV REAL , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL CMUMPS_BDC_ERROR LOGICAL STATICMODE REAL SEUIL_LOC REAL GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV COMPLEX ONE PARAMETER (ONE=(1.0E0,0.0E0)) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0E0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1)) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8)-1 CALL CMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0E0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : CMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 490 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL CMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ CALL CMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR-NPIV CALL CMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL CMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL CMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in CMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.2) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL CMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL CMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL CMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL CMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG = IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF & ( & (KEEP(486).EQ.2) & ) & THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8(68) = max(KEEP8(69), KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 490 ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC2_LDLT SUBROUTINE CMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE INTEGER, INTENT(IN) :: LPN_LIST INTEGER, INTENT(IN) :: PIVNUL_LIST(LPN_LIST) INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS COMPLEX, INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K COMPLEX ONE PARAMETER (ONE=(1.0E0,0.0E0)) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE CMUMPS_RESET_TO_ONE END MODULE CMUMPS_FAC2_LDLT_M MUMPS_5.4.1/src/mumps_memory_mod.F0000664000175000017500000007563114102210475017224 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_MEMORY_MOD INTERFACE MUMPS_DEALLOC MODULE PROCEDURE MUMPS_IDEALLOC END INTERFACE INTERFACE MUMPS_REALLOC MODULE PROCEDURE MUMPS_IREALLOC MODULE PROCEDURE MUMPS_DREALLOC, MUMPS_SREALLOC, MUMPS_ZREALLOC MODULE PROCEDURE MUMPS_CREALLOC END INTERFACE INTEGER(8), PRIVATE :: ISIZE, I8SIZE, SSIZE, DSIZE, CSIZE, ZSIZE CONTAINS SUBROUTINE MUMPS_MEMORY_SET_DATA_SIZES() INTEGER :: I(2) INTEGER(8) :: I8(2) REAL(kind(1.e0)) :: S(2) REAL(kind(1.d0)) :: D(2) COMPLEX(kind(1.e0)) :: C(2) COMPLEX(kind(1.d0)) :: Z(2) CALL MUMPS_SIZE_C(I (1), I (2), ISIZE) CALL MUMPS_SIZE_C(S (1), S (2), SSIZE) CALL MUMPS_SIZE_C(D (1), D (2), DSIZE) CALL MUMPS_SIZE_C(C (1), C (2), CSIZE) CALL MUMPS_SIZE_C(Z (1), Z (2), ZSIZE) CALL MUMPS_SIZE_C(I8(1), I8(2), I8SIZE) RETURN END SUBROUTINE MUMPS_MEMORY_SET_DATA_SIZES SUBROUTINE MUMPS_IREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER, POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER, POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*ISIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & MINSIZE*ISIZE END IF END IF RETURN END SUBROUTINE MUMPS_IREALLOC SUBROUTINE MUMPS_I8REALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER(8), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER(8), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF END IF RETURN END SUBROUTINE MUMPS_I8REALLOC SUBROUTINE MUMPS_IREALLOC8(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER, POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: LP INTEGER(8) :: MINSIZE LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER, POINTER :: TEMP(:) INTEGER(8) :: I INTEGER :: IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = int(min(MINSIZE,huge(I))) ELSE ERRTPL(1) = -13 ERRTPL(2) = int(min(MINSIZE,huge(I))) END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((int(size(ARRAY),8) .LT. MINSIZE) .OR. & ((int(size(ARRAY),8).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+MINSIZE*ISIZE END IF DO I=1, min(int(size(ARRAY),8), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((int(size(ARRAY),8) .LT. MINSIZE) .OR. & ((int(size(ARRAY),8).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*ISIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE*ISIZE END IF END IF RETURN END SUBROUTINE MUMPS_IREALLOC8 SUBROUTINE MUMPS_I8REALLOC8(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) INTEGER(8), POINTER :: ARRAY(:) INTEGER :: INFO(:), LP INTEGER(8) :: MINSIZE LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE INTEGER(8), POINTER :: TEMP(:) INTEGER :: IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD INTEGER(8) :: ASIZE, I ASIZE = int(size(ARRAY),8) IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = int(MINSIZE) ELSE ERRTPL(1) = -13 ERRTPL(2) = int(MINSIZE) END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((ASIZE .LT. MINSIZE) .OR. & ((ASIZE.NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF DO I=1, min(ASIZE, MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & ASIZE*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((ASIZE .LT. MINSIZE) .OR. & ((ASIZE.NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & ASIZE*I8SIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*I8SIZE END IF END IF RETURN END SUBROUTINE MUMPS_I8REALLOC8 SUBROUTINE MUMPS_SREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) REAL(kind(1.E0)), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE REAL(kind(1.E0)), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*SSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*SSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*SSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+MINSIZE*SSIZE END IF END IF RETURN END SUBROUTINE MUMPS_SREALLOC SUBROUTINE MUMPS_DREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) REAL(kind(1.D0)), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE REAL(kind(1.D0)), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*DSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*DSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*DSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*DSIZE END IF END IF RETURN END SUBROUTINE MUMPS_DREALLOC SUBROUTINE MUMPS_CREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) COMPLEX(kind((1.E0,1.E0))), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE COMPLEX(kind((1.E0,1.E0))), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+ & int(MINSIZE,8)*CSIZE END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*CSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT = MEMCNT- & int(size(ARRAY),8)*CSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*CSIZE END IF END IF RETURN END SUBROUTINE MUMPS_CREALLOC SUBROUTINE MUMPS_ZREALLOC(ARRAY, MINSIZE, INFO, LP, FORCE, COPY, & STRING, MEMCNT, ERRCODE) COMPLEX(kind((1.D0,1.D0))), POINTER :: ARRAY(:) INTEGER :: INFO(:) INTEGER :: MINSIZE, LP LOGICAL, OPTIONAL :: FORCE LOGICAL, OPTIONAL :: COPY CHARACTER, OPTIONAL :: STRING*(*) INTEGER, OPTIONAL :: ERRCODE INTEGER(8), OPTIONAL :: MEMCNT LOGICAL :: ICOPY, IFORCE COMPLEX(kind((1.D0,1.D0))), POINTER :: TEMP(:) INTEGER :: I, IERR, ERRTPL(2) CHARACTER(len=60) :: FMTA, FMTD IF(present(COPY)) THEN ICOPY = COPY ELSE ICOPY = .FALSE. END IF IF (present(FORCE)) THEN IFORCE = FORCE ELSE IFORCE = .FALSE. END IF IF (present(STRING)) THEN FMTA = "Allocation failed inside realloc: "//STRING FMTD = "Deallocation failed inside realloc: "//STRING ELSE FMTA = "Allocation failed inside realloc: " FMTD = "Deallocation failed inside realloc: " END IF IF (present(ERRCODE)) THEN ERRTPL(1) = ERRCODE ERRTPL(2) = MINSIZE ELSE ERRTPL(1) = -13 ERRTPL(2) = MINSIZE END IF IF(ICOPY) THEN IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN allocate(TEMP(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT))MEMCNT = MEMCNT+int(MINSIZE,8)*16_8 END IF DO I=1, min(size(ARRAY), MINSIZE) TEMP(I) = ARRAY(I) END DO IF(present(MEMCNT))MEMCNT =MEMCNT- & int(size(ARRAY),8)*ZSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF NULLIFY(ARRAY) ARRAY => TEMP NULLIFY(TEMP) END IF ELSE WRITE(LP, & '("Input array is not associated. nothing to copy here")') RETURN END IF ELSE IF(associated(ARRAY)) THEN IF ((size(ARRAY) .LT. MINSIZE) .OR. & ((size(ARRAY).NE.MINSIZE) .AND. IFORCE)) THEN IF(present(MEMCNT))MEMCNT =MEMCNT- & int(size(ARRAY),8)*ZSIZE deallocate(ARRAY, STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTD) INFO(1:2) = ERRTPL RETURN END IF ELSE RETURN END IF END IF allocate(ARRAY(MINSIZE), STAT=IERR) IF(IERR .LT. 0) THEN WRITE(LP,FMTA) INFO(1:2) = ERRTPL RETURN ELSE IF(present(MEMCNT)) MEMCNT = MEMCNT+ & int(MINSIZE,8)*ZSIZE END IF END IF RETURN END SUBROUTINE MUMPS_ZREALLOC SUBROUTINE MUMPS_IDEALLOC(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER, POINTER :: A1(:) INTEGER, POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER(8), OPTIONAL :: MEMCNT INTEGER(8) :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+int(size(A1),8)*ISIZE DEALLOCATE(A1) NULLIFY(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+int(size(A2),8)*ISIZE DEALLOCATE(A2) NULLIFY(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+int(size(A3),8)*ISIZE DEALLOCATE(A3) NULLIFY(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+int(size(A4),8)*ISIZE DEALLOCATE(A4) NULLIFY(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+int(size(A5),8)*ISIZE DEALLOCATE(A5) NULLIFY(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+int(size(A6),8)*ISIZE DEALLOCATE(A6) NULLIFY(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+int(size(A7),8)*ISIZE DEALLOCATE(A7) NULLIFY(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_IDEALLOC SUBROUTINE MUMPS_I8DEALLOC(A1, A2, A3, A4, A5, A6, A7, MEMCNT) INTEGER(8), POINTER :: A1(:) INTEGER(8), POINTER, OPTIONAL :: A2(:), A3(:), A4(:), A5(:), & A6(:), A7(:) INTEGER(8), OPTIONAL :: MEMCNT INTEGER(8) :: IMEMCNT IMEMCNT = 0 IF(associated(A1)) THEN IMEMCNT = IMEMCNT+int(size(A1),8)*I8SIZE DEALLOCATE(A1) NULLIFY(A1) END IF IF(present(A2)) THEN IF(associated(A2)) THEN IMEMCNT = IMEMCNT+int(size(A2),8)*I8SIZE DEALLOCATE(A2) NULLIFY(A2) END IF END IF IF(present(A3)) THEN IF(associated(A3)) THEN IMEMCNT = IMEMCNT+int(size(A3),8)*I8SIZE DEALLOCATE(A3) NULLIFY(A3) END IF END IF IF(present(A4)) THEN IF(associated(A4)) THEN IMEMCNT = IMEMCNT+int(size(A4),8)*I8SIZE DEALLOCATE(A4) NULLIFY(A4) END IF END IF IF(present(A5)) THEN IF(associated(A5)) THEN IMEMCNT = IMEMCNT+int(size(A5),8)*I8SIZE DEALLOCATE(A5) NULLIFY(A5) END IF END IF IF(present(A6)) THEN IF(associated(A6)) THEN IMEMCNT = IMEMCNT+int(size(A6),8)*I8SIZE DEALLOCATE(A6) NULLIFY(A6) END IF END IF IF(present(A7)) THEN IF(associated(A7)) THEN IMEMCNT = IMEMCNT+int(size(A7),8)*I8SIZE DEALLOCATE(A7) NULLIFY(A7) END IF END IF IF(present(MEMCNT)) MEMCNT = MEMCNT-IMEMCNT RETURN END SUBROUTINE MUMPS_I8DEALLOC END MODULE MUMPS_5.4.1/src/sstatic_ptr_m.F0000664000175000017500000000204114102210521016460 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_STATIC_PTR_M PUBLIC :: SMUMPS_TMP_PTR, SMUMPS_GET_TMP_PTR REAL, DIMENSION(:), POINTER, SAVE :: SMUMPS_TMP_PTR CONTAINS SUBROUTINE SMUMPS_SET_STATIC_PTR(ARRAY) REAL, DIMENSION(:), TARGET :: ARRAY SMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE SMUMPS_SET_STATIC_PTR SUBROUTINE SMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_F2003) REAL, DIMENSION(:), POINTER, INTENT(OUT) :: PTR #else REAL, DIMENSION(:), POINTER :: PTR #endif PTR => SMUMPS_TMP_PTR RETURN END SUBROUTINE SMUMPS_GET_TMP_PTR END MODULE SMUMPS_STATIC_PTR_M MUMPS_5.4.1/src/cana_driver.F0000664000175000017500000056416614102210526016114 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE CMUMPS_ANA_DRIVER(id) USE CMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE CMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE CMUMPS_PARALLEL_ANALYSIS USE CMUMPS_ANA_LR USE CMUMPS_LR_CORE USE CMUMPS_LR_STATS USE MUMPS_LR_COMMON USE CMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(CMUMPS_STRUC), TARGET :: id C C Local variables C =============== C C C Pointers inside integer array, various data INTEGER IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LOCAL_M, LOCAL_N INTEGER numroc EXTERNAL numroc INTEGER IRANK INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 INTEGER MIN_BUF_SIZE INTEGER(8) MAX_SIZE_FACTOR_TMP INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) REAL :: PEAK INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:):: IPOOL INTEGER :: LIPOOL INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS REAL, DIMENSION(:), POINTER :: RINFO REAL, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, PERLU_ON, COND INTEGER :: OOC_STRAT, BLR_STRAT INTEGER :: IDUMMY INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed LOGICAL :: SUM_OF_PEAKS INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: TEMP_MEM INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_ROOT INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_LEAF INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_SIZE INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST_SEQ INTEGER, DIMENSION (:), ALLOCATABLE :: SBTR_ID REAL, DIMENSION (:), ALLOCATABLE :: COST_TRAV_TMP INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP LOGICAL :: GCOMP_PROVIDED TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, & STEPPTR, LRGROUPSPTR INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK INTEGER :: LIW_ELT C INTERFACE C Explicit interface because of pointer arguments: SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE CMUMPS_LR_DATA_M, only : CMUMPS_BLR_STRUC_TO_MOD, & CMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Beginning of executable statements C IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) NULLIFY ( NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, STEPPTR, LRGROUPSPTR, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR ) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) IDUMMY = 1 BDUMMY = .FALSE. C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C ---------------------------------------- C Free some memory from factorization, C if allocated, at least large arrays. C This will also limit the amount of useless C data saved to disk in case of save-restore C ---------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF NULLIFY(id%S) KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C also avoid keeping BLR factors allocated if analysis C called after a previous BLR factorization without C an intermediate JOB=-2 call. CALL CMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C -------------------------------------------- C If analysis redone, suppress old, C meaningless, Step2node array. C This is necessary since we could otherwise C end up having a wrong Step2node during solve C -------------------------------------------- IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: CMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL CMUMPS_ANA_CHECK_KEEP(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that CMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL CMUMPS_DUMP_PROBLEM(id) C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).NE.0) THEN C Analysis by block with block data provided by user C C Check if block structure is centralized or distributed IF (.NOT.associated(id%BLKVAR)) THEN C BLKVAR is identity and implicitly centralized KEEP(14) = 0 ELSE IF (size(id%BLKVAR).EQ.id%N) THEN C Centralized block stucture KEEP(14) = 0 ELSE C Distributed block stucture KEEP(14) = 1 IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF IF (KEEP(13).GE.1) THEN C BLKPTR provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF NBLK=id%NBLK IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of KEEP(13).NE.0 ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF (id%MYID.EQ.MASTER.AND.allocok.EQ.0) THEN C BLKPTR and BLKVAR needed for CMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR)) THEN BLKPTR_ALLOCATED = .TRUE. allocate(id%BLKPTR(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .TRUE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ENDIF IF (.NOT.associated(id%BLKVAR).AND.allocok.EQ.0) THEN allocate(id%BLKVAR(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N id%BLKVAR(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 id%BLKPTR(IB) = I ENDDO id%BLKPTR(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, id%BLKPTR(1), id%BLKVAR(1), & SIZEOFBLOCKS, DOF2BLOCK) ENDIF C ======================= IF (KEEP(54).NE.3) THEN C ======================= C --------------------- C Matrix structure available on host C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, id%KEEP8(28), IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1)) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ==== ELSE C ==== C ------------------------------- C Matrix structure is distributed C and since KEEP(13).NE.0 then C ordering is centralized since C ------------------------------- C IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Centralized cleaned graph is ready C call directly with GCOMP READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP_DIST, READY_FOR_ANA_F) ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) ENDIF ELSE CALL CMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to CMUMPS_ANA_F and C CMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C CMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip CMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) CMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3*id%N), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=5*id%N ELSE CALL CMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in CMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=3*NBLK ENDIF ELSE ALLOCATE(IKEEPALLOC(NBLK+2*id%N), & FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=4*NBLK+2*id%N ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside CMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to CMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW_ELT = id%N + id%N + 1 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW_ELT = id%N + id%N + id%N + 3 + id%N + 1 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for CMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8 = 3_8*int(NBLK,8) ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) IKEEP3 => IKEEPALLOC(NBLK+id%N+1:NBLK+2*id%N) C id%UNS_PERM corresponds to argument PIV C in CMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL CMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL CMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) CALL MUMPS_AB_FREE_GCOMP(GCOMP) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to CMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL CMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILSPTR(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to CMUMPS_ANA_F_ELT C be used in CMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FILSPTR) ) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N IF (id%MYID .EQ. MASTER) THEN ALLOCATE( IKEEPALLOC(3*id%N), WORK2ALLOC(4*id%N), & FILSPTR(id%N), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ELSE C Because our purpose is to minimize the peak memory consumption, C we can afford to allocate on processes other than host ALLOCATE(IKEEPALLOC(3*id%N),WORK2ALLOC(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 10*id%N ELSE INFO( 2 ) = 7*id%N ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 CALL CMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF KEEP(28) = INFOG(6) END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL CMUMPS_ANA_R(NBLK, FILSPTR(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL CMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILSPTR(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + ! front matrix & real(id%KEEP(2))*real(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+NBLK-1) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL CMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILSPTR(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL CMUMPS_ANA_R(NBLK, FILSPTR(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL CMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILSPTR(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL CMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in CMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in CMUMPS_ANA_M) C is needed on all the procs during CMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in CMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- IF (id%MYID.EQ.MASTER) THEN C id%STEP is of size NBLK because it C is computed on compressed graph and then extended C and broadcasted on all procs CALL MUMPS_REALLOC(id%STEP, NBLK, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ELSE C id%STEP is of size id%N because it C is received in extended form CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C id%FILS is allocated before expand tree IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_REALLOC(id%LRGROUPS, NBLK, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ELSE CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+NBLK-2) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+NBLK-1) ELSE NBLEAF = IKEEPALLOC(NA+NBLK-2) NBROOT = IKEEPALLOC(NA+NBLK-1) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+NBLK-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+NBLK-2) < 0 ) THEN INODE = - IKEEPALLOC(NA+NBLK-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP(1:id%N) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 id%STEP(I)=ISTEP INN = FILSPTR(I) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = FILSPTR(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in CMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in CMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = FREREPTR(I) id%NE_STEPS(id%STEP(I)) = IKEEPALLOC(NE+I-1) id%ND_STEPS(id%STEP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(id%STEP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILSPTR(I) DO WHILE ( IFS .GT. 0 ) IFS= FILSPTR(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(id%STEP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C I/ Prepare data before call to grouping IF ((KEEP(54).EQ.3).AND.(KEEP(13).NE.0)) THEN C Matrix is distributed on entry and compression computed IF (KEEP(487).NE.1) CALL MUMPS_ABORT() ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, id%STEP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), id%STEP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) CALL MUMPS_AB_FREE_LMAT(LUMAT) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ELSE IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C ---> build LUMAT_REMAP on MASTER IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_AB_LMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, & INFO(1), ICNTL(1)) C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), id%STEP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (KEEP(487).NE.1) & ) THEN C Grouping preparation on slaves: C If the input matrix is distributed and the parallel analysis is C chosen, the graph used to be centralized in order to compute the C clustering. C CALL CMUMPS_GATHER_MATRIX(id) ENDIF C ============ C ============ C II/ GROUPING C ============ IF ((KEEP(54).EQ.3).AND.(KEEP(487).EQ.1)) THEN C Matrix is distributed on entry and halo of size 1 C Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILSPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C Distribute SIZEOFBLOCKS that was defined only on master C CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, C & id%COMM, IERR ) CALL CMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), LPOK, LP, id%COMM, id%MYID, id%NPROCS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF C ELSE IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C --- build LUMAT C -- LR grouping exploiting LUMAT C -- centralized => MAPCOL not needed C FIXME 5.4: call to CMUMPS_AB_LR_GROUPING "ready" to be C replaced by call to CMUMPS_AB_LR_MPI_GROUPING C IDUMMY_ARRAY(1) = -1 CALL CMUMPS_AB_LR_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP, id%MYID, id%COMM) ELSE C grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL CMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ELSE CALL CMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ENDIF ENDIF ENDIF C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP is allocated CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF IF (id%MYID.NE. MASTER) THEN CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 ENDIF C IF ((id%MYID.EQ.MASTER) .AND.(KEEP(13).NE.0)) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILSPTR, id%STEP into id%FILS, STEPPTR C and update arrays of size NSTEPS ALLOCATE(STEPPTR(id%N), LRGROUPSPTR(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=id%N GOTO 97 ENDIF IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL CMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, id%BLKPTR(1), id%BLKVAR(1), & FILSPTR(1), id%FILS(1), id%KEEP(28), & id%STEP(1), STEPPTR(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, id%LRGROUPS(1), LRGROUPSPTR(1), & id%KEEP(20), id%KEEP(38) & ) NULLIFY(PAR2_NODESPTR) DEALLOCATE(id%STEP) id%STEP=>STEPPTR NULLIFY(STEPPTR) DEALLOCATE(id%LRGROUPS) id%LRGROUPS=>LRGROUPSPTR NULLIFY(LRGROUPSPTR) DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ELSE if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF C} ENDIF IF ((id%N.EQ.NBLK).AND.associated(FILSPTR)) THEN C id%FILS has not been initialized if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF 97 CONTINUE CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL CMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL CMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL CMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF(((KEEP(494).NE.0).OR.KEEP(13).NE.0) & .AND.(id%KEEP(38).GT.0)) & THEN ! grouping at analysis (1 => LR CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NA(1), id%LNA, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%PROCNODE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DAD_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRERE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR) CALL MPI_BCAST( id%NE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%ND_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) END IF IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C At the end of ANA_N_DIST, id%PTRAR is already on every processor C because it is computed in a distributed way. C No need to broadcast it again CALL CMUMPS_ANA_N_DIST(id, id%PTRAR) IF(id%MYID .EQ. MASTER) THEN C ----------------------------------- C For distributed structure on entry, C we can now deallocate the complete C structure IRN / JCN. C ----------------------------------- IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN C IRN and JCN might have already been deallocated IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF END IF ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL CMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL CMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, id%root, & id%COMM_NODES, KEEP( 38 ), id%FILS(1), & id%KEEP(50), id%KEEP(46), & id%KEEP(51) & , id%KEEP(60), id%NPROW, id%NPCOL, id%MBLOCK, id%NBLOCK & ) ELSE id%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(id%root%MYROW, MYROW_CHECK, 1, & MPI_INTEGER, MPI_MAX, id%COMM_NODES, IERR) IF ( MYROW_CHECK .eq. -1) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( id%root%MYROW .LT. -1 .OR. & id%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN C{ C C IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%PTRAR(1), & id%PTRAR(id%N +1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id ) ELSE CALL CMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) ENDIF C} ENDIF C ----------------------------------------- C Perform some local analysis on the slaves C to estimate the size of the working space C for factorization C ----------------------------------------- IF ( I_AM_SLAVE ) THEN C{ locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES locMYID = id%MYID C =================================================== C Precompute estimates of local_m,local_n C (number of rows/columns mapped on each processor) C in case of parallel root node. C and allocate CANDIDATES C =================================================== C IF ( id%root%yes ) THEN LOCAL_M = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%MBLOCK, id%root%MYROW, 0, & id%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%NBLOCK, id%root%MYCOL, 0, & id%root%NPCOL ) ELSE LOCAL_M = 0 LOCAL_N = 0 END IF IF ( KEEP(60) .EQ. 2 .OR. KEEP(60) .EQ. 3 ) THEN C Return minimum nb rows/cols to user id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N C Also store them in root structure for convenience id%root%SCHUR_MLOC=LOCAL_M id%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- Allocate and initialise IPOOL with leaves C -- on which stats are performed IF ( I_AM_SLAVE ) THEN C{ LIPOOL = id%NA(1) C LIPOOL is number of leaf nodes and can be 0 C (for ex AboveL0 with nbthreads is 1) ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C{ C Initialize IPOOL with leaves of complete tree DO I=1, LIPOOL IPOOL(I) = id%NA(3+I-1) ENDDO ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 C NE_STEPSPTR => id%NE_STEPS KEEP(139) = MAXFR_UNDER_L0 CALL CMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOL, LIPOOL, NE_STEPSPTR(1), & id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & id%root%yes, id%root%NPROW, id%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR) C SUM_NIRNEC under L0 OMP KEEP(137)=0 C SUM_NIRNEC_OOC under L0 OMP KEEP(138)=0 C DKEEP(15) is used for dynamic load balancing only C it corresponds to the number of local operations C (in Millions) id%DKEEP(15) = RINFO(1)/1000000.0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) C KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) C Relaxed value of size of IS is not needed internally; C we save it directly in INFO(19) INFO( 19 ) = KEEP(225) + 3* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C ================================= C Size of S (relaxed with ICNTL(14) C =========================== C size of S relaxed (FR, IC) C =========================== KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S relaxed (FR or LR LU, OOC) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) C size of S relaxed (LR LU, IC) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) C size of S relaxed (LR CB, IC) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) C KEEP8( 22 ) is the OLD maximum size of receive buffer C that includes CB related communications. C KEEP( 43 ) : min size for send buffer C KEEP( 44 ) : min size for receive buffer C KEEP(43-44) kept for allocating buffers during C factorization phase CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) C We do a max with KEEP(27)=maxfront because for small C buffers, we need at least one row of cb to be sent/ C received. SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) KEEP(379)=KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF C MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min( MIN_BUF_SIZE8, int(huge (KEEP(43)),8)) MIN_BUF_SIZE = int( MIN_BUF_SIZE8 ) C KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(380) = max(KEEP(380), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) KEEP(379) = max(KEEP(379), MIN_BUF_SIZE) IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. complex space to store factors:', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF C} ELSE C --------------------- C Master is not working C --------------------- ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0E0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C -------------------------------------- C KEEP8( 26 ) : Real arrowhead size C KEEP8( 27 ) : Integer arrowhead size C INFO(3)/KEEP8( 11 ) : Estimated real space needed for factors C INFO(4)/KEEP( 26 ) : Estimated integer space needed for factors C INFO(5)/KEEP( 27 ) : Estimated max front size C KEEP8(109) : Estimated number of entries in factor C (based on ENTRIES_IN_FACTORS_LOC_MASTERS computed C during CMUMPS_ANA_DISTM, where we assume C that each master of a node computes C the complete factor size. C -------------------------------------- C note that summing ENTRIES_IN_FACTORS_LOC_MASTERS or C ENTRIES_IN_FACTORS_LOC_MASTERS should lead to the same result CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) CALL MPI_ALLREDUCE( KEEP(26), KEEP(126), 1, & MPI_INTEGER, MPI_SUM, & id%COMM, IERR) C NRLADU related: KEEP8(11) holds factors above and under L0 CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C NRLADU_if_LR_LU related: KEEP8(32) holds factors above C and under L0 C convert it in Megabytes RINFO(5) = real(KEEP8(32) & *int(KEEP(35),8))/1E6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) C in Megabytes IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = real(ITMP8*int(KEEP(35),8))/1E6 ENDIF C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) C CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) C CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL CMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) C -------------------------- C COMPUTE MEMORY ESTIMATIONS IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) C -------------------------- C ========================= C IN-CORE MEMORY STATISTICS C ========================= C OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression IF (KEEP(201) .NE. -1) OOC_STRAT=0 ! We want in-core statistics PERLU_ON = .FALSE. ! switch off PERLU to compute KEEP8(2) CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(2) = TOTAL_BYTES C C PERLU_ON = .TRUE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) IF ( PROK ) THEN WRITE(MP,'(A,I12) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES C C Centralize memory statistics on the host C C INFOG(16) = after analysis, est. mem size in Mbytes for facto, C for the processor using largest memory C INFOG(17) = after analysis, est. mem size in Mbytes for facto, C sum over all processors C INFOG(18/19) = idem at facto. C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STRAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. ! PERLU NOT taken into account C Used to compute KEEP8(3) (minimum number of bytes for OOC) CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(3) = TOTAL_BYTES C PERLU_ON = .TRUE. ! PERLU taken into account CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) id%INFO(17) = TOTAL_MBYTES C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF IF (KEEP(494).NE.0) THEN C ========================================= C NOW COMPUTE BLR statistics C ========================================= SUM_OF_PEAKS = .TRUE. CALL CMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & ) C END IF C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL CMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & id%root%MBLOCK, id%root%NBLOCK, & id%root%NPROW, id%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(IPOOL)) DEALLOCATE(IPOOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) CALL MUMPS_AB_FREE_LMAT(LUMAT) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) CALL MUMPS_AB_FREE_GCOMP(GCOMP) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) IF (associated(FILSPTR)) DEALLOCATE(FILSPTR) IF (associated(id%BLKPTR).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(id%BLKPTR) nullify(id%BLKPTR) ENDIF IF (associated(id%BLKVAR).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(id%BLKVAR) nullify(id%BLKVAR) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING CMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_ANA_DRIVER SUBROUTINE CMUMPS_ANA_CHECK_KEEP(id) C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C -- OOC/Incore strategy IF (id%KEEP(201).NE.-1) THEN id%KEEP(201)=id%ICNTL(22) IF (id%KEEP(201) .GT. 0) THEN #if defined(OLD_OOC_NOPANEL) id%KEEP(201)=2 #else id%KEEP(201)=1 #endif ENDIF ENDIF C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif C Analysis strategy is set to automatic in case of out-of-range values. IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 ) THEN id%KEEP(106)=1 C Automatic choice leads to new symbolic C factorization except(see below) if KEEP(256)==1. ELSE id%KEEP(106)=id%ICNTL(58) IF (id%KEEP(106).EQ.3) THEN C option not available id%KEEP(106)=1 ENDIF ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: CMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine CMUMPS_BDCAST C -------------------------------- id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).LT.0) THEN IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF IF (associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with BLKPTR provided by user" ENDIF id%INFO(1) = -57 id%INFO(2) = 4 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) & ) & THEN IF ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).NE.2)) THEN id%KEEP(13)=-1 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0 ) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) .AND. & (id%KEEP(244).NE.2) & ) & THEN C unsymmetic assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off because C if one activates the analysis by block IF ( (id%KEEP(23).LT.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1) & ) THEN IF (PROKG) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block compatible ", & "ONLY with SYMQAMD based symbolic factorization ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(244).EQ.2) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with parallel ordering " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE CMUMPS_ANA_CHECK_KEEP SUBROUTINE CMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(CMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROK, PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG, I_AM_SLAVE INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING CMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE CMUMPS_GATHER_MATRIX SUBROUTINE CMUMPS_DUMP_PROBLEM(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C CMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and CMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(CMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB COMPLEX, TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED COMPLEX, POINTER, DIMENSION(:) :: A_PASSED PARAMETER( MASTER = 0 ) IUNIT = 69 I_AM_SLAVE = ( id%MYID .NE. MASTER .OR. & ( id%MYID .EQ. MASTER .AND. & id%KEEP(46) .EQ. 1 ) ) I_AM_MASTER = (id%MYID.EQ.MASTER) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since CMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. C equal to IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL CMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL CMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL CMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL CMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL CMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_PROBLEM SUBROUTINE CMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='complex' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Single complex storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I12)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I12)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I12,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Single complex storage' ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_HEADER SUBROUTINE CMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(CMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), & real(id%A(I8)), aimag(id%A(I8)) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), & real(id%A(I8)), aimag(id%A(I8)) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & real(id%A_loc(I8)), aimag(id%A_loc(I8)) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & real(id%A_loc(I8)), aimag(id%A_loc(I8)) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_MATRIX SUBROUTINE CMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE CMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(CMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='complex' WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) real(id%RHS(K8)), aimag(id%RHS(K8)) ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DUMP_RHS SUBROUTINE CMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE CMUMPS_BUILD_I_AM_CAND MUMPS_5.4.1/src/cfac_front_LU_type2.F0000664000175000017500000011466514102210524017457 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC2_LU_M CONTAINS SUBROUTINE CMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) !$ USE OMP_LIB USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_FAC_FRONT_TYPE2_AUX_M USE CMUMPS_OOC USE CMUMPS_BUF, ONLY : CMUMPS_BUF_TEST USE CMUMPS_FAC_LR USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M !$ USE OMP_LIB USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) COMPLEX A( LA ) REAL UU, SEUIL TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTBL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND COMPLEX, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0E0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : CMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 2 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL CMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL CMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR,DBLARR, & ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL CMUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL CMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 490 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL CMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL CMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL CMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 490 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(68) = max(KEEP8(69), KEEP8(68)) !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(70) = max(KEEP8(71), KEEP8(70)) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) & THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE CMUMPS_FAC2_LU END MODULE CMUMPS_FAC2_LU_M MUMPS_5.4.1/src/zmumps_iXamax.F0000664000175000017500000000543514102210524016464 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION ZMUMPS_IXAMAX(N,X,INCX,GRAIN) !$ USE OMP_LIB IMPLICIT NONE COMPLEX(kind=8), intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN DOUBLE PRECISION ABSMAX INTEGER :: I INTEGER(8) :: IX !$ INTEGER :: NOMP, CHUNK !$ INTEGER :: IMAX !$ DOUBLE PRECISION :: XMAX, VALABS !$ DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 !$ NOMP = OMP_GET_MAX_THREADS() ZMUMPS_IXAMAX = 0 IF ( N.LT.1 ) RETURN ZMUMPS_IXAMAX = 1 IF ( N.EQ.1 .OR. INCX.LE.0 ) RETURN !$ IF (NOMP.GT.1 .AND. N.GE.GRAIN*2) THEN !$ IF ( INCX.EQ.1 ) THEN !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX) !$OMP& FIRSTPRIVATE(N, CHUNK) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ VALABS = abs(X(I)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ ZMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ELSE !$ CHUNK = max(GRAIN,(N+NOMP-1)/NOMP) !$ ABSMAX = RZERO !$OMP PARALLEL PRIVATE(I, VALABS, XMAX, IMAX, IX) !$OMP& FIRSTPRIVATE(N, CHUNK, INCX) !$ XMAX = RZERO !$OMP DO SCHEDULE(static, CHUNK) !$ DO I = 1, N !$ IX = 1 + int((I-1),8)*int(INCX,8) !$ VALABS = abs(X(IX)) !$ IF ( VALABS .GT. XMAX ) THEN !$ XMAX = VALABS !$ IMAX = I !$ ENDIF !$ ENDDO !$OMP END DO !$ IF (XMAX .GT. RZERO) THEN !$OMP CRITICAL !$ IF (XMAX .GT. ABSMAX) THEN !$ ZMUMPS_IXAMAX = IMAX !$ ABSMAX = XMAX !$ ENDIF !$OMP END CRITICAL !$ ENDIF !$OMP END PARALLEL !$ ENDIF !$ ELSE IF ( INCX.EQ.1 ) THEN ABSMAX = abs(X(1)) DO I = 2, N IF ( abs(X(I)) .LE. ABSMAX ) CYCLE ZMUMPS_IXAMAX = I ABSMAX = abs(X(I)) ENDDO ELSE IX = 1 ABSMAX = abs(X(1)) IX = IX + INCX DO I = 2, N IF ( abs(X(IX)).LE.ABSMAX ) GOTO 5 ZMUMPS_IXAMAX = I ABSMAX = abs(X(IX)) 5 IX = IX + INCX ENDDO ENDIF !$ ENDIF RETURN END FUNCTION ZMUMPS_IXAMAX MUMPS_5.4.1/src/dfac_driver.F0000664000175000017500000044051114102210525016071 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_DRIVER( id) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_OOC USE DMUMPS_STRUC_DEF USE DMUMPS_LR_STATS USE DMUMPS_LR_DATA_M, only: DMUMPS_BLR_INIT_MODULE, & DMUMPS_BLR_END_MODULE & , DMUMPS_BLR_STRUC_TO_MOD & , DMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE DMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE DMUMPS_ANORMINF(id, ANORMINF, LSCAL) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE DMUMPS_ANORMINF SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE DMUMPS_LR_DATA_M, only : DMUMPS_BLR_STRUC_TO_MOD, & DMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Parameters C ========== C TYPE(DMUMPS_STRUC), TARGET :: id C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: DMUMPS_LBUFR, DMUMPS_LBUFR_BYTES INTEGER(8) :: DMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: DMUMPS_LBUF, DMUMPS_LBUF_INT INTEGER(8) :: DMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, K28, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 DOUBLE PRECISION CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM C TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER MAXIS INTEGER(8) :: MAXS C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG DOUBLE PRECISION, TARGET :: S_DUMMY_ARG(1) DOUBLE PRECISION, POINTER, DIMENSION(:) :: S_PTR_ARG INTEGER NPIV_CRITICAL_PATH DOUBLE PRECISION TIME, TIMEET DOUBLE PRECISION ZERO, ONE, MONE PARAMETER( ZERO = 0.0D0, ONE = 1.0D0, MONE = -1.0D0) DOUBLE PRECISION CZERO PARAMETER( CZERO = 0.0D0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG DOUBLE PRECISION :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil DOUBLE PRECISION :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_LR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_DECOMP_ASM1 DOUBLE PRECISION :: TMP_TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TMP_TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2M C C Workspace. C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK_REAL INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER BUREGISTRE(12) INTEGER BUINTSZ, BURESZ, BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS DOUBLE PRECISION SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C INTEGER, POINTER :: JOB * Control parameters: see description in DMUMPSID DOUBLE PRECISION,DIMENSION(:),POINTER::RINFO, RINFOG DOUBLE PRECISION,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER:: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: MYIRN_loc, MYJCN_loc DOUBLE PRECISION, DIMENSION(:), POINTER :: MYA_loc INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) DOUBLE PRECISION, TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH INTEGER(8) :: TOTAL_BYTES INTEGER(8) :: I8TMP, LWK_USER_SUM8 C C External references C =================== INTEGER numroc EXTERNAL numroc INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED C Fwd in facto: DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM C C JOB=>id%JOB RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN MYIRN_loc=>id%IRN_loc MYJCN_loc=>id%JCN_loc MYA_loc=>id%A_loc ELSE MYIRN_loc=>DUMMYIRN_loc MYJCN_loc=>DUMMYJCN_loc MYA_loc=>DUMMYA_loc ENDIF N = id%N EPS = epsilon ( ZERO ) C TIMINGS: reset to 0 id%DKEEP(92)=0.0D0 id%DKEEP(93)=0.0D0 id%DKEEP(94)=0.0D0 id%DKEEP(97)=0.0D0 id%DKEEP(98)=0.0D0 id%DKEEP(56)=0.0D0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C MIN/MAX pivots reset to 0 id%DKEEP(19)=huge(0.0D0) id%DKEEP(20)=huge(0.0D0) id%DKEEP(21)=0.0D0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C Data from factorization is now freed asap C id%S, id%IS IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 NULLIFY(id%S) ENDIF ENDIF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C Free BLR factors, if any CALL DMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C IF (id%KEEP8(24).GT.0_8) THEN C We nullify S so that later when we test C if (associated(S) we can free space and reallocate it). NULLIFY(id%S) ENDIF C C -- KEEP8(24) can now then be reset safely WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user LWK_USER_SUM8 = 0_8 CALL MPI_REDUCE ( id%KEEP8(24), LWK_USER_SUM8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0D0 id%DKEEP(5)=-1.0D0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF C ---------------------- C Broadcast KEEP options C defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5D0) THEN CNTL1 = 0.5D0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 0 KEEP464COPY = 0 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF KEEP465COPY=0 IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF KEEP(489)=0 C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 50 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 50 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Ignore ICNTL(23) when WK_USER is provided c by resetting ITMP to zero on each proc where WK_USER is provided IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes IF ( PROKG ) THEN NWORKING = id%NSLAVES WRITE( MPG, 172 ) NWORKING, id%ICNTL(22), KEEP(486), & KEEP(12), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, LWK_USER_SUM8, CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL(id) END IF C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0D0 ! real part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4*BUMAXMN ALLOCATE (IWK(LIWK),BURP(M),BUCP(N), & BURS(2* (id%NPROCS)),BUCS(2* (id%NPROCS)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL DMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL DMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N CXXXX IF(N > BUMAXMN) BUMAXMN = N LIWK = 1 ALLOCATE (IWK(LIWK),BURP(1),BUCP(1), & BURS(1),BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+1+1+1+1 ENDIF LWK_REAL = M + N ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (id%INFO(1) .LT. 0) GOTO 400 CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL DMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN ! internal error since LWK_REAL=BURESZ=M+N id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL DMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ---------------------------------- C Centralized scaling, options 1 to 6 C ---------------------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN C We have an explicit copy of the original C matrix in complex format which should probably C be avoided (but do we want to keep all C those old scaling options ?) LWK = id%KEEP8(28) ELSE LWK = 1_8 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL DMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF ! Scaling distributed matrices or centralized IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=TIMEET C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8) & .AND. (K233+K231+K232).GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL DMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL DMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL DMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL DMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE C Fwd in facto: in case of repeated factorizations C with different Schur options we prefer to free C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF C Fwd in facto: allocate and broadcast RHS_MUMPS C to make it available on all processors. IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP(255) = N*id%KEEP(253) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(255) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_DOUBLE_PRECISION, MASTER,id%COMM,IERR) END DO ENDIF C Keep a copy of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 IF (KEEP(219).NE.0) THEN CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN C ------------------------ C Error allocating DMUMPS_BUF C ------------------------ id%INFO(1) = -13 id%INFO(2) = max(KEEP(108),1) END IF ENDIF C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN CALL DMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ELSE ANORMINF = ZERO ENDIF C C Set BLR threshold IF (id%DKEEP(8).LT.ZERO) THEN id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ENDIF IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A,1PD16.4)') & ' Effective value of CNTL(3) =',CNTL3 ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I10)') & 'ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for postponing =',SEUIL ENDIF !end KEEP(19) SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in DMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0D0 id%DKEEP(2) = ZERO ELSE C -- Null pivot is on IF (KEEP(19).NE.0) THEN C -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1D-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF ELSE C -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(dble(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0D10*ANORMINF, & sqrt(huge(ANORMINF))/1.0D8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST in case of null pivot detection LPN_LIST = 1 IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = N ENDIF ALLOCATE( id%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN CALL DMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate id%S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL DMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1D6) C ------------------------- C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL DMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & ) ENDIF ! MEM_ALLOWED C ENDIF ! (.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (I_AM_SLAVE) THEN ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL DMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL DMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), id%DKEEP(15), KEEP(375), MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to DMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL DMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) C C Out-Of-Core (OOC) issues. Case where we ran one factorization OOC C and the second one is in-core: we try to free OOC C related data from previous factorization. C CALL DMUMPS_CLEAN_OOC_DATA(id, IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version I8TMP = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * id%KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL DMUMPS_OOC_INIT_FACTO(id,MAXS) ELSE WRITE(*,*) "Internal error in DMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL DMUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL DMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead C ====================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE C ---------------------------------------- C Allocate variable lists. Systematically. C ---------------------------------------- IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( id%INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) NULLIFY(id%INTARR) GOTO 100 END IF ELSE ALLOCATE( id%INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) GOTO 100 END IF END IF C ----------------------------- C Allocate real values. C On master, if hybrid host and C no scaling, avoid the copy. C ----------------------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C -------------------------- C Simple pointer association C -------------------------- id%DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- IF ( id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF C ----------------- C Also prepare some C data for the root C ----------------- IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL DMUMPS_INIT_ROOT_FAC( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF C C 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (DMUMPS_ANA_F and DMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(54) .eq. 0 ) THEN C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) write(6,*) ' PB2 ALLOC INTARR' CALL MUMPS_ABORT() ENDIF ENDIF NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL DMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP,id%KEEP8, & id%FILS(1), IWK(1), ! workspace of size N & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1)) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL DMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP(1),id%KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1) ) #endif DEALLOCATE(IWK) ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL DMUMPS_FACTO_RECV_ARROWHD2( id%N, & id%DBLARR(1), id%KEEP8(26), & id%INTARR(1), id%KEEP8(27), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), id%KEEP8(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & id%root, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%INFO(1), id%INFO(2) ) ENDIF ELSE C C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL DMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & id%DBLARR(1), id%KEEP8(26), id%INTARR(1), & id%KEEP8(27), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, id%root, id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C ENDIF ELSE C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL DMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL DMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, id%root ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = TIME IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN CALL DMUMPS_BUF_INI_MYID(id%MYID_NODES) C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Reception buffer C ---------------- IF (KEEP(486).NE.0) THEN DMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP( 35 ),8) ELSE DMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- DMUMPS_LBUFR_BYTES8 = max( DMUMPS_LBUFR_BYTES8, & 100000_8 ) C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased by more than that. C This is why we use an extra factor 2 relaxation coefficient for the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for moste messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0, 8) DMUMPS_LBUFR_BYTES8 = min(DMUMPS_LBUFR_BYTES8, & int(huge (KEEP(44))-100,8)) DMUMPS_LBUFR_BYTES = int( DMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( dble(max(PERLU,MIN_PERLU))* & dble(id%KEEP8(22))/100D0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(379)) * dble(KEEP(35)), 8 ) ELSE DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)), 8 ) ENDIF DMUMPS_LBUF8 = max( DMUMPS_LBUF8, 100000_8 ) DMUMPS_LBUF8 = DMUMPS_LBUF8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUF8)/100D0, 8) C Make DMUMPS_LBUF8 small enough to be stored in a standard integer DMUMPS_LBUF8 = min(DMUMPS_LBUF8, int(huge (KEEP(43))-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: DMUMPS_LBUF8 = max(DMUMPS_LBUF8, DMUMPS_LBUFR_BYTES8+3*KEEP(34)) DMUMPS_LBUF = int(DMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN DMUMPS_LBUFR_BYTES=DMUMPS_LBUFR_BYTES*5 DMUMPS_LBUF=DMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C DMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN DMUMPS_LBUF_INT = DMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, DMUMPS_LBUFR_BYTES, DMUMPS_LBUF C and DMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) DMUMPS_LBUFR_BYTES, & DMUMPS_LBUF, DMUMPS_LBUF_INT END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I10, & /, & ' Size of async. emission buffer (bytes).. = ', I10,/, & ' Small emission buffer (bytes) .......... = ', I10) C -------------------------- C Allocate small send buffer C required for DMUMPS_FAC_B C -------------------------- CALL DMUMPS_BUF_ALLOC_SMALL_BUF( DMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= DMUMPS_LBUF_INT id%INFO(2)= (DMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in DMUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- DMUMPS_LBUFR = (DMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) ALLOCATE( BUFR( DMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = DMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', DMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C DMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, & MAXIS_ESTIM + 3 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine DMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in DMUMPS_LBUF module CALL DMUMPS_BUF_DIST_IRECV_SIZE( DMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, id%KEEP8(12), KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, DMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(dble(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/dble(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MPG,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to DMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during DMUMPS_FAC_B. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL DMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), & LDPTRAR,IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,DMUMPS_LBUFR & , DMUMPS_LBUFR_BYTES, DMUMPS_LBUF, id%INTARR(1),id%DBLARR(1), & id%root, NELT_arg, id%FRTPTR(1), id%FRTELT(1),id%COMM_LOAD, & id%ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, id%MEM_DIST(0), & id%DKEEP(1), id%PIVNUL_LIST(1), LPN_LIST, id%LRGROUPS(1) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : INTARR was not allocated C during factorization in the case C of an assembled matrix. C --------------------------------- IF ( KEEP(55) .eq. 0 ) THEN C C ---------------- C Assembled matrix C ---------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF C ELSE C C ---------------- C Elemental matrix C ---------------- IF (associated(id%INTARR)) THEN DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) ENDIF C ------------------------------------ C For the master from an hybrid host C execution without scaling, then real C values have not been copied ! C ------------------------------------- IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF C Memroy statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) ELSE IF ( id%MYID .EQ. 1 ) THEN CALL MPI_SEND( KEEP(17), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL DMUMPS_BUF_DEALL_SMALL_BUF( IERR ) C//PIV IF (KEEP(219).NE.0) THEN CALL DMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF C C Check for errors. C After DMUMPS_FAC_B every slave is aware of an error. C If master is included in computations, the call below should C not be necessary. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL DMUMPS_EXTRACT_SCHUR_REDRHS(id) IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN IF ( I_AM_SLAVE ) THEN CALL DMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN id%INFO(1)=IERR id%INFO(2)=0 ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C We want to collect statistics even in case of C error to understand if it is due to numerical C issues CC IF ( id%INFO(1) < 0 ) GOTO 500 END IF END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=TIME ENDIF C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL DMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL DMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C FIXME Check if WK_USER used and indicate, total space to WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL DMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C C IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during DMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = dble(id%KEEP8(6)*int(KEEP(35),8))/dble(1D6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = dble(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_FR, TMP_FLOP_SOLFWD_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_LR, TMP_FLOP_SOLFWD_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASM1, TMP_TIME_DECOMP_ASM1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_LOCASM2, TMP_TIME_DECOMP_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_MAPLIG1, TMP_TIME_DECOMP_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2S, TMP_TIME_DECOMP_ASMS2S & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2M, TMP_TIME_DECOMP_ASMS2M & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_SOLFWD_FR = TMP_FLOP_SOLFWD_FR FLOP_SOLFWD_LR = TMP_FLOP_SOLFWD_LR FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_DECOMP_ASM1 = TMP_TIME_DECOMP_ASM1 /id%NPROCS TIME_DECOMP_LOCASM2 = TMP_TIME_DECOMP_LOCASM2 /id%NPROCS TIME_DECOMP_MAPLIG1 = TMP_TIME_DECOMP_MAPLIG1 /id%NPROCS TIME_DECOMP_ASMS2S = TMP_TIME_DECOMP_ASMS2S /id%NPROCS TIME_DECOMP_ASMS2M = TMP_TIME_DECOMP_ASMS2M /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),id%RINFOG(3), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array IF (LPOK) THEN IF (CNTL(7) < 0.0D0) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(LP,'(/A/,A/,A/,A,A)') & ' WARNING in BLR input setting', & ' CNTL(7) < 0 is experimental: ', & ' RRQR precision = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the Users guide ' ENDIF ENDIF CALL SAVEandWRITE_GAINS(FRONTWISE, & KEEP(489), id%DKEEP, N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), KEEP(472), & KEEP(475), KEEP(478), KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0D00 ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56). INFOG(28)=KEEP(112)+KEEP(17) ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST(KEEP(109)+1:KEEP(109)+KEEP(17). C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND(id%PIVNUL_LIST(KEEP(109)+1), KEEP(17), & MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDDO ELSE CALL MPI_SEND( id%PIVNUL_LIST(1), KEEP(109), MPI_INTEGER, & MASTER,ZERO_PIV, id%COMM, IERR) CALL MPI_RECV( KEEP(220), 1, MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN DO I = 1, id%INFOG(28) CALL DMUMPS_UPDATEDETER(id%ROWSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) CALL DMUMPS_UPDATEDETER(id%COLSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) C In case of real arithmetic, initialize C RINFOG(13) to 0 (no imaginary part and C not touched by DMUMPS_DETER_REDUCTION) RINFOG(13)=0.0D0 IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) ENDIF C C 3/ Perform a reduction C CALL DMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL DMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, C id%STEP: used as workspace of size N still C allocated on master; restored on exit & id%STEP(1), & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see DMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN C ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 1 .OR. id%KEEP(50) == 2) THEN ! negative pivots WRITE(MPG, 99987) INFOG(12) END IF IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) c IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99977) INFOG(34) ENDIF END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free DBLARR (as in end_driver.F) C in case an error occurred after allocating C DBLARR and before freeing it above. IF (id%KEEP(46).EQ.1 .AND. & id%KEEP(55).NE.0 .AND. & id%MYID.EQ.MASTER .AND. & id%KEEP(52) .EQ. 0) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL DMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL DMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL DMUMPS_OOC_END_FACTO(id,IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL DMUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO C 517 CONTINUE C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 160 FORMAT( & /' Elapsed time to reformat/distribute matrix =',F12.4) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' Memory allowed (MB -- 0: N/A ) =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =',F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =',F12.4) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =',I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =',F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =',I16) 99981 FORMAT( ' INFOG(14) Number of memory compress =',I16) 99982 FORMAT( ' INFOG(13) Number of delayed pivots =',I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =',I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) Estimated deficiency =',I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG(2) Operations in node assembly =',1PD10.3/ & ' ------(3) Operations in node elimination =',1PD10.3/ & ' ICNTL (8) Scaling effectively used =',I16/ & ' INFOG (9) Real space for factors =',I16/ & ' INFOG(10) Integer space for factors =',I16/ & ' INFOG(11) Maximum front size =',I16/ & ' INFOG(29) Number of entries in factors =',I16) 99985 FORMAT( ' INFOG(12) Number of off diagonal pivots =',I16) 99986 FORMAT( ' INFOG(25) Number of tiny pivots(static) =',I16) 99987 FORMAT( ' INFOG(12) Number of negative pivots =',I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =',I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =',I16) END SUBROUTINE DMUMPS_FAC_DRIVER C SUBROUTINE DMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE DMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE DMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER DOUBLE PRECISION LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = dble(VAL)/dble(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE DMUMPS_AVGMAX_STAT8 C SUBROUTINE DMUMPS_EXTRACT_SCHUR_REDRHS(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in root%RHS_CNTR_MASTER_ROOT. C TYPE(DMUMPS_STRUC) :: id C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ================================= C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from id%root%RHS_CNTR_MASTER_ROOT C ================================= IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL dcopy(SIZE_SCHUR, & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free root%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL DMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C ----------------------------------------- BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL dcopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_DOUBLE_PRECISION, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL dcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL dcopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL dcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_DOUBLE_PRECISION, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_DOUBLE_PRECISION, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_EXTRACT_SCHUR_REDRHS MUMPS_5.4.1/src/ssol_root_parallel.F0000664000175000017500000000733114102210521017513 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT REAL RHS_SEQ( SIZE_ROOT *NRHS) REAL A( LOCAL_M, LOCAL_N ) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS REAL, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR EXTERNAL numroc INTEGER numroc INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = numroc(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL SMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL SMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) RETURN END SUBROUTINE SMUMPS_ROOT_SOLVE SUBROUTINE SMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) REAL, intent (in) :: A( LOCAL_M, LOCAL_N ) REAL, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL psgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL psgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pspotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE SMUMPS_SOLVE_2D_BCYCLIC MUMPS_5.4.1/src/sfac_asm_master_ELT_m.F0000664000175000017500000020364614102210521017772 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE SMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) !$ USE OMP_LIB USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_IS_DYNAMIC, & SMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & SMUMPS_BLR_ASM_NIV1 USE SMUMPS_LR_DATA_M, ONLY : SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_NFS4FATHER USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 REAL, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW REAL, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real REAL ZERO PARAMETER( ZERO = 0.0E0 ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in SMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress SMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL SMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL SMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL SMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL SMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) IF (IS_DYNAMIC_CB) THEN CALL SMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL SMUMPS_BUF_SEND_MAPLIG( INODE, NFRONT, & NASS1, NFS4FATHER,ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, & SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING SMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING SMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE SMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_IS_DYNAMIC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF REAL, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) REAL :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE REAL, DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT REAL ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = 0.0E0 ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL SMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL SMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL SMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress SMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL SMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL SMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL SMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL SMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL SMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & SMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))= & max(real(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = & max( MAXARR, real(A(APOSMAX+int(I-1,8)))) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL SMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL SMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL SMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL SMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL SMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING SMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV2_ELT END MODULE SMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.4.1/src/Makefile0000664000175000017500000003706214102210467015162 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # # topdir = .. libdir = $(topdir)/lib incdir = $(topdir)/include default: d .PHONY: default all s d c z clean libcommon all: $(incdir)/mumps_int_def.h libcommon s d c z libcommon: $(incdir)/mumps_int_def.h $(MAKE) $(libdir)/libmumps_common$(PLAT)$(LIBEXT) s: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=s $(libdir)/libsmumps$(PLAT)$(LIBEXT) d: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=d $(libdir)/libdmumps$(PLAT)$(LIBEXT) c: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=c $(libdir)/libcmumps$(PLAT)$(LIBEXT) z: $(incdir)/mumps_int_def.h libcommon $(MAKE) ARITH=z $(libdir)/libzmumps$(PLAT)$(LIBEXT) include $(topdir)/Makefile.inc $(incdir)/mumps_int_def.h: build_mumps_int_def ./build_mumps_int_def > $(incdir)/mumps_int_def.h build_mumps_int_def:build_mumps_int_def.o $(CC) $(OPTC) $(OPTL) build_mumps_int_def.o -o build_mumps_int_def OBJS_COMMON_MOD = \ ana_omp_m.o\ ana_blk_m.o\ ana_orderings_wrappers_m.o\ double_linked_list.o\ fac_asm_build_sort_index_ELT_m.o\ fac_asm_build_sort_index_m.o\ fac_descband_data_m.o\ fac_future_niv2_mod.o\ fac_ibct_data_m.o\ fac_maprow_data_m.o\ front_data_mgt_m.o\ lr_common.o \ mumps_comm_ibcast.o\ mumps_l0_omp_m.o\ mumps_memory_mod.o\ mumps_mpitoomp_m.o\ mumps_ooc_common.o\ mumps_static_mapping.o\ omp_tps_common_m.o OBJS_COMMON_OTHER = \ ana_blk.o\ ana_orderings.o\ ana_set_ordering.o\ ana_AMDMF.o\ bcast_errors.o\ estim_flops.o\ mumps_type_size.o \ mumps_type2_blocking.o \ mumps_version.o \ mumps_print_defined.o \ mumps_common.o\ mumps_pord.o\ mumps_metis.o\ mumps_metis64.o\ mumps_metis_int.o\ mumps_scotch.o\ mumps_scotch64.o\ mumps_scotch_int.o\ mumps_size.o\ mumps_io.o\ mumps_io_basic.o\ mumps_io_thread.o\ mumps_io_err.o\ mumps_numa.o \ mumps_thread.o \ mumps_save_restore_C.o \ mumps_config_file_C.o \ mumps_thread_affinity.o \ mumps_register_thread.o \ tools_common.o \ sol_common.o OBJS_MOD = \ $(ARITH)ana_aux.o \ $(ARITH)ana_aux_par.o \ $(ARITH)ana_lr.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_LU_type1.o\ $(ARITH)fac_front_LU_type2.o\ $(ARITH)fac_front_LDLT_type1.o\ $(ARITH)fac_front_LDLT_type2.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)fac_sispointers_m.o\ $(ARITH)fac_lr.o\ $(ARITH)fac_mem_dynamic.o\ $(ARITH)fac_omp_m.o\ $(ARITH)fac_par_m.o\ $(ARITH)fac_sol_l0omp_m.o\ $(ARITH)lr_core.o\ $(ARITH)lr_stats.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_config_file.o\ $(ARITH)mumps_load.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)mumps_ooc_buffer.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_sol_es.o\ $(ARITH)mumps_save_restore.o\ $(ARITH)mumps_save_restore_files.o\ $(ARITH)mumps_struc_def.o\ $(ARITH)omp_tps_m.o\ $(ARITH)sol_lr.o\ $(ARITH)sol_omp_m.o\ $(ARITH)static_ptr_m.o OBJS_OTHER = \ $(ARITH)ini_driver.o\ $(ARITH)ana_driver.o\ $(ARITH)fac_driver.o\ $(ARITH)sol_driver.o\ $(ARITH)sol_distrhs.o\ $(ARITH)end_driver.o\ $(ARITH)ana_aux_ELT.o\ $(ARITH)ana_dist_m.o\ $(ARITH)ana_LDLT_preprocess.o\ $(ARITH)ana_reordertree.o\ $(ARITH)arrowheads.o\ $(ARITH)bcast_int.o\ $(ARITH)fac_asm_ELT.o\ $(ARITH)fac_asm.o\ $(ARITH)fac_b.o\ $(ARITH)fac_distrib_distentry.o\ $(ARITH)fac_distrib_ELT.o\ $(ARITH)fac_lastrtnelind.o\ $(ARITH)fac_mem_alloc_cb.o\ $(ARITH)fac_mem_compress_cb.o\ $(ARITH)fac_mem_free_block_cb.o\ $(ARITH)fac_mem_stack_aux.o\ $(ARITH)fac_mem_stack.o\ $(ARITH)fac_process_band.o\ $(ARITH)fac_process_blfac_slave.o\ $(ARITH)fac_process_blocfacto_LDLT.o\ $(ARITH)fac_process_blocfacto.o\ $(ARITH)fac_process_bf.o\ $(ARITH)fac_process_end_facto_slave.o\ $(ARITH)fac_process_contrib_type1.o\ $(ARITH)fac_process_contrib_type2.o\ $(ARITH)fac_process_contrib_type3.o\ $(ARITH)fac_process_maprow.o\ $(ARITH)fac_process_master2.o\ $(ARITH)fac_process_message.o\ $(ARITH)fac_process_root2slave.o\ $(ARITH)fac_process_root2son.o\ $(ARITH)fac_process_rtnelind.o\ $(ARITH)fac_root_parallel.o\ $(ARITH)fac_scalings.o\ $(ARITH)fac_determinant.o\ $(ARITH)fac_scalings_simScaleAbs.o\ $(ARITH)fac_scalings_simScale_util.o\ $(ARITH)fac_sol_pool.o\ $(ARITH)fac_type3_symmetrize.o\ $(ARITH)ini_defaults.o\ $(ARITH)mumps_c.o\ $(ARITH)mumps_driver.o\ $(ARITH)mumps_f77.o\ $(ARITH)mumps_gpu.o\ $(ARITH)mumps_iXamax.o\ $(ARITH)ana_mtrans.o\ $(ARITH)ooc_panel_piv.o\ $(ARITH)rank_revealing.o\ $(ARITH)sol_aux.o\ $(ARITH)sol_bwd_aux.o\ $(ARITH)sol_bwd.o\ $(ARITH)sol_c.o\ $(ARITH)sol_fwd_aux.o\ $(ARITH)sol_fwd.o\ $(ARITH)sol_matvec.o\ $(ARITH)sol_root_parallel.o\ $(ARITH)tools.o\ $(ARITH)type3_root.o $(libdir)/libmumps_common$(PLAT)$(LIBEXT): $(OBJS_COMMON_MOD) $(OBJS_COMMON_OTHER) $(AR)$@ $? $(RANLIB) $@ $(libdir)/lib$(ARITH)mumps$(PLAT)$(LIBEXT): $(OBJS_MOD) $(OBJS_OTHER) $(AR)$@ $? $(RANLIB) $@ # Dependencies between modules: # i) arithmetic-dependent modules: $(ARITH)ana_aux.o: $(ARITH)mumps_struc_def.o \ mumps_static_mapping.o \ ana_orderings_wrappers_m.o \ ana_blk_m.o $(ARITH)ana_aux_par.o: $(ARITH)mumps_struc_def.o \ mumps_memory_mod.o \ ana_orderings_wrappers_m.o $(ARITH)ana_lr.o: $(ARITH)lr_core.o\ $(ARITH)lr_stats.o\ lr_common.o\ ana_orderings_wrappers_m.o \ ana_blk_m.o $(ARITH)fac_asm_master_ELT_m.o: omp_tps_common_m.o \ fac_ibct_data_m.o \ fac_asm_build_sort_index_ELT_m.o \ lr_common.o \ $(ARITH)fac_mem_dynamic.o \ $(ARITH)lr_core.o \ $(ARITH)ana_lr.o \ $(ARITH)mumps_lr_data_m.o \ $(ARITH)mumps_struc_def.o \ $(ARITH)omp_tps_m.o \ $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_load.o $(ARITH)fac_asm_master_m.o: omp_tps_common_m.o \ fac_ibct_data_m.o \ fac_asm_build_sort_index_m.o \ lr_common.o \ $(ARITH)fac_mem_dynamic.o \ $(ARITH)lr_core.o \ $(ARITH)ana_lr.o \ $(ARITH)mumps_lr_data_m.o \ $(ARITH)mumps_struc_def.o \ $(ARITH)omp_tps_m.o \ $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_load.o $(ARITH)fac_front_aux.o: $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_load.o\ $(ARITH)mumps_ooc.o\ mumps_ooc_common.o\ mumps_l0_omp_m.o $(ARITH)fac_front_LU_type1.o : $(ARITH)fac_front_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_lr_data_m.o\ mumps_l0_omp_m.o $(ARITH)fac_front_LU_type2.o : $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_comm_buffer.o\ mumps_comm_ibcast.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)mumps_struc_def.o $(ARITH)fac_front_LDLT_type1.o : $(ARITH)fac_front_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_lr_data_m.o\ mumps_l0_omp_m.o $(ARITH)fac_front_LDLT_type2.o : $(ARITH)fac_front_aux.o\ $(ARITH)fac_front_type2_aux.o\ $(ARITH)mumps_ooc.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_load.o\ $(ARITH)fac_lr.o\ $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)ana_lr.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)mumps_struc_def.o $(ARITH)fac_front_type2_aux.o : mumps_ooc_common.o\ $(ARITH)fac_front_aux.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_struc_def.o\ $(ARITH)mumps_comm_buffer.o\ $(ARITH)mumps_load.o\ mumps_comm_ibcast.o\ fac_ibct_data_m.o $(ARITH)fac_lr.o: $(ARITH)lr_core.o\ $(ARITH)lr_type.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)lr_stats.o $(ARITH)fac_mem_dynamic.o: $(ARITH)mumps_load.o\ $(ARITH)static_ptr_m.o $(ARITH)fac_omp_m.o: $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)fac_front_LU_type1.o\ $(ARITH)fac_front_LDLT_type1.o\ $(ARITH)mumps_load.o\ $(ARITH)omp_tps_m.o\ $(ARITH)lr_stats.o\ $(ARITH)mumps_struc_def.o\ omp_tps_common_m.o\ mumps_l0_omp_m.o $(ARITH)fac_sol_l0omp_m.o: $(ARITH)mumps_struc_def.o $(ARITH)fac_omp_m.o: $(ARITH)mumps_struc_def.o \ $(ARITH)fac_mem_dynamic.o\ $(ARITH)omp_tps_m.o\ omp_tps_common_m.o $(ARITH)fac_par_m.o: $(ARITH)mumps_load.o\ $(ARITH)mumps_ooc.o\ $(ARITH)fac_asm_master_m.o\ $(ARITH)fac_asm_master_ELT_m.o\ $(ARITH)omp_tps_m.o\ $(ARITH)fac_front_LU_type1.o\ $(ARITH)fac_front_LU_type2.o\ $(ARITH)fac_front_LDLT_type1.o\ $(ARITH)fac_front_LDLT_type2.o\ $(ARITH)fac_mem_dynamic.o\ $(ARITH)mumps_struc_def.o\ $(ARITH)lr_stats.o\ omp_tps_common_m.o\ mumps_l0_omp_m.o $(ARITH)lr_core.o: $(ARITH)lr_type.o\ $(ARITH)mumps_lr_data_m.o\ $(ARITH)lr_stats.o\ lr_common.o $(ARITH)lr_stats.o: $(ARITH)lr_type.o \ $(ARITH)mumps_struc_def.o $(ARITH)mumps_comm_buffer.o: mumps_comm_ibcast.o \ $(ARITH)lr_type.o \ $(ARITH)lr_core.o \ $(ARITH)mumps_lr_data_m.o \ fac_ibct_data_m.o $(ARITH)mumps_config_file.o: $(ARITH)mumps_struc_def.o $(ARITH)mumps_load.o: $(ARITH)mumps_comm_buffer.o \ $(ARITH)mumps_struc_def.o \ fac_future_niv2_mod.o $(ARITH)mumps_lr_data_m.o: $(ARITH)lr_type.o\ front_data_mgt_m.o $(ARITH)mumps_ooc_buffer.o: mumps_ooc_common.o $(ARITH)mumps_ooc.o: $(ARITH)mumps_struc_def.o \ $(ARITH)mumps_ooc_buffer.o \ mumps_ooc_common.o $(ARITH)mumps_sol_es.o: $(ARITH)lr_type.o \ $(ARITH)mumps_lr_data_m.o $(ARITH)mumps_save_restore.o: $(ARITH)mumps_struc_def.o \ $(ARITH)mumps_save_restore_files.o \ $(ARITH)mumps_lr_data_m.o \ $(ARITH)mumps_ooc.o \ $(ARITH)fac_sol_l0omp_m.o \ front_data_mgt_m.o $(ARITH)mumps_save_restore_files.o : $(ARITH)mumps_struc_def.o $(ARITH)sol_lr.o: $(ARITH)lr_type.o\ $(ARITH)lr_stats.o\ $(ARITH)mumps_lr_data_m.o $(ARITH)sol_omp_m.o: $(ARITH)mumps_struc_def.o # Dependencies between modules: # ii) arithmetic-independent modules: ana_omp_m.o: double_linked_list.o fac_asm_build_sort_index_ELT_m.o:omp_tps_common_m.o fac_asm_build_sort_index_m.o: omp_tps_common_m.o fac_descband_data_m.o: front_data_mgt_m.o fac_ibct_data_m.o: front_data_mgt_m.o fac_maprow_data_m.o: front_data_mgt_m.o mumps_comm_ibcast.o: fac_future_niv2_mod.o mumps_static_mapping.o: lr_common.o # Compile modules before the rest $(OBJS_COMMON_OTHER):$(OBJS_COMMON_MOD) $(OBJS_OTHER):$(OBJS_COMMON_MOD) $(OBJS_MOD) .SUFFIXES: .c .F .o .F.o: $(FC) $(OPTF) -I. -I../include $(INCS) $(IORDERINGSF) $(ORDERINGSF) -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) -I../include $(INCS) $(CDEFS) $(IORDERINGSC) $(ORDERINGSC) -c $*.c $(OUTC)$*.o $(ARITH)mumps_c.o: mumps_c.c $(CC) $(OPTC) -I../include $(INCS) $(CDEFS) -DMUMPS_ARITH=MUMPS_ARITH_$(ARITH) \ $(IORDERINGSC) $(ORDERINGSC) -c mumps_c.c $(OUTC)$@ clean: $(RM) *.o *.mod $(incdir)/mumps_int_def.h build_mumps_int_def MUMPS_5.4.1/src/sfac_sispointers_m.F0000664000175000017500000000150714102210525017511 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C SMUMPS_FAC_DRIVER and SMUMPS_FAC_B C ---------------------------------- TYPE S_IS_POINTERS_T REAL, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE S_IS_POINTERS_T END MODULE SMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.4.1/src/cana_aux_par.F0000664000175000017500000030335414102210523016243 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_PARALLEL_ANALYSIS USE CMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS INCLUDE 'mpif.h' PUBLIC CMUMPS_ANA_F_PAR INTERFACE CMUMPS_ANA_F_PAR MODULE PROCEDURE CMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, COMM_NODES, NPROCS, NSLAVES, MYID INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER :: N, COMM INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK CONTAINS SUBROUTINE CMUMPS_ANA_F_PAR(id, WORK1, WORK2, NFSIZ, FILS, & FRERE) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER :: NFSIZ(:), FILS(:), FRERE(:) TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: IPE(:), NV(:), & NE(:), NA(:), NODE(:), & ND(:), SUBORD(:), NAMALG(:), & IPS(:), CUMUL(:), & SAVEIRN(:), SAVEJCN(:) INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG LOGICAL :: SPLITROOT INTEGER(8), PARAMETER :: K79REF=12000000_8 INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) DOUBLE PRECISION :: TIMEB nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) ord%PERMTAB => WORK1(1 : id%N) ord%PERITAB => WORK1(id%N+1 : 2*id%N) ord%TREETAB => WORK1(2*id%N+1 : 3*id%N) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_SET_PAR_ORD(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) CALL CMUMPS_DO_PAR_ORD(id, ord, WORK2) IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(*,'(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(id%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL CMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:id%N) NE => WORK1(id%N+1 : 2*id%N) NA => WORK1(2*id%N+1 : 3*id%N) NODE => WORK2(1 : id%N ) ND => WORK2(id%N+1 : 2*id%N) SUBORD => WORK2(2*id%N+1 : 3*id%N) NAMALG => WORK2(3*id%N+1 : 4*id%N) CALL MUMPS_REALLOC(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL CMUMPS_ANA_LNEW(id%N, IPE(1), NV(1), IPS(1), NE(1), & NA(1), NFSIZ(1), NODE(1), id%INFOG(6), FILS(1), FRERE(1), & ND(1), NEMIN, SUBORD(1), id%KEEP(60), id%KEEP(20), & id%KEEP(38), NAMALG(1), id%KEEP(104), CUMUL(1), & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%NSLAVES, & id%KEEP(250).EQ.1, .FALSE., IDUMMY, LIDUMMY) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL CMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(id%N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL CMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2)) & id%KEEP(210)=0 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0)) & id%KEEP(210)=1 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0)) & id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN IDUMMY(1) = -1 CALL CMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), SPLITROOT, & MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = (((id%ICNTL(13).GT.0) .AND. & (id%NSLAVES.GT.id%ICNTL(13))) .OR. & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL CMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF END IF RETURN END SUBROUTINE CMUMPS_ANA_F_PAR SUBROUTINE CMUMPS_SET_PAR_ORD(id, ord) TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29) CALL MPI_BCAST( id%KEEP(245), 1, & MPI_INTEGER, 0, id%COMM, IERR ) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(245) .EQ. 0) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) id%KEEP(245) = 1 IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, & ord%COMM_NODES, IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to ParMETIS.")') id%KEEP(245) = 2 RETURN #endif id%INFO(1) = -38 id%INFOG(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP, & '("No parallel ordering tools available.")') WRITE(LP, & '("Please install PT-SCOTCH or ParMETIS.")') END IF RETURN ELSE IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, ord%COMM_NODES, & IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF END SUBROUTINE CMUMPS_SET_PAR_ORD SUBROUTINE CMUMPS_DO_PAR_ORD(id, ord, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) CALL CMUMPS_PTSCOTCH_ORD(id, ord, WORK) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) CALL CMUMPS_PARMETIS_ORD(id, ord, WORK) if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_NODES, IERR) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF RETURN END SUBROUTINE CMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_PARMETIS_ORD(id, ord, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IERR=0 IF(size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL CMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:id%N) CALL MUMPS_REALLOC(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_BUILD_TREE(ord) ord%N = id%N ord%COMM = id%COMM RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE CMUMPS_PARMETIS_ORD #endif #if defined(ptscotch) SUBROUTINE CMUMPS_PTSCOTCH_ORD(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF (size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside CMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) BASE = id%NPROCS-id%NSLAVES BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL CMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL CMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 CALL MUMPS_REALLOC(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) END IF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = id%N ord%COMM = id%COMM CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) RETURN 11 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE CMUMPS_PTSCOTCH_ORD #endif FUNCTION CMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: CMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(CMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF CMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN CMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN CMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = id%N END IF DO I=1, ANODE WEIGHT = ord%NW(LIST(I)) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT END DO I = ord%SON(BIG) DO WEIGHT = ord%NW(I) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT IF(ord%BROTHER(I) .EQ. -1) EXIT I = ord%BROTHER(I) END DO TOPROWS = ord%TOPNODES(2)+ord%RANGTAB(BIG+1)-ord%RANGTAB(BIG) SUBMEM = 7 *id%N HOSTMEM = 12*id%N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/id%N) IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN CMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE CMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION CMUMPS_STOP_DESCENT FUNCTION CMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: CMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR CMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE CMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN CMUMPS_CNT_KIDS = CMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION CMUMPS_CNT_KIDS SUBROUTINE CMUMPS_GET_SUBTREES(ord, id) IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(CMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok LOGICAL :: SD NNODES = ord%NSLAVES CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. CMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL CMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL CMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = CMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = CMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL CMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL CMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL CMUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL CMUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(46) .EQ. 1) THEN BASE = 0 ELSE ord%FIRST(1) = 0 ord%LAST(1) = -1 BASE = 1 END IF DO I=1, ANODE CURR = LIST(I) ND = CURR IF(ord%SON(ND) .NE. -1) THEN ND = ord%SON(ND) DO IF((ord%SON(ND) .EQ. -1) .AND. & (ord%BROTHER(ND).EQ.-1)) THEN EXIT ELSE IF(ord%BROTHER(ND) .EQ. -1) THEN ND = ord%SON(ND) ELSE ND = ord%BROTHER(ND) END IF END DO END IF ord%FIRST(BASE+I) = ord%RANGTAB(ND) ord%LAST(BASE+I) = ord%RANGTAB(CURR+1)-1 END DO DO I=ANODE+1, id%NSLAVES ord%FIRST(BASE+I) = id%N+1 ord%LAST(BASE+I) = id%N END DO DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE CMUMPS_GET_SUBTREES SUBROUTINE CMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(size(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in CMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : id%N) ELEN => WORK( id%N+1 : 2*id%N) LENG => WORK(2*id%N+1 : 3*id%N) PERM => WORK(3*id%N+1 : 4*id%N) END IF CALL CMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1 : 2*id%N) CALL CMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = id%N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(real(TMP)*1.10E0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), & HIDX, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, id%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(id%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, id%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, id%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL CMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL CMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & id%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & id%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & id%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & id%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, id%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, id%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE CMUMPS_PARSYMFACT SUBROUTINE CMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE CMUMPS_MAKE_LOC_IDX SUBROUTINE CMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE CMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in CMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE CMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), SDISPL(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : id%N) LENG => WORK(id%N+1 : 2*id%N) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*id%N id%KEEP8(126) = id%KEEP8(127)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END DO CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, id%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(id%N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL CMUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL CMUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE CMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE CMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & SDISPL(:), HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : id%N) HALO_MAP => WORK(id%N+1 : 2*id%N) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END IF END DO CALL CMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, id%N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, id%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE CMUMPS_BUILD_LOC_GRAPH SUBROUTINE CMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in CMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in CMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in CMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in CMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in CMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE CMUMPS_SEND_BUF SUBROUTINE CMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE CMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE CMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE CMUMPS_BUILD_TREE SUBROUTINE CMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, TYPE) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(id%N/ord%NSLAVES,8) DO I=1, ord%NSLAVES FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NSLAVES) = MAX(LAST(BASE+ord%NSLAVES), id%N) DO I = ord%NSLAVES+1, id%NSLAVES+1 FIRST(BASE+I) = id%N+1 LAST (BASE+I) = id%N END DO ELSE IF (TYPE.EQ.2) THEN TMP => WORK(1:id%N) NZ_ROW => WORK(id%N+1:2*id%N) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MPI_ALLREDUCE(TMP(1), NZ_ROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NSLAVES,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, id%N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((id%N-I).EQ.(ord%NSLAVES-P-1)) .OR. & (I.EQ.id%N) & ) THEN P = P+1 IF(P.EQ.ord%NSLAVES) THEN FIRST(BASE+P) = F LAST(BASE+P) = id%N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = id%N+1 LAST(BASE+J) = id%N END DO END IF RETURN END SUBROUTINE CMUMPS_GRAPH_DIST #endif SUBROUTINE CMUMPS_MERGESWAP(N, L, A1, A2) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A1(:), A2(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A1(LP) A1(LP) = A1(I) A1(I) = ISWAP ISWAP = A2(LP) A2(LP) = A2(I) A2(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE CMUMPS_MERGESWAP #if defined(DETERMINISTIC_PARALLEL_GRAPH) SUBROUTINE CMUMPS_MERGESWAP1(N, L, A) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A(LP) A(LP) = A(I) A(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE CMUMPS_MERGESWAP1 #endif SUBROUTINE CMUMPS_MERGESORT(N, K, L) INTEGER :: N INTEGER :: K(:), L(0:) INTEGER :: P, Q, S, T CONTINUE L(0) = 1 T = N + 1 DO P = 1,N - 1 IF (K(P) <= K(P+1)) THEN L(P) = P + 1 ELSE L(T) = - (P+1) T = P END IF END DO L(T) = 0 L(N) = 0 IF (L(N+1) == 0) THEN RETURN ELSE L(N+1) = iabs(L(N+1)) END IF 200 CONTINUE S = 0 T = N+1 P = L(S) Q = L(T) IF(Q .EQ. 0) RETURN 300 CONTINUE IF(K(P) .GT. K(Q)) GOTO 600 CONTINUE L(S) = sign(P,L(S)) S = P P = L(P) IF (P .GT. 0) GOTO 300 CONTINUE L(S) = Q S = T DO T = Q Q = L(Q) IF (Q .LE. 0) EXIT END DO GOTO 800 600 CONTINUE L(S) = sign(Q, L(S)) S = Q Q = L(Q) IF (Q .GT. 0) GOTO 300 CONTINUE L(S) = P S = T DO T = P P = L(P) IF (P .LE. 0) EXIT END DO 800 CONTINUE P = -P Q = -Q IF(Q.EQ.0) THEN L(S) = sign(P, L(S)) L(T) = 0 GOTO 200 END IF GOTO 300 END SUBROUTINE CMUMPS_MERGESORT FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:) #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8) IF (id%KEEP(10).EQ.1) THEN CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(CMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) BASEVAL_I8 = int(BASEVAL,8) VERTLOCNBR_I8 = int(VERTLOCNBR,8) ENDIF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.4.1/src/dfac_mem_stack.F0000664000175000017500000005507314102210522016543 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) DOUBLE PRECISION A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR, MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR, & MUMPS_ROOTSSARBR LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 INPLACE = .FALSE. MIN_SPACE_IN_PLACE = 0_8 IOLDPS = PTLUST_S(STEP(INODE)) INTSIZ = IW(IOLDPS+XXI) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS + 1+KEEP(IXSZ)) NMAXNPIV = max(NPIV, NMAXNPIV) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in DMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL DMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL DMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL DMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL DMUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL DMUMPS_PROCESS_RTNELIND( root, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL DMUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL DMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL DMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & DMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & DMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL DMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL DMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL DMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL DMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL DMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I = 1, NCBROW_PREVIOUSLY_MOVED*NPIV A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) CALL DMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL DMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE DMUMPS_FAC_STACK MUMPS_5.4.1/src/zfac_omp_m.F0000664000175000017500000000076214102210525015733 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_OMP_M END MODULE ZMUMPS_FAC_OMP_M MUMPS_5.4.1/src/cbcast_int.F0000664000175000017500000000307714102210523015732 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE CMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL CMUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to CMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE CMUMPS_MCAST2 SUBROUTINE CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE CMUMPS_BDC_ERROR MUMPS_5.4.1/src/sfac_asm_master_m.F0000664000175000017500000021310714102210521017257 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE SMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & ) !$ USE OMP_LIB USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_IS_DYNAMIC, & SMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & SMUMPS_BLR_ASM_NIV1 USE SMUMPS_LR_DATA_M, ONLY : SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_NFS4FATHER USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 REAL, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: JK8, J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW REAL, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = N NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in SMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN SMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL SMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN SMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL SMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL SMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL SMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL SMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) IF (IS_DYNAMIC_CB) THEN CALL SMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL SMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) DO 250 JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING SMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING SMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV1 SUBROUTINE SMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_IS_DYNAMIC USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF REAL, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) REAL :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR REAL DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE REAL, DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: JK8, AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER IJROW,NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT REAL ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = 0.0E0 ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL SMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL SMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL SMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL SMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress SMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL SMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL SMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL SMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN SMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+KEEP(IXSZ)+NSLAVES)= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL SMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL SMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL SMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & SMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL SMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1_8 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = MAXARR ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL SMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL SMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL SMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL SMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL SMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & SMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING SMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING SMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_ASM_NIV2 END MODULE SMUMPS_FAC_ASM_MASTER_M MUMPS_5.4.1/src/fac_future_niv2_mod.F0000664000175000017500000000106414102210475017541 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FUTURE_NIV2 INTEGER, DIMENSION(:), ALLOCATABLE, PUBLIC :: FUTURE_NIV2 END MODULE MUMPS_FUTURE_NIV2 MUMPS_5.4.1/src/mumps_io_thread.c0000664000175000017500000004370114102210474017040 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_io_thread.h" #include "mumps_c_types.h" #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) /* Exported global variables */ MUMPS_INT io_flag_stop,current_req_num; pthread_t io_thread,main_thread; pthread_mutex_t io_mutex; pthread_cond_t cond_io,cond_nb_free_finished_requests,cond_nb_free_active_requests,cond_stop; pthread_mutex_t io_mutex_cond; MUMPS_INT int_sem_io,int_sem_nb_free_finished_requests,int_sem_nb_free_active_requests,int_sem_stop; MUMPS_INT with_sem; struct request_io *io_queue; MUMPS_INT first_active,last_active,nb_active; MUMPS_INT *finished_requests_inode,*finished_requests_id,first_finished_requests, last_finished_requests,nb_finished_requests,smallest_request_id; MUMPS_INT mumps_owns_mutex; MUMPS_INT test_request_called_from_mumps; /* Other global variables */ double inactive_time_io_thread; MUMPS_INT time_flag_io_thread; struct timeval origin_time_io_thread; /** * Main function of the io thread when semaphores are used. */ void* mumps_async_thread_function_with_sem (void* arg){ struct request_io *current_io_request; MUMPS_INT ierr,_sem_stop; struct timeval start_time,end_time; MUMPS_INT ret_code; for (;;){ gettimeofday(&start_time,NULL); if(with_sem==2){ mumps_wait_sem(&int_sem_io,&cond_io); } /* sem_wait(&sem_io); */ gettimeofday(&end_time,NULL); if(time_flag_io_thread){ inactive_time_io_thread=inactive_time_io_thread+((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)start_time.tv_sec+((double)start_time.tv_usec/1000000)); }else{ inactive_time_io_thread=((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)origin_time_io_thread.tv_sec+((double)origin_time_io_thread.tv_usec/1000000)); } if(!time_flag_io_thread){ time_flag_io_thread=1; } /* Check if the main thread ordered to stop this slave thread */ /* sem_getvalue(&sem_stop,&_sem_stop); */ if(with_sem==2){ mumps_get_sem(&int_sem_stop,&_sem_stop); } if(_sem_stop==IO_FLAG_STOP){ /* The thread must stop */ break; /* Breaks the while loop. */ } current_io_request=&io_queue[first_active]; switch(current_io_request->io_type) { case IO_WRITE: ret_code=mumps_io_do_write_block(current_io_request->addr, current_io_request->size, &(current_io_request->file_type), current_io_request->vaddr, &ierr); if(ret_code<0){ goto end; } break; case IO_READ: ret_code=mumps_io_do_read_block(current_io_request->addr, current_io_request->size, &(current_io_request->file_type), current_io_request->vaddr, &ierr); if(ret_code<0){ goto end; } break; default: printf("Error : Mumps_IO : Operation %d is neither READ nor WRITE\n",current_io_request->io_type); exit (-3); } /* Notify that the IO was performed */ /* Wait that finished_requests queue could register the notification */ if(with_sem==2){ mumps_wait_sem(&int_sem_nb_free_finished_requests,&cond_nb_free_finished_requests); } pthread_mutex_lock(&io_mutex); /* Updates active queue bounds */ /* Register the notification in finished_requests queue and updates its bounds. */ finished_requests_id[last_finished_requests]=current_io_request->req_num; finished_requests_inode[last_finished_requests]=current_io_request->inode; last_finished_requests=(last_finished_requests+1)%(MAX_FINISH_REQ); /* ??? */ nb_finished_requests++; /* Realeases the lock : ***UNLOCK*** */ nb_active--; if(first_activeint_local_cond),&(current_io_request->local_cond)); } pthread_mutex_unlock(&io_mutex); /* Finally increases the number of free active requests.*/ /* sem_post(&sem_nb_free_active_requests); */ mumps_post_sem(&int_sem_nb_free_active_requests,&cond_nb_free_active_requests); } end: /* The main thread ordered the end of the IO thread (it changed sem_stop). We exit. */ pthread_exit(NULL); /* FIXME Not reached */ /* return NULL; */ } MUMPS_INT mumps_test_request_th(MUMPS_INT* request_id,MUMPS_INT *flag){ /* Tests if the request "request_id" has finished. It sets the flag */ /* argument to 1 if the request has finished (0 otherwise) */ MUMPS_INT request_pos; MUMPS_INT i; i=mumps_check_error_th(); if(i!=0){ return i; } pthread_mutex_lock(&io_mutex); /* printf("entering test !!! \n"); */ if(*request_id < smallest_request_id){ *flag=1; /* exit (-2); */ }else{ if(nb_finished_requests==0){ *flag=0; }else{ request_pos=(first_finished_requests+nb_finished_requests-1)%(MAX_IO*2); if(*request_id > finished_requests_id[request_pos]){ /*the request has not been treated yet since it is not in the list of treated requests*/ i=0; /*this loop is only for checking (no special treatment is done*/ while(i we just have to increase smallest_request_id*/ smallest_request_id++; if(!mumps_owns_mutex) pthread_mutex_unlock(&io_mutex); if(with_sem) { if(with_sem==2){ mumps_post_sem(&int_sem_nb_free_finished_requests,&cond_nb_free_finished_requests); } } return 0; } MUMPS_INT mumps_low_level_init_ooc_c_th(MUMPS_INT* async, MUMPS_INT* ierr){ MUMPS_INT i, ret_code; char buf[128]; /* Computes the number of files needed. Uses ceil value. */ *ierr=0; current_req_num=0; with_sem=2; first_active=0; last_active=0; nb_active=0; first_finished_requests=0; last_finished_requests=0; nb_finished_requests=0; smallest_request_id=0; mumps_owns_mutex=0; inactive_time_io_thread=0; time_flag_io_thread=0; gettimeofday(&origin_time_io_thread,NULL); /* mumps_io_flag_async=*async; */ if(*async!=IO_ASYNC_TH){ *ierr = -91; sprintf(buf,"Internal error: mumps_low_level_init_ooc_c_th should not to be called with strat_IO=%d\n",*async); return mumps_io_error(*ierr,buf); } if(*async){ pthread_mutex_init(&io_mutex,NULL); mumps_io_init_err_lock(); #ifdef WITH_PFUNC mumps_io_init_pointers_lock(); #endif io_queue=(struct request_io *)malloc(MAX_IO*sizeof(struct request_io)); if(with_sem==2){ for(i=0;i IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN CMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL CMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN CMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL CMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL CMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL CMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL CMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) IF (IS_DYNAMIC_CB) THEN CALL CMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL CMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) DO 250 JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING CMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING CMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV1 SUBROUTINE CMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_IS_DYNAMIC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE COMPLEX, DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: JK8, AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER IJROW,NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL CMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL CMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL CMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress CMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL CMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL CMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN CMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+KEEP(IXSZ)+NSLAVES)= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL CMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL CMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL CMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & CMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1_8 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = cmplx(MAXARR,kind=kind(A)) ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL CMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL CMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL CMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL CMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL CMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & CMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV2 END MODULE CMUMPS_FAC_ASM_MASTER_M MUMPS_5.4.1/src/dfac_process_master2.F0000664000175000017500000001637214102210522017712 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE DMUMPS_LOAD USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL DMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_MASTER2 MUMPS_5.4.1/src/csol_bwd.F0000664000175000017500000001475014102210523015415 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE CMUMPS_STATIC_PTR_M, ONLY : CMUMPS_SET_STATIC_PTR, & CMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS COMPLEX A(LA), W(LWC) COMPLEX W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine CMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) BLOQ = ( III .EQ. IIPOOL ) CALL CMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 CALL CMUMPS_SET_STATIC_PTR(A) CALL CMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL CMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .EQ. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE CMUMPS_SOL_S MUMPS_5.4.1/src/front_data_mgt_m.F0000664000175000017500000007105214102210475017131 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE PRIVATE C -------------------------------------------- C This module contains routines to manage C handlers of various data associated to C active fronts *during the factorization*. C C It should be initialized at the beginning C of the factorization and terminated at the C end of the factorization. C C There are two types of data, see below. C C 'A' is for active type 2 fronts: list must C be empty at the end of the factorization C C 'F' will be for general fronts -- currently used C for BLR fronts, in three situations: C 1/ factorization of type 2 symmetric active fronts C (requires temporary storage of BLR panels) C 2/ LRSOLVE: BLR factors are kept until solution phase C (liberated in JOB=-2 or at the beginning of a new facto) C 3/ LRCB: CB is dynamically allocated and compressed C (liberated before the end of the factorization) C C Only handlers are managed in this module. C The data itself is in the module above using it. C For example, FAC_MAPROW_DATA_M manages MAPROW C messages that arrive too early. It handles an C array that contains all early MAPROW messages C and that is indexed with the handlers managed C by MUMPS_FRONT_DATA_MGT_M. C C -------------------------------------------- C C =============== C Public routines C =============== PUBLIC :: MUMPS_FDM_INIT, & MUMPS_FDM_END, & MUMPS_FDM_START_IDX, & MUMPS_FDM_END_IDX & , MUMPS_FDM_MOD_TO_STRUC & , MUMPS_FDM_STRUC_TO_MOD & , MUMPS_SAVE_RESTORE_FRONT_DATA C STACK_FREE_IDX(1:NB_FREE_IDX) holds the NB_FREE_IDX indices C of free handlers C STACK_FREE_IDX(NB_FREE_IDX+1:size(STACK_FREE_IDX)) is trash data TYPE FDM_STRUC_T INTEGER :: NB_FREE_IDX INTEGER, DIMENSION(:), POINTER :: STACK_FREE_IDX => null() INTEGER, DIMENSION(:), POINTER :: COUNT_ACCESS => null() END TYPE FDM_STRUC_T TYPE (FDM_STRUC_T), TARGET, SAVE :: FDM_A, FDM_F CONTAINS C SUBROUTINE MUMPS_FDM_INIT(WHAT, INITIAL_SIZE, INFO) C C Purpose: C ======= C C Initialize handler data ('A' or 'F') C C Arguments: C ========= C INTEGER, INTENT(IN) :: INITIAL_SIZE CHARACTER, INTENT(IN) :: WHAT ! 'A' or 'F' INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables: C =============== C INTEGER :: IERR TYPE (FDM_STRUC_T), POINTER :: FDM_PTR C CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) ALLOCATE( FDM_PTR%STACK_FREE_IDX(INITIAL_SIZE), & FDM_PTR%COUNT_ACCESS (INITIAL_SIZE), stat=IERR ) IF (IERR < 0) THEN INFO(1) = -13 INFO(2) = INITIAL_SIZE * 2 RETURN ENDIF CALL MUMPS_FDM_SET_ALL_FREE(FDM_PTR) RETURN END SUBROUTINE MUMPS_FDM_INIT C SUBROUTINE MUMPS_FDM_END(WHAT) C C Purpose: C ======= C Free module datastructures associated to "WHAT" at C the end of a phase (typically factorization). C CHARACTER, INTENT(IN) :: WHAT C C Local variables C =============== C TYPE (FDM_STRUC_T), POINTER :: FDM_PTR C CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) IF (associated(FDM_PTR%STACK_FREE_IDX)) THEN DEALLOCATE(FDM_PTR%STACK_FREE_IDX) NULLIFY(FDM_PTR%STACK_FREE_IDX) FDM_PTR%NB_FREE_IDX=0 ELSE C Should not be called twice or when array is unassociated WRITE(*,*) "Internal error 1 in MUMPS_FDM_END", WHAT CALL MUMPS_ABORT() ENDIF IF (associated(FDM_PTR%COUNT_ACCESS)) THEN DEALLOCATE(FDM_PTR%COUNT_ACCESS) NULLIFY(FDM_PTR%COUNT_ACCESS) ELSE C Should not be called twice or when array is unassociated WRITE(*,*) "Internal error 2 in MUMPS_FDM_END", WHAT CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_FDM_END C SUBROUTINE MUMPS_FDM_MOD_TO_STRUC(WHAT, id_FDM_ENCODING,INFO) C C Purpose: C ======= C C Save module information in struture. C id_FDM_ENCODING corresponds to id%FDM_F_ENCODING C This version requires that WHAT is equal to 'F'. C C id_FDM_ENDODING takes responsibility of pointing to module C FDM_F information. This typically allows data from the module C to be passed from factorization to solve through the instance C and manage multiple instances. C CHARACTER, INTENT(IN) :: WHAT INTEGER, INTENT(INOUT) :: INFO(2) #if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_ENCODING #else CHARACTER, DIMENSION(:), POINTER :: id_FDM_ENCODING #endif C C Local variables C =============== C C Character array of arbitrary dimension 1 CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR C IF (WHAT .NE. 'F') THEN WRITE(*,*) "Internal error 1 in MUMPS_FDM_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF IF (associated(id_FDM_ENCODING)) THEN C Should be unassociated for this to work WRITE(*,*) "Internal error 2 in MUMPS_FDM_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF CHAR_LENGTH=size(transfer(FDM_F,CHAR_ARRAY)) ALLOCATE(id_FDM_ENCODING(CHAR_LENGTH), stat=IERR ) IF (IERR < 0) THEN INFO(1) = -13 INFO(2) = CHAR_LENGTH RETURN ENDIF C ------------------------------ C Fill contents of pointer array C with FDM_F derived datatype C ------------------------------ id_FDM_ENCODING = transfer(FDM_F,CHAR_ARRAY) C ---------------------------------------------- C FDM_F is not to be used again before a call to C MUMPS_FDM_STRUC_TO_MOD, invalidate its content C ---------------------------------------------- FDM_F%NB_FREE_IDX=-9999999 NULLIFY(FDM_F%STACK_FREE_IDX) NULLIFY(FDM_F%COUNT_ACCESS) RETURN END SUBROUTINE MUMPS_FDM_MOD_TO_STRUC C SUBROUTINE MUMPS_FDM_STRUC_TO_MOD(WHAT, id_FDM_ENCODING) C C Purpose: C ======= C C Set module pointer information from id_FDM_ENCODING) typically C at beginning of solve. Suppress from structure since C responsibility of pointing to module data is now inside C the module. C CHARACTER, INTENT(IN) :: WHAT #if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, INTENT(INOUT) & :: id_FDM_ENCODING #else CHARACTER, DIMENSION(:), POINTER :: id_FDM_ENCODING #endif C C Local variables C =============== C IF (.NOT.associated(id_FDM_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_FDM_STRUC_TO_MOD" ENDIF FDM_F=transfer(id_FDM_ENCODING,FDM_F) C Module is now responsible for accessing data. DEALLOCATE(id_FDM_ENCODING) NULLIFY(id_FDM_ENCODING) RETURN END SUBROUTINE MUMPS_FDM_STRUC_TO_MOD C SUBROUTINE MUMPS_FDM_START_IDX(WHAT, FROM, IWHANDLER, INFO) C C Purpose: C ======= C C Return a new free index/handler C (typically stored in IW) C CHARACTER, INTENT(IN) :: WHAT CHARACTER(LEN=*), INTENT(IN) :: FROM !For debugging purposes only INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables C =============== C INTEGER :: OLD_SIZE, NEW_SIZE, IERR INTEGER :: I INTEGER, DIMENSION(:), POINTER :: TMP_COUNT_ACCESS TYPE(FDM_STRUC_T), POINTER :: FDM_PTR CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) C IF (IWHANDLER .GT. 0) THEN C Already started, counter should at least be 1 IF (FDM_PTR%COUNT_ACCESS(IWHANDLER) .LT. 1) THEN WRITE(*,*) "Internal error 1 in MUMPS_FDM_START_IDX", & FDM_PTR%COUNT_ACCESS(IWHANDLER) CALL MUMPS_ABORT() ENDIF GOTO 100 ENDIF C IF (FDM_PTR%NB_FREE_IDX .EQ. 0) THEN OLD_SIZE = size(FDM_PTR%STACK_FREE_IDX) NEW_SIZE = (OLD_SIZE * 3) / 2 + 1 ! or something else FDM_PTR%NB_FREE_IDX = NEW_SIZE - OLD_SIZE DEALLOCATE(FDM_PTR%STACK_FREE_IDX) ALLOCATE(FDM_PTR%STACK_FREE_IDX(NEW_SIZE), & TMP_COUNT_ACCESS(NEW_SIZE), stat=IERR) IF (IERR < 0) THEN INFO(1) = -13 INFO(2) = NEW_SIZE RETURN ENDIF C All new handlers indices are created DO I=1, FDM_PTR%NB_FREE_IDX FDM_PTR%STACK_FREE_IDX(I)=NEW_SIZE-I+1 ENDDO C Count access: copy old ones DO I=1, OLD_SIZE TMP_COUNT_ACCESS(I)=FDM_PTR%COUNT_ACCESS(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE TMP_COUNT_ACCESS(I)=0 ENDDO DEALLOCATE(FDM_PTR%COUNT_ACCESS) FDM_PTR%COUNT_ACCESS=>TMP_COUNT_ACCESS ENDIF C IWHANDLER = FDM_PTR%STACK_FREE_IDX(FDM_PTR%NB_FREE_IDX) FDM_PTR%NB_FREE_IDX = FDM_PTR%NB_FREE_IDX - 1 100 CONTINUE C Number of modules accessing this handler FDM_PTR%COUNT_ACCESS(IWHANDLER)=FDM_PTR%COUNT_ACCESS(IWHANDLER)+1 RETURN END SUBROUTINE MUMPS_FDM_START_IDX C SUBROUTINE MUMPS_FDM_END_IDX(WHAT, FROM, IWHANDLER) C C Purpose: C ======= C C Notify than an index/handler has been freed. C Mark it free for future reuse. C CHARACTER, INTENT(IN) :: WHAT CHARACTER(LEN=*), INTENT(IN) :: FROM ! for debug purposes only INTEGER, INTENT(INOUT) :: IWHANDLER TYPE(FDM_STRUC_T), POINTER :: FDM_PTR C CALL MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) IF (IWHANDLER .LE.0) THEN C Already ended WRITE(*,*) "Internal error 1 in MUMPS_FDM_END_IDX",IWHANDLER CALL MUMPS_ABORT() ENDIF FDM_PTR%COUNT_ACCESS(IWHANDLER)=FDM_PTR%COUNT_ACCESS(IWHANDLER)-1 IF (FDM_PTR%COUNT_ACCESS(IWHANDLER) .LT. 0) THEN C Negative counter! WRITE(*,*) "Internal error 2 in MUMPS_FDM_END_IDX", & IWHANDLER, FDM_PTR%COUNT_ACCESS(IWHANDLER) CALL MUMPS_ABORT() ENDIF IF (FDM_PTR%COUNT_ACCESS(IWHANDLER) .EQ.0 ) THEN IF (FDM_PTR%NB_FREE_IDX .GE. size(FDM_PTR%STACK_FREE_IDX)) THEN WRITE(*,*) "Internal error 3 in MUMPS_FDM_END_IDX" CALL MUMPS_ABORT() ENDIF FDM_PTR%NB_FREE_IDX = FDM_PTR%NB_FREE_IDX + 1 C Having incremented the nb of free handlers we C store the index (IWHANDLER) that has been C effectively released for future reuse. FDM_PTR%STACK_FREE_IDX(FDM_PTR%NB_FREE_IDX) = IWHANDLER IWHANDLER = -8888 ! has been used and is now free ENDIF C RETURN END SUBROUTINE MUMPS_FDM_END_IDX C =================== C Private subroutines C =================== SUBROUTINE MUMPS_FDM_SET_PTR(WHAT, FDM_PTR) CHARACTER, INTENT(IN) :: WHAT #if defined(MUMPS_F2003) TYPE(FDM_STRUC_T), POINTER, INTENT(OUT) :: FDM_PTR #else TYPE(FDM_STRUC_T), POINTER :: FDM_PTR #endif C IF ( WHAT .EQ. 'A' ) THEN FDM_PTR => FDM_A ELSE IF ( WHAT .EQ. 'F' ) THEN FDM_PTR => FDM_F ELSE C Should be called with either A or F WRITE(*,*) "Internal error 1 in MUMPS_FDM_INIT" WRITE(*,*) "Allowed arguments for WHAT are A or F" CALL MUMPS_ABORT() ENDIF END SUBROUTINE MUMPS_FDM_SET_PTR SUBROUTINE MUMPS_FDM_SET_ALL_FREE(FDM_PTR) C C Purpose: C ======= C Initialize the stack of free elements for the first time C TYPE(FDM_STRUC_T), POINTER :: FDM_PTR INTEGER :: I FDM_PTR%NB_FREE_IDX = size(FDM_PTR%STACK_FREE_IDX) DO I = 1, FDM_PTR%NB_FREE_IDX FDM_PTR%STACK_FREE_IDX(I)=FDM_PTR%NB_FREE_IDX-I+1 FDM_PTR%COUNT_ACCESS (I)=0 ENDDO RETURN END SUBROUTINE MUMPS_FDM_SET_ALL_FREE C ! ---------- MUMPS_SAVE_RESTORE_FRONT_DATA ----------------------- ! SUBROUTINE MUMPS_SAVE_RESTORE_FRONT_DATA(id_FDM_F_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IMPLICIT NONE C ======= C Purpose C ======= C C This routine is designed to manage a FDM_STRUC_T structure (save, restore, compute memory) C C ========== C Parameters C ========== C C FDM_STRUC : TYPE (FDM_STRUC_T) : the main structure C C unit : The unit of the file to be written or read C C mode : the type of operation to be performed by the routine C memory_save = compute the size of the save file and of the structure C save = save the instace C restore = restore the instace C C TOTAL_FILE_SIZE : size of the file to be written or read C C TOTAL_STRUC_SIZE : size of the structure to be saved or restored C C SIZE_INT : size of an integer C C INFO : copies of of INFO(1) and INFO(2) to allow save/restore of failled instaces C CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: NbRecords,NbSubRecords INTEGER:: SIZE_GEST_FDM_F INTEGER(8):: SIZE_VARIABLES_FDM_F NbRecords=0 SIZE_GEST_FDM_F=0 SIZE_VARIABLES_FDM_F=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if((trim(mode).EQ."memory_save").OR.(trim(mode).EQ."save")) then call MUMPS_FDM_STRUC_TO_MOD("F",id_FDM_F_ENCODING) endif if(trim(mode).EQ."memory_save") then CALL MUMPS_SAVE_RESTORE_FDM_STRUC( & FDM_F & ,unit,MYID,"memory_save" & ,SIZE_GEST_FDM_F & ,SIZE_VARIABLES_FDM_F & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) elseif(trim(mode).EQ."save") then CALL MUMPS_SAVE_RESTORE_FDM_STRUC( & FDM_F & ,unit,MYID,"save" & ,SIZE_GEST_FDM_F & ,SIZE_VARIABLES_FDM_F & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then CALL MUMPS_SAVE_RESTORE_FDM_STRUC( & FDM_F & ,unit,MYID,"restore" & ,SIZE_GEST_FDM_F & ,SIZE_VARIABLES_FDM_F & ,SIZE_INT, TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 endif if(trim(mode).EQ."memory_save") then C If the size to write (SIZE_VARIABLES) is greater than 2^31 C Subrecords are created which need to be taken into account in C the file size computation NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_FDM_F SIZE_GEST=SIZE_GEST+SIZE_GEST_FDM_F #if !defined(MUMPS_F2003) C If the file is not written with access="stream", which is only done in MUMPS_F2003, C the record length's is written at the beginning and at the end of each record C This is done using 2 INTEGERs so we use 2*SIZE_INT more space for each record SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call MUMPS_FDM_MOD_TO_STRUC("F",id_FDM_F_ENCODING,INFO(1)) 100 continue RETURN END SUBROUTINE MUMPS_SAVE_RESTORE_FRONT_DATA ! --------------------------------- MUMPS_SAVE_RESTORE_BLR_STRUC ----------------------------- ! SUBROUTINE MUMPS_SAVE_RESTORE_FDM_STRUC(FDM_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IMPLICIT NONE C ======= C Purpose C ======= C C This routine is designed to manage a BLR_STRUC_T structure (save, restore, compute memory) C C ========== C Parameters C ========== C C BLR_STRUC : TYPE (BLR_STRUC_T) : the main structure C C unit : The unit of the file to be written or read C C mode : the type of operation to be performed by the routine C memory_save = compute the size of the save file and of the structure C save = save the instace C restore = restore the instace C C TOTAL_FILE_SIZE : size of the file to be written or read C C TOTAL_STRUC_SIZE : size of the structure to be saved or restored C C SIZE_INT : size of an integer C C INFO1/INFO2 : copies of of INFO(1) and INFO(2) to allow save/restore of failled instaces C TYPE(FDM_STRUC_T) :: FDM_STRUC INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_FDM_STRUC_T PARAMETER (NBVARIABLES_FDM_STRUC_T = 3) CHARACTER(len=30), dimension(NBVARIABLES_FDM_STRUC_T):: & VARIABLES_FDM_STRUC_T CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_FDM_STRUC_T):: & SIZE_VARIABLES_FDM_STRUC_T INTEGER,dimension(NBVARIABLES_FDM_STRUC_T)::SIZE_GEST_FDM_STRUC_T INTEGER,dimension(NBVARIABLES_FDM_STRUC_T)::NbRecords_FDM_STRUC_T INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_FDM_STRUC_T(1)="NB_FREE_IDX" VARIABLES_FDM_STRUC_T(2)="STACK_FREE_IDX" VARIABLES_FDM_STRUC_T(3)="COUNT_ACCESS" SIZE_VARIABLES_FDM_STRUC_T(:)=0_8 SIZE_GEST_FDM_STRUC_T(:)=0 NbRecords_FDM_STRUC_T(:)=0 C C BEGINNING OF THE MAIN LOOP ON ALL VARIABLES OF THE STRUCTURE C DO i1=1,NBVARIABLES_FDM_STRUC_T TMP_STRING = VARIABLES_FDM_STRUC_T(i1) SELECT CASE(TMP_STRING) CASE("NB_FREE_IDX") NbRecords_FDM_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_FDM_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_FDM_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) FDM_STRUC%NB_FREE_IDX if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_FDM_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) FDM_STRUC%NB_FREE_IDX if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("STACK_FREE_IDX") NbRecords_FDM_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(FDM_STRUC%STACK_FREE_IDX)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%STACK_FREE_IDX,1)*SIZE_INT ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(FDM_STRUC%STACK_FREE_IDX)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%STACK_FREE_IDX,1)*SIZE_INT write(unit,iostat=err) & size(FDM_STRUC%STACK_FREE_IDX,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) FDM_STRUC%STACK_FREE_IDX ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(FDM_STRUC%STACK_FREE_IDX) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)=size_array1*SIZE_INT allocate(FDM_STRUC%STACK_FREE_IDX(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) FDM_STRUC%STACK_FREE_IDX endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("COUNT_ACCESS") NbRecords_FDM_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(FDM_STRUC%COUNT_ACCESS)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%COUNT_ACCESS,1)*SIZE_INT ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(FDM_STRUC%COUNT_ACCESS)) THEN SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)= & size(FDM_STRUC%COUNT_ACCESS,1)*SIZE_INT write(unit,iostat=err) & size(FDM_STRUC%COUNT_ACCESS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) FDM_STRUC%COUNT_ACCESS ELSE SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(FDM_STRUC%COUNT_ACCESS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_FDM_STRUC_T(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_FDM_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_FDM_STRUC_T(i1)=size_array1*SIZE_INT allocate(FDM_STRUC%COUNT_ACCESS(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) FDM_STRUC%COUNT_ACCESS endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then C If the size to write (SIZE_VARIABLES_FDM_STRUC_T(i1)) is greater than 2^31 C Subrecords are created which need to be taken into account in C the file size computation NbSubRecords=int(SIZE_VARIABLES_FDM_STRUC_T(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_FDM_STRUC_T(i1)=NbRecords_FDM_STRUC_T(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_FDM_STRUC_T(i1) & +int(SIZE_GEST_FDM_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_FDM_STRUC_T(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_FDM_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_FDM_STRUC_T(i1) & +int(SIZE_GEST_FDM_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_FDM_STRUC_T(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_FDM_STRUC_T) Local_SIZE_GEST=sum(SIZE_GEST_FDM_STRUC_T) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_FDM_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE MUMPS_SAVE_RESTORE_FDM_STRUC END MODULE MUMPS_FRONT_DATA_MGT_M MUMPS_5.4.1/src/smumps_gpu.c0000664000175000017500000000117314102210474016055 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "smumps_gpu.h" void MUMPS_CALL smumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.4.1/src/sfac_process_contrib_type2.F0000664000175000017500000004754214102210521021141 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_LOAD USE SMUMPS_BUF USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_FAC_LR, ONLY: SMUMPS_DECOMPRESS_PANEL USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR, & SMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NB_BLR_COLS, allocok, & NBROWS_PACKET_2PACK, PANEL_BEG_OFFSET INTEGER(8) :: LA_TEMP REAL, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), ALLOCATABLE, TARGET :: BLR_CB(:) INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE REAL, DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL SMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF ( SLAVE_NODE ) THEN IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL SMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL SMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 3, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ENDIF CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 200 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_REAL, & COMM, IERR ) CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ENDDO 200 CONTINUE CALL SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL SMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 4, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW+I-1 ), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW & ) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 300 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_REAL, & COMM, IERR ) CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH &) ENDDO 300 CONTINUE IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_REAL, & COMM, IERR ) CALL SMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL SMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL SMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) CALL SMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL SMUMPS_DM_FREE_BLOCK( DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE SMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.4.1/src/sfac_asm.F0000664000175000017500000010037014102210521015365 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON ) USE SMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON, IWPOSCB INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), STEP(N), PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)), ROWLIST(NBROWS) REAL A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW LOGICAL, INTENT(IN) :: IS_ofType5or6 INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER HF,HS, NSLAVES, NFRONT, NASS1, & IOLDPS, ISTCHK, LSTK, NSLSON,NELIM, & NPIVS,NCOLS,J1,JJ,JJ1,NROWS, & LDAFS_PERE, IBEG, DIAG INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (KEEP(50).EQ.0) THEN LDAFS_PERE = NFRONT ELSE IF ( NSLAVES .eq. 0 ) THEN LDAFS_PERE = NFRONT ELSE LDAFS_PERE = NASS1 ENDIF ENDIF HF = 6 + NSLAVES + KEEP(IXSZ) POSEL1 = POSELT - int(LDAFS_PERE,8) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) OPASSW = OPASSW + dble(NBROWS*NBCOLS) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DO JJ = 1, NBROWS DO JJ1 = 1, NBCOLS JJ2 = APOS + int(JJ1-1,8) A(JJ2)=A(JJ2)+VALSON(JJ1,JJ) ENDDO APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO 170 JJ = 1, NBROWS APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO 160 JJ1 = 1, NBCOLS JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 160 CONTINUE 170 CONTINUE ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DIAG = ROWLIST(1) DO JJ = 1, NBROWS DO JJ1 = 1, DIAG JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO DIAG = DIAG+1 APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO JJ = 1, NBROWS IF (ROWLIST(JJ).LE.NASS1.and..NOT.IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(JJ) - 1,8) DO JJ1 = 1, NELIM JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO IBEG = NELIM+1 ELSE IBEG = 1 ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, NBCOLS IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_MASTER SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) REAL :: RHS_MUMPS(KEEP(255)) REAL :: A(LA) INTEGER :: INTARR(KEEP8(27)) REAL :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) REAL A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG REAL, POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8)) + & VALSON(1:NBCOLS-IDIAG,I) APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE SMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB REAL A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO IPOSCB = IPOSCB + 1_8 ENDDO ENDIF ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE SMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB REAL A( LA ) REAL SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 DO I = 1, NELIM POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) IF (.NOT. CB_IS_COMPRESSED) THEN IPOSCB = 1_8 + int( I - 1, 8 ) * int(NCOLS,8) ENDIF DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_LDLT_ASM_NIV12 SUBROUTINE SMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_RESTORE_INDICES SUBROUTINE SMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) USE SMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON,IWPOSCB INTEGER NBCOLS INTEGER IW(LIW), STEP(N), & PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)) REAL A(LA) REAL VALSON(NBCOLS) DOUBLE PRECISION OPASSW INTEGER HF,HS, NSLAVES, NASS1, & IOLDPS, ISTCHK, & LSTK, NSLSON,NELIM,NPIVS,NCOLS, J1, & JJ1,NROWS INTEGER(8) POSELT, APOS, JJ2 INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(real(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = VALSON(JJ1) ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ASM_MAX SUBROUTINE SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) REAL, intent(inout) :: A(LA) REAL, intent(in) :: RHS_MUMPS(KEEP(255)) REAL, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(N), PTRARW(N) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: J18, J28, JJ8, JK8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS REAL ZERO PARAMETER( ZERO = 0.0E0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE DO WHILE (IN.GT.0) AINPUT8 = PTRARW(IN) JK8 = PTRAIW(IN) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE SMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: SMUMPS_IS_TRSM_LARGE_ENOUGH, & SMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF NCB = NFRONT-NASS1 IF (PARPIV_T1.EQ.-2) THEN IF ( & ( SMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( SMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF RETURN END SUBROUTINE SMUMPS_SET_PARPIVT1 LOGICAL FUNCTION SMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) SMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION SMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION SMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) SMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION SMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE SMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253 ) & IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 REAL, intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB REAL :: ZERO REAL :: RMAX PARAMETER( ZERO = 0.0E0 ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = real(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = RMAX ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = real(A(APOSMAX+int(I,8)-1_8)) DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = RMAX APOS = APOS+NFRONT_8 ENDDO ENDIF CALL SMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1) RETURN END SUBROUTINE SMUMPS_PARPIVT1_SET_MAX SUBROUTINE SMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) REAL, intent(inout):: PARPIV(LPARPIV) INTEGER :: I REAL :: EPS, RMIN, RZERO, RTMP LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0E0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) DO I = 1, LPARPIV RTMP = real(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN EPS = sqrt(epsilon(RZERO)) RMIN = min(RMIN, EPS) DO I = 1, LPARPIV RTMP = real(PARPIV(I)) IF (real(PARPIV(I)).EQ.RZERO) THEN PARPIV(I) = -RMIN ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE SMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) USE SMUMPS_FAC_FRONT_AUX_M, & ONLY: SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1 INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED REAL, intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL SMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253 ) ENDIF RETURN END SUBROUTINE SMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX MUMPS_5.4.1/src/cmumps_lr_data_m.F0000664000175000017500000036621714102210524017140 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_LR_DATA_M USE CMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: CMUMPS_BLR_END_FRONT, CMUMPS_BLR_INIT_MODULE, & CMUMPS_BLR_END_MODULE, CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_INIT, & CMUMPS_BLR_SAVE_PANEL_LORU, CMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & CMUMPS_BLR_SAVE_BEGS_BLR_C, CMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & CMUMPS_BLR_DEC_AND_RETRIEVE_L, CMUMPS_BLR_RETRIEVE_PANEL_LORU, & CMUMPS_BLR_DEC_AND_TRYFREE_L, CMUMPS_BLR_TRY_FREE_PANEL, & CMUMPS_BLR_FREE_CB_LRB, CMUMPS_BLR_FREE_ALL_PANELS, & CMUMPS_BLR_SAVE_CB_LRB, & CMUMPS_BLR_RETRIEVE_CB_LRB, CMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & CMUMPS_BLR_SAVE_BEGS_BLR_DYN, CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & CMUMPS_BLR_RETRIEVE_NB_PANELS, CMUMPS_BLR_EMPTY_PANEL_LORU, & CMUMPS_BLR_SAVE_NFS4FATHER, CMUMPS_BLR_RETRIEVE_NFS4FATHER, & CMUMPS_BLR_SAVE_M_ARRAY, CMUMPS_BLR_RETRIEVE_M_ARRAY, & CMUMPS_BLR_FREE_M_ARRAY & , CMUMPS_BLR_STRUC_TO_MOD, CMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if ! defined(MUMPS_F2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , CMUMPS_BLR_SAVE_DIAG_BLOCK, CMUMPS_BLR_RETRIEVE_DIAG_BLOCK & , CMUMPS_SAVE_RESTORE_BLR TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type COMPLEX, POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER REAL, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) CONTAINS SUBROUTINE CMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_INIT_MODULE SUBROUTINE CMUMPS_BLR_END_MODULE(INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP LOGICAL :: IS_FIXME_ALREADY_PRINTED IS_FIXME_ALREADY_PRINTED = .FALSE. IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL CMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) ELSE CALL CMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_END_MODULE SUBROUTINE CMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_MOD_TO_STRUC SUBROUTINE CMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE CMUMPS_BLR_STRUC_TO_MOD SUBROUTINE CMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE CMUMPS_BLR_INIT_FRONT SUBROUTINE CMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in CMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in CMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE CMUMPS_BLR_SAVE_INIT SUBROUTINE CMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & "NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN IF (NEEDS_THREAD_SAFETY) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ELSE KEEP8(71) = KEEP8(71) - MEM_FREED KEEP8(73) = KEEP8(73) - MEM_FREED KEEP8(69) = KEEP8(69) - MEM_FREED ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), KEEP8) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE CMUMPS_BLR_END_FRONT SUBROUTINE CMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE CMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE CMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE CMUMPS_BLR_SAVE_CB_LRB SUBROUTINE CMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D ) COMPLEX,POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE CMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE CMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE CMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE CMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in CMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 RETURN END SUBROUTINE CMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION CMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF CMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in CMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF CMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION CMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in CMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE CMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) COMPLEX, POINTER, INTENT(OUT) :: THEBLOCK(:) #else COMPLEX, POINTER :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in CMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in CMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE CMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE CMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE CMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE CMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in CMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE CMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) REAL, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE CMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE CMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) REAL, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #else REAL, DIMENSION(:), POINTER :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE CMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE CMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE CMUMPS_BLR_FREE_M_ARRAY SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 CALL CMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8) RETURN END SUBROUTINE CMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE CMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE CMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in CMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in CMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) CALL DEALLOC_LRB(THELRB,KEEP8) ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE CMUMPS_BLR_FREE_CB_LRB SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE CMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if((trim(mode).EQ."memory_save").OR.(trim(mode).EQ."save")) then call CMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(trim(mode).EQ."memory_save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL CMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL CMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call CMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_BLR SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_STRUC_T PARAMETER (NBVARIABLES_BLR_STRUC_T = 15) CHARACTER(len=30), dimension(NBVARIABLES_BLR_STRUC_T):: & VARIABLES_BLR_STRUC_T CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords,Local_NbRecords INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 VARIABLES_BLR_STRUC_T(1)="IsSYM" VARIABLES_BLR_STRUC_T(2)="IsT2" VARIABLES_BLR_STRUC_T(3)="IsSLAVE" VARIABLES_BLR_STRUC_T(4)="PANELS_L" VARIABLES_BLR_STRUC_T(5)="PANELS_U" VARIABLES_BLR_STRUC_T(6)="CB_LRB" VARIABLES_BLR_STRUC_T(7)="BEGS_BLR_STATIC" VARIABLES_BLR_STRUC_T(8)="BEGS_BLR_DYNAMIC" VARIABLES_BLR_STRUC_T(9)="BEGS_BLR_L" VARIABLES_BLR_STRUC_T(10)="BEGS_BLR_COL" VARIABLES_BLR_STRUC_T(11)="NB_ACCESSES_INIT" VARIABLES_BLR_STRUC_T(12)="NB_PANELS" VARIABLES_BLR_STRUC_T(13)="DIAG_BLOCKS" VARIABLES_BLR_STRUC_T(14)="NFS4FATHER" VARIABLES_BLR_STRUC_T(15)="M_ARRAY" SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T TMP_STRING = VARIABLES_BLR_STRUC_T(i1) SELECT CASE(TMP_STRING) CASE("IsSYM") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsT2") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsSLAVE") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_STATIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_DYNAMIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_L") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_COL") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_ACCESSES_INIT") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_PANELS") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("PANELS_L") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE("PANELS_U") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE("CB_LRB") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"memory_save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"restore" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE("DIAG_BLOCKS") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL CMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL CMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE("NFS4FATHER") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("M_ARRAY") if(trim(mode).EQ."restore") then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE CMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_LRB_TYPE PARAMETER (NBVARIABLES_LRB_TYPE = 6) CHARACTER(len=30), dimension(NBVARIABLES_LRB_TYPE):: & VARIABLES_LRB_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_LRB_TYPE(1)="Q" VARIABLES_LRB_TYPE(2)="R" VARIABLES_LRB_TYPE(3)="K" VARIABLES_LRB_TYPE(4)="M" VARIABLES_LRB_TYPE(5)="N" VARIABLES_LRB_TYPE(6)="ISLR" SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE TMP_STRING = VARIABLES_LRB_TYPE(i1) SELECT CASE(TMP_STRING) CASE("Q") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("R") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("K") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("M") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("N") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("ISLR") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_LRB SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_PANEL_TYPE PARAMETER (NBVARIABLES_BLR_PANEL_TYPE = 2) CHARACTER(len=30), dimension(NBVARIABLES_BLR_PANEL_TYPE):: & VARIABLES_BLR_PANEL_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords,Local_NbRecords INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL VARIABLES_BLR_PANEL_TYPE(1)="NB_ACCESSES_LEFT" VARIABLES_BLR_PANEL_TYPE(2)="LRB_PANEL" SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE TMP_STRING = VARIABLES_BLR_PANEL_TYPE(i1) SELECT CASE(TMP_STRING) CASE("NB_ACCESSES_LEFT") NbRecords_BLR_PANEL_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE("LRB_PANEL") if(trim(mode).EQ."memory_save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL CMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE CMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_DIAG_BLOCK_TYPE PARAMETER (NBVARIABLES_DIAG_BLOCK_TYPE = 1) CHARACTER(len=30), dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & VARIABLES_DIAG_BLOCK_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_DIAG_BLOCK_TYPE(1)="DIAG_BLOCK" SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE TMP_STRING = VARIABLES_DIAG_BLOCK_TYPE(i1) SELECT CASE(TMP_STRING) CASE("DIAG_BLOCK") NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(trim(mode).EQ."restore") then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_DIAG_BLOCK END MODULE CMUMPS_LR_DATA_M MUMPS_5.4.1/src/cmumps_gpu.h0000664000175000017500000000114314102210474016037 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef CMUMPS_GPU_H #define CMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL cmumps_gpu_return(); #endif /* CMUMPS_GPU_H */ MUMPS_5.4.1/src/cmumps_sol_es.F0000664000175000017500000007012614102210524016471 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SOL_ES PRIVATE PUBLIC:: PRUNED_SIZE_LOADED PUBLIC:: CMUMPS_CHAIN_PRUN_NODES PUBLIC:: CMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: CMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: CMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: CMUMPS_TREE_PRUN_NODES PUBLIC:: CMUMPS_TREE_PRUN_NODES_STATS PUBLIC:: CMUMPS_SOL_ES_INIT INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK INTEGER(8) :: PRUNED_SIZE_LOADED INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE CMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF RETURN END SUBROUTINE CMUMPS_SOL_ES_INIT SUBROUTINE CMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(KEEP28), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE CMUMPS_TREE_PRUN_NODES SUBROUTINE CMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(nb_nodes_RHS) INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER :: Pruned_SONS(KEEP28) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE CMUMPS_CHAIN_PRUN_NODES SUBROUTINE CMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE CMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE CMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in CMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) RETURN END SUBROUTINE CMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION CMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN CMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN CMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE CMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV+1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE CMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION CMUMPS_LOCAL_FACTOR_SIZE INTEGER(8) FUNCTION CMUMPS_LOCAL_FACTOR_SIZE_BLR(IW,LIW,PTR, & LRSTATUS, IWHANDLER, & PHASE, LDLT, IS_ROOT) USE CMUMPS_LR_DATA_M USE CMUMPS_LR_TYPE INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: LRSTATUS, IWHANDLER INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW, FACTOR_SIZE INTEGER :: NB_PANELS, IPANEL, LorU, IBLOCK LOGICAL :: LR_ACTIVATED TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: LRB_PANEL NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB LR_ACTIVATED=(LRSTATUS.GE.2) IF (LR_ACTIVATED) THEN FACTOR_SIZE = 0_8 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IWHANDLER, NB_PANELS) IF (LDLT.EQ.0) THEN LorU = PHASE ELSE LorU = 0 ENDIF DO IPANEL=1,NB_PANELS IF (IS_ROOT.AND.IPANEL.EQ.NB_PANELS) THEN CYCLE ENDIF IF (CMUMPS_BLR_EMPTY_PANEL_LORU(IWHANDLER, LorU, IPANEL)) & THEN CYCLE ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU(IWHANDLER, LorU, & IPANEL, LRB_PANEL) IF (size(LRB_PANEL).GT.0) THEN IF (PHASE.EQ.0) THEN FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)-1_8)/2_8 ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)+1_8)/2_8 ENDIF ENDIF DO IBLOCK=1,size(LRB_PANEL) IF (LRB_PANEL(IBLOCK)%ISLR) THEN FACTOR_SIZE = FACTOR_SIZE + int(LRB_PANEL(IBLOCK)%K,8)* & int(LRB_PANEL(IBLOCK)%M+LRB_PANEL(IBLOCK)%M,8) ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(IBLOCK)%M*LRB_PANEL(IBLOCK)%N,8) ENDIF ENDDO ENDDO CMUMPS_LOCAL_FACTOR_SIZE_BLR = FACTOR_SIZE ELSE CMUMPS_LOCAL_FACTOR_SIZE_BLR = & CMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, PTR, PHASE, LDLT, IS_ROOT) ENDIF RETURN END FUNCTION CMUMPS_LOCAL_FACTOR_SIZE_BLR SUBROUTINE CMUMPS_TREE_PRUN_NODES_STATS(MYID, N, KEEP28, KEEP201, & FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC) INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, MYID, N INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INTEGER I, ISTEP INTEGER(8) :: Pruned_Size IF (KEEP201 .GT. 0) THEN Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDDO PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF RETURN END SUBROUTINE CMUMPS_TREE_PRUN_NODES_STATS SUBROUTINE CMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) IF (KEEP201 .GT. 0) THEN Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDIF ENDDO IF (KEEP201.GT.0) THEN IF (FR_FACT .NE. 0_8) THEN PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_CHAIN_PRUN_NODES_STATS END MODULE CMUMPS_SOL_ES SUBROUTINE CMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " CMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN CMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " CMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " CMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE CMUMPS_PERMUTE_RHS_GS SUBROUTINE CMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE CMUMPS_PERMUTE_RHS_AM1 SUBROUTINE CMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE, & PERM_PO LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & LOAD_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in CMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in CMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) LOAD_PROCS = 0 USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO IF(reorder) THEN posintmprhs = 0 ALLOCATE(PERM_PO(N),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO J=1,N PERM_PO(SYM_PERM(J))=J END DO nblocks = N/NBRHS DO I = 1, nblocks USED = .FALSE. DO J=1, NBRHS USED(TMP_RHS(NBRHS*(I-1)+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END DO IF(mod(N,NBRHS).NE.0) THEN USED = .FALSE. DO J=1, mod(N,NBRHS) USED(TMP_RHS(NBRHS*nblocks+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END IF DEALLOCATE(PERM_PO) ELSE PERM_RHS = TMP_RHS END IF DEALLOCATE(TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & USED, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE) RETURN END SUBROUTINE CMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.4.1/src/mumps_thread_affinity.c0000664000175000017500000000114314102210474020234 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_thread_affinity.h" void MUMPS_CALL MUMPS_THREAD_AFFINITY_RETURN() { /* * Thread affinity tools will be available in the future. */ } MUMPS_5.4.1/src/dsol_c.F0000664000175000017500000023575714102210522015077 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOL_C(root, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, POSINRHSCOMP_BWD, & NZ_RHS, NBCOL_INBLOC, NRHS_ORIG, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS & ) USE DMUMPS_OOC USE DMUMPS_SOL_ES USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( DMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) DOUBLE PRECISION, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSCOMP, NB_FS_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT DOUBLE PRECISION A(LA), W(LWC), & W2(KEEP(133)) DOUBLE PRECISION :: RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP_FWD(N), & POSINRHSCOMP_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IERR INTEGER(8) :: IAPOS INTEGER IOLDPS, & LOCAL_M, & LOCAL_N #if defined(V_T) INTEGER soln_c_class, forw_soln, back_soln, root_soln #endif LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL SWITCH_OFF_ES LOGICAL DUMMY_BOOL INTEGER :: IDUMMY DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS INTEGER nb_nodes_RHS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER nb_prun_roots, JAM1 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in DMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. SWITCH_OFF_ES = .FALSE. IF ( KEEP(111).NE.0 .OR. KEEP(252).NE.0 ) THEN DOFORWARD = .FALSE. ENDIF IF (KEEP(221).eq.1) DOBACKWARD = .FALSE. IF (KEEP(221).eq.2) DOFORWARD = .FALSE. IF ( KEEP(60).EQ.0 .AND. & ( & (KEEP(38).NE.0 .AND. root%yes) & .OR. & (KEEP(20).NE.0 .AND. MYID_NODES.EQ.MASTER_ROOT) & ) & .AND. KEEP(252).EQ.0 & ) &THEN DOROOT = .TRUE. ELSE DOROOT = .FALSE. ENDIF DOROOT_BWD_PANEL = DOROOT .AND. MTYPE.NE.1 .AND. KEEP(50).EQ.0 & .AND. KEEP(201).EQ.1 DOROOT_FWD_OOC = DOROOT .AND. .NOT.DOROOT_BWD_PANEL AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN = (Exploit_Sparsity.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity = .FALSE. DO_PRUN = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in DMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF IF ( DO_PRUN ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN ) THEN nb_prun_nodes = 0 nb_prun_roots = 0 Pruned_SONS(:) = -1 IF ( Exploit_Sparsity ) THEN nb_nodes_RHS = 0 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ELSE IF ( AM1 ) THEN nb_nodes_RHS = 0 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF CALL DMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) CALL DMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL DMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity) MODE_RHS_BOUNDS = 2 CALL DMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL DMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL DMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) SWITCH_OFF_ES = .TRUE. ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF CALL DMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) IF (DO_PRUN) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM DMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=TIME_FWD + DKEEP(117) ENDIF IF (DO_PRUN.AND.SWITCH_OFF_ES) THEN DO_PRUN = .FALSE. Exploit_Sparsity = .FALSE. IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF IF ( DOBACKWARD .AND. DO_PRUN ) THEN nb_prun_leaves = 0 IF ( Exploit_Sparsity .AND. (KEEP(111).EQ.0) ) THEN nb_nodes_RHS = nb_prun_roots ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nodes_RHS(1:nb_prun_roots)=Pruned_Roots(1:nb_prun_roots) DEALLOCATE(Pruned_Roots) ELSE nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF IF ( Exploit_Sparsity ) THEN CALL DMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) CALL DMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL DMUMPS_TREE_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), & KEEP8(31), & STEP, & Pruned_List, & nb_prun_nodes, OOC_FCT_TYPE_TMP) ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after DMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL DMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after DMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=TIME_SpecialRoot + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity.AND.(KEEP(111).EQ.0) ) & .OR. AM1 ) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN OOC_STATE_NODE(STEP(KEEP(38)))=-4 ENDIF ENDIF IF (Exploit_Sparsity.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = AM1 IF ( AM1 ) THEN CALL DMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL DMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL DMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL DMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL DMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL DMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSCOMP_F.NE.NB_FS_IN_RHSCOMP_TOT)) THEN DO I =1, N II = POSINRHSCOMP_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSCOMP_F)) THEN DO K=1,NRHS RHSCOMP(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( DO_PRUN & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF CALL DMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & ) CALL DMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=TIME_BWD+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSCOMP,1).GT.0) & WRITE (MP,99993) (RHSCOMP(I,1),I=1,K) IF (size(RHSCOMP,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (Exploit_Sparsity.OR.AM1.OR.SWITCH_OFF_ES) THEN IF ( allocated(nodes_RHS)) DEALLOCATE (nodes_RHS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5D14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5D14.6)) 99992 FORMAT (//' LEAVING SOLVE (DMUMPS_SOL_C) WITH') END SUBROUTINE DMUMPS_SOL_C SUBROUTINE DMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSCOMP DOUBLE PRECISION RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSCOMP, POSINRHSCOMP(LPOS_N) DOUBLE PRECISION, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER :: JCOL_RHS INTEGER :: K242 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in DMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in DMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL DMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL DMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL DMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_DOUBLE_PRECISION, & COMM, IERR) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO ENDIF ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE DMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: LOCAL_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN LOCAL_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LOCAL_LSCAL) THEN RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSCOMP= POSINRHSCOMP(IW(J1)) DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL DMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE DMUMPS_NPIV_BLOCK_ADD SUBROUTINE DMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE DMUMPS_NPIV_BLOCK_SEND END SUBROUTINE DMUMPS_GATHER_SOLUTION SUBROUTINE DMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSCOMP, LRHSCOMP, NRHSCOMP_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, & LSCAL, SCALING, LSCALING, & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSCOMP, LPOS_ROW, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSCOMP, NRHSCOMP_COL DOUBLE PRECISION, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSCOMP INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP(LPOS_ROW) DOUBLE PRECISION :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSCOMP INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in DMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(II) IF (IPOSINRHSCOMP.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL DMUMPS_AM1_BLOCK_ADD ( .TRUE. ) IRHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & I RHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & RHS_SPARSE_COPY(IZ) K = K+1 ELSE CALL DMUMPS_AM1_BLOCK_ADD ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL DMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_PRECISION, & COMM, IERR) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE DMUMPS_AM1_BLOCK_ADD ( SCALE_ONLY ) LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN III = I IF (KEEP(23).NE.0) III = UNS_PERM_INV(I) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS_SPARSE_COPY(IZ)*SCALING(III) ENDIF RETURN ENDIF CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_PRECISION, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL DMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE DMUMPS_AM1_BLOCK_ADD SUBROUTINE DMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE DMUMPS_AM1_BLOCK_SEND END SUBROUTINE DMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE DMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, scaling_data, LSCAL & , IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) LOGICAL LSCAL LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_DISTSOL_INDICES SUBROUTINE DMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSCOMP, LRHSCOMP, NBRHS_EFF, & POSINRHSCOMP, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t TYPE (scaling_data_t) :: scaling_data LOGICAL LSCAL INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSCOMP INTEGER POSINRHSCOMP(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS DOUBLE PRECISION SOL_LOC( LSOL_LOC, NRHS ) DOUBLE PRECISION RHSCOMP( LRHSCOMP, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSCOMP, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: ROOT !$ LOGICAL :: OMP_FLAG DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN ROOT=.false. IF (KEEP(38).ne.0) ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) ROOT = STEP(KEEP(20))==ISTEP IF ( ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSCOMP) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE DMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSCOMP, NCOL_RHSCOMP INTEGER ICNTL(60), INFO(80) DOUBLE PRECISION, intent(in) :: RHS (LRHS, NCOL_RHS) DOUBLE PRECISION, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), NB_FS_IN_RHSCOMP_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_DOUBLE_PRECISION, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_DOUBLE_PRECISION, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL DMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL DMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE DMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_PRECISION, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_PRECISION, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSCOMP( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE DMUMPS_GET_BUF_INDX_RHS END SUBROUTINE DMUMPS_SCATTER_RHS SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & NBENT_RHSCOMP, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP, NB_FS_IN_RHSCOMP INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 ENDDO IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) = IPOSINRHSCOMP+JJ-JCOL ENDDO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO NB_FS_IN_RHSCOMP = IPOSINRHSCOMP -1 IF (POSINRHSCOMP_COL_ALLOC) IPOSINRHSCOMP_COL=IPOSINRHSCOMP IF (IPOSINRHSCOMP.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(J1+JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN POSINRHSCOMP_COL(IW(JCOL+JJ)) = - IPOSINRHSCOMP_COL IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSCOMP = IPOSINRHSCOMP - 1 IF (POSINRHSCOMP_COL_ALLOC) & NBENT_RHSCOMP = max(NBENT_RHSCOMP, IPOSINRHSCOMP_COL-1) RETURN END SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP_AM1 & (NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, SIZE_UNS_PERM_INV & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW, & SIZE_UNS_PERM_INV INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP INTEGER, intent(out):: NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER I, JAM1 INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSCOMP_ROW, IPOSINRHSCOMP_COL INTEGER NBENT_RHSCOMP_ROW, NBENT_RHSCOMP_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF(KEEP(237).EQ.0) THEN WRITE(*,*)'BUILD_POSINRHSCOMP_SPARSE available for A-1 only !' CALL MUMPS_ABORT() END IF POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP_ROW = 0 IPOSINRHSCOMP_COL = 0 DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_ROW(IW(J1)).EQ.0) THEN DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) & = IPOSINRHSCOMP_ROW + JJ - J1 + 1 ENDDO IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + NPIV IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) & = - N - (IPOSINRHSCOMP_COL + JJ - JCOL + 1) ENDDO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ENDIF ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO NB_FS_IN_RHSCOMP_FWD = IPOSINRHSCOMP_ROW IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_COL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ))) = & IPOSINRHSCOMP_COL+JJ-JCOL+1 END DO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ELSE IF (POSINRHSCOMP_COL(ABSJCOL).LT.-N) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ)))= & -(N+POSINRHSCOMP_COL(abs(IW(JJ)))) END DO ELSE IF ((POSINRHSCOMP_COL(ABSJCOL).LT.0).AND. & (POSINRHSCOMP_COL(ABSJCOL).GE.-N))THEN WRITE(*,*)'Internal error 7 in BUILD...SPARSE' CALL MUMPS_ABORT() ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSCOMP_TOT = IPOSINRHSCOMP_COL IF (NSLAVES.NE.1) THEN DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + 1 POSINRHSCOMP_ROW(IW(JJ+J1)) & = -IPOSINRHSCOMP_ROW END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = -IPOSINRHSCOMP_COL ELSE IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).LT.-N) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = POSINRHSCOMP_COL(IW(JCOL+JJ)) + N END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSCOMP_ROW = IPOSINRHSCOMP_ROW NBENT_RHSCOMP_COL = IPOSINRHSCOMP_COL NBENT_RHSCOMP = max(NBENT_RHSCOMP_ROW,NBENT_RHSCOMP_COL) RETURN END SUBROUTINE DMUMPS_BUILD_POSINRHSCOMP_AM1 MUMPS_5.4.1/src/mumps_size.c0000664000175000017500000000220714102210474016050 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Utility to automatically get the sizes of Fortran types */ #include "mumps_size.h" void MUMPS_CALL MUMPS_SIZE_C(char *a, char *b, MUMPS_INT8 *diff) { *diff = (MUMPS_INT8) (b - a); } void MUMPS_CALL MUMPS_ADDR_C(char *a, MUMPS_INT8 *addr) { *addr=*(MUMPS_INT8*)&a; /* With the form "*addr=(MUMPS_INT8)a", "(MUMPS_INT8)a" and "a" may have different binary representations for large addresses. In the above code, "(MUMPS_INT8*)&a" is a pointer to the address "a", considering that "a" is a MUMPS_INT8 rather than an address. Then the content of that pointer is the exact binary representation of the address a, but stored in a MUMPS_INT8 (signed 64-bit integer). */ } MUMPS_5.4.1/src/cend_driver.F0000664000175000017500000003735114102210526016112 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_END_DRIVER( id ) USE CMUMPS_OOC USE CMUMPS_STRUC_DEF USE CMUMPS_BUF IMPLICIT NONE include 'mpif.h' TYPE( CMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR INTEGER MASTER PARAMETER ( MASTER = 0 ) C Explicit needed because of pointer arguments INTERFACE SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES END INTERFACE I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C ---------------------------------- C Special stuff for implementations C where MPI_CANCEL does not exist or C is not correctly implemented. C At the moment, this is only C required for the slaves. C ---------------------------------- IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL CMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. id%root%yes ) THEN CALL blacs_gridexit( id%root%CNTXT_BLACS ) id%root%gridinit_done = .FALSE. END IF END IF IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. (This was the case on the C old SP2 in Bonn.) CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF C ----------------------------------- C Right-hand-side is always user data C We do not free it. C ----------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C C C C --------------------------------- C Allocated by CMUMPS, Used by user. C CMUMPS deallocates. User should C use them before CMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) C C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C ------------------------------------------------ C For hybrid host and element entry, C and DBLARR have not been allocated C on the master except if there was scaing. C ------------------------------------------------ IF (id%KEEP(46).eq.1 .and. & id%KEEP(55).ne.0 .and. & id%MYID .eq. MASTER .and. & id%KEEP(52) .eq. 0 ) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF IF (associated(id%INTARR)) THEN DEALLOCATE(id%INTARR) NULLIFY(id%INTARR) ENDIF IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF C IPIV is used both for ScaLAPACK and RR C Keep it outside CMUMPS_RR_FREE_POINTERS IF (associated(id%root%IPIV)) THEN DEALLOCATE(id%root%IPIV) NULLIFY(id%root%IPIV) ENDIF IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(id%root%RHS_ROOT))THEN DEALLOCATE(id%root%RHS_ROOT) NULLIFY(id%root%RHS_ROOT) ENDIF CALL CMUMPS_RR_FREE_POINTERS(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C id%CANDIDATES,id%I_AM_CAND and id%ISTEP_TO_INIV2 C can be allocated on non-working master C in the case of arrowheads distribution IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF c IF (id%KEEP(201).GT.0) THEN IF(associated (id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated (id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated (id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated (id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF IF(associated (id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF c ENDIF ! IF(id%KEEP(486).NE.0) THEN IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF CALL CMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%MPITOOMP_PROCS_MAP)) THEN DEALLOCATE(id%MPITOOMP_PROCS_MAP) NULLIFY(id%MPITOOMP_PROCS_MAP) ENDIF IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C ---------------------------------------------- C Deallocate S only after finishing the receives C (S is normally the largest memory available) C ---------------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) DEALLOCATE(id%S) ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL CMUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL CMUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C Mapping information used during solve IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF RETURN END SUBROUTINE CMUMPS_END_DRIVER SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE CMUMPS_LR_DATA_M, only : CMUMPS_BLR_STRUC_TO_MOD, & CMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL CMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL CMUMPS_BLR_END_MODULE(0, KEEP8, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES MUMPS_5.4.1/src/ana_orderings_wrappers_m.F0000664000175000017500000011036514102210475020700 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE CONTAINS #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto32( NCMP, IPE8, IW, FRERE, & NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), FRERE(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS), IW(:) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER(8) :: IPE8(:) INTEGER,ALLOCATABLE, DIMENSION(:) :: IPE INTEGER :: allocok IF (IPE8(NCMP+1) .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR( & IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NCMP+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1), NCMP+1, IPE) CALL METIS_NODEWND(NCMP, IPE, IW(1),FRERE(1), & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) RETURN END SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto32 SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32( NCMP, IPE8, IW, NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER,ALLOCATABLE, DIMENSION(:) :: IPE INTEGER :: allocok IF (IPE8(NCMP+1) .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR( & IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NCMP+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1), NCMP+1, IPE) CALL METIS_NODEND(NCMP, IPE, IW(1), & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) DEALLOCATE(IPE) RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32 #else SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32( NCMP, IPE8, IW, FRERE, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, IKEEP1(:), IKEEP2(:), FRERE(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER,ALLOCATABLE, DIMENSION(:) :: IPE INTEGER :: allocok IF (IPE8(NCMP+1) .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR( & IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NCMP+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1), NCMP+1, IPE) CALL METIS_NODEND( NCMP, IPE, IW(1), FRERE(1), & OPTIONS_METIS, IKEEP2(1), IKEEP1(1)) DEALLOCATE(IPE) RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto32 #endif #endif #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto64( NCMP, IPE8, IW, FRERE, & NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK, KEEP10, INPLACE64_GRAPH_COPY ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), FRERE(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS), IW(:) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, FRERE8, & IKEEP18, IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEWND(NCMP, IPE8(1), IW(1),FRERE, & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8(NCMP+1)-1_8) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* ( IPE8(NCMP+1)-1_8 ) & , INFO(2) & ) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), IPE8(NCMP+1)-1_8, IW8 ) ENDIF ALLOCATE(FRERE8(NCMP), & IKEEP18(NCMP), IKEEP28(NCMP), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* ( 3_8*int(NCMP,8) ) & , INFO(2) & ) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in METIS_NODEWND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64 (FRERE, NCMP , FRERE8) IF (INPLACE64_GRAPH_COPY) THEN CALL METIS_NODEWND(NCMP, IPE8(1), IW(1),FRERE8, & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) ELSE CALL METIS_NODEWND(NCMP, IPE8(1), IW8,FRERE8, & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) ENDIF CALL MUMPS_ICOPY_64TO32(IKEEP18, NCMP, IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28, NCMP, IKEEP2(1)) IF (INPLACE64_GRAPH_COPY) THEN DEALLOCATE(FRERE8, IKEEP18, IKEEP28) ELSE DEALLOCATE(IW8, FRERE8, IKEEP18, IKEEP28) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_METIS_NODEWND_MIXEDto64 SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64( NCMP, IPE8, IW, NUMFLAG, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK, KEEP10, & LIW8, INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH & ) IMPLICIT NONE INTEGER :: INFO(2), LOPTIONS_METIS INTEGER :: NCMP, NUMFLAG, IKEEP1(:), IKEEP2(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER(8) :: LIW8 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, & IKEEP18, IKEEP28 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEND(NCMP, IPE8(1), IW(1), & NUMFLAG, OPTIONS_METIS, & IKEEP2(1), IKEEP1(1) ) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8(NCMP+1)-1_8) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP10,8)* & ( IPE8(NCMP+1)-1_8+2_8*int(NCMP,8) ) & , INFO(2) ) IF (LPOK) WRITE(LP,'(A)') & "ERROR 1 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), IPE8(NCMP+1)-1_8, IW8 ) ENDIF ALLOCATE(IKEEP18(NCMP), IKEEP28(NCMP), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP10,8)* & 2_8*int(NCMP,8), INFO(2) ) IF (LPOK) WRITE(LP,'(A)') & "ERROR 2 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF IF (INPLACE64_GRAPH_COPY) THEN CALL METIS_NODEND(NCMP, IPE8(1), IW(1), & NUMFLAG, OPTIONS_METIS, & IKEEP28, IKEEP18 ) ELSE CALL METIS_NODEND(NCMP, IPE8(1), IW8, & NUMFLAG, OPTIONS_METIS, & IKEEP28, IKEEP18 ) ENDIF CALL MUMPS_ICOPY_64TO32(IKEEP18, NCMP, IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28, NCMP, IKEEP2(1)) IF (INPLACE64_GRAPH_COPY) THEN IF (INPLACE64_RESTORE_GRAPH) THEN CALL MUMPS_ICOPY_64TO32_64C_IP(IW(1), IPE8(NCMP+1)-1_8) ENDIF DEALLOCATE(IKEEP18, IKEEP28) ELSE DEALLOCATE(IW8, IKEEP18, IKEEP28) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64 #else SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64( NCMP, IPE8, IW, FRERE, & OPTIONS_METIS, LOPTIONS_METIS, IKEEP2, IKEEP1, INFO, & LP, LPOK, KEEP10, & LIW8, INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH & ) IMPLICIT NONE INTEGER :: INFO(2) INTEGER :: LOPTIONS_METIS INTEGER :: NCMP, IKEEP1(:), IKEEP2(:), FRERE(:), IW(:) INTEGER :: OPTIONS_METIS(LOPTIONS_METIS) INTEGER(8) :: IPE8(:) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER(8) :: LIW8 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IW8, FRERE8, & IKEEP18, IKEEP28, & OPTIONS_METIS8 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL METIS_NODEND( NCMP, IPE8(1), IW(1), FRERE(1), & OPTIONS_METIS, IKEEP2(1), IKEEP1(1) ) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8(NCMP+1)-1_8) ELSE ALLOCATE(IW8(IPE8(NCMP+1)-1_8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( int(KEEP10,8) * (IPE8(NCMP+1)-1_8) & , INFO(2) ) IF (LPOK) WRITE(LP,'(A)') & "ERROR 1 memory allocation in METIS_METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), IPE8(NCMP+1)-1_8, IW8 ) ENDIF ALLOCATE(FRERE8(NCMP), & IKEEP18(NCMP), IKEEP28(NCMP), & OPTIONS_METIS8(LOPTIONS_METIS), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* & (3_8*int(NCMP,8)+int(LOPTIONS_METIS,8)) & , INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR 2 memory allocation in METIS_NODEND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64 (FRERE(1), NCMP, FRERE8) CALL MUMPS_ICOPY_32TO64 (OPTIONS_METIS, LOPTIONS_METIS, & OPTIONS_METIS8) IF (INPLACE64_GRAPH_COPY) THEN CALL METIS_NODEND( int(NCMP,8), IPE8(1), IW(1), FRERE8, & OPTIONS_METIS8, IKEEP28, IKEEP18 ) ELSE CALL METIS_NODEND( int(NCMP,8), IPE8(1), IW8, FRERE8, & OPTIONS_METIS8, IKEEP28, IKEEP18 ) ENDIF CALL MUMPS_ICOPY_64TO32(IKEEP18, NCMP, IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28, NCMP, IKEEP2(1)) IF (INPLACE64_GRAPH_COPY) THEN IF (INPLACE64_RESTORE_GRAPH) THEN CALL MUMPS_ICOPY_64TO32_64C_IP(IW(1), IPE8(NCMP+1)-1_8) ENDIF DEALLOCATE(FRERE8, IKEEP18, IKEEP28, OPTIONS_METIS8) ELSE DEALLOCATE(IW8, FRERE8, IKEEP18, IKEEP28, OPTIONS_METIS8) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_METIS_NODEND_MIXEDto64 #endif #endif #if defined(scotch) || defined(ptscotch) SUBROUTINE MUMPS_SCOTCH_MIXEDto32(NCMP, LIW8, IPE8, PARENT, IWFR8, & PTRAR, IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED) IMPLICIT NONE INTEGER, INTENT(IN) :: NCMP INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(INOUT) :: IPE8(:) INTEGER, INTENT(OUT) :: PARENT(NCMP) INTEGER(8), INTENT(IN) :: IWFR8 INTEGER :: PTRAR(NCMP) INTEGER :: IW(:) INTEGER :: IWL1(NCMP) INTEGER, INTENT(OUT) :: IKEEP1(:) INTEGER, INTENT(OUT) :: IKEEP2(:) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: WEIGHTUSED INTEGER, INTENT(IN) :: WEIGHTREQUESTED INTEGER, DIMENSION(:), ALLOCATABLE :: IPE INTEGER :: allocok IF (IWFR8 .GE. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR(IPE8(NCMP+1), INFO(2)) RETURN ENDIF ALLOCATE(IPE(NCMP+1), stat=allocok) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto32" INFO(1) = -7 INFO(2) = NCMP+1 RETURN ENDIF CALL MUMPS_ICOPY_64TO32(IPE8(1),NCMP+1,IPE) CALL MUMPS_SCOTCH( NCMP, int(LIW8), IPE, int(IWFR8), & PTRAR, IW(1), IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, & WEIGHTUSED, WEIGHTREQUESTED ) PARENT(1:NCMP)=IPE(1:NCMP) DEALLOCATE(IPE) RETURN END SUBROUTINE MUMPS_SCOTCH_MIXEDto32 SUBROUTINE MUMPS_SCOTCH_MIXEDto64( & NCMP, LIW8, IPE8, PARENT, IWFR8, & PTRAR, IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP10, & INPLACE64_GRAPH_COPY, & WEIGHTUSED, WEIGHTREQUESTED ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCMP INTEGER(8), INTENT(IN) :: LIW8 INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(INOUT) :: IPE8(:) INTEGER, INTENT(OUT) :: PARENT(NCMP) INTEGER(8), INTENT(IN) :: IWFR8 INTEGER :: PTRAR(NCMP) INTEGER :: IW(:) INTEGER :: IWL1(NCMP) INTEGER, INTENT(OUT) :: IKEEP1(:) INTEGER, INTENT(OUT) :: IKEEP2(:) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: KEEP10 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER, INTENT(OUT) :: WEIGHTUSED INTEGER, INTENT(IN) :: WEIGHTREQUESTED INTEGER(8), DIMENSION(:), ALLOCATABLE :: & PTRAR8, IW8, IWL18, IKEEP18, & IKEEP28, IPE8_TEMP INTEGER :: allocok ALLOCATE( IPE8_TEMP(NCMP+1), stat=allocok ) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,*) & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto64" INFO(1) = -7 INFO(2) = NCMP+1 RETURN ENDIF IPE8_TEMP(1:NCMP+1) = IPE8(1:NCMP+1) IF (KEEP10.EQ.1) THEN CALL MUMPS_SCOTCH_64( NCMP, LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR, IW(1), IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, & WEIGHTUSED, WEIGHTREQUESTED) PARENT(1:NCMP) = int(IPE8_TEMP(1:NCMP)) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), IPE8_TEMP(NCMP+1)-1_8) ELSE ALLOCATE( IW8(LIW8), stat=allocok ) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,*) & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto64" INFO(1) = -7 CALL MUMPS_SET_IERROR( int(KEEP10,8) * LIW8 & , INFO(2) ) GOTO 500 ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1),LIW8,IW8) ENDIF ALLOCATE( & PTRAR8(NCMP), IWL18(NCMP), IKEEP18(NCMP), IKEEP28(NCMP), & stat=allocok ) IF (allocok > 0) THEN IF (LPOK) WRITE(LP,*) & "ERROR memory allocation in MUMPS_SCOTCH_MIXEDto64" INFO(1) = -7 CALL MUMPS_SET_IERROR( int(KEEP10,8) * & ( int(NCMP,8)*4_8 ) & , INFO(2) ) GOTO 500 ENDIF CALL MUMPS_ICOPY_32TO64(PTRAR,NCMP,PTRAR8) IF (WEIGHTREQUESTED.EQ.1) THEN CALL MUMPS_ICOPY_32TO64(IWL1,NCMP,IWL18) ENDIF IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_SCOTCH_64( int(NCMP,8), LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR8, IW(1), IWL18, & IKEEP1(1), IKEEP2(1), NCMPA, & WEIGHTUSED, & WEIGHTREQUESTED ) ELSE CALL MUMPS_SCOTCH_64( int(NCMP,8), LIW8, & IPE8_TEMP(1), & IWFR8, & PTRAR8, IW8, IWL18, & IKEEP1(1), IKEEP2(1), NCMPA, & WEIGHTUSED, & WEIGHTREQUESTED ) ENDIF IF (NCMPA .LT. 0) THEN IF (LPOK) WRITE(LP,*) & ' Error on output from SCOTCH, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 3 GOTO 500 ENDIF CALL MUMPS_ICOPY_64TO32(IWL18,NCMP,IWL1) CALL MUMPS_ICOPY_64TO32(IKEEP18,NCMP,IKEEP1(1)) CALL MUMPS_ICOPY_64TO32(IKEEP28,NCMP,IKEEP2(1)) CALL MUMPS_ICOPY_64TO32(IPE8_TEMP(1),NCMP,PARENT) 500 CONTINUE IF (.NOT.INPLACE64_GRAPH_COPY) THEN IF (ALLOCATED(IW8)) DEALLOCATE(IW8) ENDIF IF (ALLOCATED(PTRAR8)) DEALLOCATE(PTRAR8) IF (ALLOCATED(IWL18)) DEALLOCATE(IWL18) IF (ALLOCATED(IKEEP18)) DEALLOCATE(IKEEP18) IF (ALLOCATED(IKEEP28)) DEALLOCATE(IKEEP28) ENDIF IF (ALLOCATED(IPE8_TEMP)) DEALLOCATE(IPE8_TEMP) RETURN END SUBROUTINE MUMPS_SCOTCH_MIXEDto64 #endif #if defined (scotch) || defined (ptscotch) SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, JCNHALO, & NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE include 'scotchf.h' INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(HALOEDGENBR), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION :: GRAFDAT(SCOTCH_GRAPHDIM) DOUBLE PRECISION :: STRADAT(SCOTCH_STRATDIM) INTEGER :: BASEVAL, IERR, EDGENBR INTEGER, ALLOCATABLE :: IPTRHALO_I4(:) INTEGER :: allocok IF (IPTRHALO(size(IPTRHALO)) .GE. int(huge(LP),8)) THEN IFLAG = -51 CALL MUMPS_SET_IERROR( IPTRHALO (size(IPTRHALO)), & IERROR ) RETURN ENDIF ALLOCATE(IPTRHALO_I4(size(IPTRHALO)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 IERROR = size(IPTRHALO) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_SCOTCH_KWAY_MIXEDto32" RETURN END IF CALL MUMPS_ICOPY_64TO32(IPTRHALO, & size(IPTRHALO), IPTRHALO_I4) BASEVAL = 1 EDGENBR = IPTRHALO_I4(NHALO+1) CALL SCOTCHFGRAPHBUILD(GRAFDAT(1), BASEVAL, NHALO, & IPTRHALO_I4(1), IPTRHALO_I4(2), IPTRHALO_I4(1), & IPTRHALO_I4(1), EDGENBR, JCNHALO(1), JCNHALO(1), IERR) CALL SCOTCHFSTRATINIT(STRADAT, IERR) CALL SCOTCHFGRAPHPART(GRAFDAT(1), NBGROUPS, STRADAT(1), & PARTS(1), IERR) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFGRAPHEXIT(GRAFDAT) PARTS(1:NHALO) = PARTS(1:NHALO)+1 DEALLOCATE(IPTRHALO_I4) RETURN END SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto32 SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, JCNHALO, & NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE include 'scotchf.h' INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(HALOEDGENBR), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION :: GRAFDAT(SCOTCH_GRAPHDIM) DOUBLE PRECISION :: STRADAT(SCOTCH_STRATDIM) INTEGER :: IERR INTEGER(8), ALLOCATABLE :: JCNHALO_I8(:), PARTS_I8(:) INTEGER(8) :: NHALO_I8, NBGROUPS_I8, EDGENBR_I8, & BASEVAL_I8 INTEGER :: allocok ALLOCATE(JCNHALO_I8(IPTRHALO(NHALO+1)-1_8), & PARTS_I8(size(PARTS)), stat=allocok) IF (allocok > 0) THEN IFLAG =-7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* (IPTRHALO(NHALO+1)-1_8 & +int(size(PARTS),8)), & IERROR) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_SCOTCH_KWAY_MIXEDto64 " ENDIF CALL MUMPS_ICOPY_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) BASEVAL_I8 = 1_8 EDGENBR_I8 = IPTRHALO(NHALO+1) CALL SCOTCHFGRAPHBUILD(GRAFDAT(1), BASEVAL_I8, NHALO_I8, & IPTRHALO(1), IPTRHALO(2), IPTRHALO(1), & IPTRHALO(1), EDGENBR_I8, JCNHALO_I8(1), JCNHALO_I8(1), IERR) CALL SCOTCHFSTRATINIT(STRADAT, IERR) CALL SCOTCHFGRAPHPART(GRAFDAT(1), NBGROUPS_I8, STRADAT(1), & PARTS_I8(1), IERR) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFGRAPHEXIT(GRAFDAT) CALL MUMPS_ICOPY_64TO32(PARTS_I8, & size(PARTS), PARTS) DEALLOCATE(JCNHALO_I8, PARTS_I8) PARTS(1:NHALO) = PARTS(1:NHALO)+1 RETURN END SUBROUTINE MUMPS_SCOTCH_KWAY_MIXEDto64 #endif #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) SUBROUTINE MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(HALOEDGENBR), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, ALLOCATABLE :: IPTRHALO_I4(:) INTEGER :: allocok IF (IPTRHALO(size(IPTRHALO)) .GE. int(huge(LP),8)) THEN IFLAG = -51 CALL MUMPS_SET_IERROR( IPTRHALO (size(IPTRHALO)), & IERROR) RETURN ENDIF ALLOCATE(IPTRHALO_I4(size(IPTRHALO)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 IERROR = size(IPTRHALO) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_MIXEDto32" RETURN END IF CALL MUMPS_ICOPY_64TO32(IPTRHALO, & size(IPTRHALO), IPTRHALO_I4) CALL MUMPS_METIS_KWAY(NHALO, IPTRHALO_I4(1), & JCNHALO(1), NBGROUPS, PARTS(1)) DEALLOCATE(IPTRHALO_I4) RETURN END SUBROUTINE MUMPS_METIS_KWAY_MIXEDto32 SUBROUTINE MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(HALOEDGENBR), PARTS(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: JCNHALO_I8, PARTS_I8 INTEGER(8) :: NHALO_I8, NBGROUPS_I8 INTEGER :: allocok ALLOCATE(JCNHALO_I8(IPTRHALO(NHALO+1)-1_8), & PARTS_I8(size(PARTS)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* (IPTRHALO(NHALO+1)-1_8+int(size(PARTS),8)), & IERROR) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_MIXEDto64 " ENDIF NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) CALL MUMPS_ICOPY_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) CALL MUMPS_METIS_KWAY_64(NHALO_I8, IPTRHALO(1), & JCNHALO_I8(1), NBGROUPS_I8, PARTS_I8(1)) CALL MUMPS_ICOPY_64TO32(PARTS_I8, & size(PARTS), PARTS) DEALLOCATE(JCNHALO_I8, PARTS_I8) RETURN END SUBROUTINE MUMPS_METIS_KWAY_MIXEDto64 SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(HALOEDGENBR), PARTS(NHALO), VWGT(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, ALLOCATABLE :: IPTRHALO_I4(:) INTEGER :: allocok IF (IPTRHALO(size(IPTRHALO)) .GE. int(huge(LP),8)) THEN IFLAG = -51 CALL MUMPS_SET_IERROR( IPTRHALO (size(IPTRHALO)), & IERROR) RETURN ENDIF ALLOCATE(IPTRHALO_I4(size(IPTRHALO)), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 IERROR = size(IPTRHALO) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_AB_MIXEDto32" RETURN END IF CALL MUMPS_ICOPY_64TO32(IPTRHALO, & size(IPTRHALO), IPTRHALO_I4) CALL MUMPS_METIS_KWAY_AB(NHALO, IPTRHALO_I4(1), & JCNHALO(1), NBGROUPS, PARTS(1), VWGT(1)) DEALLOCATE(IPTRHALO_I4) RETURN END SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto32 SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, NBGROUPS, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, NBGROUPS INTEGER :: JCNHALO(HALOEDGENBR), PARTS(NHALO), VWGT(NHALO) INTEGER(8) :: IPTRHALO(NHALO+1) INTEGER, INTENT(IN) :: LP, KEEP10 LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: JCNHALO_I8, PARTS_I8 INTEGER(8), ALLOCATABLE, DIMENSION(:) :: VWGT_I8 INTEGER(8) :: NHALO_I8, NBGROUPS_I8 INTEGER :: allocok ALLOCATE(JCNHALO_I8(IPTRHALO(NHALO+1)-1_8), & PARTS_I8(size(PARTS)), VWGT_I8(NHALO), stat=allocok) IF (allocok > 0) THEN IFLAG = -7 CALL MUMPS_SET_IERROR( & int(KEEP10,8)* (IPTRHALO(NHALO+1)-1_8+int(size(PARTS),8)) & +int(NHALO,8), IERROR) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_METIS_KWAY_AB_MIXEDto64 " ENDIF NHALO_I8 = int(NHALO,8) NBGROUPS_I8 = int(NBGROUPS,8) CALL MUMPS_ICOPY_32TO64_64C(JCNHALO, & IPTRHALO(NHALO+1)-1, JCNHALO_I8) CALL MUMPS_ICOPY_32TO64_64C(VWGT, & NHALO_I8, VWGT_I8) CALL MUMPS_METIS_KWAY_AB_64(NHALO_I8, IPTRHALO(1), & JCNHALO_I8(1), NBGROUPS_I8, PARTS_I8(1), & VWGT_I8(1)) CALL MUMPS_ICOPY_64TO32(PARTS_I8, & size(PARTS), PARTS) DEALLOCATE(JCNHALO_I8, PARTS_I8, VWGT_I8) RETURN END SUBROUTINE MUMPS_METIS_KWAY_AB_MIXEDto64 #endif #if defined(pord) SUBROUTINE MUMPS_PORDF_MIXEDto32( NVTX, NEDGES8, XADJ8, IW, & NV, NCMPA, PARENT, & INFO, LP, LPOK, KEEP10 ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER(8) :: XADJ8(:) INTEGER, INTENT(OUT) :: NV(NVTX) INTEGER :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 INTEGER, DIMENSION(:), ALLOCATABLE :: XADJ INTEGER :: I, allocok IF (NEDGES8.GT. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) RETURN ENDIF ALLOCATE(XADJ(NVTX+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NVTX+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX+1, XADJ) CALL MUMPS_PORDF( NVTX, int(NEDGES8), XADJ, IW(1), & NV, NCMPA ) DO I= 1, NVTX PARENT(I) = XADJ(I) ENDDO DEALLOCATE(XADJ) RETURN END SUBROUTINE MUMPS_PORDF_MIXEDto32 SUBROUTINE MUMPS_PORDF_MIXEDto64( NVTX, NEDGES8, XADJ8, IW, & NV, NCMPA, PARENT, & INFO, LP, LPOK, KEEP10, & INPLACE64_GRAPH_COPY ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX INTEGER, INTENT(OUT) :: NCMPA INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER(8) :: XADJ8(:) INTEGER, INTENT(OUT) :: NV(NVTX) INTEGER, INTENT(IN) :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER(8), DIMENSION(:), ALLOCATABLE :: IW8, NV8 INTEGER :: I, allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8(1), IW(1), & NV, NCMPA ) DO I=1, NVTX PARENT(I)=int(XADJ8(I)) ENDDO ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), NEDGES8) ELSE ALLOCATE(IW8(NEDGES8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), NEDGES8, IW8) ENDIF ALLOCATE(NV8(NVTX), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NVTX,8),INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORD_MIXEDto64" RETURN ENDIF IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8(1), IW(1), & NV8, NCMPA ) ELSE CALL MUMPS_PORDF( int(NVTX,8), NEDGES8, XADJ8(1), IW8, & NV8, NCMPA ) DEALLOCATE(IW8) ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX, PARENT) CALL MUMPS_ICOPY_64TO32(NV8, NVTX, NV) DEALLOCATE(NV8) ENDIF RETURN END SUBROUTINE MUMPS_PORDF_MIXEDto64 SUBROUTINE MUMPS_PORDF_WND_MIXEDto32( NVTX, NEDGES8, & XADJ8, IW, & NV, NCMPA, N, PARENT, & INFO, LP, LPOK, KEEP10 ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX, N INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(INOUT) :: NV(NVTX) INTEGER(8) :: XADJ8(:) INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 INTEGER, DIMENSION(:), ALLOCATABLE :: XADJ INTEGER :: I, allocok IF (NEDGES8.GT. int(huge(IW),8)) THEN INFO(1) = -51 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) RETURN ENDIF ALLOCATE(XADJ(NVTX+1), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 INFO(2)=NVTX+1 IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORDF_WND_MIXEDto32" RETURN ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1),NVTX+1,XADJ) CALL MUMPS_PORDF_WND( NVTX, int(NEDGES8), & XADJ, IW(1), & NV, NCMPA, N ) DO I= 1, NVTX PARENT(I) = XADJ(I) ENDDO DEALLOCATE(XADJ) RETURN END SUBROUTINE MUMPS_PORDF_WND_MIXEDto32 SUBROUTINE MUMPS_PORDF_WND_MIXEDto64( NVTX, NEDGES8, & XADJ8, IW, & NV, NCMPA, N, PARENT, & INFO, LP, LPOK, KEEP10, & INPLACE64_GRAPH_COPY ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NVTX, N INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(INOUT) :: NV(NVTX) INTEGER(8) :: XADJ8(:) INTEGER(8), INTENT(IN) :: NEDGES8 INTEGER :: IW(:) INTEGER, INTENT(OUT) :: PARENT(NVTX) INTEGER, INTENT(IN) :: KEEP10 LOGICAL, INTENT(IN) :: INPLACE64_GRAPH_COPY INTEGER(8), DIMENSION(:), ALLOCATABLE :: IW8, NV8 INTEGER :: allocok IF (KEEP10.EQ.1) THEN CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8(1), IW(1), & NV, NCMPA, int(N,8) ) CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX, PARENT) ELSE IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_ICOPY_32TO64_64C_IP(IW(1), NEDGES8) ELSE ALLOCATE(IW8(NEDGES8), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(NEDGES8,INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORDF_WND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64_64C(IW(1), NEDGES8, IW8) ENDIF ALLOCATE(NV8(NVTX), stat=allocok) IF (allocok > 0) THEN INFO(1)=-7 CALL MUMPS_SET_IERROR(int(NVTX,8),INFO(2)) IF (LPOK) WRITE(LP,'(A)') & "ERROR memory allocation in MUMPS_PORDF_WND_MIXEDto64" RETURN ENDIF CALL MUMPS_ICOPY_32TO64(NV, NVTX, NV8) IF (INPLACE64_GRAPH_COPY) THEN CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8(1), IW(1), & NV8, NCMPA, int(N,8) ) ELSE CALL MUMPS_PORDF_WND( int(NVTX,8), NEDGES8, & XADJ8(1), IW8, & NV8, NCMPA, int(N,8) ) DEALLOCATE(IW8) ENDIF CALL MUMPS_ICOPY_64TO32(XADJ8(1), NVTX, PARENT) CALL MUMPS_ICOPY_64TO32(NV8, NVTX, NV) DEALLOCATE(NV8) ENDIF RETURN END SUBROUTINE MUMPS_PORDF_WND_MIXEDto64 #endif SUBROUTINE MUMPS_ANA_WRAP_RETURN() RETURN END SUBROUTINE MUMPS_ANA_WRAP_RETURN END MODULE MUMPS_ANA_ORD_WRAPPERS MUMPS_5.4.1/src/bcast_errors.F0000664000175000017500000000204614102210475016312 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_PROPINFO( ICNTL, INFO, COMM, ID ) INTEGER ICNTL(60), INFO(80), COMM, ID INCLUDE 'mpif.h' #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: IN( 2 ), OUT( 2 ) #else INTEGER :: IN( 2 ), OUT( 2 ) #endif INTEGER :: LP, IERR LP = ICNTL( 1 ) IN( 1 ) = INFO ( 1 ) IN( 2 ) = ID CALL MPI_ALLREDUCE( IN, OUT, 1, MPI_2INTEGER, MPI_MINLOC, & COMM, IERR) IF ( OUT( 1 ) .LT. 0 .and. INFO(1) .GE. 0 ) THEN INFO( 1 ) = -001 INFO( 2 ) = OUT( 2 ) END IF RETURN END SUBROUTINE MUMPS_PROPINFO MUMPS_5.4.1/src/zmumps_f77.F0000664000175000017500000003611214102210524015634 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, & PERM_IN, PERM_INhere, RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, & SAVE_DIR, SAVE_PREFIX, & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, & SAVE_DIRLEN, SAVE_PREFIXLEN, & METIS_OPTIONS & ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=63, OOC_TMPDIR_MAX_LENGTH=255) PARAMETER(PB_MAX_LENGTH=255) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) COMPLEX(kind=8), TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) COMPLEX(kind=8), TARGET :: WK_USER(*) COMPLEX(kind=8), TARGET :: REDRHS(*) DOUBLE PRECISION, TARGET :: ROWSCA(*), COLSCA(*) COMPLEX(kind=8), TARGET :: SCHUR(*) COMPLEX(kind=8), TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE ZMUMPS_STRUC_PTR TYPE (ZMUMPS_STRUC), POINTER :: PTR END TYPE ZMUMPS_STRUC_PTR TYPE (ZMUMPS_STRUC), POINTER :: mumps_par TYPE (ZMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (ZMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: ZMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER ZMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (ZMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM EXTERNAL ZMUMPS_ASSIGN_COLSCA, & ZMUMPS_ASSIGN_ROWSCA IF (JOB == -1) THEN DO I = 1, ZMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(ZMUMPS_STRUC_ARRAY_SIZE + & ZMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in ZMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, ZMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = ZMUMPS_STRUC_ARRAY_SIZE+1, ZMUMPS_STRUC_ARRAY_SIZE + & ZMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = ZMUMPS_STRUC_ARRAY_SIZE+1 ZMUMPS_STRUC_ARRAY_SIZE = ZMUMPS_STRUC_ARRAY_SIZE + & ZMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in ZMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0D0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0D0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & ZMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in ZMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in ZMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%SCHUR_MLOC = SCHUR_MLOC mumps_par%SCHUR_NLOC = SCHUR_NLOC mumps_par%SCHUR_LLD = SCHUR_LLD mumps_par%MBLOCK = MBLOCK mumps_par%NBLOCK = NBLOCK mumps_par%NPROW = NPROW mumps_par%NPCOL = NPCOL IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO CALL ZMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc SIZE_SCHUR = mumps_par%SIZE_SCHUR LWK_USER = mumps_par%LWK_USER NELT = mumps_par%NELT DEFICIENCY = mumps_par%Deficiency SCHUR_MLOC = mumps_par%SCHUR_MLOC SCHUR_NLOC = mumps_par%SCHUR_NLOC SCHUR_LLD = mumps_par%SCHUR_LLD MBLOCK = mumps_par%MBLOCK NBLOCK = mumps_par%NBLOCK NPROW = mumps_par%NPROW NPCOL = mumps_par%NPCOL IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF (associated( mumps_par%COLSCA)) THEN CALL ZMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL ZMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA)) THEN CALL ZMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL ZMUMPS_NULLIFY_C_ROWSCA() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,OOC_TMPDIR_MAX_LENGTH OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,OOC_PREFIX_MAX_LENGTH OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) ZMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE ZMUMPS_F77 MUMPS_5.4.1/src/mumps_scotch_int.c0000664000175000017500000000142514102210474017234 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_scotch_int.h" #if defined(scotch) || defined(ptscotch) # include # include "scotch.h" #endif void MUMPS_CALL MUMPS_SCOTCH_INTSIZE(MUMPS_INT *scotch_intsize) { # if defined(scotch) || defined(ptscotch) *scotch_intsize=8*sizeof(SCOTCH_Num); # else *scotch_intsize=-99999; # endif } MUMPS_5.4.1/src/zfac_process_root2slave.F0000664000175000017500000003172214102210524020461 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER :: allocok COMPLEX(kind=8), DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' INTEGER numroc, MUMPS_PROCNODE EXTERNAL numroc, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = numroc( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = numroc( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL ZMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL ZMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL ZMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL ZMUMPS_ASM_ELT_ROOT(N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL ZMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL ZMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL ZMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL ZMUMPS_ASM_ELT_ROOT( N, root, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL ZMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL ZMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL ZMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(root%RHS_ROOT)) DEALLOCATE(root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN root%RHS_ROOT=ZERO CALL ZMUMPS_ASM_RHS_ROOT( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => root%RHS_ROOT NULLIFY(root%RHS_ROOT) ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = NEW_LOCAL_M*root%RHS_NLOC GOTO 700 ENDIF DO J = 1, root%RHS_NLOC DO I = 1, OLD_LOCAL_M root%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M root%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE ZMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD COMPLEX(kind=8) NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE ZMUMPS_COPY_ROOT MUMPS_5.4.1/src/dsol_lr.F0000664000175000017500000007060714102210523015262 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SOL_LR USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSCOMP INTEGER, INTENT(IN) :: IW(LIW), POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NELIM_GLOBAL, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in DMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT NELIM_GLOBAL = & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(NPARTSASS+1) & - BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(NPARTSASS+1) DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL DMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL dgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL dgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL dgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL dgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL dgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL dgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL DMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL DMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE DMUMPS_SOL_FWD_LR_SU SUBROUTINE DMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in DMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL DMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ELSE CALL DMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SOL_SLAVE_LR_U SUBROUTINE DMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL DOUBLE PRECISION, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) DOUBLE PRECISION, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok, CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & DMUMPS_SOL_FWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL dgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL dgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL dgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif RETURN END SUBROUTINE DMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE DMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: IPOSINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR, PCBINRHSCOMP INTEGER(8) :: PCB_LAST, PWCB INTEGER :: IPIV_PANEL DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in DMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PCBINRHSCOMP= IPOSINRHSCOMP + NPIV_GLOBAL PCB_LAST = PTWCB + int(LIELL ,8) PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) CYCLE NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSCOMP + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF CALL DMUMPS_SOL_BWD_BLR_UPDATE ( & RHSCOMP, int(LRHSCOMP,8), NRHS, LRHSCOMP, & int(IPOSINRHSCOMP,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSCOMP(IPIV_PANEL,JBDEB),LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL dgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL dgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL DMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) ENDDO RETURN END SUBROUTINE DMUMPS_SOL_BWD_LR_SU SUBROUTINE DMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL DOUBLE PRECISION, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) DOUBLE PRECISION, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK,allocok,CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & DMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, !$OMP& POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL dgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL dgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL dgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL dgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL dgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call daxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call daxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE DMUMPS_SOL_BWD_BLR_UPDATE END MODULE DMUMPS_SOL_LR SUBROUTINE DMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSCOMP, LRHSCOMP, NRHS, & PPIVINRHSCOMP, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWC DOUBLE PRECISION, INTENT(IN) :: DIAG(LDIAG) DOUBLE PRECISION, INTENT(INOUT) :: W(LWC) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LDAJ DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL dtrsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), & LRHSCOMP) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL dtrsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), LRHSCOMP) END IF RETURN END SUBROUTINE DMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.4.1/src/mumps_scotch.c0000664000175000017500000000456614102210474016373 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Interfacing with SCOTCH and pt-SCOTCH */ #include #include "mumps_scotch.h" #if defined(scotch) || defined(ptscotch) void MUMPS_CALL MUMPS_SCOTCH( const MUMPS_INT * const n, const MUMPS_INT * const iwlen, MUMPS_INT * const petab, const MUMPS_INT * const pfree, MUMPS_INT * const lentab, MUMPS_INT * const iwtab, MUMPS_INT * const nvtab, MUMPS_INT * const elentab, MUMPS_INT * const lasttab, MUMPS_INT * const ncmpa, MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ) { /* weightused(out) = 1 if weight of nodes provided in nvtab are used (esmumpsv is called) = 0 otherwise */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv prototype with 64-bit integers weights of nodes in the graph are used on entry (nvtab) */ if ( *weightrequested == 1 ) { *ncmpa = esmumpsv( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=1; } else { /* esmumps prototype with standard integers (weights of nodes not used on entry) */ *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=0; } #else /* esmumps prototype with standard integers (weights of nodes not used on entry) */ *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=0; #endif } #endif /* scotch */ #if defined(ptscotch) void MUMPS_CALL MUMPS_DGRAPHINIT(SCOTCH_Dgraph *graphptr, MPI_Fint *comm, MPI_Fint *ierr) { MPI_Comm int_comm; int_comm = MPI_Comm_f2c(*comm); *ierr = SCOTCH_dgraphInit(graphptr, int_comm); return; } #endif MUMPS_5.4.1/src/cfac_type3_symmetrize.F0000664000175000017500000001364214102210523020130 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID COMPLEX BUF( BLOCK_SIZE * BLOCK_SIZE ) COMPLEX A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL CMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL CMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL CMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL CMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE CMUMPS_SYMMETRIZE SUBROUTINE CMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM COMPLEX BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_COMPLEX, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE CMUMPS_SEND_BLOCK SUBROUTINE CMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE COMPLEX BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_COMPLEX, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL ccopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE CMUMPS_RECV_BLOCK SUBROUTINE CMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA COMPLEX A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE CMUMPS_TRANS_DIAG SUBROUTINE CMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD COMPLEX A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE CMUMPS_TRANSPO MUMPS_5.4.1/src/sana_driver.F0000664000175000017500000056366614102210525016137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE SMUMPS_ANA_DRIVER(id) USE SMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE SMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE SMUMPS_PARALLEL_ANALYSIS USE SMUMPS_ANA_LR USE SMUMPS_LR_CORE USE SMUMPS_LR_STATS USE MUMPS_LR_COMMON USE SMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(SMUMPS_STRUC), TARGET :: id C C Local variables C =============== C C C Pointers inside integer array, various data INTEGER IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LOCAL_M, LOCAL_N INTEGER numroc EXTERNAL numroc INTEGER IRANK INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 INTEGER MIN_BUF_SIZE INTEGER(8) MAX_SIZE_FACTOR_TMP INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) REAL :: PEAK INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:):: IPOOL INTEGER :: LIPOOL INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS REAL, DIMENSION(:), POINTER :: RINFO REAL, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, PERLU_ON, COND INTEGER :: OOC_STRAT, BLR_STRAT INTEGER :: IDUMMY INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed LOGICAL :: SUM_OF_PEAKS INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: TEMP_MEM INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_ROOT INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_LEAF INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_SIZE INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST_SEQ INTEGER, DIMENSION (:), ALLOCATABLE :: SBTR_ID REAL, DIMENSION (:), ALLOCATABLE :: COST_TRAV_TMP INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP LOGICAL :: GCOMP_PROVIDED TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, & STEPPTR, LRGROUPSPTR INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK INTEGER :: LIW_ELT C INTERFACE C Explicit interface because of pointer arguments: SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE SMUMPS_LR_DATA_M, only : SMUMPS_BLR_STRUC_TO_MOD, & SMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Beginning of executable statements C IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) NULLIFY ( NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, STEPPTR, LRGROUPSPTR, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR ) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) IDUMMY = 1 BDUMMY = .FALSE. C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C ---------------------------------------- C Free some memory from factorization, C if allocated, at least large arrays. C This will also limit the amount of useless C data saved to disk in case of save-restore C ---------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF NULLIFY(id%S) KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C also avoid keeping BLR factors allocated if analysis C called after a previous BLR factorization without C an intermediate JOB=-2 call. CALL SMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C -------------------------------------------- C If analysis redone, suppress old, C meaningless, Step2node array. C This is necessary since we could otherwise C end up having a wrong Step2node during solve C -------------------------------------------- IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: SMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL SMUMPS_ANA_CHECK_KEEP(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that SMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL SMUMPS_DUMP_PROBLEM(id) C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).NE.0) THEN C Analysis by block with block data provided by user C C Check if block structure is centralized or distributed IF (.NOT.associated(id%BLKVAR)) THEN C BLKVAR is identity and implicitly centralized KEEP(14) = 0 ELSE IF (size(id%BLKVAR).EQ.id%N) THEN C Centralized block stucture KEEP(14) = 0 ELSE C Distributed block stucture KEEP(14) = 1 IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF IF (KEEP(13).GE.1) THEN C BLKPTR provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF NBLK=id%NBLK IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of KEEP(13).NE.0 ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF (id%MYID.EQ.MASTER.AND.allocok.EQ.0) THEN C BLKPTR and BLKVAR needed for SMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR)) THEN BLKPTR_ALLOCATED = .TRUE. allocate(id%BLKPTR(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .TRUE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ENDIF IF (.NOT.associated(id%BLKVAR).AND.allocok.EQ.0) THEN allocate(id%BLKVAR(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N id%BLKVAR(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 id%BLKPTR(IB) = I ENDDO id%BLKPTR(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, id%BLKPTR(1), id%BLKVAR(1), & SIZEOFBLOCKS, DOF2BLOCK) ENDIF C ======================= IF (KEEP(54).NE.3) THEN C ======================= C --------------------- C Matrix structure available on host C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, id%KEEP8(28), IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1)) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ==== ELSE C ==== C ------------------------------- C Matrix structure is distributed C and since KEEP(13).NE.0 then C ordering is centralized since C ------------------------------- C IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Centralized cleaned graph is ready C call directly with GCOMP READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP_DIST, READY_FOR_ANA_F) ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) ENDIF ELSE CALL SMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to SMUMPS_ANA_F and C SMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C SMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip SMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) SMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3*id%N), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=5*id%N ELSE CALL SMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in SMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=3*NBLK ENDIF ELSE ALLOCATE(IKEEPALLOC(NBLK+2*id%N), & FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=4*NBLK+2*id%N ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside SMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to SMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW_ELT = id%N + id%N + 1 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW_ELT = id%N + id%N + id%N + 3 + id%N + 1 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for SMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8 = 3_8*int(NBLK,8) ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) IKEEP3 => IKEEPALLOC(NBLK+id%N+1:NBLK+2*id%N) C id%UNS_PERM corresponds to argument PIV C in SMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL SMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL SMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) CALL MUMPS_AB_FREE_GCOMP(GCOMP) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to SMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL SMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILSPTR(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to SMUMPS_ANA_F_ELT C be used in SMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FILSPTR) ) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N IF (id%MYID .EQ. MASTER) THEN ALLOCATE( IKEEPALLOC(3*id%N), WORK2ALLOC(4*id%N), & FILSPTR(id%N), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ELSE C Because our purpose is to minimize the peak memory consumption, C we can afford to allocate on processes other than host ALLOCATE(IKEEPALLOC(3*id%N),WORK2ALLOC(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 10*id%N ELSE INFO( 2 ) = 7*id%N ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 CALL SMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF KEEP(28) = INFOG(6) END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL SMUMPS_ANA_R(NBLK, FILSPTR(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL SMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILSPTR(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = real(id%INFOG(5))*real(id%INFOG(5)) + ! front matrix & real(id%KEEP(2))*real(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+NBLK-1) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL SMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILSPTR(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL SMUMPS_ANA_R(NBLK, FILSPTR(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL SMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILSPTR(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL SMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in SMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in SMUMPS_ANA_M) C is needed on all the procs during SMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in SMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- IF (id%MYID.EQ.MASTER) THEN C id%STEP is of size NBLK because it C is computed on compressed graph and then extended C and broadcasted on all procs CALL MUMPS_REALLOC(id%STEP, NBLK, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ELSE C id%STEP is of size id%N because it C is received in extended form CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C id%FILS is allocated before expand tree IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_REALLOC(id%LRGROUPS, NBLK, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ELSE CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+NBLK-2) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+NBLK-1) ELSE NBLEAF = IKEEPALLOC(NA+NBLK-2) NBROOT = IKEEPALLOC(NA+NBLK-1) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+NBLK-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+NBLK-2) < 0 ) THEN INODE = - IKEEPALLOC(NA+NBLK-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP(1:id%N) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 id%STEP(I)=ISTEP INN = FILSPTR(I) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = FILSPTR(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in SMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in SMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = FREREPTR(I) id%NE_STEPS(id%STEP(I)) = IKEEPALLOC(NE+I-1) id%ND_STEPS(id%STEP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(id%STEP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILSPTR(I) DO WHILE ( IFS .GT. 0 ) IFS= FILSPTR(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(id%STEP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C I/ Prepare data before call to grouping IF ((KEEP(54).EQ.3).AND.(KEEP(13).NE.0)) THEN C Matrix is distributed on entry and compression computed IF (KEEP(487).NE.1) CALL MUMPS_ABORT() ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, id%STEP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), id%STEP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) CALL MUMPS_AB_FREE_LMAT(LUMAT) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ELSE IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C ---> build LUMAT_REMAP on MASTER IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_AB_LMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, & INFO(1), ICNTL(1)) C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), id%STEP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (KEEP(487).NE.1) & ) THEN C Grouping preparation on slaves: C If the input matrix is distributed and the parallel analysis is C chosen, the graph used to be centralized in order to compute the C clustering. C CALL SMUMPS_GATHER_MATRIX(id) ENDIF C ============ C ============ C II/ GROUPING C ============ IF ((KEEP(54).EQ.3).AND.(KEEP(487).EQ.1)) THEN C Matrix is distributed on entry and halo of size 1 C Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILSPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C Distribute SIZEOFBLOCKS that was defined only on master C CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, C & id%COMM, IERR ) CALL SMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), LPOK, LP, id%COMM, id%MYID, id%NPROCS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF C ELSE IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C --- build LUMAT C -- LR grouping exploiting LUMAT C -- centralized => MAPCOL not needed C FIXME 5.4: call to SMUMPS_AB_LR_GROUPING "ready" to be C replaced by call to SMUMPS_AB_LR_MPI_GROUPING C IDUMMY_ARRAY(1) = -1 CALL SMUMPS_AB_LR_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP, id%MYID, id%COMM) ELSE C grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL SMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ELSE CALL SMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ENDIF ENDIF ENDIF C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP is allocated CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF IF (id%MYID.NE. MASTER) THEN CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 ENDIF C IF ((id%MYID.EQ.MASTER) .AND.(KEEP(13).NE.0)) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILSPTR, id%STEP into id%FILS, STEPPTR C and update arrays of size NSTEPS ALLOCATE(STEPPTR(id%N), LRGROUPSPTR(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=id%N GOTO 97 ENDIF IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL SMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, id%BLKPTR(1), id%BLKVAR(1), & FILSPTR(1), id%FILS(1), id%KEEP(28), & id%STEP(1), STEPPTR(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, id%LRGROUPS(1), LRGROUPSPTR(1), & id%KEEP(20), id%KEEP(38) & ) NULLIFY(PAR2_NODESPTR) DEALLOCATE(id%STEP) id%STEP=>STEPPTR NULLIFY(STEPPTR) DEALLOCATE(id%LRGROUPS) id%LRGROUPS=>LRGROUPSPTR NULLIFY(LRGROUPSPTR) DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ELSE if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF C} ENDIF IF ((id%N.EQ.NBLK).AND.associated(FILSPTR)) THEN C id%FILS has not been initialized if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF 97 CONTINUE CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL SMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL SMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL SMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF(((KEEP(494).NE.0).OR.KEEP(13).NE.0) & .AND.(id%KEEP(38).GT.0)) & THEN ! grouping at analysis (1 => LR CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NA(1), id%LNA, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%PROCNODE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DAD_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRERE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR) CALL MPI_BCAST( id%NE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%ND_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) END IF IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C At the end of ANA_N_DIST, id%PTRAR is already on every processor C because it is computed in a distributed way. C No need to broadcast it again CALL SMUMPS_ANA_N_DIST(id, id%PTRAR) IF(id%MYID .EQ. MASTER) THEN C ----------------------------------- C For distributed structure on entry, C we can now deallocate the complete C structure IRN / JCN. C ----------------------------------- IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN C IRN and JCN might have already been deallocated IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF END IF ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL SMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL SMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, id%root, & id%COMM_NODES, KEEP( 38 ), id%FILS(1), & id%KEEP(50), id%KEEP(46), & id%KEEP(51) & , id%KEEP(60), id%NPROW, id%NPCOL, id%MBLOCK, id%NBLOCK & ) ELSE id%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(id%root%MYROW, MYROW_CHECK, 1, & MPI_INTEGER, MPI_MAX, id%COMM_NODES, IERR) IF ( MYROW_CHECK .eq. -1) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( id%root%MYROW .LT. -1 .OR. & id%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN C{ C C IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%PTRAR(1), & id%PTRAR(id%N +1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id ) ELSE CALL SMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) ENDIF C} ENDIF C ----------------------------------------- C Perform some local analysis on the slaves C to estimate the size of the working space C for factorization C ----------------------------------------- IF ( I_AM_SLAVE ) THEN C{ locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES locMYID = id%MYID C =================================================== C Precompute estimates of local_m,local_n C (number of rows/columns mapped on each processor) C in case of parallel root node. C and allocate CANDIDATES C =================================================== C IF ( id%root%yes ) THEN LOCAL_M = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%MBLOCK, id%root%MYROW, 0, & id%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%NBLOCK, id%root%MYCOL, 0, & id%root%NPCOL ) ELSE LOCAL_M = 0 LOCAL_N = 0 END IF IF ( KEEP(60) .EQ. 2 .OR. KEEP(60) .EQ. 3 ) THEN C Return minimum nb rows/cols to user id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N C Also store them in root structure for convenience id%root%SCHUR_MLOC=LOCAL_M id%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- Allocate and initialise IPOOL with leaves C -- on which stats are performed IF ( I_AM_SLAVE ) THEN C{ LIPOOL = id%NA(1) C LIPOOL is number of leaf nodes and can be 0 C (for ex AboveL0 with nbthreads is 1) ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C{ C Initialize IPOOL with leaves of complete tree DO I=1, LIPOOL IPOOL(I) = id%NA(3+I-1) ENDDO ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 C NE_STEPSPTR => id%NE_STEPS KEEP(139) = MAXFR_UNDER_L0 CALL SMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOL, LIPOOL, NE_STEPSPTR(1), & id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & id%root%yes, id%root%NPROW, id%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR) C SUM_NIRNEC under L0 OMP KEEP(137)=0 C SUM_NIRNEC_OOC under L0 OMP KEEP(138)=0 C DKEEP(15) is used for dynamic load balancing only C it corresponds to the number of local operations C (in Millions) id%DKEEP(15) = RINFO(1)/1000000.0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) C KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) C Relaxed value of size of IS is not needed internally; C we save it directly in INFO(19) INFO( 19 ) = KEEP(225) + 3* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C ================================= C Size of S (relaxed with ICNTL(14) C =========================== C size of S relaxed (FR, IC) C =========================== KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S relaxed (FR or LR LU, OOC) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) C size of S relaxed (LR LU, IC) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) C size of S relaxed (LR CB, IC) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) C KEEP8( 22 ) is the OLD maximum size of receive buffer C that includes CB related communications. C KEEP( 43 ) : min size for send buffer C KEEP( 44 ) : min size for receive buffer C KEEP(43-44) kept for allocating buffers during C factorization phase CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) C We do a max with KEEP(27)=maxfront because for small C buffers, we need at least one row of cb to be sent/ C received. SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) KEEP(379)=KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF C MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min( MIN_BUF_SIZE8, int(huge (KEEP(43)),8)) MIN_BUF_SIZE = int( MIN_BUF_SIZE8 ) C KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(380) = max(KEEP(380), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) KEEP(379) = max(KEEP(379), MIN_BUF_SIZE) IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. real space to store factors :', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF C} ELSE C --------------------- C Master is not working C --------------------- ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0E0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C -------------------------------------- C KEEP8( 26 ) : Real arrowhead size C KEEP8( 27 ) : Integer arrowhead size C INFO(3)/KEEP8( 11 ) : Estimated real space needed for factors C INFO(4)/KEEP( 26 ) : Estimated integer space needed for factors C INFO(5)/KEEP( 27 ) : Estimated max front size C KEEP8(109) : Estimated number of entries in factor C (based on ENTRIES_IN_FACTORS_LOC_MASTERS computed C during SMUMPS_ANA_DISTM, where we assume C that each master of a node computes C the complete factor size. C -------------------------------------- C note that summing ENTRIES_IN_FACTORS_LOC_MASTERS or C ENTRIES_IN_FACTORS_LOC_MASTERS should lead to the same result CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) CALL MPI_ALLREDUCE( KEEP(26), KEEP(126), 1, & MPI_INTEGER, MPI_SUM, & id%COMM, IERR) C NRLADU related: KEEP8(11) holds factors above and under L0 CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C NRLADU_if_LR_LU related: KEEP8(32) holds factors above C and under L0 C convert it in Megabytes RINFO(5) = real(KEEP8(32) & *int(KEEP(35),8))/1E6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) C in Megabytes IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = real(ITMP8*int(KEEP(35),8))/1E6 ENDIF C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_REAL, MPI_SUM, & id%COMM, IERR) C CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) C CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL SMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) C -------------------------- C COMPUTE MEMORY ESTIMATIONS IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) C -------------------------- C ========================= C IN-CORE MEMORY STATISTICS C ========================= C OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression IF (KEEP(201) .NE. -1) OOC_STRAT=0 ! We want in-core statistics PERLU_ON = .FALSE. ! switch off PERLU to compute KEEP8(2) CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(2) = TOTAL_BYTES C C PERLU_ON = .TRUE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) IF ( PROK ) THEN WRITE(MP,'(A,I12) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES C C Centralize memory statistics on the host C C INFOG(16) = after analysis, est. mem size in Mbytes for facto, C for the processor using largest memory C INFOG(17) = after analysis, est. mem size in Mbytes for facto, C sum over all processors C INFOG(18/19) = idem at facto. C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STRAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. ! PERLU NOT taken into account C Used to compute KEEP8(3) (minimum number of bytes for OOC) CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(3) = TOTAL_BYTES C PERLU_ON = .TRUE. ! PERLU taken into account CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) id%INFO(17) = TOTAL_MBYTES C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF IF (KEEP(494).NE.0) THEN C ========================================= C NOW COMPUTE BLR statistics C ========================================= SUM_OF_PEAKS = .TRUE. CALL SMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & ) C END IF C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL SMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & id%root%MBLOCK, id%root%NBLOCK, & id%root%NPROW, id%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(IPOOL)) DEALLOCATE(IPOOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) CALL MUMPS_AB_FREE_LMAT(LUMAT) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) CALL MUMPS_AB_FREE_GCOMP(GCOMP) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) IF (associated(FILSPTR)) DEALLOCATE(FILSPTR) IF (associated(id%BLKPTR).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(id%BLKPTR) nullify(id%BLKPTR) ENDIF IF (associated(id%BLKVAR).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(id%BLKVAR) nullify(id%BLKVAR) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING SMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_ANA_DRIVER SUBROUTINE SMUMPS_ANA_CHECK_KEEP(id) C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C -- OOC/Incore strategy IF (id%KEEP(201).NE.-1) THEN id%KEEP(201)=id%ICNTL(22) IF (id%KEEP(201) .GT. 0) THEN #if defined(OLD_OOC_NOPANEL) id%KEEP(201)=2 #else id%KEEP(201)=1 #endif ENDIF ENDIF C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif C Analysis strategy is set to automatic in case of out-of-range values. IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 ) THEN id%KEEP(106)=1 C Automatic choice leads to new symbolic C factorization except(see below) if KEEP(256)==1. ELSE id%KEEP(106)=id%ICNTL(58) IF (id%KEEP(106).EQ.3) THEN C option not available id%KEEP(106)=1 ENDIF ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: SMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine SMUMPS_BDCAST C -------------------------------- id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).LT.0) THEN IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF IF (associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with BLKPTR provided by user" ENDIF id%INFO(1) = -57 id%INFO(2) = 4 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) & ) & THEN IF ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).NE.2)) THEN id%KEEP(13)=-1 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0 ) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) .AND. & (id%KEEP(244).NE.2) & ) & THEN C unsymmetic assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off because C if one activates the analysis by block IF ( (id%KEEP(23).LT.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1) & ) THEN IF (PROKG) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block compatible ", & "ONLY with SYMQAMD based symbolic factorization ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(244).EQ.2) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with parallel ordering " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE SMUMPS_ANA_CHECK_KEEP SUBROUTINE SMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(SMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROK, PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG, I_AM_SLAVE INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING SMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE SMUMPS_GATHER_MATRIX SUBROUTINE SMUMPS_DUMP_PROBLEM(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C SMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and SMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(SMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB REAL, TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED REAL, POINTER, DIMENSION(:) :: A_PASSED PARAMETER( MASTER = 0 ) IUNIT = 69 I_AM_SLAVE = ( id%MYID .NE. MASTER .OR. & ( id%MYID .EQ. MASTER .AND. & id%KEEP(46) .EQ. 1 ) ) I_AM_MASTER = (id%MYID.EQ.MASTER) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since SMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. C equal to IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL SMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL SMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL SMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL SMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL SMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_PROBLEM SUBROUTINE SMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='real' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Single precision storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I12)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I12)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I12,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Single precision storage' ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_HEADER SUBROUTINE SMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(SMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), id%A(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), id%A(I8) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & id%A_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & id%A_loc(I8) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_MATRIX SUBROUTINE SMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE SMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(SMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='real' WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) id%RHS(K8) ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DUMP_RHS SUBROUTINE SMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE SMUMPS_BUILD_I_AM_CAND MUMPS_5.4.1/src/dfac_process_contrib_type2.F0000664000175000017500000004771614102210522021126 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_LOAD USE DMUMPS_BUF USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_FAC_LR, ONLY: DMUMPS_DECOMPRESS_PANEL USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR, & DMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NB_BLR_COLS, allocok, & NBROWS_PACKET_2PACK, PANEL_BEG_OFFSET INTEGER(8) :: LA_TEMP DOUBLE PRECISION, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), ALLOCATABLE, TARGET :: BLR_CB(:) INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE DOUBLE PRECISION, DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL DMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF ( SLAVE_NODE ) THEN IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL DMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL DMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 3, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ENDIF CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 200 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ENDDO 200 CONTINUE CALL DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL DMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 4, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW+I-1 ), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW & ) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 300 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH &) ENDDO 300 CONTINUE IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL DMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL DMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL DMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) CALL DMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL DMUMPS_DM_FREE_BLOCK( DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.4.1/src/dfac_scalings_simScale_util.F0000664000175000017500000012063614102210525021261 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) C IMPLICIT NONE EXTERNAL DMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(DMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL DMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL DMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif C WE FIRST ZERO OUT DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE DMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: MYID, NUMPROCS, M, N, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C [ROW/COL]PARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: ROWPARTVEC(M) INTEGER, INTENT(IN) :: COLPARTVEC(N) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C INUMMYR < M and INUMMYC < N (CPA or <= ??) C INUMMYR holds the number of rows allocated to me C or non empty on my proc C INUMMYC idem with columns INTEGER INUMMYR, INUMMYC C C INTERNAL working array INTEGER IWRK(IWSZ) C C Local variables INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 INUMMYC = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED C INUMMYR first counts number of rows affected to me C (that will be centralized on MYID) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IC = JCN_loc(I8) IR = IRN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) THEN IWRK(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO C RETURN END SUBROUTINE DMUMPS_FINDNUMMYROWCOL SUBROUTINE DMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER(8) :: NZ_loc INTEGER MYID, NUMPROCS, M, N INTEGER INUMMYR, INUMMYC, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = M IF(N > MAXMN) MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE DMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION DMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I, IID DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) DMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN DMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION DMUMPS_CHK1LOC INTEGER FUNCTION DMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION EPS C LOCAL VARS INTEGER I DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) DMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN DMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION DMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION DMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ DOUBLE PRECISION DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL DMUMPS_CHK1LOC INTEGER DMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = DMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = DMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) DMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION DMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C DOUBLE PRECISION FUNCTION DMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ) C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I, IIND DOUBLE PRECISION ERRMAX INTRINSIC abs ERRMAX = -RONE DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO DMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION DMUMPS_ERRSCALOC DOUBLE PRECISION FUNCTION DMUMPS_ERRSCA1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) C LOCAL VARS DOUBLE PRECISION RONE PARAMETER(RONE=1.0D0) INTEGER I DOUBLE PRECISION ERRMAX1 INTRINSIC abs ERRMAX1 = -RONE DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO DMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION DMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND) = D(IIND)/sqrt(TMPD(IIND)) ENDDO RETURN END SUBROUTINE DMUMPS_UPDATESCALE SUBROUTINE DMUMPS_UPSCALE1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I DOUBLE PRECISION RZERO PARAMETER(RZERO=0.0D0) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO RETURN END SUBROUTINE DMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE DMUMPS_INITREALLST C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_INVLIST(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ DOUBLE PRECISION D(DSZ) INTEGER INDX(INDXSZ) C LOCALS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0D0/D(IIND) ENDDO RETURN END SUBROUTINE DMUMPS_INVLIST C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_INITREAL(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ DOUBLE PRECISION D(DSZ) DOUBLE PRECISION VAL C LOCAL VARS INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE DMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ DOUBLE PRECISION TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I DOUBLE PRECISION DZERO PARAMETER(DZERO=0.0D0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE DMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE DMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX hold col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE DMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE DMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE DMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL DOUBLE PRECISION TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) DOUBLE PRECISION ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) DOUBLE PRECISION OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_DOUBLE_PRECISION, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_DOCOMM1N SUBROUTINE DMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL DMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc INTEGER, INTENT(IN) :: ISZ, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(DMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL DMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL DMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 IWRK(2*IC-1) = IWRK(2*IC-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_CREATEPARTVECSYM SUBROUTINE DMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE DMUMPS_NUMVOLSNDRCVSYM SUBROUTINE DMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC).EQ.0) THEN IWRK(IC)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C THE SMAME THING APPLIES FOR COLS C No need to do anything C RETURN END SUBROUTINE DMUMPS_FINDNUMMYROWCOLSYM INTEGER FUNCTION DMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ DOUBLE PRECISION D(N) INTEGER INDXR(INDXRSZ) DOUBLE PRECISION EPS INTEGER COMM EXTERNAL DMUMPS_CHK1LOC INTEGER DMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = DMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) DMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION DMUMPS_CHKCONVGLOSYM SUBROUTINE DMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE DMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE DMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE DMUMPS_SETUPCOMMSSYM MUMPS_5.4.1/src/ssol_bwd_aux.F0000664000175000017500000020576614102210521016321 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE SMUMPS_OOC USE SMUMPS_BUF USE SMUMPS_SOL_LR, only : SMUMPS_SOL_BWD_LR_SU INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) REAL :: A(LA), W(LWC) REAL :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR = 0_8 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) CALL SMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 SMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR = PTRACB(STEP( INODE )) - 1_8 CALL SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL SMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL SMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL SMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) ELSE IPOSINRHSCOMP = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL SMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB_PANEL = PTWCB + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL SMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL sgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL sgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE CALL strsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ELSE CALL strsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL SMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL sgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL sgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL sgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSCOMP,8) & + int(IPOSINRHSCOMP,8) CALL SMUMPS_SOLVE_BWD_TRSOLVE( A(1), LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSCOMP(1,1), KEEP8(25), LRHSCOMP, PPIV_COURANT, & MTYPE, KEEP) ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL SMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE )) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL SMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE SMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC REAL W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) REAL A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) REAL RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL SMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE SMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE SMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE SMUMPS_OOC USE SMUMPS_SOL_LR, ONLY: SMUMPS_SOL_SLAVE_LR_U, & SMUMPS_SOL_BWD_LR_SU USE SMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC REAL W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) REAL RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG REAL ZERO, ALPHA, ONE PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL SMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_REAL, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSCOMP = abs( POSINRHSCOMP_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF ( (IPOSINRHSCOMP.EQ.0) .OR. & ( IPOSINRHSCOMP.GT.N ) ) CYCLE RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_REAL, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL SMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL SMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL SMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_REAL, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN CALL SMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( LIELL*NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 260 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 260 END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - LIELL*NRHS_B PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTRACB(STEP(INODE))+NPIV-1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR8 = IFR8 + J2-KEEP(253)-J1+1 IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL SMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, & NROW_L, NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL=NPANELS,1,-1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) PTWCB_PANEL = PTRACB(STEP(INODE)) + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL SMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL sgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL sgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF CALL strsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL sgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+NPIV ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF CALL strsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL SMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(1) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NRHS_B == 1 ) THEN CALL sgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE CALL sgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE #endif CALL strsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(IPOS)) IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL SMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IN))) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, KEEP, & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL SMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE SMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE SMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in SMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE SMUMPS_BUILD_PANEL_POS MUMPS_5.4.1/src/dana_reordertree.F0000664000175000017500000012350114102210522017120 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DOUBLE PRECISION PEAK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,NSTK,INODE,I,allocok,LOCAL_PERM INTEGER(8) NCB INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER, DIMENSION (:), POINTER :: TAB INTEGER dernier,fin INTEGER cour,II INTEGER CB_current,CB_MAX,ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE,SUM,MEM_SEC_PERM,FACT_SIZE_T, & MEM_SIZE_T,TOTAL_MEM_SIZE,TMP_TOTAL_MEM_SIZE,TMP_SUM, & SIZECB, SIZECB_LASTSON INTEGER(8) TMP8 LOGICAL SBTR_M INTEGER FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in DMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL DMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NSTK = NE(STEP(INODE)) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL DMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL DMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL DMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF CONTINUE IFATH=INODE DO II=1,2 SUM=0_8 FACT_SIZE=0_8 FACT_SIZE_T=0_8 MEM_SIZE=0_8 MEM_SIZE_T=0_8 CB_MAX=0 CB_current=0 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in DMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL DMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(dble(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL DMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_REORDER_TREE SUBROUTINE DMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE DOUBLE PRECISION PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR DOUBLE PRECISION COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok,LOCAL_PERM INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER x,dernier,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE, & TOTAL_MEM_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF IF (K47 == 4 .OR. ((K47.GE.2).AND.(K81.GE. 1))) THEN DO I=1,SLAVEF INDICE(I)=1 ENDDO DO I=1,SLAVEF DO x=1,SIZE_MEM_SBTR MEM_SUBTREE(x,I)=-1.0D0 ENDDO ENDDO ENDIF SBTR_M=((K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1)))) MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in DMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL DMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & DMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE DMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL DMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL DMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE DMUMPS_FUSION_SORT MUMPS_5.4.1/src/ssol_omp_m.F0000664000175000017500000000076614102210522015771 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SOL_L0OMP_M END MODULE SMUMPS_SOL_L0OMP_M MUMPS_5.4.1/src/mumps_scotch64.c0000664000175000017500000000465514102210474016544 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Interfacing with 64-bit SCOTCH and pt-SCOTCH */ #include #include "mumps_scotch64.h" #if defined(scotch) || defined(ptscotch) void MUMPS_CALL MUMPS_SCOTCH_64( const MUMPS_INT8 * const n, /* in */ const MUMPS_INT8 * const iwlen, /* in */ MUMPS_INT8 * const petab, /* inout */ const MUMPS_INT8 * const pfree, /* in */ MUMPS_INT8 * const lentab, /* in (modified in ANA_H) */ MUMPS_INT8 * const iwtab, /* in (modified in ANA_H) */ MUMPS_INT8 * const nvtab, /* out or inout if weight used on entry */ MUMPS_INT8 * const elentab, /* out */ MUMPS_INT8 * const lasttab, /* out */ MUMPS_INT * const ncmpa, /* out */ MUMPS_INT * const weightused, /* out */ MUMPS_INT * const weightrequested ) /* in */ { /* weightused(out) = 1 if weight of nodes provided in nvtab are used (esmumpsv is called) = 0 otherwise */ #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv prototype with 64-bit integers weights of nodes in the graph are used on entry (nvtab) */ if ( *weightrequested == 1 ) { *ncmpa = esmumpsv( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=1; } else { /* esmumps prototype with standard integers (weights of nodes not used on entry) */ *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=0; } #else /* esmumps prototype with standard integers (weights of nodes not used on entry) */ *ncmpa = esmumps( *n, *iwlen, petab, *pfree, lentab, iwtab, nvtab, elentab, lasttab ); *weightused=0; #endif } #endif MUMPS_5.4.1/src/cmumps_save_restore.F0000664000175000017500000126553314102210524017717 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SAVE_RESTORE USE CMUMPS_STRUC_DEF USE CMUMPS_SAVE_RESTORE_FILES USE CMUMPS_LR_DATA_M USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE CONTAINS SUBROUTINE CMUMPS_REMOVE_SAVED(id) USE CMUMPS_OOC INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (CMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK,UNIT_OK,UNIT_OP LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (CMUMPS_STRUC) :: localid ierr = 0 call CMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN fileunit = 40 inquire (UNIT=fileunit,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = fileunit ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL CMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call CMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call CMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END SUBROUTINE CMUMPS_REMOVE_SAVED SUBROUTINE CMUMPS_RESTORE_OOC(localid) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: UNIT_OK,UNIT_OP TYPE (CMUMPS_STRUC) :: localid NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL CMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN IN=50 inquire(UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN localid%INFO(1) = -79 localid%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = 0 endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_SAVE_RESTORE_STRUCTURE(localid,IN,"restore_ooc" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE CMUMPS_RESTORE_OOC SUBROUTINE CMUMPS_COMPUTE_MEMORY_SAVE(id, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) INCLUDE 'mpif.h' INTEGER::NBVARIABLES,NBVARIABLES_ROOT INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (CMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE CMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE CMUMPS_SAVE(id) INCLUDE 'mpif.h' INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOT,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (CMUMPS_STRUC) :: id INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL CMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUT=60 inquire (UNIT=OUT,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUTINFO=70 inquire (UNIT=OUTINFO,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUTINFO ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,OUT,"save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFO(1) endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by CMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_F2003) write(OUTINFO,*) "Using MUMPS_F2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_SAVE SUBROUTINE CMUMPS_RESTORE(id) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (CMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL CMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN IN=80 inquire (UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL CMUMPS_SAVE_RESTORE_STRUCTURE(id,IN,"restore" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFO(1):" & , id%INFO(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else id%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_RESTORE SUBROUTINE CMUMPS_SAVE_RESTORE_STRUCTURE(id,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE CMUMPS_FACSOL_L0OMP_M, ONLY : CMUMPS_SAVE_RESTORE_L0FACARRAY IMPLICIT NONE INCLUDE 'mpif.h' INTEGER,intent(in)::unit,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=*),intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOT)::SIZE_VARIABLES_ROOT INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOT)::SIZE_GEST_ROOT INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER(len=30), allocatable, dimension(:)::VARIABLES CHARACTER(len=30), allocatable, dimension(:)::VARIABLES_ROOT CHARACTER(len=30) :: TMP_STRING1, TMP_STRING2 CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOT)::NbRecords_ROOT INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64 INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOT)::DIFF_SIZE_ALLOC_READ_ROOT INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC TYPE (CMUMPS_STRUC) :: id allocate(VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES(186)="ASSOCIATED_OOC_FILES" VARIABLES(185)="pad16" VARIABLES(184)="Deficiency" VARIABLES(183)="NB_SINGULAR_VALUES" VARIABLES(182)="SINGULAR_VALUES" VARIABLES(181)="MPITOOMP_PROCS_MAP" VARIABLES(180)="L0_OMP_MAPPING" VARIABLES(179)="PTR_LEAFS_L0_OMP" VARIABLES(178)="PERM_L0_OMP" VARIABLES(177)="VIRT_L0_OMP_MAPPING" VARIABLES(176)="VIRT_L0_OMP" VARIABLES(175)="PHYS_L0_OMP" VARIABLES(174)="IPOOL_A_L0_OMP" VARIABLES(173)="IPOOL_B_L0_OMP" VARIABLES(172)="I8_L0_OMP" VARIABLES(171)="I4_L0_OMP" VARIABLES(170)="THREAD_LA" VARIABLES(169)="LL0_OMP_FACTORS" VARIABLES(168)="LL0_OMP_MAPPING" VARIABLES(167)="L_VIRT_L0_OMP" VARIABLES(166)="L_PHYS_L0_OMP" VARIABLES(165)="LPOOL_B_L0_OMP" VARIABLES(164)="LPOOL_A_L0_OMP" VARIABLES(163)="L0_OMP_FACTORS" VARIABLES(162)="BLRARRAY_ENCODING" VARIABLES(161)="FDM_F_ENCODING" VARIABLES(160)="pad13" VARIABLES(159)="NBGRP" VARIABLES(158)="LRGROUPS" VARIABLES(157)="root" VARIABLES(156)="WORKING" VARIABLES(155)="IPTR_WORKING" VARIABLES(154)="pad14" VARIABLES(153)="SUP_PROC" VARIABLES(152)="PIVNUL_LIST" VARIABLES(151)="OOC_FILE_NAMES" VARIABLES(150)="OOC_FILE_NAME_LENGTH" VARIABLES(149)="pad12" VARIABLES(148)="OOC_NB_FILE_TYPE" VARIABLES(147)="OOC_NB_FILES" VARIABLES(146)="OOC_TOTAL_NB_NODES" VARIABLES(145)="OOC_VADDR" VARIABLES(144)="OOC_SIZE_OF_BLOCK" VARIABLES(143)="OOC_INODE_SEQUENCE" VARIABLES(142)="OOC_MAX_NB_NODES_FOR_ZONE" VARIABLES(141)="INSTANCE_NUMBER" VARIABLES(140)="CB_SON_SIZE" VARIABLES(139)="DKEEP" VARIABLES(138)="LWK_USER" VARIABLES(137)="NBSA_LOCAL" VARIABLES(136)="WK_USER" VARIABLES(135)="CROIX_MANU" VARIABLES(134)="SCHED_SBTR" VARIABLES(133)="SCHED_GRP" VARIABLES(132)="SCHED_DEP" VARIABLES(131)="SBTR_ID" VARIABLES(130)="DEPTH_FIRST_SEQ" VARIABLES(129)="DEPTH_FIRST" VARIABLES(128)="MY_NB_LEAF" VARIABLES(127)="MY_FIRST_LEAF" VARIABLES(126)="MY_ROOT_SBTR" VARIABLES(125)="COST_TRAV" VARIABLES(124)="MEM_SUBTREE" VARIABLES(123)="RHSCOMP" VARIABLES(122)="POSINRHSCOMP_COL" VARIABLES(121)="pad11" VARIABLES(120)="POSINRHSCOMP_COL_ALLOC" VARIABLES(119)="POSINRHSCOMP_ROW" VARIABLES(118)="MEM_DIST" VARIABLES(117)="I_AM_CAND" VARIABLES(116)="TAB_POS_IN_PERE" VARIABLES(115)="FUTURE_NIV2" VARIABLES(114)="ISTEP_TO_INIV2" VARIABLES(113)="CANDIDATES" VARIABLES(112)="ELTPROC" VARIABLES(111)="LELTVAR" VARIABLES(110)="NELT_loc" VARIABLES(109)="DBLARR" VARIABLES(108)="INTARR" VARIABLES(107)="PROCNODE" VARIABLES(106)="S" VARIABLES(105)="PTRFAC" VARIABLES(104)="PTLUST_S" VARIABLES(103)="Step2node" VARIABLES(102)="PROCNODE_STEPS" VARIABLES(101)="NA" VARIABLES(100)="PTRAR" VARIABLES(99)="FRTELT" VARIABLES(98)="FRTPTR" VARIABLES(97)="FILS" VARIABLES(96)="DAD_STEPS" VARIABLES(95)="FRERE_STEPS" VARIABLES(94)="ND_STEPS" VARIABLES(93)="NE_STEPS" VARIABLES(92)="STEP" VARIABLES(91)="NBSA" VARIABLES(90)="LNA" VARIABLES(89)="KEEP" VARIABLES(88)="IS" VARIABLES(87)="ASS_IRECV" VARIABLES(86)="NSLAVES" VARIABLES(85)="NPROCS" VARIABLES(84)="MYID" VARIABLES(83)="COMM_LOAD" VARIABLES(82)="MYID_NODES" VARIABLES(81)="COMM_NODES" VARIABLES(80)="INST_Number" VARIABLES(79)="MAX_SURF_MASTER" VARIABLES(78)="KEEP8" VARIABLES(77)="pad7" VARIABLES(76)="SAVE_PREFIX" VARIABLES(75)="SAVE_DIR" VARIABLES(74)="WRITE_PROBLEM" VARIABLES(73)="OOC_PREFIX" VARIABLES(72)="OOC_TMPDIR" VARIABLES(71)="VERSION_NUMBER" VARIABLES(70)="MAPPING" VARIABLES(69)="LISTVAR_SCHUR" VARIABLES(68)="SCHUR_CINTERFACE" VARIABLES(67)="SCHUR" VARIABLES(66)="SIZE_SCHUR" VARIABLES(65)="SCHUR_LLD" VARIABLES(64)="SCHUR_NLOC" VARIABLES(63)="SCHUR_MLOC" VARIABLES(62)="NBLOCK" VARIABLES(61)="MBLOCK" VARIABLES(60)="NPCOL" VARIABLES(59)="NPROW" VARIABLES(58)="UNS_PERM" VARIABLES(57)="SYM_PERM" VARIABLES(56)="METIS_OPTIONS" VARIABLES(55)="RINFOG" VARIABLES(54)="RINFO" VARIABLES(53)="CNTL" VARIABLES(52)="COST_SUBTREES" VARIABLES(51)="INFOG" VARIABLES(50)="INFO" VARIABLES(49)="ICNTL" VARIABLES(48)="pad6" VARIABLES(47)="LSOL_loc" VARIABLES(46)="LREDRHS" VARIABLES(45)="LRHS_loc" VARIABLES(44)="Nloc_RHS" VARIABLES(43)="NZ_RHS" VARIABLES(42)="NRHS" VARIABLES(41)="LRHS" VARIABLES(40)="IRHS_loc" VARIABLES(39)="ISOL_loc" VARIABLES(38)="IRHS_PTR" VARIABLES(37)="IRHS_SPARSE" VARIABLES(36)="RHS_loc" VARIABLES(35)="SOL_loc" VARIABLES(34)="RHS_SPARSE" VARIABLES(33)="REDRHS" VARIABLES(32)="RHS" VARIABLES(31)="BLKVAR" VARIABLES(30)="BLKPTR" VARIABLES(29)="pad5" VARIABLES(28)="NBLK" VARIABLES(27)="PERM_IN" VARIABLES(26)="pad4" VARIABLES(25)="A_ELT" VARIABLES(24)="ELTVAR" VARIABLES(23)="ELTPTR" VARIABLES(22)="pad3" VARIABLES(21)="NELT" VARIABLES(20)="pad2" VARIABLES(19)="A_loc" VARIABLES(18)="JCN_loc" VARIABLES(17)="IRN_loc" VARIABLES(16)="NNZ_loc" VARIABLES(15)="pad1" VARIABLES(14)="NZ_loc" VARIABLES(13)="pad0" VARIABLES(12)="ROWSCA" VARIABLES(11)="COLSCA" VARIABLES(10)="JCN" VARIABLES(9)="IRN" VARIABLES(8)="A" VARIABLES(7)="NNZ" VARIABLES(6)="NZ" VARIABLES(5)="N" VARIABLES(4)="JOB" VARIABLES(3)="PAR" VARIABLES(2)="SYM" VARIABLES(1)="COMM" allocate(VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES_ROOT(35)="rootpad4" VARIABLES_ROOT(34)="NB_SINGULAR_VALUES" VARIABLES_ROOT(33)="SINGULAR_VALUES" VARIABLES_ROOT(32)="SVD_VT" VARIABLES_ROOT(31)="SVD_U" VARIABLES_ROOT(30)="gridinit_done" VARIABLES_ROOT(29)="yes" VARIABLES_ROOT(28)="rootpad3" VARIABLES_ROOT(27)="QR_RCOND" VARIABLES_ROOT(26)="rootpad" VARIABLES_ROOT(25)="RHS_ROOT" VARIABLES_ROOT(24)="rootpad2" VARIABLES_ROOT(23)="QR_TAU" VARIABLES_ROOT(22)="SCHUR_POINTER" VARIABLES_ROOT(21)="RHS_CNTR_MASTER_ROOT" VARIABLES_ROOT(20)="rootpad1" VARIABLES_ROOT(19)="IPIV" VARIABLES_ROOT(18)="RG2L_COL" VARIABLES_ROOT(17)="RG2L_ROW" VARIABLES_ROOT(16)="rootpad0" VARIABLES_ROOT(15)="LPIV" VARIABLES_ROOT(14)="CNTXT_BLACS" VARIABLES_ROOT(13)="DESCRIPTOR" VARIABLES_ROOT(12)="TOT_ROOT_SIZE" VARIABLES_ROOT(11)="ROOT_SIZE" VARIABLES_ROOT(10)="RHS_NLOC" VARIABLES_ROOT(9)="SCHUR_LLD" VARIABLES_ROOT(8)="SCHUR_NLOC" VARIABLES_ROOT(7)="SCHUR_MLOC" VARIABLES_ROOT(6)="MYCOL" VARIABLES_ROOT(5)="MYROW" VARIABLES_ROOT(4)="NPCOL" VARIABLES_ROOT(3)="NPROW" VARIABLES_ROOT(2)="NBLOCK" VARIABLES_ROOT(1)="MBLOCK" OOC_INDICES=(/147,148,150,151/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(16) SIZE_ARITH_DEP = id%KEEP(35) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOT(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOT(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(trim(mode).EQ."memory_save") then elseif(trim(mode).EQ."save") then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="CMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (trim(mode).EQ."restore_ooc") THEN BASIC_CHECK = .true. ENDIF CALL CMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(trim(mode).EQ."fake_restore") then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("OOC_NB_FILES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILE_TYPE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAMES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAME_LENGTH") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(trim(mode).EQ."restore_ooc") then goto 200 endif DO i1=1,NBVARIABLES TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("COMM") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("SYM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SYM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SYM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%PAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%PAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("JOB") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("N") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%N if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%N if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ICNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_SUBTREES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP8") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) read(unit,iostat=err) id%KEEP8 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) read(unit,iostat=err) id%KEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DKEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("A") CASE("IRN") CASE("JCN") CASE("COLSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COLSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%COLSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COLSCA)) THEN write(unit,iostat=err) size(id%COLSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%COLSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COLSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%COLSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COLSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("ROWSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ROWSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ROWSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ROWSCA)) THEN write(unit,iostat=err) size(id%ROWSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%ROWSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ROWSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%ROWSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ROWSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("NZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IRN_loc") CASE("JCN_loc") CASE("A_loc") CASE("NELT") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPTR") CASE("ELTVAR") CASE("A_ELT") CASE("PERM_IN") CASE("BLKPTR") CASE("BLKVAR") CASE("RHS") CASE("REDRHS") CASE("RHS_SPARSE") CASE("SOL_loc") CASE("RHS_loc") CASE("IRHS_SPARSE") CASE("IRHS_PTR") CASE("ISOL_loc") CASE("IRHS_loc") CASE("LRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ_RHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_RHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_RHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRHS_loc") CASE("Nloc_RHS") CASE("LSOL_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LSOL_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LSOL_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LREDRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LREDRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LREDRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SYM_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%SYM_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SYM_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SYM_PERM)) THEN write(unit,iostat=err) size(id%SYM_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SYM_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SYM_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SYM_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SYM_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("UNS_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SIZE_SCHUR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR") CASE("SCHUR_CINTERFACE") CASE("LISTVAR_SCHUR") CASE("MAPPING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("VERSION_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TMPDIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WRITE_PROBLEM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MAX_SURF_MASTER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INST_Number") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INST_Number if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INST_Number if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_NODES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID_NODES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID_NODES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID_NODES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_LOAD") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROCS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROCS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROCS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NSLAVES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NSLAVES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NSLAVES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASS_IRECV") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ASS_IRECV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%ASS_IRECV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Deficiency") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%Deficiency if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%Deficiency if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LNA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LNA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LNA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBSA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("STEP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%STEP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%STEP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%STEP)) THEN write(unit,iostat=err) size(id%STEP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%STEP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%STEP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES(i1),id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%STEP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%STEP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ND_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Step2node") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRERE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DAD_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FILS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FILS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FILS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FILS)) THEN write(unit,iostat=err) size(id%FILS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FILS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FILS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FILS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FILS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRAR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(trim(mode).EQ."restore") then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTPTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTELT") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NA") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTLUST_S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRFAC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array_INT8_1,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE") CASE("INTARR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%INTARR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(27)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%INTARR)) THEN write(unit,iostat=err) id%KEEP8(27) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%INTARR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%INTARR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%INTARR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%INTARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DBLARR") CASE("NELT_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LELTVAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LELTVAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LELTVAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPROC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I4_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I8_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CANDIDATES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ISTEP_TO_INIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FUTURE_NIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TAB_POS_IN_PERE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I_AM_CAND") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_DIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_ROW") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_ROW,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_ROW,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_ROW ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_ROW) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_ROW(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_ROW endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL_ALLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_COL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_COL ELSE write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%POSINRHSCOMP_COL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_COL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_COL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%POSINRHSCOMP_COL=>id%POSINRHSCOMP_ROW endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHSCOMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%RHSCOMP)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%RHSCOMP)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSCOMP ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%RHSCOMP) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSCOMP(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSCOMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_SUBTREE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_TRAV") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_ROOT_SBTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_FIRST_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_NB_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST_SEQ") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SBTR_ID") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHED_DEP") CASE("SCHED_GRP") CASE("CROIX_MANU") CASE("WK_USER") CASE("NBSA_LOCAL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LWK_USER") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("CB_SON_SIZE") CASE("INSTANCE_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_MAX_NB_NODES_FOR_ZONE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_INODE_SEQUENCE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_SIZE_OF_BLOCK") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_VADDR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TOTAL_NB_NODES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILES") CASE("OOC_NB_FILE_TYPE") CASE("OOC_FILE_NAMES") CASE("OOC_FILE_NAME_LENGTH") CASE("PIVNUL_LIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SUP_PROC") CASE("IPTR_WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("root") DO i2=1,NBVARIABLES_ROOT TMP_STRING2 = VARIABLES_ROOT(i2) SELECT CASE(TMP_STRING2) CASE("MBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then NbRecords_ROOT(i2)=1 SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TOT_ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DESCRIPTOR") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=size(id%root%DESCRIPTOR,1) & *SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT* & size(id%root%DESCRIPTOR,1) read(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTXT_BLACS") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPIV") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RG2L_ROW") CASE("RG2L_COL") CASE("IPIV") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%IPIV)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%IPIV)) THEN write(unit,iostat=err) size(id%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_INT allocate(id%root%IPIV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_CNTR_MASTER_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%RHS_CNTR_MASTER_ROOT,1) & *SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN write(unit,iostat=err) & size(id%root%RHS_CNTR_MASTER_ROOT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_CNTR_MASTER_ROOT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_ARITH_DEP allocate(id%root%RHS_CNTR_MASTER_ROOT(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_POINTER") CASE("QR_TAU") CASE("RHS_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size(id%root%RHS_ROOT,1) & *size(id%root%RHS_ROOT,2)*SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_ROOT)) THEN write(unit,iostat=err) size(id%root%RHS_ROOT,1) & ,size(id%root%RHS_ROOT,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_ROOT ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_ROOT) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size_array1*size_array2 & *SIZE_ARITH_DEP allocate(id%root%RHS_ROOT(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("QR_RCOND") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL read(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("yes") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("gridinit_done") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SVD_U") CASE("SVD_VT") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("rootpad0","rootpad1","rootpad2","rootpad", & "rootpad3","rootpad4") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_ROOT(i2)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_ROOT(i2)=NbRecords_ROOT(i2)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_ROOT(i2) & +SIZE_GEST_ROOT(i2) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES_ROOT(i2)+ & DIFF_SIZE_ALLOC_READ_ROOT(i2) size_read=size_read+SIZE_VARIABLES_ROOT(i2) & +int(SIZE_GEST_ROOT(i2),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO CASE("NBGRP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBGRP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBGRP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRGROUPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%LRGROUPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%LRGROUPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%LRGROUPS)) THEN write(unit,iostat=err) size(id%LRGROUPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LRGROUPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%LRGROUPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%LRGROUPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LRGROUPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FDM_F_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("BLRARRAY_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL CMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL CMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL CMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L0_OMP_FACTORS") CASE("SCHED_SBTR") CASE("LPOOL_A_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPOOL_B_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_PHYS_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_VIRT_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_MAPPING") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_FACTORS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("THREAD_LA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IPOOL_A_L0_OMP") CASE("IPOOL_B_L0_OMP") CASE("PHYS_L0_OMP") CASE("VIRT_L0_OMP") CASE("VIRT_L0_OMP_MAPPING") CASE("PERM_L0_OMP") CASE("PTR_LEAFS_L0_OMP") CASE("L0_OMP_MAPPING") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASSOCIATED_OOC_FILES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE("SAVE_DIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SAVE_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MPITOOMP_PROCS_MAP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MPITOOMP_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MPITOOMP_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MPITOOMP_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MPITOOMP_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MPITOOMP_PROCS_MAP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MPITOOMP_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("METIS_OPTIONS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("pad0","pad1","pad2","pad3","pad4","pad5","pad6","pad7", & "pad11","pad111", "pad12","pad13","pad14","pad15","pad16") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO 200 continue if(trim(mode).EQ."memory_save") then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+sum(SIZE_VARIABLES_ROOT) & +SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOT) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOT) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if !defined(MUMPS_F2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOT)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(trim(mode).EQ."save") then elseif(trim(mode).EQ."restore") then if(id%root%gridinit_done) then id%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( id%root%CNTXT_BLACS, 'R', & id%root%NPROW, id%root%NPCOL ) id%root%gridinit_done = .TRUE. endif elseif(trim(mode).EQ."fake_restore") then elseif(trim(mode).EQ."restore_ooc") then endif 100 continue deallocate(VARIABLES, VARIABLES_ROOT) RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_STRUCTURE END MODULE CMUMPS_SAVE_RESTORE MUMPS_5.4.1/src/mumps_l0_omp_m.F0000664000175000017500000000135214102210475016544 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_L0_OMP_M LOGICAL, DIMENSION(:), POINTER :: NB_CORE_PER_THREAD_CHANGED INTEGER, DIMENSION(:), POINTER :: NB_CORE_PER_THREAD INTEGER :: THREAD_ID LOGICAL :: IS_ROOT_OF_L0_OMP !$OMP THREADPRIVATE ( THREAD_ID , IS_ROOT_OF_L0_OMP ) END MODULE MUMPS_L0_OMP_M MUMPS_5.4.1/src/dfac_front_LU_type2.F0000664000175000017500000011506014102210523017445 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC2_LU_M CONTAINS SUBROUTINE DMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) !$ USE OMP_LIB USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_FAC_FRONT_TYPE2_AUX_M USE DMUMPS_OOC USE DMUMPS_BUF, ONLY : DMUMPS_BUF_TEST USE DMUMPS_FAC_LR USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M !$ USE OMP_LIB USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTBL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0D0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : DMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 2 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL DMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL DMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR,DBLARR, & ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL DMUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL DMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 490 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL DMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL DMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL DMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 490 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(68) = max(KEEP8(69), KEEP8(68)) !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(70) = max(KEEP8(71), KEEP8(70)) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) & THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE DMUMPS_FAC2_LU END MODULE DMUMPS_FAC2_LU_M MUMPS_5.4.1/src/dana_driver.F0000664000175000017500000056401214102210525016102 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE DMUMPS_ANA_DRIVER(id) USE DMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE DMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE DMUMPS_PARALLEL_ANALYSIS USE DMUMPS_ANA_LR USE DMUMPS_LR_CORE USE DMUMPS_LR_STATS USE MUMPS_LR_COMMON USE DMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(DMUMPS_STRUC), TARGET :: id C C Local variables C =============== C C C Pointers inside integer array, various data INTEGER IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LOCAL_M, LOCAL_N INTEGER numroc EXTERNAL numroc INTEGER IRANK INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 INTEGER MIN_BUF_SIZE INTEGER(8) MAX_SIZE_FACTOR_TMP INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) DOUBLE PRECISION :: PEAK INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:):: IPOOL INTEGER :: LIPOOL INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, PERLU_ON, COND INTEGER :: OOC_STRAT, BLR_STRAT INTEGER :: IDUMMY INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed LOGICAL :: SUM_OF_PEAKS INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: TEMP_MEM INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_ROOT INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_LEAF INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_SIZE INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST_SEQ INTEGER, DIMENSION (:), ALLOCATABLE :: SBTR_ID DOUBLE PRECISION, DIMENSION (:), ALLOCATABLE :: COST_TRAV_TMP INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP LOGICAL :: GCOMP_PROVIDED TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, & STEPPTR, LRGROUPSPTR INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK INTEGER :: LIW_ELT C INTERFACE C Explicit interface because of pointer arguments: SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE DMUMPS_LR_DATA_M, only : DMUMPS_BLR_STRUC_TO_MOD, & DMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Beginning of executable statements C IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) NULLIFY ( NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, STEPPTR, LRGROUPSPTR, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR ) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) IDUMMY = 1 BDUMMY = .FALSE. C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C ---------------------------------------- C Free some memory from factorization, C if allocated, at least large arrays. C This will also limit the amount of useless C data saved to disk in case of save-restore C ---------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF NULLIFY(id%S) KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C also avoid keeping BLR factors allocated if analysis C called after a previous BLR factorization without C an intermediate JOB=-2 call. CALL DMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C -------------------------------------------- C If analysis redone, suppress old, C meaningless, Step2node array. C This is necessary since we could otherwise C end up having a wrong Step2node during solve C -------------------------------------------- IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: DMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL DMUMPS_ANA_CHECK_KEEP(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that DMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL DMUMPS_DUMP_PROBLEM(id) C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).NE.0) THEN C Analysis by block with block data provided by user C C Check if block structure is centralized or distributed IF (.NOT.associated(id%BLKVAR)) THEN C BLKVAR is identity and implicitly centralized KEEP(14) = 0 ELSE IF (size(id%BLKVAR).EQ.id%N) THEN C Centralized block stucture KEEP(14) = 0 ELSE C Distributed block stucture KEEP(14) = 1 IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF IF (KEEP(13).GE.1) THEN C BLKPTR provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF NBLK=id%NBLK IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of KEEP(13).NE.0 ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF (id%MYID.EQ.MASTER.AND.allocok.EQ.0) THEN C BLKPTR and BLKVAR needed for DMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR)) THEN BLKPTR_ALLOCATED = .TRUE. allocate(id%BLKPTR(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .TRUE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ENDIF IF (.NOT.associated(id%BLKVAR).AND.allocok.EQ.0) THEN allocate(id%BLKVAR(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N id%BLKVAR(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 id%BLKPTR(IB) = I ENDDO id%BLKPTR(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, id%BLKPTR(1), id%BLKVAR(1), & SIZEOFBLOCKS, DOF2BLOCK) ENDIF C ======================= IF (KEEP(54).NE.3) THEN C ======================= C --------------------- C Matrix structure available on host C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, id%KEEP8(28), IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1)) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ==== ELSE C ==== C ------------------------------- C Matrix structure is distributed C and since KEEP(13).NE.0 then C ordering is centralized since C ------------------------------- C IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Centralized cleaned graph is ready C call directly with GCOMP READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP_DIST, READY_FOR_ANA_F) ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) ENDIF ELSE CALL DMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to DMUMPS_ANA_F and C DMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C DMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip DMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) DMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3*id%N), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=5*id%N ELSE CALL DMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in DMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=3*NBLK ENDIF ELSE ALLOCATE(IKEEPALLOC(NBLK+2*id%N), & FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=4*NBLK+2*id%N ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside DMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to DMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW_ELT = id%N + id%N + 1 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW_ELT = id%N + id%N + id%N + 3 + id%N + 1 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for DMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8 = 3_8*int(NBLK,8) ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) IKEEP3 => IKEEPALLOC(NBLK+id%N+1:NBLK+2*id%N) C id%UNS_PERM corresponds to argument PIV C in DMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL DMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL DMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) CALL MUMPS_AB_FREE_GCOMP(GCOMP) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to DMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL DMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILSPTR(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to DMUMPS_ANA_F_ELT C be used in DMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FILSPTR) ) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N IF (id%MYID .EQ. MASTER) THEN ALLOCATE( IKEEPALLOC(3*id%N), WORK2ALLOC(4*id%N), & FILSPTR(id%N), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ELSE C Because our purpose is to minimize the peak memory consumption, C we can afford to allocate on processes other than host ALLOCATE(IKEEPALLOC(3*id%N),WORK2ALLOC(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 10*id%N ELSE INFO( 2 ) = 7*id%N ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 CALL DMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF KEEP(28) = INFOG(6) END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL DMUMPS_ANA_R(NBLK, FILSPTR(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL DMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILSPTR(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = dble(id%INFOG(5))*dble(id%INFOG(5)) + ! front matrix & dble(id%KEEP(2))*dble(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+NBLK-1) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL DMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILSPTR(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL DMUMPS_ANA_R(NBLK, FILSPTR(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL DMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILSPTR(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL DMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in DMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in DMUMPS_ANA_M) C is needed on all the procs during DMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in DMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- IF (id%MYID.EQ.MASTER) THEN C id%STEP is of size NBLK because it C is computed on compressed graph and then extended C and broadcasted on all procs CALL MUMPS_REALLOC(id%STEP, NBLK, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ELSE C id%STEP is of size id%N because it C is received in extended form CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C id%FILS is allocated before expand tree IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_REALLOC(id%LRGROUPS, NBLK, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ELSE CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+NBLK-2) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+NBLK-1) ELSE NBLEAF = IKEEPALLOC(NA+NBLK-2) NBROOT = IKEEPALLOC(NA+NBLK-1) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+NBLK-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+NBLK-2) < 0 ) THEN INODE = - IKEEPALLOC(NA+NBLK-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP(1:id%N) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 id%STEP(I)=ISTEP INN = FILSPTR(I) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = FILSPTR(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in DMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in DMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = FREREPTR(I) id%NE_STEPS(id%STEP(I)) = IKEEPALLOC(NE+I-1) id%ND_STEPS(id%STEP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(id%STEP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILSPTR(I) DO WHILE ( IFS .GT. 0 ) IFS= FILSPTR(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(id%STEP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C I/ Prepare data before call to grouping IF ((KEEP(54).EQ.3).AND.(KEEP(13).NE.0)) THEN C Matrix is distributed on entry and compression computed IF (KEEP(487).NE.1) CALL MUMPS_ABORT() ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, id%STEP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), id%STEP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) CALL MUMPS_AB_FREE_LMAT(LUMAT) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ELSE IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C ---> build LUMAT_REMAP on MASTER IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_AB_LMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, & INFO(1), ICNTL(1)) C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), id%STEP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (KEEP(487).NE.1) & ) THEN C Grouping preparation on slaves: C If the input matrix is distributed and the parallel analysis is C chosen, the graph used to be centralized in order to compute the C clustering. C CALL DMUMPS_GATHER_MATRIX(id) ENDIF C ============ C ============ C II/ GROUPING C ============ IF ((KEEP(54).EQ.3).AND.(KEEP(487).EQ.1)) THEN C Matrix is distributed on entry and halo of size 1 C Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILSPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C Distribute SIZEOFBLOCKS that was defined only on master C CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, C & id%COMM, IERR ) CALL DMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), LPOK, LP, id%COMM, id%MYID, id%NPROCS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF C ELSE IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C --- build LUMAT C -- LR grouping exploiting LUMAT C -- centralized => MAPCOL not needed C FIXME 5.4: call to DMUMPS_AB_LR_GROUPING "ready" to be C replaced by call to DMUMPS_AB_LR_MPI_GROUPING C IDUMMY_ARRAY(1) = -1 CALL DMUMPS_AB_LR_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP, id%MYID, id%COMM) ELSE C grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL DMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ELSE CALL DMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ENDIF ENDIF ENDIF C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP is allocated CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF IF (id%MYID.NE. MASTER) THEN CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 ENDIF C IF ((id%MYID.EQ.MASTER) .AND.(KEEP(13).NE.0)) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILSPTR, id%STEP into id%FILS, STEPPTR C and update arrays of size NSTEPS ALLOCATE(STEPPTR(id%N), LRGROUPSPTR(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=id%N GOTO 97 ENDIF IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL DMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, id%BLKPTR(1), id%BLKVAR(1), & FILSPTR(1), id%FILS(1), id%KEEP(28), & id%STEP(1), STEPPTR(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, id%LRGROUPS(1), LRGROUPSPTR(1), & id%KEEP(20), id%KEEP(38) & ) NULLIFY(PAR2_NODESPTR) DEALLOCATE(id%STEP) id%STEP=>STEPPTR NULLIFY(STEPPTR) DEALLOCATE(id%LRGROUPS) id%LRGROUPS=>LRGROUPSPTR NULLIFY(LRGROUPSPTR) DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ELSE if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF C} ENDIF IF ((id%N.EQ.NBLK).AND.associated(FILSPTR)) THEN C id%FILS has not been initialized if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF 97 CONTINUE CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL DMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL DMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL DMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF(((KEEP(494).NE.0).OR.KEEP(13).NE.0) & .AND.(id%KEEP(38).GT.0)) & THEN ! grouping at analysis (1 => LR CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NA(1), id%LNA, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%PROCNODE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DAD_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRERE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR) CALL MPI_BCAST( id%NE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%ND_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) END IF IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C At the end of ANA_N_DIST, id%PTRAR is already on every processor C because it is computed in a distributed way. C No need to broadcast it again CALL DMUMPS_ANA_N_DIST(id, id%PTRAR) IF(id%MYID .EQ. MASTER) THEN C ----------------------------------- C For distributed structure on entry, C we can now deallocate the complete C structure IRN / JCN. C ----------------------------------- IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN C IRN and JCN might have already been deallocated IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF END IF ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL DMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL DMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, id%root, & id%COMM_NODES, KEEP( 38 ), id%FILS(1), & id%KEEP(50), id%KEEP(46), & id%KEEP(51) & , id%KEEP(60), id%NPROW, id%NPCOL, id%MBLOCK, id%NBLOCK & ) ELSE id%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(id%root%MYROW, MYROW_CHECK, 1, & MPI_INTEGER, MPI_MAX, id%COMM_NODES, IERR) IF ( MYROW_CHECK .eq. -1) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( id%root%MYROW .LT. -1 .OR. & id%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN C{ C C IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%PTRAR(1), & id%PTRAR(id%N +1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id ) ELSE CALL DMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) ENDIF C} ENDIF C ----------------------------------------- C Perform some local analysis on the slaves C to estimate the size of the working space C for factorization C ----------------------------------------- IF ( I_AM_SLAVE ) THEN C{ locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES locMYID = id%MYID C =================================================== C Precompute estimates of local_m,local_n C (number of rows/columns mapped on each processor) C in case of parallel root node. C and allocate CANDIDATES C =================================================== C IF ( id%root%yes ) THEN LOCAL_M = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%MBLOCK, id%root%MYROW, 0, & id%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%NBLOCK, id%root%MYCOL, 0, & id%root%NPCOL ) ELSE LOCAL_M = 0 LOCAL_N = 0 END IF IF ( KEEP(60) .EQ. 2 .OR. KEEP(60) .EQ. 3 ) THEN C Return minimum nb rows/cols to user id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N C Also store them in root structure for convenience id%root%SCHUR_MLOC=LOCAL_M id%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- Allocate and initialise IPOOL with leaves C -- on which stats are performed IF ( I_AM_SLAVE ) THEN C{ LIPOOL = id%NA(1) C LIPOOL is number of leaf nodes and can be 0 C (for ex AboveL0 with nbthreads is 1) ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C{ C Initialize IPOOL with leaves of complete tree DO I=1, LIPOOL IPOOL(I) = id%NA(3+I-1) ENDDO ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 C NE_STEPSPTR => id%NE_STEPS KEEP(139) = MAXFR_UNDER_L0 CALL DMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOL, LIPOOL, NE_STEPSPTR(1), & id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & id%root%yes, id%root%NPROW, id%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR) C SUM_NIRNEC under L0 OMP KEEP(137)=0 C SUM_NIRNEC_OOC under L0 OMP KEEP(138)=0 C DKEEP(15) is used for dynamic load balancing only C it corresponds to the number of local operations C (in Millions) id%DKEEP(15) = RINFO(1)/1000000.0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) C KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) C Relaxed value of size of IS is not needed internally; C we save it directly in INFO(19) INFO( 19 ) = KEEP(225) + 3* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C ================================= C Size of S (relaxed with ICNTL(14) C =========================== C size of S relaxed (FR, IC) C =========================== KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S relaxed (FR or LR LU, OOC) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) C size of S relaxed (LR LU, IC) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) C size of S relaxed (LR CB, IC) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) C KEEP8( 22 ) is the OLD maximum size of receive buffer C that includes CB related communications. C KEEP( 43 ) : min size for send buffer C KEEP( 44 ) : min size for receive buffer C KEEP(43-44) kept for allocating buffers during C factorization phase CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) C We do a max with KEEP(27)=maxfront because for small C buffers, we need at least one row of cb to be sent/ C received. SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) KEEP(379)=KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF C MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min( MIN_BUF_SIZE8, int(huge (KEEP(43)),8)) MIN_BUF_SIZE = int( MIN_BUF_SIZE8 ) C KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(380) = max(KEEP(380), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) KEEP(379) = max(KEEP(379), MIN_BUF_SIZE) IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. real space to store factors :', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF C} ELSE C --------------------- C Master is not working C --------------------- ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0D0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C -------------------------------------- C KEEP8( 26 ) : Real arrowhead size C KEEP8( 27 ) : Integer arrowhead size C INFO(3)/KEEP8( 11 ) : Estimated real space needed for factors C INFO(4)/KEEP( 26 ) : Estimated integer space needed for factors C INFO(5)/KEEP( 27 ) : Estimated max front size C KEEP8(109) : Estimated number of entries in factor C (based on ENTRIES_IN_FACTORS_LOC_MASTERS computed C during DMUMPS_ANA_DISTM, where we assume C that each master of a node computes C the complete factor size. C -------------------------------------- C note that summing ENTRIES_IN_FACTORS_LOC_MASTERS or C ENTRIES_IN_FACTORS_LOC_MASTERS should lead to the same result CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) CALL MPI_ALLREDUCE( KEEP(26), KEEP(126), 1, & MPI_INTEGER, MPI_SUM, & id%COMM, IERR) C NRLADU related: KEEP8(11) holds factors above and under L0 CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C NRLADU_if_LR_LU related: KEEP8(32) holds factors above C and under L0 C convert it in Megabytes RINFO(5) = dble(KEEP8(32) & *int(KEEP(35),8))/1D6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) C in Megabytes IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = dble(ITMP8*int(KEEP(35),8))/1D6 ENDIF C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) C CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) C CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL DMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) C -------------------------- C COMPUTE MEMORY ESTIMATIONS IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) C -------------------------- C ========================= C IN-CORE MEMORY STATISTICS C ========================= C OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression IF (KEEP(201) .NE. -1) OOC_STRAT=0 ! We want in-core statistics PERLU_ON = .FALSE. ! switch off PERLU to compute KEEP8(2) CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(2) = TOTAL_BYTES C C PERLU_ON = .TRUE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) IF ( PROK ) THEN WRITE(MP,'(A,I12) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES C C Centralize memory statistics on the host C C INFOG(16) = after analysis, est. mem size in Mbytes for facto, C for the processor using largest memory C INFOG(17) = after analysis, est. mem size in Mbytes for facto, C sum over all processors C INFOG(18/19) = idem at facto. C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STRAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. ! PERLU NOT taken into account C Used to compute KEEP8(3) (minimum number of bytes for OOC) CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(3) = TOTAL_BYTES C PERLU_ON = .TRUE. ! PERLU taken into account CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) id%INFO(17) = TOTAL_MBYTES C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF IF (KEEP(494).NE.0) THEN C ========================================= C NOW COMPUTE BLR statistics C ========================================= SUM_OF_PEAKS = .TRUE. CALL DMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & ) C END IF C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL DMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & id%root%MBLOCK, id%root%NBLOCK, & id%root%NPROW, id%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(IPOOL)) DEALLOCATE(IPOOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) CALL MUMPS_AB_FREE_LMAT(LUMAT) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) CALL MUMPS_AB_FREE_GCOMP(GCOMP) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) IF (associated(FILSPTR)) DEALLOCATE(FILSPTR) IF (associated(id%BLKPTR).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(id%BLKPTR) nullify(id%BLKPTR) ENDIF IF (associated(id%BLKVAR).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(id%BLKVAR) nullify(id%BLKVAR) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING DMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_ANA_DRIVER SUBROUTINE DMUMPS_ANA_CHECK_KEEP(id) C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C -- OOC/Incore strategy IF (id%KEEP(201).NE.-1) THEN id%KEEP(201)=id%ICNTL(22) IF (id%KEEP(201) .GT. 0) THEN #if defined(OLD_OOC_NOPANEL) id%KEEP(201)=2 #else id%KEEP(201)=1 #endif ENDIF ENDIF C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif C Analysis strategy is set to automatic in case of out-of-range values. IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 ) THEN id%KEEP(106)=1 C Automatic choice leads to new symbolic C factorization except(see below) if KEEP(256)==1. ELSE id%KEEP(106)=id%ICNTL(58) IF (id%KEEP(106).EQ.3) THEN C option not available id%KEEP(106)=1 ENDIF ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: DMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine DMUMPS_BDCAST C -------------------------------- id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).LT.0) THEN IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF IF (associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with BLKPTR provided by user" ENDIF id%INFO(1) = -57 id%INFO(2) = 4 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) & ) & THEN IF ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).NE.2)) THEN id%KEEP(13)=-1 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0 ) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) .AND. & (id%KEEP(244).NE.2) & ) & THEN C unsymmetic assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off because C if one activates the analysis by block IF ( (id%KEEP(23).LT.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1) & ) THEN IF (PROKG) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block compatible ", & "ONLY with SYMQAMD based symbolic factorization ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(244).EQ.2) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with parallel ordering " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE DMUMPS_ANA_CHECK_KEEP SUBROUTINE DMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(DMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROK, PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG, I_AM_SLAVE INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING DMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE DMUMPS_GATHER_MATRIX SUBROUTINE DMUMPS_DUMP_PROBLEM(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C DMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and DMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(DMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB DOUBLE PRECISION, TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED DOUBLE PRECISION, POINTER, DIMENSION(:) :: A_PASSED PARAMETER( MASTER = 0 ) IUNIT = 69 I_AM_SLAVE = ( id%MYID .NE. MASTER .OR. & ( id%MYID .EQ. MASTER .AND. & id%KEEP(46) .EQ. 1 ) ) I_AM_MASTER = (id%MYID.EQ.MASTER) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since DMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. C equal to IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL DMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL DMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL DMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL DMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL DMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_PROBLEM SUBROUTINE DMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='real' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Double precision storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I12)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I12)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I12,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Double precision storage' ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_HEADER SUBROUTINE DMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE DMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(DMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), id%A(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), id%A(I8) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='real' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & id%A_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & id%A_loc(I8) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_MATRIX SUBROUTINE DMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE DMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(DMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='real' WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) id%RHS(K8) ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DUMP_RHS SUBROUTINE DMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE DMUMPS_BUILD_I_AM_CAND MUMPS_5.4.1/src/zfac_process_bf.F0000664000175000017500000000103114102210524016736 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE ZMUMPS_PROCESS_BF_RETURN MUMPS_5.4.1/src/dfac_omp_m.F0000664000175000017500000000076214102210523015703 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_OMP_M END MODULE DMUMPS_FAC_OMP_M MUMPS_5.4.1/src/mumps_scotch_int.h0000664000175000017500000000133214102210474017236 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SCOTCH_INT_H #define MUMPS_SCOTCH_INT_H #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #define MUMPS_SCOTCH_INTSIZE \ F_SYMBOL(scotch_intsize,SCOTCH_INTSIZE) void MUMPS_CALL MUMPS_SCOTCH_INTSIZE(MUMPS_INT *scotch_int_size); #endif MUMPS_5.4.1/src/smumps_comm_buffer.F0000664000175000017500000040417714102210521017515 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_BUF PRIVATE PUBLIC :: SMUMPS_BUF_TRY_FREE_CB, SMUMPS_BUF_INIT, & SMUMPS_BUF_INI_MYID, & SMUMPS_BUF_ALLOC_CB , SMUMPS_BUF_DEALL_CB , & SMUMPS_BUF_ALLOC_SMALL_BUF, SMUMPS_BUF_DEALL_SMALL_BUF, & SMUMPS_BUF_ALLOC_LOAD_BUFFER,SMUMPS_BUF_DEALL_LOAD_BUFFER, & SMUMPS_BUF_SEND_CB, SMUMPS_BUF_SEND_VCB, & SMUMPS_BUF_SEND_1INT, SMUMPS_BUF_SEND_DESC_BANDE, & SMUMPS_BUF_SEND_MAPLIG, SMUMPS_BUF_SEND_MAITRE2, & SMUMPS_BUF_SEND_CONTRIB_TYPE2, & SMUMPS_BUF_SEND_BLOCFACTO, SMUMPS_BUF_SEND_BLFAC_SLAVE, & SMUMPS_BUF_SEND_MASTER2SLAVE, & SMUMPS_BUF_SEND_CONTRIB_TYPE3, SMUMPS_BUF_SEND_RTNELIND, & SMUMPS_BUF_SEND_ROOT2SLAVE, SMUMPS_BUF_SEND_ROOT2SON, & SMUMPS_BUF_SEND_BACKVEC,SMUMPS_BUF_SEND_UPDATE_LOAD, & SMUMPS_BUF_DIST_IRECV_SIZE, & SMUMPS_BUF_BCAST_ARRAY, SMUMPS_BUF_ALL_EMPTY, & SMUMPS_BUF_BROADCAST, SMUMPS_BUF_SEND_NOT_MSTR, & SMUMPS_BUF_SEND_FILS ,SMUMPS_BUF_DEALL_MAX_ARRAY & ,SMUMPS_BUF_MAX_ARRAY_MINSIZE & ,SMUMPS_BUF_TEST PUBLIC :: SMUMPS_BLR_PACK_CB_LRB & ,SMUMPS_MPI_PACK_LRB & ,SMUMPS_MPI_UNPACK_LRB INTEGER NEXT, REQ, CONTENT, OVHSIZE PARAMETER( NEXT = 0, REQ = 1, CONTENT = 2, OVHSIZE = 2 ) INTEGER, SAVE :: SIZEofINT, SIZEofREAL, BUF_MYID TYPE SMUMPS_COMM_BUFFER_TYPE INTEGER LBUF, HEAD, TAIL,LBUF_INT, ILASTMSG INTEGER, DIMENSION(:),POINTER :: CONTENT END TYPE SMUMPS_COMM_BUFFER_TYPE TYPE ( SMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_CB TYPE ( SMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_SMALL TYPE ( SMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_LOAD INTEGER, SAVE :: SIZE_RBUF_BYTES INTEGER, SAVE :: BUF_LMAX_ARRAY REAL, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE SMUMPS_BUF_TRY_FREE_CB() CALL SMUMPS_BUF_TRY_FREE(BUF_CB) RETURN END SUBROUTINE SMUMPS_BUF_TRY_FREE_CB SUBROUTINE SMUMPS_BUF_TRY_FREE(B) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B INCLUDE 'mpif.h' LOGICAL :: FLAG INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, & STATUS, IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF RETURN END SUBROUTINE SMUMPS_BUF_TRY_FREE SUBROUTINE SMUMPS_BUF_INI_MYID( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE SMUMPS_BUF_INI_MYID SUBROUTINE SMUMPS_BUF_INIT( IntSize, RealSize ) IMPLICIT NONE INTEGER IntSize, RealSize SIZEofINT = IntSize SIZEofREAL = RealSize NULLIFY(BUF_CB %CONTENT) NULLIFY(BUF_SMALL%CONTENT) NULLIFY(BUF_LOAD%CONTENT) BUF_CB%LBUF = 0 BUF_CB%LBUF_INT = 0 BUF_CB%HEAD = 1 BUF_CB%TAIL = 1 BUF_CB%ILASTMSG = 1 BUF_SMALL%LBUF = 0 BUF_SMALL%LBUF_INT = 0 BUF_SMALL%HEAD = 1 BUF_SMALL%TAIL = 1 BUF_SMALL%ILASTMSG = 1 BUF_LOAD%LBUF = 0 BUF_LOAD%LBUF_INT = 0 BUF_LOAD%HEAD = 1 BUF_LOAD%TAIL = 1 BUF_LOAD%ILASTMSG = 1 RETURN END SUBROUTINE SMUMPS_BUF_INIT SUBROUTINE SMUMPS_BUF_ALLOC_CB( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE SMUMPS_BUF_ALLOC_CB SUBROUTINE SMUMPS_BUF_ALLOC_SMALL_BUF( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE SMUMPS_BUF_ALLOC_SMALL_BUF SUBROUTINE SMUMPS_BUF_ALLOC_LOAD_BUFFER( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE SMUMPS_BUF_ALLOC_LOAD_BUFFER SUBROUTINE SMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_LOAD, IERR ) RETURN END SUBROUTINE SMUMPS_BUF_DEALL_LOAD_BUFFER SUBROUTINE SMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE SMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF ALLOCATE(BUF_MAX_ARRAY(NFS4FATHER),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF BUF_LMAX_ARRAY=NFS4FATHER RETURN END SUBROUTINE SMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE SMUMPS_BUF_DEALL_CB( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_CB, IERR ) RETURN END SUBROUTINE SMUMPS_BUF_DEALL_CB SUBROUTINE SMUMPS_BUF_DEALL_SMALL_BUF( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_SMALL, IERR ) RETURN END SUBROUTINE SMUMPS_BUF_DEALL_SMALL_BUF SUBROUTINE BUF_ALLOC( BUF, SIZE, IERR ) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE, IERR IERR = 0 BUF%LBUF = SIZE BUF%LBUF_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT IF ( associated ( BUF%CONTENT ) ) DEALLOCATE( BUF%CONTENT ) ALLOCATE( BUF%CONTENT( BUF%LBUF_INT ), stat = IERR ) IF (IERR .NE. 0) THEN NULLIFY( BUF%CONTENT ) IERR = -1 BUF%LBUF = 0 BUF%LBUF_INT = 0 END IF BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_ALLOC SUBROUTINE BUF_DEALL( BUF, IERR ) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER :: IERR INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( .NOT. associated ( BUF%CONTENT ) ) THEN BUF%HEAD = 1 BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END IF DO WHILE ( BUF%HEAD.NE.0 .AND. BUF%HEAD .NE. BUF%TAIL ) CALL MPI_TEST(BUF%CONTENT( BUF%HEAD + REQ ), FLAG, & STATUS, IERR_MPI) IF ( .not. FLAG ) THEN WRITE(*,*) '** Warning: trying to cancel a request.' WRITE(*,*) '** This might be problematic' CALL MPI_CANCEL( BUF%CONTENT( BUF%HEAD + REQ ), IERR_MPI ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), & IERR_MPI ) END IF BUF%HEAD = BUF%CONTENT( BUF%HEAD + NEXT ) END DO DEALLOCATE( BUF%CONTENT ) NULLIFY( BUF%CONTENT ) BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_DEALL SUBROUTINE SMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) REAL A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_REAL, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_CB SUBROUTINE SMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN REAL CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) REAL SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_REAL, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE SMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, IPOSINRHSCOMP, NPIV REAL W( max( 1, LDW * NRHS_B ) ) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_REAL, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_VCB SUBROUTINE SMUMPS_BUF_SEND_1INT( I, DEST, TAG, COMM, & KEEP, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER IPOS, IREQ, MSG_SIZE, POSITION INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 CALL MPI_PACK_SIZE( 1, MPI_INTEGER, & COMM, MSG_SIZE, IERR_MPI ) CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in SMUMPS_BUF_SEND_1INT', & ' Buf size (bytes)= ',BUF_SMALL%LBUF RETURN ENDIF POSITION=0 CALL MPI_PACK( I, 1, & MPI_INTEGER, BUF_SMALL%CONTENT( IPOS ), & MSG_SIZE, & POSITION, COMM, IERR_MPI ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_1INT SUBROUTINE SMUMPS_BUF_ALL_EMPTY(CHECK_COMM_NODES, & CHECK_COMM_LOAD,FLAG) LOGICAL, INTENT(IN) :: CHECK_COMM_NODES, CHECK_COMM_LOAD LOGICAL, INTENT(OUT) :: FLAG LOGICAL FLAG1, FLAG2, FLAG3 FLAG = .TRUE. IF (CHECK_COMM_NODES) THEN CALL SMUMPS_BUF_EMPTY( BUF_SMALL, FLAG1 ) CALL SMUMPS_BUF_EMPTY( BUF_CB, FLAG2 ) FLAG = FLAG .AND. FLAG1 .AND. FLAG2 ENDIF IF ( CHECK_COMM_LOAD ) THEN CALL SMUMPS_BUF_EMPTY( BUF_LOAD, FLAG3 ) FLAG = FLAG .AND. FLAG3 ENDIF RETURN END SUBROUTINE SMUMPS_BUF_ALL_EMPTY SUBROUTINE SMUMPS_BUF_EMPTY( B, FLAG ) TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL SMUMPS_BUF_SIZE_AVAILABLE(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE SMUMPS_BUF_EMPTY SUBROUTINE SMUMPS_BUF_SIZE_AVAILABLE( B, SIZE_AV ) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER SIZE_AV INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END IF IF ( B%HEAD .LE. B%TAIL ) THEN SIZE_AV = max( B%LBUF_INT - B%TAIL, B%HEAD - 2 ) ELSE SIZE_AV = B%HEAD - B%TAIL - 1 END IF SIZE_AV = min(SIZE_AV - OVHSIZE, SIZE_AV) SIZE_AV = SIZE_AV * SIZEofINT RETURN END SUBROUTINE SMUMPS_BUF_SIZE_AVAILABLE SUBROUTINE SMUMPS_BUF_TEST() INTEGER :: IPOS, IREQ, IERR INTEGER, PARAMETER :: IONE=1 INTEGER :: MSG_SIZE INTEGER :: DEST2(1) DEST2=-10 MSG_SIZE=1 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2,.TRUE.) RETURN END SUBROUTINE SMUMPS_BUF_TEST SUBROUTINE BUF_LOOK( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST, TEST_ONLY) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR LOGICAL, INTENT(IN), OPTIONAL :: TEST_ONLY INTEGER NDEST INTEGER, INTENT(IN) :: PDEST(max(1,NDEST)) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: MSG_SIZE_INT INTEGER :: IBUF LOGICAL :: FLAG INTEGER :: STATUS(MPI_STATUS_SIZE) IERR = 0 IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF MSG_SIZE_INT = ( MSG_SIZE + ( SIZEofINT - 1 ) ) / SIZEofINT MSG_SIZE_INT = MSG_SIZE_INT + OVHSIZE IF (present(TEST_ONLY)) RETURN FLAG = ( ( B%HEAD .LE. B%TAIL ) & .AND. ( & ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL ) & .OR. ( MSG_SIZE_INT .LE. B%HEAD - 2 ) ) ) & .OR. & ( ( B%HEAD .GT. B%TAIL ) & .AND. ( MSG_SIZE_INT .LE. B%HEAD - B%TAIL - 1 ) ) IF ( .NOT. FLAG & ) THEN IERR = -1 IF ( MSG_SIZE_INT .GT. B%LBUF_INT - 1 ) THEN IERR = -2 ENDIF IPOS = -1 IREQ = -1 RETURN END IF IF ( B%HEAD .LE. B%TAIL ) THEN IF ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL + 1 ) THEN IBUF = B%TAIL ELSE IF ( MSG_SIZE_INT .LE. B%HEAD - 1 ) THEN IBUF = 1 END IF ELSE IBUF = B%TAIL END IF B%CONTENT( B%ILASTMSG + NEXT ) = IBUF B%ILASTMSG = IBUF B%TAIL = IBUF + MSG_SIZE_INT B%CONTENT( IBUF + NEXT ) = 0 IPOS = IBUF + CONTENT IREQ = IBUF + REQ RETURN END SUBROUTINE BUF_LOOK SUBROUTINE BUF_ADJUST( BUF, SIZE ) IMPLICIT NONE TYPE ( SMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE INTEGER SIZE_INT SIZE_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT SIZE_INT = SIZE_INT + OVHSIZE BUF%TAIL = BUF%ILASTMSG + SIZE_INT RETURN END SUBROUTINE BUF_ADJUST SUBROUTINE SMUMPS_BUF_SEND_DESC_BANDE( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & ESTIM_NFS4FATHER_ATSON, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER, intent(in) :: INODE INTEGER, intent(in) :: NLIG, NCOL, NASS, NSLAVES INTEGER, intent(in) :: ESTIM_NFS4FATHER_ATSON INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER, INTENT(IN) :: IBC_SOURCE INTEGER LIST_SLAVES( NSLAVES ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: LRSTATUS INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 9 + NLIG + NCOL + NSLAVES + 1 ) SIZE_BYTES = SIZE_INT * SIZEofINT IF (SIZE_INT.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_BYTES, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = SIZE_INT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NBPROCFILS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NLIG POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCOL POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = LRSTATUS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ESTIM_NFS4FATHER_ATSON POSITION = POSITION + 1 IF (NSLAVES.GT.0) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = & LIST_SLAVES( 1: NSLAVES ) POSITION = POSITION + NSLAVES ENDIF BUF_CB%CONTENT( POSITION:POSITION + NLIG - 1 ) = ILIG POSITION = POSITION + NLIG BUF_CB%CONTENT( POSITION:POSITION + NCOL - 1 ) = ICOL POSITION = POSITION + NCOL POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE_BYTES ) THEN WRITE(*,*) 'Error in SMUMPS_BUF_SEND_DESC_BANDE :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE_BYTES, & MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_DESC_BANDE SUBROUTINE SMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) REAL VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_REAL, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 2 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_MAITRE2 SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, PERM, IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID, NPIV_CHECK ) USE SMUMPS_LR_TYPE USE SMUMPS_LR_DATA_M IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT (in), OPTIONAL :: NPIV_CHECK INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ), PERM( max(1, NBROW )) INTEGER IW_CBSON( * ) REAL A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX REAL, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER NBINT, L INTEGER(8) :: APOS, SHIFTCB_SON, LDA_SON8 INTEGER IPOS_IN_SLAVE INTEGER STATE_SON INTEGER INDICE_PERE, NROW, IPOS, IREQ, NOSLA INTEGER IONE, J, THIS_ROW_LENGTH INTEGER SIZE_DESC_BANDE, DESC_BANDE_BYTES LOGICAL RECV_BUF_SMALLER_THAN_SEND LOGICAL NOT_ENOUGH_SPACE INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & NBROWS_PACKET_2PACK, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' REAL ZERO PARAMETER (ZERO = 0.0E0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+PERM(1)-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = PERM(1) + NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(7+SLAVEF+KEEP(127)*2) SIZE_DESC_BANDE=SIZE_DESC_BANDE+int(real(KEEP(12))* & real(SIZE_DESC_BANDE)/100.0E0) SIZE_DESC_BANDE=max(SIZE_DESC_BANDE, & 7+NSLAVES_PERE+NFRONT_PERE+NFRONT_PERE-NASS_PERE) ENDIF DESC_BANDE_BYTES=SIZE_DESC_BANDE*SIZEofINT IF ( SIZE_AV .LT. SIZE_RBUF_BYTES-DESC_BANDE_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES-DESC_BANDE_BYTES ENDIF SIZE1=0 IF (NBROWS_ALREADY_SENT==0) THEN IF(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN ONEorTWO = 1 ELSE ONEorTWO = 2 ENDIF IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + PERM(1) - LMAP + NBROWS_ALREADY_SENT - 1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 2 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( 1 + 2 * LROW + 2 * PERM(1) + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) NBROWS_PACKET_2PACK = NBROWS_PACKET IF (CB_IS_LR) THEN NBROWS_PACKET_2PACK = CURRENT_PANEL_SIZE CALL MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_REALS, CB_LRB, & NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND) NOT_ENOUGH_SPACE = (SIZE_AV.LT.SIZE_REALS) IF (.NOT.NOT_ENOUGH_SPACE) THEN NBROWS_PACKET = min(NBROWS_PACKET, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) ENDIF ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET_2PACK * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET_2PACK + ( NBROWS_PACKET_2PACK * & ( NBROWS_PACKET_2PACK + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET_2PACK CALL MPI_PACK_SIZE( SIZE_REALS, MPI_REAL, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND .AND. & .NOT. CB_IS_LR) & THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR) THEN CALL SMUMPS_BLR_PACK_CB_LRB(CB_LRB, NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND, & PANEL_BEG_OFFSET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR) IF (KEEP(50).ne.0) THEN DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL SMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/SMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_OUT, & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND) USE SMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND INTEGER, intent(out) :: SIZE_OUT INTEGER :: J TYPE(LRB_TYPE), POINTER :: LRB SIZE_OUT = 0 DO J=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J) IF (LRB%ISLR) THEN SIZE_OUT = SIZE_OUT + LRB%K*(LRB%M+LRB%N) ELSE SIZE_OUT = SIZE_OUT + LRB%M*LRB%N ENDIF ENDDO RETURN END SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB SUBROUTINE SMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET, & BUF, LBUF, POSITION, COMM, IERR) USE SMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET INTEGER, intent(out) :: IERR INTEGER, intent(in) :: COMM, LBUF INTEGER, intent(inout) :: POSITION INTEGER, intent(inout) :: BUF(:) INTEGER :: J, IERR_MPI INCLUDE 'mpif.h' IERR = 0 CALL MPI_PACK( NB_BLR_COLS-NB_COL_SHIFT, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( PANEL_BEG_OFFSET, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) DO J=1,NB_BLR_COLS-NB_COL_SHIFT CALL SMUMPS_MPI_PACK_LRB( & CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J), & BUF, LBUF, POSITION, COMM, IERR ) ENDDO END SUBROUTINE SMUMPS_BLR_PACK_CB_LRB SUBROUTINE SMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, NSLAVES, SLAVES_PERE, & TROW, NCBSON, & COMM, IERR, & DEST, NDEST, SLAVEF, & & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) IMPLICIT NONE INTEGER INODE, NFRONT, NASS1, NCBSON, NSLAVES, & NDEST INTEGER SLAVEF, MYID, ISON INTEGER TROW( NCBSON ) INTEGER DEST( NDEST ) INTEGER SLAVES_PERE( NSLAVES ) INTEGER COMM, IERR INTEGER KEEP(500), N INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_AV, IDEST, NSEND, SIZE, NFS4FATHER INTEGER TROW_SIZE, POSITION, INDX, INIV2 INTEGER IPOS, IREQ INTEGER IONE PARAMETER ( IONE=1 ) INTEGER NASS_SON NASS_SON = -99998 IERR = 0 IF ( NDEST .eq. 1 ) THEN IF ( DEST(1).EQ.MYID ) GOTO 500 SIZE = SIZEofINT * ( 7 + NSLAVES + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+NCBSON-1 ) = & TROW( 1: NCBSON ) POSITION = POSITION + NCBSON POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) 'Error in SMUMPS_BUF_SEND_MAPLIG :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( NDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) ELSE NSEND = 0 DO IDEST = 1, NDEST IF ( DEST( IDEST ) .ne. MYID ) NSEND = NSEND + 1 END DO SIZE = SIZEofINT * & ( ( OVHSIZE + 7 + NSLAVES )* NSEND + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IDEST, NCBSON, & NDEST, & TROW_SIZE, INDX ) SIZE = SIZEofINT * ( NSLAVES + TROW_SIZE + 7 ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error SMUMPS_BUF_SEND_MAPLIG', & 'IERR after BUF_LOOK=',IERR CALL MUMPS_ABORT() END IF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+TROW_SIZE-1 ) = & TROW( INDX: INDX + TROW_SIZE - 1 ) POSITION = POSITION + TROW_SIZE POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:', & 'Wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( IDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) END IF END DO END IF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_BUF_SEND_MAPLIG SUBROUTINE SMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, & WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & & IERR ) USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) REAL, intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTBL LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE3, SIZET, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS INTEGER :: NBMSGS INTEGER, ALLOCATABLE, DIMENSION(:) :: RELAY_INFO INTEGER :: LRELAY_INFO, DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT IERR = 0 LRELAY_INFO = 0 NBMSGS = NDEST IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE( 4, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE( 1, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_REAL, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_REAL, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LorU, SIZE3, COMM, IERR ) SIZE2 = SIZE2+SIZE3 ENDIF ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF END IF SSS = SSS + SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF ENDIF IF (LRELAY_INFO.GT.0) THEN CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , RELAY_INFO(2)) ELSE CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , PDEST) ENDIF IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NBMSGS - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NBMSGS - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NBMSGS - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NBMSGS POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTBL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF ( (NPIV.GT.0) & ) THEN IF (NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO CALL SMUMPS_MPI_PACK_LR( BLR_LorU, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1), & SIZET, POSITION, COMM, IERR) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) DO IDEST = 1, NBMSGS IF (LRELAY_INFO .GT. 0) THEN DEST_BLOCFACTO = RELAY_INFO(IDEST+1) ELSE DEST_BLOCFACTO = PDEST(IDEST) ENDIF IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO SIZET = SIZET - ( NBMSGS - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE SMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR ) USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE REAL UIP21K( NPIV, * ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL REAL, intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZET, & IDEST, IPOSMSG, SSS, SSLR IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_REAL, & COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR ELSE CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LS, SSLR, COMM, IERR ) SIZE2=SIZE2+SSLR ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SSS = SSS+SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL MUMPS_MPI_PACK_SCALE_LR( BLR_LS, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1 ), & SIZET, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR ) ELSE CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_REAL, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO SIZET = SIZET - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) REAL VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL SMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_REAL, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_REAL, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW(INDCOL_SON( I )) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW( INDROW_SON( I ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = RG2L_COL( INDCOL_SON( J ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IPOS_ROOT = RG2L_ROW( INDCOL_SON( J ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = RG2L_COL( INDROW_SON( I ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_REAL, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) RETURN END SUBROUTINE MUMPS_MPI_PACK_SCALE_LR END MODULE SMUMPS_BUF MUMPS_5.4.1/src/zfac_process_rtnelind.F0000664000175000017500000001123014102210524020170 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_RTNELIND( ROOT, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE ZMUMPS_LOAD USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: ROOT INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : ZMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE ZMUMPS_PROCESS_RTNELIND MUMPS_5.4.1/src/mumps_ooc_common.F0000664000175000017500000001073714102210475017201 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER, PARAMETER :: FCT = 0 INTEGER, PARAMETER, PUBLIC :: TYPEF_INVALID = -999999 INTEGER, PUBLIC :: TYPEF_L, TYPEF_U, TYPEF_CB INTEGER OOC_NB_FILE_TYPE, OOC_FCT_TYPE INTEGER, DIMENSION(:,:),POINTER :: OOC_INODE_SEQUENCE INTEGER(8), DIMENSION(:,:),POINTER :: OOC_VADDR INTEGER,DIMENSION(:),POINTER:: KEEP_OOC INTEGER ICNTL1 INTEGER(8), DIMENSION(:),ALLOCATABLE :: AddVirtLibre LOGICAL,SAVE :: STRAT_IO_ASYNC,WITH_BUF,SOLVE INTEGER, DIMENSION(:),POINTER :: STEP_OOC,PROCNODE_OOC INTEGER, SAVE :: MYID_OOC,SLAVEF_OOC,LOW_LEVEL_STRAT_IO INTEGER(8), SAVE :: HBUF_SIZE, DIM_BUF_IO INTEGER ERR_STR_OOC_MAX_LEN PARAMETER(ERR_STR_OOC_MAX_LEN = 512) CHARACTER(len=1):: ERR_STR_OOC(ERR_STR_OOC_MAX_LEN) INTEGER DIM_ERR_STR_OOC TYPE IO_BLOCK INTEGER :: INODE LOGICAL :: MASTER INTEGER :: Typenode INTEGER :: NROW, NCOL, NFS LOGICAL :: Last INTEGER :: LastPiv INTEGER :: LastPanelWritten_L INTEGER :: LastPanelWritten_U INTEGER,POINTER,DIMENSION(:) :: INDICES END TYPE PUBLIC IO_BLOCK INTEGER, PUBLIC :: STRAT_WRITE_MAX, STRAT_TRY_WRITE PARAMETER (STRAT_WRITE_MAX=1, STRAT_TRY_WRITE=2) END MODULE MUMPS_OOC_COMMON SUBROUTINE MUMPS_OOC_CONVERT_2INTTOBIGINT(INT1,INT2,BIGINT) IMPLICIT NONE INTEGER INT1,INT2 INTEGER(8) BIGINT INTEGER(8) TMP1,TMP2,CONV PARAMETER (CONV=1073741824_8) TMP1=int(INT1,kind=kind(TMP1)) TMP2=int(INT2,kind=kind(TMP2)) BIGINT=(TMP1*CONV)+TMP2 RETURN END SUBROUTINE MUMPS_OOC_CONVERT_2INTTOBIGINT SUBROUTINE MUMPS_OOC_CONVERT_BIGINTTO2INT(INT1,INT2,BIGINT) IMPLICIT NONE INTEGER INT1,INT2 INTEGER(8) BIGINT INTEGER(8) TMP1,TMP2,CONV PARAMETER (CONV=1073741824_8) TMP1=BIGINT/CONV TMP2=mod(BIGINT,CONV) INT1=int(TMP1) INT2=int(TMP2) RETURN END SUBROUTINE MUMPS_OOC_CONVERT_BIGINTTO2INT SUBROUTINE MUMPS_OOC_INIT_FILETYPE & (TYPEF_L,TYPEF_U,TYPEF_CB,K201, K251, K50, & TYPEF_INVALID) IMPLICIT NONE INTEGER, intent(out):: TYPEF_L, TYPEF_U, TYPEF_CB INTEGER, intent(in) :: K201, K251, K50 INTEGER, intent(in) :: TYPEF_INVALID IF (K201 .EQ. 1 .AND. K50.EQ.0) THEN IF ( K251.NE.2 ) THEN TYPEF_L = 1 TYPEF_U = 2 TYPEF_CB = 3 ELSE TYPEF_U = 1 TYPEF_L = TYPEF_INVALID TYPEF_CB = 2 ENDIF ELSE TYPEF_L = 1 TYPEF_U = TYPEF_INVALID TYPEF_CB=2 ENDIF RETURN END SUBROUTINE MUMPS_OOC_INIT_FILETYPE INTEGER FUNCTION MUMPS_OOC_GET_FCT_TYPE & (FWDORBWD, MTYPE, K201, K50) USE MUMPS_OOC_COMMON INTEGER, intent(in) :: MTYPE, K201, K50 CHARACTER(len=1), intent(in) :: FWDORBWD IF ( (TYPEF_L .NE. 1 .AND. TYPEF_L .NE. TYPEF_INVALID) & .OR. (TYPEF_U .NE. 1 .AND. TYPEF_U .NE. 2 .AND. & TYPEF_U .NE. TYPEF_INVALID) ) THEN WRITE(*,*) "Internal error 1 in MUMPS_OOC_GET_FCT_TYPE", & TYPEF_L, TYPEF_U CALL MUMPS_ABORT() ENDIF IF (FWDORBWD .NE. 'F' .AND. FWDORBWD .NE. 'B') THEN WRITE(*,*) "Internal error in MUMPS_OOC_GET_FCT_TYPE,",FWDORBWD CALL MUMPS_ABORT() ENDIF IF (K201 .EQ. 1) THEN IF (FWDORBWD .EQ. 'F') THEN IF((MTYPE.NE.1).AND.(K50.EQ.0))THEN MUMPS_OOC_GET_FCT_TYPE=TYPEF_U ELSE MUMPS_OOC_GET_FCT_TYPE=TYPEF_L ENDIF ELSE IF(K50.EQ.0)THEN IF(MTYPE.NE.1)THEN MUMPS_OOC_GET_FCT_TYPE=TYPEF_L ELSE MUMPS_OOC_GET_FCT_TYPE=TYPEF_U ENDIF ELSE MUMPS_OOC_GET_FCT_TYPE=TYPEF_L ENDIF ENDIF ELSE MUMPS_OOC_GET_FCT_TYPE = 1 ENDIF RETURN END FUNCTION MUMPS_OOC_GET_FCT_TYPE MUMPS_5.4.1/src/dfac_scalings_simScaleAbs.F0000664000175000017500000013653014102210525020652 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant DMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. DMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C DMUMPS_SIMSCALEABSUNS and DMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) DOUBLE PRECISION A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS C IMPORTANT POINTERS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 DOUBLE PRECISION EPS C EXTERNALS EXTERNAL DMUMPS_SIMSCALEABSUNS,DMUMPS_SIMSCALEABSSYM, & DMUMPS_INITREAL C MUST HAVE IT INTEGER I IF(SYM.EQ.0) THEN CALL DMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL DMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_SIMSCALEABS SUBROUTINE DMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, INTSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) DOUBLE PRECISION A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER REGISTRE(12) INTEGER IWRK(IWRKSZ) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ITDCPTR, ISRRPTR INTEGER OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL DMUMPS_CREATEPARTVEC, & DMUMPS_NUMVOLSNDRCV, & DMUMPS_SETUPCOMMS, & DMUMPS_FINDNUMMYROWCOL, & DMUMPS_CHKCONVGLO, & DMUMPS_CHK1CONV, & DMUMPS_FILLMYROWCOLINDICES, & DMUMPS_INITREAL, & DMUMPS_INITREALLST, & DMUMPS_DOCOMMINF, & DMUMPS_DOCOMM1N INTEGER DMUMPS_CHKCONVGLO INTEGER DMUMPS_CHK1CONV DOUBLE PRECISION DMUMPS_ERRSCALOC DOUBLE PRECISION DMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER RESZR, RESZC INTEGER INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR DOUBLE PRECISION ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG DOUBLE PRECISION INFERRROW, INFERRCOL, INFERRL, INFERRG INTEGER OORANGEIND INFERRG = -RONE ONEERRG = -RONE OORANGEIND = 0 MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL DMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL DMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) C Compute sndrcv sizes, store them for later use CALL DMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL DMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) CALL DMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZC = ICSNDRCVNUM + OCSNDRCVNUM + & ICSNDRCVVOL + OCSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYC INTSZ = INTSZR + INTSZC + MAXMN + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(5) = ICSNDRCVNUM REGISTRE(6) = OCSNDRCVNUM REGISTRE(7) = ICSNDRCVVOL REGISTRE(8) = OCSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(10) = INUMMYC REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) ICSNDRCVNUM = REGISTRE(5) OCSNDRCVNUM = REGISTRE(6) ICSNDRCVVOL = REGISTRE(7) OCSNDRCVVOL = REGISTRE(8) INUMMYR = REGISTRE(9) INUMMYC = REGISTRE(10) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL DMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), INUMMYC, & IWRK(1+INUMMYR+INUMMYC), IWRKSZ-INUMMYR-INUMMYC ) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 C C MPI [-----------------] REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL DMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL DMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL DMUMPS_INITREAL(ROWSCA, M, RZERO) CALL DMUMPS_INITREAL(COLSCA, N, RZERO) CALL DMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL DMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL DMUMPS_INITREAL(ROWSCA, M, RONE) CALL DMUMPS_INITREAL(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M C ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL DMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL DMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL DMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO) CALL DMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL DMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL DMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = DMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols INFERRCOL = DMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL DMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = DMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols INFERRCOL = DMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL DMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL DMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = DMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols ONEERRCOL = DMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL DMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = DMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols ONEERRCOL = DMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL DMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL DMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL DMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL DMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1+M), N, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) If(MYID.EQ.0) THEN DO I=1, N COLSCA(I) = WRKRC(I+M) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE DMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, IWRKSZ, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) DOUBLE PRECISION A_loc(NZ_loc) INTEGER PARTVEC(N), RSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION SCA(N) INTEGER ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR DOUBLE PRECISION ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL DMUMPS_CREATEPARTVECSYM, & DMUMPS_NUMVOLSNDRCVSYM, & DMUMPS_SETUPCOMMSSYM, & DMUMPS_FINDNUMMYROWCOLSYM, & DMUMPS_CHKCONVGLOSYM, & DMUMPS_CHK1CONV, & DMUMPS_FILLMYROWCOLINDICESSYM, & DMUMPS_DOCOMMINF, & DMUMPS_DOCOMM1N, & DMUMPS_INITREAL, & DMUMPS_INITREALLST INTEGER DMUMPS_CHKCONVGLOSYM INTEGER DMUMPS_CHK1CONV DOUBLE PRECISION DMUMPS_ERRSCALOC DOUBLE PRECISION DMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER INTSZR INTEGER MAXMN INTEGER I, IERROR DOUBLE PRECISION ONEERRL, ONEERRG DOUBLE PRECISION INFERRL, INFERRG INTEGER OORANGEIND OORANGEIND = 0 INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL DMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) C CALL DMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C CALL DMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) C INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL DMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C MPI [-----------------] REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL DMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL DMUMPS_INITREAL(SCA, N, RZERO) CALL DMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL DMUMPS_INITREAL(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL DMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL DMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL DMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = DMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = DMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = & WRKRC(ITDRPTR-1+IC) + ELM ENDIF ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = WRKRC(ITDRPTR-1+IC) + ELM ENDIF ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = DMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = DMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL DMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL DMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL DMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SIMSCALEABSSYM MUMPS_5.4.1/src/cfac_process_root2slave.F0000664000175000017500000003161614102210523020433 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE CMUMPS_LOAD USE CMUMPS_OOC USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) INTEGER :: allocok COMPLEX, DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' INTEGER numroc, MUMPS_PROCNODE EXTERNAL numroc, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = numroc( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = numroc( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL CMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL CMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL CMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL CMUMPS_ASM_ELT_ROOT(N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL CMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL CMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL CMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL CMUMPS_ASM_ELT_ROOT( N, root, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL CMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL CMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL CMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(root%RHS_ROOT)) DEALLOCATE(root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN root%RHS_ROOT=ZERO CALL CMUMPS_ASM_RHS_ROOT( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => root%RHS_ROOT NULLIFY(root%RHS_ROOT) ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = NEW_LOCAL_M*root%RHS_NLOC GOTO 700 ENDIF DO J = 1, root%RHS_NLOC DO I = 1, OLD_LOCAL_M root%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M root%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE CMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD COMPLEX NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE CMUMPS_COPY_ROOT MUMPS_5.4.1/src/smumps_save_restore_files.F0000664000175000017500000002617014102210522021106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SAVE_RESTORE_FILES USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER :: LEN_SAVE_FILE PARAMETER( LEN_SAVE_FILE = 550) CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif #if defined(OOC_VERBOSE) write(*,*) 'First ooc file: ', & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH-2) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE SMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="SMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE SMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 supp=200+MYID open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE SMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix CHARACTER(len=255):: tmp_savedir,savedir CHARACTER(len=255):: tmp_saveprefix,saveprefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_savedir='' tmp_saveprefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_dir_C(len_save_dir,tmp_savedir) if(tmp_savedir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") then id%INFO(1) = -77 id%INFO(2) = 0 else savedir=trim(adjustl(tmp_savedir(1:len_save_dir))) len_save_dir=len_trim(savedir(1:len_save_dir)) endif ELSE savedir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(savedir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_prefix_C(len_save_prefix,tmp_saveprefix) if(tmp_saveprefix(1:len_save_prefix).EQ."NAME_NOT_INITIALIZED") & then saveprefix="save" len_save_prefix=len_trim(saveprefix) else saveprefix= & trim(adjustl(tmp_saveprefix(1:len_save_prefix))) len_save_prefix=len_trim(saveprefix(1:len_save_prefix)) endif ELSE saveprefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(saveprefix) ENDIF write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=savedir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(savedir))//"/" else SAVE_FILE=trim(adjustl(savedir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE SMUMPS_GET_SAVE_FILES SUBROUTINE SMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (SMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE SMUMPS_CHECK_FILE_NAME END MODULE SMUMPS_SAVE_RESTORE_FILES SUBROUTINE SMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE SMUMPS_SAVE_FILES_RETURN MUMPS_5.4.1/src/cfac_process_blfac_slave.F0000664000175000017500000005213114102210523020567 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_FAC_LR USE CMUMPS_LR_DATA_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR USE CMUMPS_FAC_FRONT_AUX_M, & ONLY : CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if defined(BLR_MT) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY COMPLEX, ALLOCATABLE, DIMENSION(:) :: UDYNAMIC COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) DYNAMIC = .FALSE. POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) IF ( NPIV .LE. 0 ) THEN NPIV = - NPIV WRITE(*,*) MYID,':error, received negative NPIV in BLFAC' CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOLU, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL CMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL CMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_COMPLEX, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL CMUMPS_TREAT_DESCBAND(INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL CMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL CMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC) THEN CALL cgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL cgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL CMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL CMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (COMPRESS_CB) THEN CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL CMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL CMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.4.1/src/dfac_front_LDLT_type1.F0000664000175000017500000011347314102210523017671 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE DMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_OOC USE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW DOUBLE PRECISION MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION,ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL DMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTBL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL DMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if defined(BLR_MT) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL DMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL DMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC) #endif IF ( (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL DMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif END IF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL DMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL DMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL DMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC1_LDLT END MODULE DMUMPS_FAC1_LDLT_M MUMPS_5.4.1/src/mumps_type2_blocking.F0000664000175000017500000005061114102210475017757 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION MUMPS_BLOC2_GET_NSLAVESMIN & ( SLAVEF, K48, K821, K50, & NFRONT, NCB, K375, K119) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50, NFRONT, NCB INTEGER, INTENT (IN) :: K375 INTEGER, INTENT (IN) :: K119 INTEGER(8), INTENT (IN) :: K821 INTEGER NSLAVESMIN, NASS, KMAX REAL Wmaster, Wtotal, Wmax INTEGER ACC,X REAL MUMPS_BLOC2_COUT INTEGER MUMPS_REG_GETKMAX EXTERNAL MUMPS_BLOC2_COUT, MUMPS_REG_GETKMAX KMAX = MUMPS_REG_GETKMAX( K821, NCB ) NASS = NFRONT - NCB NSLAVESMIN = 1 IF ( K48 .EQ.0 .OR. & (K48.EQ.5 .AND. (K119.EQ.1. OR.K50.EQ.0))) THEN NSLAVESMIN = max(NCB/max(1,KMAX),1) ELSE IF (K48 .EQ. 3 .OR.(K48.EQ.5 .AND.K50.NE.0) ) THEN Wmax = MUMPS_BLOC2_COUT(KMAX,NFRONT,NASS) Wtotal = MUMPS_BLOC2_COUT(NCB,NFRONT,NASS) Wmaster = real(NASS)*real(NASS)*real(NASS)/(3.0E0) IF ( Wmaster .GT. Wmax ) THEN NSLAVESMIN = max ( nint ( Wtotal / Wmaster ), 1 ) ELSE NSLAVESMIN = max ( nint ( Wtotal / Wmax ), 1 ) ENDIF IF (K48 .EQ. 5) THEN IF (K119.EQ.2) THEN NSLAVESMIN = max ( NSLAVESMIN/2, 1 ) ENDIF END IF ELSE IF (K48 .EQ. 4 ) THEN IF ( K821 > 0_8 ) THEN WRITE(*,*) 'Internal Error 1 in MUMPS_BLOC2_GET_NSLAVESMIN' CALL MUMPS_ABORT() ENDIF CALL MUMPS_ABORT_ON_OVERFLOW(K821, & "K821 too large in MUMPS_BLOC2_GET_NSLAVESMIN" ) KMAX=int(abs(K821)) IF(K50.EQ.0)THEN NSLAVESMIN = max(int( & (int(NCB,8)*int(NCB,8))/int(KMAX,8) & ),1) ELSE ACC=0 NSLAVESMIN=0 DO WHILE (ACC.NE.NCB) X=int((-real(NFRONT-NCB+ACC) & +sqrt(((real(NFRONT-NCB+ACC)* & real(NFRONT-NCB+ACC))+real(4)* & real(KMAX))))/ & real(2)) ACC=ACC+X NSLAVESMIN=NSLAVESMIN+1 IF (((NCB-ACC)*NCB).LT.KMAX)THEN ACC=NCB NSLAVESMIN=NSLAVESMIN+1 ENDIF ENDDO ENDIF ENDIF NSLAVESMIN = min ( NSLAVESMIN,(SLAVEF-1) ) MUMPS_BLOC2_GET_NSLAVESMIN = & min ( NSLAVESMIN, NCB ) IF (K375 .EQ. 1) THEN MUMPS_BLOC2_GET_NSLAVESMIN=1 ENDIF RETURN END FUNCTION MUMPS_BLOC2_GET_NSLAVESMIN INTEGER FUNCTION MUMPS_BLOC2_GET_NSLAVESMAX & ( SLAVEF, K48, K821, K50, & NFRONT, NCB, K375, K119 ) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50,NFRONT, NCB, K375, K119 INTEGER(8), INTENT(IN) :: K821 INTEGER NSLAVESMAX, KMAX, KMIN INTEGER NSLAVESMIN INTEGER MUMPS_REG_GETKMAX,MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NS_BLSIZE EXTERNAL MUMPS_REG_GETKMAX,MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NS_BLSIZE IF (K48 .eq. 0 .OR. K48.eq.3.OR.K48.EQ.5) THEN KMAX = MUMPS_REG_GETKMAX( K821, NCB ) KMIN = MUMPS_GETKMIN( K821, K50, KMAX, NCB) NSLAVESMAX = MUMPS_BLOC2_GET_NS_BLSIZE( & SLAVEF, K48, K50, KMIN, NFRONT, NCB ) ELSE NSLAVESMAX = SLAVEF-1 ENDIF NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375, K119 ) NSLAVESMAX = max ( NSLAVESMAX, NSLAVESMIN ) MUMPS_BLOC2_GET_NSLAVESMAX = & min ( NSLAVESMAX, NCB ) IF (K375 .EQ. 1) THEN MUMPS_BLOC2_GET_NSLAVESMAX = SLAVEF-1 ENDIF RETURN END FUNCTION MUMPS_BLOC2_GET_NSLAVESMAX SUBROUTINE MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP,KEEP8, & NCB, NFR, SLAVEF, NBROWMAX, MAXSURFCB8 & ) IMPLICIT NONE INTEGER, intent(in) :: WHAT, NCB, NFR, SLAVEF INTEGER, intent(in) :: KEEP(500) INTEGER(8) KEEP8(150) INTEGER, intent(out) :: NBROWMAX INTEGER(8), intent(out) :: MAXSURFCB8 INTEGER KMAX, KMIN, NSLAVES, SIZEDUMMY, TABDUMMY(1) EXTERNAL MUMPS_REG_GETKMAX, MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN INTEGER MUMPS_REG_GETKMAX, MUMPS_GETKMIN, & MUMPS_BLOC2_GET_NSLAVESMIN IF ( WHAT .NE. 1 .and. WHAT .NE. 2 ) THEN IF (WHAT .NE. 4 .and. WHAT .NE. 5 .AND. & KEEP(48).NE.5 ) THEN WRITE(*,*) "Internal error 1 in MUMPS_MAX_SURFCB_NBROWS" CALL MUMPS_ABORT() END IF ENDIF KMAX = MUMPS_REG_GETKMAX( KEEP8(21), NCB ) IF (WHAT .EQ.1.OR.WHAT.EQ.2) THEN NSLAVES = MUMPS_BLOC2_GET_NSLAVESMIN( SLAVEF, KEEP(48), & KEEP8(21), KEEP(50), & NFR, NCB, KEEP(375), KEEP(119) ) ELSE NSLAVES=SLAVEF ENDIF IF ( KEEP(48) == 0 .OR. (KEEP(48).EQ.5.AND.KEEP(50).EQ.0)) THEN NBROWMAX = NCB / NSLAVES + mod( NCB, NSLAVES ) IF ( WHAT == 2 .OR. WHAT == 5 ) & MAXSURFCB8 = int(NBROWMAX,8) * int(NCB,8) ELSE IF (KEEP(48) == 3.OR.(KEEP(48).EQ.5.AND.KEEP(50).NE.0))THEN KMIN = MUMPS_GETKMIN( KEEP8(21), KEEP(50), KMAX, NCB ) SIZEDUMMY = 1 IF (WHAT.GT.3) THEN CALL MUMPS_BLOC2_SET_POSK483( & WHAT-3, NSLAVES, NFR, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) ELSE CALL MUMPS_BLOC2_SET_POSK483( & WHAT, NSLAVES, NFR, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB8, TABDUMMY, SIZEDUMMY) ENDIF ELSE IF ( KEEP(48) == 4 ) THEN IF (KEEP8(21) > 0_8) THEN WRITE(*,*) "Internal error 2 in MUMPS_MAX_SURFCB_NBROWS" CALL MUMPS_ABORT() END IF IF(KEEP(50).EQ.0)THEN IF ( abs(KEEP8(21)) * int( SLAVEF - 1,8 ) > & int( NCB,8) * int(NFR,8) ) THEN NBROWMAX = (NCB + SLAVEF -2 ) / ( SLAVEF - 1 ) IF ( WHAT == 2 ) MAXSURFCB8 = int(NBROWMAX,8) *int(NCB,8) ELSE NBROWMAX=int( & (abs(KEEP8(21)) + int(NFR - 1,8)) & / int(NFR,8) & ) IF ( WHAT == 2 ) MAXSURFCB8 = abs(KEEP8(21)) ENDIF ELSE NBROWMAX=int((-real(NFR-NCB) & +sqrt((real(NFR-NCB)* & real(NFR-NCB))+real(4)* & real(abs(KEEP8(21)))))/ & real(2)) IF ( WHAT == 2 ) MAXSURFCB8 = abs(KEEP8(21)) ENDIF ELSE NBROWMAX = NCB IF (WHAT == 2) MAXSURFCB8 = int(NCB,8) * int(NCB,8) ENDIF NBROWMAX = min ( max(NBROWMAX, 1), NCB) RETURN END SUBROUTINE MUMPS_MAX_SURFCB_NBROWS INTEGER FUNCTION MUMPS_BLOC2_GET_NS_BLSIZE( SLAVEF, K48, K50, & BLSIZE, NFRONT, NCB) IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, K48, K50, BLSIZE, NFRONT, NCB INTEGER NSLAVES, NASS REAL Wtotal, Wblsize REAL MUMPS_BLOC2_COUT EXTERNAL MUMPS_BLOC2_COUT NASS = NFRONT - NCB NSLAVES = SLAVEF-1 IF ( K48 .EQ.0 .OR. (K48.EQ.5 .AND. K50.EQ.0)) THEN NSLAVES = max(NCB/max(1,BLSIZE),1) ELSE IF (K48.EQ.3 .OR. (K48.EQ.5 .AND. K50.NE.0))THEN Wblsize = MUMPS_BLOC2_COUT(BLSIZE,NFRONT,NASS) Wtotal = MUMPS_BLOC2_COUT(NCB,NFRONT,NASS) NSLAVES = max(nint ( Wtotal / Wblsize ), 1) ENDIF MUMPS_BLOC2_GET_NS_BLSIZE = & min ( NSLAVES,(SLAVEF-1) ) RETURN END FUNCTION MUMPS_BLOC2_GET_NS_BLSIZE SUBROUTINE MUMPS_BLOC2_SET_POSK483( & GETPOSITIONS, NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, & NBROWMAX, MAXSURFCB, TABPOS, SIZETABPOS) IMPLICIT NONE INTEGER, INTENT (IN) :: GETPOSITIONS, & NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, SIZETABPOS INTEGER, INTENT (OUT) :: NBROWMAX INTEGER(8), INTENT(OUT) :: MAXSURFCB INTEGER, INTENT (OUT) :: TABPOS(SIZETABPOS) REAL W, COSTni REAL delta INTEGER SumNi, NCOLim1, I, BLSIZE, NASS LOGICAL GETROW, GETSURF, GETPOS, GET_AVGROW, GET_AVGSURF REAL MUMPS_BLOC2_COUT EXTERNAL MUMPS_BLOC2_COUT GETROW = (GETPOSITIONS.EQ.1) GETSURF= (GETPOSITIONS.EQ.2) GETPOS = (GETPOSITIONS.EQ.3) GET_AVGROW = (GETPOSITIONS.EQ.4) GET_AVGSURF = (GETPOSITIONS.EQ.5) NBROWMAX = 0 MAXSURFCB = 0_8 IF (GETPOS) THEN TABPOS (1) = 1 TABPOS (NSLAVES+1)= NCB+1 TABPOS (SLAVEF+2) = NSLAVES ENDIF IF (NSLAVES.EQ.1) THEN IF ( GETSURF ) THEN NBROWMAX = NCB MAXSURFCB = int(NCB,8)*int(NCB,8) ELSEIF ( GETROW ) THEN NBROWMAX = NCB ENDIF ELSE NASS = NFRONT - NCB W = MUMPS_BLOC2_COUT(NCB,NFRONT,NASS) SumNi = 0 NCOLim1 = NASS DO I = 1, NSLAVES-1 delta = real(2*NCOLim1-NASS+1)**2 + & (real(4)*W)/real(NASS*(NSLAVES-I+1)) delta = sqrt(delta) delta = (real(-2*NCOLim1+NASS-1) + delta )/real(2) BLSIZE = max(int(delta), 1) IF ( (NFRONT-NCOLim1-BLSIZE) .LE. NSLAVES-I ) THEN BLSIZE = 1 ENDIF NCOLim1 = NCOLim1+BLSIZE COSTni = MUMPS_BLOC2_COUT(BLSIZE,NCOLim1,NASS) W = W - COSTni IF (GETPOS) TABPOS(I) = SumNi + 1 IF (GETSURF) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) MAXSURFCB = max ( MAXSURFCB, & int(BLSIZE,8)* int(SumNi+BLSIZE,8) ) ELSEIF ( GETROW ) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) RETURN ELSEIF (GET_AVGSURF) THEN NBROWMAX = NBROWMAX + BLSIZE MAXSURFCB = MAXSURFCB + int(BLSIZE,8)*int(SumNi+BLSIZE,8) ELSEIF (GET_AVGROW) THEN NBROWMAX = NBROWMAX + BLSIZE ENDIF SumNi = SumNi + BLSIZE ENDDO BLSIZE = NCB - SumNi IF (BLSIZE.LE.0) THEN write(*,*) ' Error in MUMPS_BLOC2_SET_POSK483: ', & ' size lastbloc ', BLSIZE CALL MUMPS_ABORT() ENDIF if (NCOLim1+BLSIZE.NE.NFRONT) then write(*,*) ' Error in MUMPS_BLOC2_SET_POSK483: ', & ' NCOLim1, BLSIZE, NFRONT=', & NCOLim1, BLSIZE, NFRONT CALL MUMPS_ABORT() endif IF (GETPOS) TABPOS(NSLAVES) = SumNi + 1 IF (GETSURF) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) MAXSURFCB = max ( MAXSURFCB, & int(BLSIZE,8)* int(SumNi+BLSIZE,8 )) ELSEIF ( GETROW ) THEN NBROWMAX = max ( NBROWMAX, & BLSIZE ) ELSEIF (GET_AVGSURF) THEN NBROWMAX = NBROWMAX + BLSIZE MAXSURFCB = MAXSURFCB + int(BLSIZE,8)*int(SumNi+BLSIZE,8) NBROWMAX=(NBROWMAX+NSLAVES-1)/NSLAVES MAXSURFCB=(MAXSURFCB+int(NSLAVES-1,8))/int(NSLAVES,8) ELSEIF (GET_AVGROW) THEN NBROWMAX = NBROWMAX + BLSIZE NBROWMAX=(NBROWMAX+NSLAVES-1)/NSLAVES ENDIF ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_SET_POSK483 SUBROUTINE MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS_IN_PERE, & NSLAVES, NFRONT, NCB & ) IMPLICIT NONE INTEGER, INTENT( IN ) :: NCB, NSLAVES, SLAVEF, NFRONT, & KEEP(500) INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2) INTEGER :: I, BLSIZE INTEGER KMIN, KMAX, NBROWDUMMY, & GETPOSITIONS, SIZECOLTAB INTEGER(8) MAXSURFDUMMY8 INTEGER MUMPS_GETKMIN, MUMPS_REG_GETKMAX EXTERNAL MUMPS_GETKMIN, MUMPS_REG_GETKMAX, & MUMPS_BLOC2_SET_POSK483 IF (KEEP(48).EQ.0) THEN BLSIZE = NCB / NSLAVES TAB_POS_IN_PERE( 1 ) = 1 DO I = 1, NSLAVES-1 TAB_POS_IN_PERE( I+1 ) = TAB_POS_IN_PERE(I) + & BLSIZE ENDDO TAB_POS_IN_PERE(NSLAVES+1) = NCB+1 TAB_POS_IN_PERE(SLAVEF+2) = NSLAVES RETURN ELSE IF (KEEP(48).EQ.3 ) THEN KMAX = MUMPS_REG_GETKMAX(KEEP8(21), NCB) KMIN = MUMPS_GETKMIN(KEEP8(21), KEEP(50), KMAX, NCB) GETPOSITIONS = 3 SIZECOLTAB = SLAVEF+2 CALL MUMPS_BLOC2_SET_POSK483( & GETPOSITIONS, NSLAVES, NFRONT, NCB, & KMIN, KMAX, SLAVEF, & NBROWDUMMY, MAXSURFDUMMY8, & TAB_POS_IN_PERE(1), SIZECOLTAB) ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_SETPARTITION SUBROUTINE MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & ISLAVE, NCB, NSLAVES, SIZE, FIRST_INDEX ) IMPLICIT NONE INTEGER, INTENT( IN ) :: ISLAVE, NCB, NSLAVES, SLAVEF, & KEEP(500), INODE, N INTEGER(8) KEEP8(150) INTEGER, INTENT( IN ) :: STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, INTENT( OUT ):: SIZE, FIRST_INDEX INTEGER BLSIZE, J IF (KEEP(48).EQ.0) THEN BLSIZE = NCB / NSLAVES IF ( ISLAVE .NE. NSLAVES ) THEN SIZE = BLSIZE ELSE SIZE = BLSIZE + mod( NCB, NSLAVES ) END IF FIRST_INDEX = ( ISLAVE - 1 ) * BLSIZE + 1 ELSEIF (KEEP(48).EQ.3) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX ELSEIF (KEEP(48).EQ.4) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX ELSEIF (KEEP(48).EQ.5) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) FIRST_INDEX = TAB_POS_IN_PERE (ISLAVE,J) SIZE = TAB_POS_IN_PERE (ISLAVE+1,J) - FIRST_INDEX ELSE WRITE(*,*) 'Error in MUMPS_BLOC2 undef strat' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_GET_SLAVE_INFO REAL FUNCTION MUMPS_BLOC2_COUT(NROW,NCOL,NASS) IMPLICIT NONE INTEGER, INTENT (IN) :: NROW,NCOL,NASS MUMPS_BLOC2_COUT = real(NASS)*real(NROW)* & real(2*NCOL - NASS - NROW + 1) RETURN END FUNCTION MUMPS_BLOC2_COUT INTEGER FUNCTION MUMPS_REG_GET_NSLAVES & (K821, K48, K50, SLAVEF, & NCB, NFRONT, NSLAVES_less, NMB_OF_CAND, K375, K119) IMPLICIT NONE INTEGER, INTENT( IN ) :: NCB, NFRONT, NSLAVES_less, & K48, K50, SLAVEF, NMB_OF_CAND, K375, K119 INTEGER(8), INTENT(IN) :: K821 INTEGER NSLAVES INTEGER KMAX, NPIV, & NSLAVES_ref, NSLAVES_max REAL WK_MASTER, WK_SLAVE INTEGER MUMPS_REG_GETKMAX, MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX REAL MUMPS_BLOC2_COUT EXTERNAL MUMPS_REG_GETKMAX, MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_COUT IF (NMB_OF_CAND.LE.0) THEN ENDIF IF ( (K48.EQ.0).OR. (K48.EQ.3) ) THEN KMAX = MUMPS_REG_GETKMAX( K821, NCB ) NSLAVES_ref = MUMPS_BLOC2_GET_NSLAVESMIN( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375, K119 ) NSLAVES = NSLAVES_ref IF ( NSLAVES_ref.LT.SLAVEF ) THEN NSLAVES_max = MUMPS_BLOC2_GET_NSLAVESMAX( & SLAVEF, K48, K821, K50, NFRONT, NCB, K375, K119 ) IF ( NSLAVES_max .LT. NSLAVES_less ) THEN NSLAVES = NSLAVES_max ELSE NSLAVES = NSLAVES_less ENDIF NSLAVES = max(NSLAVES_ref,NSLAVES) ENDIF NSLAVES = min (NSLAVES, NMB_OF_CAND) IF ( NSLAVES.GT.NSLAVES_ref) THEN NPIV = NFRONT - NCB IF ( K50.EQ.0 ) THEN WK_SLAVE = real( NPIV ) * real( NCB ) * & ( 2.0E0 * real(NFRONT) - real(NPIV) ) & / real(NSLAVES) WK_MASTER = 0.66667E0 * & real(NPIV)*real(NPIV)*real(NPIV)+ & real(NPIV)*real(NPIV)*real(NCB) ELSE WK_SLAVE = MUMPS_BLOC2_COUT(NCB,NFRONT,NPIV) & / real(NSLAVES) WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV)/3.0E0 ENDIF IF ( (WK_MASTER.GT.WK_SLAVE).AND. & (WK_SLAVE.GT.1.0E0) ) THEN NSLAVES = & int( real(NSLAVES) * (WK_SLAVE/WK_MASTER)) NSLAVES = max(NSLAVES_ref, NSLAVES) ENDIF ENDIF ELSE NSLAVES = NSLAVES_less ENDIF NSLAVES = min (NSLAVES, NCB) NSLAVES = min (NSLAVES, NMB_OF_CAND) MUMPS_REG_GET_NSLAVES = NSLAVES RETURN END FUNCTION MUMPS_REG_GET_NSLAVES SUBROUTINE MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS, NCB, & NSLAVES, POSITION, ISLAVE, IPOSSLAVE ) IMPLICIT NONE INTEGER, INTENT( IN ) :: KEEP(500),INODE,N,SLAVEF INTEGER(8) KEEP8(150) INTEGER, INTENT( IN ) :: STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, INTENT( IN ) :: NASS, NCB, & NSLAVES, POSITION INTEGER, INTENT( OUT ) :: ISLAVE, IPOSSLAVE INTEGER BLSIZE, J, ISHIFT IF ((NSLAVES.LE.0).OR.(POSITION.LE.NASS)) THEN ISLAVE = 0 IPOSSLAVE = POSITION RETURN ENDIF IF (KEEP(48).NE.0.and.KEEP(48).NE.3.and.KEEP(48).NE.4 & .and.KEEP(48).NE.5) THEN WRITE(*,*) 'Error in MUMPS_BLOC2_GET_ISLAVE: undef strat' CALL MUMPS_ABORT() ENDIF IF (KEEP(48).ne.0) THEN J = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = POSITION - NASS DO ISLAVE = NSLAVES,1,-1 IF ( ISHIFT .GE. TAB_POS_IN_PERE(ISLAVE,J)) THEN IPOSSLAVE = ISHIFT - TAB_POS_IN_PERE(ISLAVE,J) + 1 EXIT END IF END DO ELSE BLSIZE = NCB / NSLAVES ISLAVE = min( NSLAVES, & ( POSITION - NASS - 1 ) / BLSIZE + 1 ) IPOSSLAVE = POSITION - NASS - ( ISLAVE - 1 ) * BLSIZE ENDIF RETURN END SUBROUTINE MUMPS_BLOC2_GET_ISLAVE INTEGER FUNCTION MUMPS_GETKMIN( K821, K50, KMAX, NCB ) IMPLICIT NONE INTEGER, INTENT( IN ) :: KMAX, NCB, K50 INTEGER(8), INTENT(IN) :: K821 INTEGER KMIN, MINGRAN INTEGER(8) :: KMINSURF IF ( ( NCB .LE.0 ).OR. (KMAX.LE.0) ) THEN MUMPS_GETKMIN = 1 RETURN ENDIF IF (K50.EQ.0) THEN KMINSURF = 60000_8 #if defined(t3e) || defined(sgi) MINGRAN = 40 #else MINGRAN = 50 #endif ELSE KMINSURF = 30000_8 #if defined(t3e) || defined(sgi) MINGRAN = 10 #else MINGRAN = 20 #endif ENDIF IF (K821.GT.0_8) THEN #if defined(t3e) || defined(sgi) KMIN = max(MINGRAN,KMAX/10) #else KMIN = max(MINGRAN,KMAX/20) #endif ELSE KMINSURF = max( abs(K821)/500_8, KMINSURF ) KMIN = max( & int( KMINSURF / int(max(NCB,1),8) ), & 1 & ) ENDIF KMIN = min(KMIN,KMAX) KMIN = max(KMIN,1) MUMPS_GETKMIN = KMIN RETURN END FUNCTION MUMPS_GETKMIN INTEGER FUNCTION MUMPS_REG_GETKMAX( KEEP821, NCB ) IMPLICIT NONE INTEGER, intent( in ) :: NCB INTEGER(8), intent( in ) :: KEEP821 INTEGER KMAX IF ( NCB .LE.0 ) THEN MUMPS_REG_GETKMAX = 1 RETURN ENDIF IF ( KEEP821.GT.0_8 ) THEN KMAX = int(KEEP821) ELSE KMAX = -int(KEEP821/int(NCB,8)) ENDIF KMAX = min (NCB, KMAX) MUMPS_REG_GETKMAX = max ( KMAX, 1 ) RETURN END FUNCTION MUMPS_REG_GETKMAX MUMPS_5.4.1/src/dtype3_root.F0000664000175000017500000015222714102210522016075 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ASS_ROOT( root, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N DOUBLE PRECISION VAL_SON( NCOL_SON, NROW_SON ) DOUBLE PRECISION VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT DOUBLE PRECISION RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ASS_ROOT RECURSIVE SUBROUTINE DMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_OOC USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION, DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL DMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in DMUMPS_BUILD_AND_SEND_CB_ROOT' CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ELSE IF (IGLOB .GT. N) THEN POS_IN_ROOT = IGLOB - N ELSE POS_IN_ROOT = root%RG2L_COL( IGLOB ) ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL(JGLOB) ELSE POS_IN_ROOT = JGLOB-N ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) IF (JGLOB.GT.N) THEN NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 ENDIF PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_COL(JGLOB) JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN POS_IN_ROOT = root%RG2L_ROW(JGLOB) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) NSUPROW(IROW+1) = NSUPROW(IROW+1)+1 PTRROW( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ENDIF ELSE IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod( ( POS_IN_ROOT - 1 ) / root%MBLOCK, & root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW ( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ELSE IF (IGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL( IGLOB ) ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_COL( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / & root%NBLOCK, root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ELSE IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 END IF END DO IF (BCP_SYM_NONEMPTY) THEN DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (IGLOB.LE.N) CYCLE POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ENDDO DO I=1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF (JGLOB.GT.N) THEN EXIT ELSE POS_IN_ROOT = root%RG2L_ROW(JGLOB) ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL DMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL DMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL DMUMPS_ROOT_LOCAL_ASSEMBLY( N, & root%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL DMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL DMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "DMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL DMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L_ROW(1), root%RG2L_COL(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW,INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL DMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING DMUMPS_BUILD_AND_SEND_CB_ROOT" CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING DMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE DMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in DMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE DMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE DMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L_ROW, RG2L_COL, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N DOUBLE PRECISION VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL DOUBLE PRECISION VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L_ROW( N ), RG2L_COL( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC DOUBLE PRECISION RHS_ROOT( LOCAL_M, NLOC) INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB IF (KEEP(50).EQ.0) THEN DO ISUB = 1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL-NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL -NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IPOS_ROOT = RG2L_ROW(IGLOB) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( I, J ) END DO END DO ELSE DO ISUB = 1, NSUBSET_COL-NSUPCOL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = RG2L_COL( IGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = IGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE DMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE DMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (DMUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE, NPROWtemp, NPCOLtemp LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL DMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_INIT_ROOT_ANA SUBROUTINE DMUMPS_INIT_ROOT_FAC( N, root, FILS, IROOT, & KEEP, INFO ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( DMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(80), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) THEN DEALLOCATE( root%RG2L_ROW ) NULLIFY( root%RG2L_ROW ) ENDIF IF ( associated( root%RG2L_COL ) ) THEN DEALLOCATE( root%RG2L_COL ) NULLIFY( root%RG2L_COL ) ENDIF ALLOCATE( root%RG2L_ROW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=N RETURN ENDIF ALLOCATE( root%RG2L_COL( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN DEALLOCATE( root%RG2L_ROW ); NULLIFY( root%RG2L_ROW ) INFO(1)=-13 INFO(2)=N RETURN ENDIF INODE = IROOT I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L_ROW( INODE ) = I root%RG2L_COL( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE DMUMPS_INIT_ROOT_FAC SUBROUTINE DMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(dble(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE DMUMPS_DEF_GRID SUBROUTINE DMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK DOUBLE PRECISION APAR( LOCAL_M, LOCAL_N ) DOUBLE PRECISION ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine DMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE DMUMPS_SCATTER_ROOT SUBROUTINE DMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK DOUBLE PRECISION APAR( LOCAL_M, LOCAL_N ) DOUBLE PRECISION ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION,DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine DMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_PRECISION, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE DMUMPS_GATHER_ROOT SUBROUTINE DMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (DMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER numroc EXTERNAL numroc DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max(1, root%RHS_NLOC) ELSE root%RHS_NLOC = 1 ENDIF IF (associated( root%RHS_ROOT) ) & DEALLOCATE (root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(LOCAL_M,root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = LOCAL_M*root%RHS_NLOC RETURN ENDIF IF (KEEP(253).NE.0) THEN root%RHS_ROOT = ZERO CALL DMUMPS_ASM_RHS_ROOT ( N, FILS, & root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL DMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL DMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL DMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL DMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL DMUMPS_ASM_ELT_ROOT( N, root, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL DMUMPS_ASM_ELT_ROOT( N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ROOT_ALLOC_STATIC SUBROUTINE DMUMPS_ASM_ELT_ROOT( N, root, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) DOUBLE PRECISION VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) DOUBLE PRECISION DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, JGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI JGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L_ROW(JGLOB) ENDDO DO J = 1, SIZEI JGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = INTARR(J1+I-1) IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_ASM_ELT_ROOT SUBROUTINE DMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER FILS(N) TYPE (DMUMPS_ROOT_STRUC ) :: root DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER JCOL, IPOS_ROOT, JPOS_ROOT, & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS, & INODE INODE = KEEP(38) DO WHILE (INODE.GT.0) IPOS_ROOT = root%RG2L_ROW( INODE ) IROW_GRID = mod( ( IPOS_ROOT - 1 ) / root%MBLOCK, root%NPROW ) IF ( IROW_GRID .NE. root%MYROW ) GOTO 100 ILOCRHS = root%MBLOCK * ( ( IPOS_ROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOS_ROOT - 1, root%MBLOCK ) + 1 DO JCOL = 1, KEEP(253) JPOS_ROOT = JCOL JCOL_GRID = mod((JPOS_ROOT-1)/root%NBLOCK, root%NPCOL) IF (JCOL_GRID.NE.root%MYCOL ) CYCLE JLOCRHS = root%NBLOCK * ( ( JPOS_ROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOS_ROOT - 1, root%NBLOCK ) + 1 root%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE DMUMPS_ASM_RHS_ROOT SUBROUTINE DMUMPS_ASM_ARR_ROOT( N, root, IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRARW( N ), PTRAIW( N ) DOUBLE PRECISION VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) DOUBLE PRECISION DBLARR(LDBLARR) DOUBLE PRECISION VAL INTEGER(8) :: JJ, J1,JK, J2,J3, J4, AINPUT INTEGER IORG, IBROT, NUMORG, & IROW, JCOL INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IBROT = IROOT DO IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) IBROT = FILS(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ASM_ARR_ROOT MUMPS_5.4.1/src/sfac_scalings_simScaleAbs.F0000664000175000017500000013562014102210525020670 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant SMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. SMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C SMUMPS_SIMSCALEABSUNS and SMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) REAL A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR C LOCALS C IMPORTANT POINTERS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 REAL EPS C EXTERNALS EXTERNAL SMUMPS_SIMSCALEABSUNS,SMUMPS_SIMSCALEABSSYM, & SMUMPS_INITREAL C MUST HAVE IT INTEGER I IF(SYM.EQ.0) THEN CALL SMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL SMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_SIMSCALEABS SUBROUTINE SMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, INTSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) REAL A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER REGISTRE(12) INTEGER IWRK(IWRKSZ) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ITDCPTR, ISRRPTR INTEGER OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL SMUMPS_CREATEPARTVEC, & SMUMPS_NUMVOLSNDRCV, & SMUMPS_SETUPCOMMS, & SMUMPS_FINDNUMMYROWCOL, & SMUMPS_CHKCONVGLO, & SMUMPS_CHK1CONV, & SMUMPS_FILLMYROWCOLINDICES, & SMUMPS_INITREAL, & SMUMPS_INITREALLST, & SMUMPS_DOCOMMINF, & SMUMPS_DOCOMM1N INTEGER SMUMPS_CHKCONVGLO INTEGER SMUMPS_CHK1CONV REAL SMUMPS_ERRSCALOC REAL SMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER RESZR, RESZC INTEGER INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR REAL ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG REAL INFERRROW, INFERRCOL, INFERRL, INFERRG INTEGER OORANGEIND INFERRG = -RONE ONEERRG = -RONE OORANGEIND = 0 MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL SMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL SMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) C Compute sndrcv sizes, store them for later use CALL SMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL SMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) CALL SMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZC = ICSNDRCVNUM + OCSNDRCVNUM + & ICSNDRCVVOL + OCSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYC INTSZ = INTSZR + INTSZC + MAXMN + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY REAL SPACE RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(5) = ICSNDRCVNUM REGISTRE(6) = OCSNDRCVNUM REGISTRE(7) = ICSNDRCVVOL REGISTRE(8) = OCSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(10) = INUMMYC REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) ICSNDRCVNUM = REGISTRE(5) OCSNDRCVNUM = REGISTRE(6) ICSNDRCVVOL = REGISTRE(7) OCSNDRCVVOL = REGISTRE(8) INUMMYR = REGISTRE(9) INUMMYC = REGISTRE(10) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL SMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), INUMMYC, & IWRK(1+INUMMYR+INUMMYC), IWRKSZ-INUMMYR-INUMMYC ) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 C C MPI [-----------------] REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL SMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL SMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL SMUMPS_INITREAL(ROWSCA, M, RZERO) CALL SMUMPS_INITREAL(COLSCA, N, RZERO) CALL SMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL SMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL SMUMPS_INITREAL(ROWSCA, M, RONE) CALL SMUMPS_INITREAL(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M C ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL SMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL SMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL SMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO) CALL SMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL SMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL SMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = SMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols INFERRCOL = SMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL SMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = SMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols INFERRCOL = SMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL SMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL SMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = SMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols ONEERRCOL = SMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL SMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = SMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols ONEERRCOL = SMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL SMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL SMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL SMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL SMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1+M), N, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) If(MYID.EQ.0) THEN DO I=1, N COLSCA(I) = WRKRC(I+M) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE SMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, IWRKSZ, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) REAL A_loc(NZ_loc) INTEGER PARTVEC(N), RSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL SCA(N) INTEGER ISZWRKRC REAL WRKRC(ISZWRKRC) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR REAL ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL SMUMPS_CREATEPARTVECSYM, & SMUMPS_NUMVOLSNDRCVSYM, & SMUMPS_SETUPCOMMSSYM, & SMUMPS_FINDNUMMYROWCOLSYM, & SMUMPS_CHKCONVGLOSYM, & SMUMPS_CHK1CONV, & SMUMPS_FILLMYROWCOLINDICESSYM, & SMUMPS_DOCOMMINF, & SMUMPS_DOCOMM1N, & SMUMPS_INITREAL, & SMUMPS_INITREALLST INTEGER SMUMPS_CHKCONVGLOSYM INTEGER SMUMPS_CHK1CONV REAL SMUMPS_ERRSCALOC REAL SMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER INTSZR INTEGER MAXMN INTEGER I, IERROR REAL ONEERRL, ONEERRG REAL INFERRL, INFERRG INTEGER OORANGEIND OORANGEIND = 0 INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL SMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) C CALL SMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C CALL SMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) C INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY REAL SPACE RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL SMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C MPI [-----------------] REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL SMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL SMUMPS_INITREAL(SCA, N, RZERO) CALL SMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL SMUMPS_INITREAL(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL SMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL SMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL SMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = SMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = SMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = & WRKRC(ITDRPTR-1+IC) + ELM ENDIF ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = WRKRC(ITDRPTR-1+IC) + ELM ENDIF ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = SMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = SMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL SMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL SMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL SMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SIMSCALEABSSYM MUMPS_5.4.1/src/dmumps_gpu.h0000664000175000017500000000114314102210474016040 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef DMUMPS_GPU_H #define DMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL dmumps_gpu_return(); #endif /* DMUMPS_GPU_H */ MUMPS_5.4.1/src/dmumps_f77.F0000664000175000017500000003611714102210522015611 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, & PERM_IN, PERM_INhere, RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, & SAVE_DIR, SAVE_PREFIX, & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, & SAVE_DIRLEN, SAVE_PREFIXLEN, & METIS_OPTIONS & ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=63, OOC_TMPDIR_MAX_LENGTH=255) PARAMETER(PB_MAX_LENGTH=255) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) DOUBLE PRECISION, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) DOUBLE PRECISION, TARGET :: WK_USER(*) DOUBLE PRECISION, TARGET :: REDRHS(*) DOUBLE PRECISION, TARGET :: ROWSCA(*), COLSCA(*) DOUBLE PRECISION, TARGET :: SCHUR(*) DOUBLE PRECISION, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE DMUMPS_STRUC_PTR TYPE (DMUMPS_STRUC), POINTER :: PTR END TYPE DMUMPS_STRUC_PTR TYPE (DMUMPS_STRUC), POINTER :: mumps_par TYPE (DMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (DMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: DMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER DMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (DMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM EXTERNAL DMUMPS_ASSIGN_COLSCA, & DMUMPS_ASSIGN_ROWSCA IF (JOB == -1) THEN DO I = 1, DMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(DMUMPS_STRUC_ARRAY_SIZE + & DMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in DMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, DMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = DMUMPS_STRUC_ARRAY_SIZE+1, DMUMPS_STRUC_ARRAY_SIZE + & DMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = DMUMPS_STRUC_ARRAY_SIZE+1 DMUMPS_STRUC_ARRAY_SIZE = DMUMPS_STRUC_ARRAY_SIZE + & DMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in DMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0D0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0D0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & DMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in DMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in DMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%SCHUR_MLOC = SCHUR_MLOC mumps_par%SCHUR_NLOC = SCHUR_NLOC mumps_par%SCHUR_LLD = SCHUR_LLD mumps_par%MBLOCK = MBLOCK mumps_par%NBLOCK = NBLOCK mumps_par%NPROW = NPROW mumps_par%NPCOL = NPCOL IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO CALL DMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc SIZE_SCHUR = mumps_par%SIZE_SCHUR LWK_USER = mumps_par%LWK_USER NELT = mumps_par%NELT DEFICIENCY = mumps_par%Deficiency SCHUR_MLOC = mumps_par%SCHUR_MLOC SCHUR_NLOC = mumps_par%SCHUR_NLOC SCHUR_LLD = mumps_par%SCHUR_LLD MBLOCK = mumps_par%MBLOCK NBLOCK = mumps_par%NBLOCK NPROW = mumps_par%NPROW NPCOL = mumps_par%NPCOL IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF (associated( mumps_par%COLSCA)) THEN CALL DMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL DMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA)) THEN CALL DMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL DMUMPS_NULLIFY_C_ROWSCA() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,OOC_TMPDIR_MAX_LENGTH OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,OOC_PREFIX_MAX_LENGTH OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) DMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE DMUMPS_F77 MUMPS_5.4.1/src/zsol_distrhs.F0000664000175000017500000005422614102210525016354 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSCOMP, LD_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE ZMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size COMPLEX(kind=8), INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSCOMP, LD_RHSCOMP INTEGER, INTENT(IN) :: POSINRHSCOMP_FWD(N) COMPLEX(kind=8), INTENT(OUT) :: RHSCOMP(LD_RHSCOMP, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0, 0.0D0) !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ENDIF NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL ZMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSCOMP), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in ZMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSCOMP ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSCOMP,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSCOMP TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL ZMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL ZMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL ZMUMPS_DR_TRY_RECV() CALL ZMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL ZMUMPS_DR_TRY_RECV() CALL ZMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL ZMUMPS_DR_TRY_FREE_SEND() ENDDO CALL ZMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE ZMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE ZMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE ZMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_DOUBLE_COMPLEX, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL ZMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE ZMUMPS_DR_TRY_RECV SUBROUTINE ZMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) COMPLEX(kind=8), INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSCOMP=POSINRHSCOMP_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSCOMP IF ( .NOT. TOUCHED(IRHSCOMP) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSCOMP=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS IRHSCOMP=BUFRECI_ARG(I) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K) + & BUFRECR_ARG(I,K) ENDDO ENDDO !$OMP END PARALLEL DO DO I = 1, NBRECORDS IRHSCOMP = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE ZMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE ZMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSCOMP INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in ZMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT)* & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE ZMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE ZMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DR_GET_NEW_BUF SUBROUTINE ZMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DR_TRY_FREE_SEND SUBROUTINE ZMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) * & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_DOUBLE_COMPLEX, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_DR_TRY_SEND SUBROUTINE ZMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSCOMP ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSCOMP > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSCOMP IF ( .NOT. TOUCHED(IFS) ) THEN RHSCOMP( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_DR_EMPTY_ROWS END SUBROUTINE ZMUMPS_SCATTER_DIST_RHS SUBROUTINE ZMUMPS_SOL_INIT_IRHS_loc(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%ICNTL(20).EQ.10) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_BUILD_IRHS_loc(id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE ZMUMPS_SOL_INIT_IRHS_loc MUMPS_5.4.1/src/zsol_omp_m.F0000664000175000017500000000076614102210525016003 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SOL_L0OMP_M END MODULE ZMUMPS_SOL_L0OMP_M MUMPS_5.4.1/src/mumps_io_err.c0000664000175000017500000001047114102210474016357 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io_err.h" #include "mumps_io_basic.h" #include "mumps_c_types.h" #if defined( MUMPS_WIN32 ) # include #endif /* Exported global variables */ char* mumps_err; MUMPS_INT* dim_mumps_err; MUMPS_INT mumps_err_max_len; MUMPS_INT err_flag; #if ! ( defined(MUMPS_WIN32) || defined(WITHOUT_PTHREAD) ) pthread_mutex_t err_mutex; #endif /* ! ( MUMPS_WIN32 || WITHOUT_PTHREAD ) */ /* Functions */ /* Keeps a C pointer to store error description string that will be displayed by the Fortran layers. * dim contains the size of the Fortran character array to store the description. */ void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(MUMPS_INT *dim, char* err_str, mumps_ftnlen l1){ mumps_err = err_str; dim_mumps_err = (MUMPS_INT *) dim; mumps_err_max_len = (MUMPS_INT) *dim; err_flag = 0; return; } #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) MUMPS_INLINE MUMPS_INT mumps_io_protect_err() { if(mumps_io_flag_async==IO_ASYNC_TH){ pthread_mutex_lock(&err_mutex); } return 0; } MUMPS_INLINE MUMPS_INT mumps_io_unprotect_err() { if(mumps_io_flag_async==IO_ASYNC_TH){ pthread_mutex_unlock(&err_mutex); } return 0; } MUMPS_INT mumps_io_init_err_lock() { pthread_mutex_init(&err_mutex,NULL); return 0; } MUMPS_INT mumps_io_destroy_err_lock() { pthread_mutex_destroy(&err_mutex); return 0; } MUMPS_INT mumps_check_error_th() { /* If err_flag != 0, then error_str is set */ return err_flag; } #endif /* MUMPS_WIN32 && WITHOUT_PTHREAD */ MUMPS_INT mumps_io_error(MUMPS_INT mumps_errno, const char* desc) { MUMPS_INT len; #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_protect_err(); #endif if(err_flag == 0){ strncpy(mumps_err, desc, mumps_err_max_len); /* mumps_err is a FORTRAN string, we do not care about adding a final 0 */ len = (MUMPS_INT) strlen(desc); *dim_mumps_err = (len <= mumps_err_max_len ) ? len : mumps_err_max_len; err_flag = mumps_errno; } #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_unprotect_err(); #endif return mumps_errno; } MUMPS_INT mumps_io_sys_error(MUMPS_INT mumps_errno, const char* desc) { MUMPS_INT len = 2; /* length of ": " */ const char* _desc; char* _err; #if defined( MUMPS_WIN32 ) MUMPS_INT _err_len; #endif #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_protect_err(); #endif if(err_flag==0){ if(desc == NULL) { _desc = ""; } else { len += (MUMPS_INT) strlen(desc); _desc = desc; } #if ! defined( MUMPS_WIN32 ) _err = strerror(errno); len += (MUMPS_INT) strlen(_err); snprintf(mumps_err, mumps_err_max_len, "%s: %s", _desc, _err); /* mumps_err is a FORTRAN string, we do not care about adding a final 0 */ #else /* This a VERY UGLY workaround for snprintf: this function has been * integrated quite lately into the ANSI stdio: some windows compilers are * not up-to-date yet. */ if( len >= mumps_err_max_len - 1 ) { /* then do not print sys error msg at all */ len -= 2; len = (len >= mumps_err_max_len ) ? mumps_err_max_len - 1 : len; _err = strdup( _desc ); _err[len] = '\0'; sprintf(mumps_err, "%s", _err); } else { _err = strdup(strerror(errno)); _err_len = (MUMPS_INT) strlen(_err); /* We will use sprintf, so make space for the final '\0' ! */ if((len + _err_len) >= mumps_err_max_len) { /* truncate _err, not to overtake mumps_err_max_len at the end. */ _err[mumps_err_max_len - len - 1] = '\0'; len = mumps_err_max_len - 1; } else { len += _err_len; } sprintf(mumps_err, "%s: %s", _desc, _err); } free(_err); #endif *dim_mumps_err = (len <= mumps_err_max_len ) ? len : mumps_err_max_len; err_flag = mumps_errno; } #if ! defined( MUMPS_WIN32 ) && ! defined( WITHOUT_PTHREAD ) mumps_io_unprotect_err(); #endif return mumps_errno; } MUMPS_5.4.1/src/cfac_scalings.F0000664000175000017500000002705414102210523016401 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) COMPLEX, INTENT(IN) :: ASPK(NZ8) REAL COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER LWK_REAL COMPLEX WK(LWK8) REAL WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I LOGICAL PROK REAL ONE PARAMETER( ONE = 1.0E0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROK) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROK) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROK) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL CMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN CALL CMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL CMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 410 INFO(1) = -5 INFO(2) = 5*N-LWK_REAL IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_A SUBROUTINE CMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX VAL(NZ8) REAL RNOR(N),CNOR(N) REAL COLSCA(N),ROWSCA(N) REAL CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) REAL VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE CMUMPS_ROWCOL SUBROUTINE CMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX, INTENT(IN) :: VAL(NZ8) REAL, INTENT(OUT) :: CNOR(N) REAL, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT REAL VDIAG INTEGER I,J INTEGER(8) :: K8 REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE CMUMPS_FAC_Y SUBROUTINE CMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 COMPLEX , INTENT(IN) :: VAL(NZ8) REAL , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT REAL :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE CMUMPS_FAC_V SUBROUTINE CMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX VAL(NZ8) REAL RNOR(N) REAL ROWSCA(N) INTEGER MPRINT REAL VDIAG INTEGER I,J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE CMUMPS_FAC_X SUBROUTINE CMUMPS_ANORMINF( id, ANORMINF, LSCAL ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE(CMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL INTEGER, DIMENSION (:), POINTER :: KEEP,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE COMPLEX DUMMY(1) REAL ZERO PARAMETER( ZERO = 0.0E0) REAL, ALLOCATABLE :: SUMR(:), SUMR_LOC(:) INTEGER :: allocok, MTYPE, I INFO =>id%INFO KEEP =>id%KEEP KEEP8 =>id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN ALLOCATE( SUMR( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL CMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL CMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1), KEEP8(1), & id%COLSCA(1)) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL CMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, KEEP(1),KEEP8(1) ) ELSE CALL CMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL CMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL CMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1)) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = real(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE CMUMPS_ANORMINF MUMPS_5.4.1/src/dfac_process_rtnelind.F0000664000175000017500000001123214102210522020142 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_RTNELIND( ROOT, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE DMUMPS_LOAD USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: ROOT INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : DMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE DMUMPS_PROCESS_RTNELIND MUMPS_5.4.1/src/zfac_front_LU_type2.F0000664000175000017500000011505114102210525017475 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC2_LU_M CONTAINS SUBROUTINE ZMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) !$ USE OMP_LIB USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_FAC_FRONT_TYPE2_AUX_M USE ZMUMPS_OOC USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_TEST USE ZMUMPS_FAC_LR USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTBL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0D0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : ZMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 2 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL ZMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR,DBLARR, & ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL ZMUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL ZMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 490 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL ZMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 490 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(68) = max(KEEP8(69), KEEP8(68)) !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(70) = max(KEEP8(71), KEEP8(70)) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) & THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE ZMUMPS_FAC2_LU END MODULE ZMUMPS_FAC2_LU_M MUMPS_5.4.1/src/ssol_lr.F0000664000175000017500000007016314102210522015275 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SOL_LR USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSCOMP INTEGER, INTENT(IN) :: IW(LIW), POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN REAL, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR REAL, INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NELIM_GLOBAL, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in SMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT NELIM_GLOBAL = & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(NPARTSASS+1) & - BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(NPARTSASS+1) DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL SMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL sgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL sgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL sgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL sgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL sgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL sgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL SMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL SMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE SMUMPS_SOL_FWD_LR_SU SUBROUTINE SMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN REAL, INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in SMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL SMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ELSE CALL SMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SOL_SLAVE_LR_U SUBROUTINE SMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL REAL, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) REAL, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB REAL, ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok, CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & SMUMPS_SOL_FWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL sgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL sgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL sgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif RETURN END SUBROUTINE SMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE SMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: IPOSINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR REAL, INTENT(INOUT) :: WCB(LWCB) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR, PCBINRHSCOMP INTEGER(8) :: PCB_LAST, PWCB INTEGER :: IPIV_PANEL REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in SMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PCBINRHSCOMP= IPOSINRHSCOMP + NPIV_GLOBAL PCB_LAST = PTWCB + int(LIELL ,8) PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) CYCLE NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSCOMP + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF CALL SMUMPS_SOL_BWD_BLR_UPDATE ( & RHSCOMP, int(LRHSCOMP,8), NRHS, LRHSCOMP, & int(IPOSINRHSCOMP,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSCOMP(IPIV_PANEL,JBDEB),LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL sgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL sgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL SMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) ENDDO RETURN END SUBROUTINE SMUMPS_SOL_BWD_LR_SU SUBROUTINE SMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL REAL, INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) REAL, INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB REAL, ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK REAL, ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK,allocok,CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & SMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, !$OMP& POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL sgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL sgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL sgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL sgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL sgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call saxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call saxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE SMUMPS_SOL_BWD_BLR_UPDATE END MODULE SMUMPS_SOL_LR SUBROUTINE SMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSCOMP, LRHSCOMP, NRHS, & PPIVINRHSCOMP, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWC REAL, INTENT(IN) :: DIAG(LDIAG) REAL, INTENT(INOUT) :: W(LWC) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LDAJ REAL ONE PARAMETER (ONE = 1.0E0) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL strsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), & LRHSCOMP) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL strsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), LRHSCOMP) END IF RETURN END SUBROUTINE SMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.4.1/src/sfac_process_end_facto_slave.F0000664000175000017500000002632614102210521021467 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE SMUMPS_LR_DATA_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL SMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL SMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL SMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL SMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL SMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in SMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE SMUMPS_END_FACTO_SLAVE MUMPS_5.4.1/src/cmumps_save_restore_files.F0000664000175000017500000002617014102210524021070 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_SAVE_RESTORE_FILES USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER :: LEN_SAVE_FILE PARAMETER( LEN_SAVE_FILE = 550) CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif #if defined(OOC_VERBOSE) write(*,*) 'First ooc file: ', & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH-2) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE CMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="CMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE CMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 supp=200+MYID open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE CMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix CHARACTER(len=255):: tmp_savedir,savedir CHARACTER(len=255):: tmp_saveprefix,saveprefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_savedir='' tmp_saveprefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_dir_C(len_save_dir,tmp_savedir) if(tmp_savedir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") then id%INFO(1) = -77 id%INFO(2) = 0 else savedir=trim(adjustl(tmp_savedir(1:len_save_dir))) len_save_dir=len_trim(savedir(1:len_save_dir)) endif ELSE savedir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(savedir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_prefix_C(len_save_prefix,tmp_saveprefix) if(tmp_saveprefix(1:len_save_prefix).EQ."NAME_NOT_INITIALIZED") & then saveprefix="save" len_save_prefix=len_trim(saveprefix) else saveprefix= & trim(adjustl(tmp_saveprefix(1:len_save_prefix))) len_save_prefix=len_trim(saveprefix(1:len_save_prefix)) endif ELSE saveprefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(saveprefix) ENDIF write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=savedir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(savedir))//"/" else SAVE_FILE=trim(adjustl(savedir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE CMUMPS_GET_SAVE_FILES SUBROUTINE CMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (CMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE CMUMPS_CHECK_FILE_NAME END MODULE CMUMPS_SAVE_RESTORE_FILES SUBROUTINE CMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE CMUMPS_SAVE_FILES_RETURN MUMPS_5.4.1/src/cmumps_ooc_buffer.F0000664000175000017500000004330414102210524017314 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC COMPLEX, DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE CMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE CMUMPS_OOC_NEXT_HBUF SUBROUTINE CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL CMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL CMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE CMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE CMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE CMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE CMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL CMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL CMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE CMUMPS_INIT_OOC_BUF SUBROUTINE CMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_END_OOC_BUF SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL CMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE CMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK COMPLEX BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE CMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL CMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE CMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE CMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL CMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL CMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE CMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE CMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE CMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE CMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' CMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL CMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL CMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'CMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL CMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL ccopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL ccopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL ccopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE CMUMPS_COPY_LU_TO_BUFFER END MODULE CMUMPS_OOC_BUFFER MUMPS_5.4.1/src/mumps_metis64.h0000664000175000017500000000336114102210474016400 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_METIS64_H #define MUMPS_METIS64_H /* Interfacing with 64-bit (par)metis, for METIS 4 or METIS 5 */ #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #if defined(parmetis) || defined(parmetis3) #include "mpi.h" #define MUMPS_PARMETIS_64 \ F_SYMBOL(parmetis_64,PARMETIS_64) void MUMPS_CALL MUMPS_PARMETIS_64(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, #if defined(parmetis3) MUMPS_INT *numflag, MUMPS_INT *options, #else MUMPS_INT8 *numflag, MUMPS_INT8 *options, #endif MUMPS_INT8 *order, MUMPS_INT8 *sizes, MUMPS_INT *comm, MUMPS_INT *ierr); #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #define MUMPS_METIS_KWAY_64 \ F_SYMBOL(metis_kway_64,METIS_KWAY_64) void MUMPS_CALL MUMPS_METIS_KWAY_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part); #define MUMPS_METIS_KWAY_AB_64 \ F_SYMBOL(metis_kway_ab_64,METIS_KWAY_AB_64) void MUMPS_CALL MUMPS_METIS_KWAY_AB_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part, MUMPS_INT8 *vwgt); #endif #endif MUMPS_5.4.1/src/sfac_lastrtnelind.F0000664000175000017500000001760314102210521017316 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL SMUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'SMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL SMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL SMUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'SMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ELSE CALL SMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL SMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL SMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_LAST_RTNELIND MUMPS_5.4.1/src/smumps_struc_def.F0000664000175000017500000000102414102210521017167 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_STRUC_DEF INCLUDE 'smumps_struc.h' END MODULE SMUMPS_STRUC_DEF MUMPS_5.4.1/src/cfac_asm_ELT.F0000664000175000017500000002365114102210523016061 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) COMPLEX :: A(LA) COMPLEX :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL CMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE CMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: INTARR(LINTARR) COMPLEX, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE CMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.4.1/src/dmumps_save_restore.F0000664000175000017500000126553314102210523017717 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SAVE_RESTORE USE DMUMPS_STRUC_DEF USE DMUMPS_SAVE_RESTORE_FILES USE DMUMPS_LR_DATA_M USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_REMOVE_SAVED(id) USE DMUMPS_OOC INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (DMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK,UNIT_OK,UNIT_OP LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (DMUMPS_STRUC) :: localid ierr = 0 call DMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN fileunit = 40 inquire (UNIT=fileunit,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = fileunit ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL DMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call DMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call DMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END SUBROUTINE DMUMPS_REMOVE_SAVED SUBROUTINE DMUMPS_RESTORE_OOC(localid) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: UNIT_OK,UNIT_OP TYPE (DMUMPS_STRUC) :: localid NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL DMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN IN=50 inquire(UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN localid%INFO(1) = -79 localid%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = 0 endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_SAVE_RESTORE_STRUCTURE(localid,IN,"restore_ooc" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE DMUMPS_RESTORE_OOC SUBROUTINE DMUMPS_COMPUTE_MEMORY_SAVE(id, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) INCLUDE 'mpif.h' INTEGER::NBVARIABLES,NBVARIABLES_ROOT INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (DMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE DMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE DMUMPS_SAVE(id) INCLUDE 'mpif.h' INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOT,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (DMUMPS_STRUC) :: id INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL DMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUT=60 inquire (UNIT=OUT,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUTINFO=70 inquire (UNIT=OUTINFO,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUTINFO ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,OUT,"save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFO(1) endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by DMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_F2003) write(OUTINFO,*) "Using MUMPS_F2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_SAVE SUBROUTINE DMUMPS_RESTORE(id) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (DMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL DMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN IN=80 inquire (UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL DMUMPS_SAVE_RESTORE_STRUCTURE(id,IN,"restore" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFO(1):" & , id%INFO(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else id%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_RESTORE SUBROUTINE DMUMPS_SAVE_RESTORE_STRUCTURE(id,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE DMUMPS_FACSOL_L0OMP_M, ONLY : DMUMPS_SAVE_RESTORE_L0FACARRAY IMPLICIT NONE INCLUDE 'mpif.h' INTEGER,intent(in)::unit,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=*),intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOT)::SIZE_VARIABLES_ROOT INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOT)::SIZE_GEST_ROOT INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER(len=30), allocatable, dimension(:)::VARIABLES CHARACTER(len=30), allocatable, dimension(:)::VARIABLES_ROOT CHARACTER(len=30) :: TMP_STRING1, TMP_STRING2 CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOT)::NbRecords_ROOT INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64 INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOT)::DIFF_SIZE_ALLOC_READ_ROOT INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC TYPE (DMUMPS_STRUC) :: id allocate(VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES(186)="ASSOCIATED_OOC_FILES" VARIABLES(185)="pad16" VARIABLES(184)="Deficiency" VARIABLES(183)="NB_SINGULAR_VALUES" VARIABLES(182)="SINGULAR_VALUES" VARIABLES(181)="MPITOOMP_PROCS_MAP" VARIABLES(180)="L0_OMP_MAPPING" VARIABLES(179)="PTR_LEAFS_L0_OMP" VARIABLES(178)="PERM_L0_OMP" VARIABLES(177)="VIRT_L0_OMP_MAPPING" VARIABLES(176)="VIRT_L0_OMP" VARIABLES(175)="PHYS_L0_OMP" VARIABLES(174)="IPOOL_A_L0_OMP" VARIABLES(173)="IPOOL_B_L0_OMP" VARIABLES(172)="I8_L0_OMP" VARIABLES(171)="I4_L0_OMP" VARIABLES(170)="THREAD_LA" VARIABLES(169)="LL0_OMP_FACTORS" VARIABLES(168)="LL0_OMP_MAPPING" VARIABLES(167)="L_VIRT_L0_OMP" VARIABLES(166)="L_PHYS_L0_OMP" VARIABLES(165)="LPOOL_B_L0_OMP" VARIABLES(164)="LPOOL_A_L0_OMP" VARIABLES(163)="L0_OMP_FACTORS" VARIABLES(162)="BLRARRAY_ENCODING" VARIABLES(161)="FDM_F_ENCODING" VARIABLES(160)="pad13" VARIABLES(159)="NBGRP" VARIABLES(158)="LRGROUPS" VARIABLES(157)="root" VARIABLES(156)="WORKING" VARIABLES(155)="IPTR_WORKING" VARIABLES(154)="pad14" VARIABLES(153)="SUP_PROC" VARIABLES(152)="PIVNUL_LIST" VARIABLES(151)="OOC_FILE_NAMES" VARIABLES(150)="OOC_FILE_NAME_LENGTH" VARIABLES(149)="pad12" VARIABLES(148)="OOC_NB_FILE_TYPE" VARIABLES(147)="OOC_NB_FILES" VARIABLES(146)="OOC_TOTAL_NB_NODES" VARIABLES(145)="OOC_VADDR" VARIABLES(144)="OOC_SIZE_OF_BLOCK" VARIABLES(143)="OOC_INODE_SEQUENCE" VARIABLES(142)="OOC_MAX_NB_NODES_FOR_ZONE" VARIABLES(141)="INSTANCE_NUMBER" VARIABLES(140)="CB_SON_SIZE" VARIABLES(139)="DKEEP" VARIABLES(138)="LWK_USER" VARIABLES(137)="NBSA_LOCAL" VARIABLES(136)="WK_USER" VARIABLES(135)="CROIX_MANU" VARIABLES(134)="SCHED_SBTR" VARIABLES(133)="SCHED_GRP" VARIABLES(132)="SCHED_DEP" VARIABLES(131)="SBTR_ID" VARIABLES(130)="DEPTH_FIRST_SEQ" VARIABLES(129)="DEPTH_FIRST" VARIABLES(128)="MY_NB_LEAF" VARIABLES(127)="MY_FIRST_LEAF" VARIABLES(126)="MY_ROOT_SBTR" VARIABLES(125)="COST_TRAV" VARIABLES(124)="MEM_SUBTREE" VARIABLES(123)="RHSCOMP" VARIABLES(122)="POSINRHSCOMP_COL" VARIABLES(121)="pad11" VARIABLES(120)="POSINRHSCOMP_COL_ALLOC" VARIABLES(119)="POSINRHSCOMP_ROW" VARIABLES(118)="MEM_DIST" VARIABLES(117)="I_AM_CAND" VARIABLES(116)="TAB_POS_IN_PERE" VARIABLES(115)="FUTURE_NIV2" VARIABLES(114)="ISTEP_TO_INIV2" VARIABLES(113)="CANDIDATES" VARIABLES(112)="ELTPROC" VARIABLES(111)="LELTVAR" VARIABLES(110)="NELT_loc" VARIABLES(109)="DBLARR" VARIABLES(108)="INTARR" VARIABLES(107)="PROCNODE" VARIABLES(106)="S" VARIABLES(105)="PTRFAC" VARIABLES(104)="PTLUST_S" VARIABLES(103)="Step2node" VARIABLES(102)="PROCNODE_STEPS" VARIABLES(101)="NA" VARIABLES(100)="PTRAR" VARIABLES(99)="FRTELT" VARIABLES(98)="FRTPTR" VARIABLES(97)="FILS" VARIABLES(96)="DAD_STEPS" VARIABLES(95)="FRERE_STEPS" VARIABLES(94)="ND_STEPS" VARIABLES(93)="NE_STEPS" VARIABLES(92)="STEP" VARIABLES(91)="NBSA" VARIABLES(90)="LNA" VARIABLES(89)="KEEP" VARIABLES(88)="IS" VARIABLES(87)="ASS_IRECV" VARIABLES(86)="NSLAVES" VARIABLES(85)="NPROCS" VARIABLES(84)="MYID" VARIABLES(83)="COMM_LOAD" VARIABLES(82)="MYID_NODES" VARIABLES(81)="COMM_NODES" VARIABLES(80)="INST_Number" VARIABLES(79)="MAX_SURF_MASTER" VARIABLES(78)="KEEP8" VARIABLES(77)="pad7" VARIABLES(76)="SAVE_PREFIX" VARIABLES(75)="SAVE_DIR" VARIABLES(74)="WRITE_PROBLEM" VARIABLES(73)="OOC_PREFIX" VARIABLES(72)="OOC_TMPDIR" VARIABLES(71)="VERSION_NUMBER" VARIABLES(70)="MAPPING" VARIABLES(69)="LISTVAR_SCHUR" VARIABLES(68)="SCHUR_CINTERFACE" VARIABLES(67)="SCHUR" VARIABLES(66)="SIZE_SCHUR" VARIABLES(65)="SCHUR_LLD" VARIABLES(64)="SCHUR_NLOC" VARIABLES(63)="SCHUR_MLOC" VARIABLES(62)="NBLOCK" VARIABLES(61)="MBLOCK" VARIABLES(60)="NPCOL" VARIABLES(59)="NPROW" VARIABLES(58)="UNS_PERM" VARIABLES(57)="SYM_PERM" VARIABLES(56)="METIS_OPTIONS" VARIABLES(55)="RINFOG" VARIABLES(54)="RINFO" VARIABLES(53)="CNTL" VARIABLES(52)="COST_SUBTREES" VARIABLES(51)="INFOG" VARIABLES(50)="INFO" VARIABLES(49)="ICNTL" VARIABLES(48)="pad6" VARIABLES(47)="LSOL_loc" VARIABLES(46)="LREDRHS" VARIABLES(45)="LRHS_loc" VARIABLES(44)="Nloc_RHS" VARIABLES(43)="NZ_RHS" VARIABLES(42)="NRHS" VARIABLES(41)="LRHS" VARIABLES(40)="IRHS_loc" VARIABLES(39)="ISOL_loc" VARIABLES(38)="IRHS_PTR" VARIABLES(37)="IRHS_SPARSE" VARIABLES(36)="RHS_loc" VARIABLES(35)="SOL_loc" VARIABLES(34)="RHS_SPARSE" VARIABLES(33)="REDRHS" VARIABLES(32)="RHS" VARIABLES(31)="BLKVAR" VARIABLES(30)="BLKPTR" VARIABLES(29)="pad5" VARIABLES(28)="NBLK" VARIABLES(27)="PERM_IN" VARIABLES(26)="pad4" VARIABLES(25)="A_ELT" VARIABLES(24)="ELTVAR" VARIABLES(23)="ELTPTR" VARIABLES(22)="pad3" VARIABLES(21)="NELT" VARIABLES(20)="pad2" VARIABLES(19)="A_loc" VARIABLES(18)="JCN_loc" VARIABLES(17)="IRN_loc" VARIABLES(16)="NNZ_loc" VARIABLES(15)="pad1" VARIABLES(14)="NZ_loc" VARIABLES(13)="pad0" VARIABLES(12)="ROWSCA" VARIABLES(11)="COLSCA" VARIABLES(10)="JCN" VARIABLES(9)="IRN" VARIABLES(8)="A" VARIABLES(7)="NNZ" VARIABLES(6)="NZ" VARIABLES(5)="N" VARIABLES(4)="JOB" VARIABLES(3)="PAR" VARIABLES(2)="SYM" VARIABLES(1)="COMM" allocate(VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES_ROOT(35)="rootpad4" VARIABLES_ROOT(34)="NB_SINGULAR_VALUES" VARIABLES_ROOT(33)="SINGULAR_VALUES" VARIABLES_ROOT(32)="SVD_VT" VARIABLES_ROOT(31)="SVD_U" VARIABLES_ROOT(30)="gridinit_done" VARIABLES_ROOT(29)="yes" VARIABLES_ROOT(28)="rootpad3" VARIABLES_ROOT(27)="QR_RCOND" VARIABLES_ROOT(26)="rootpad" VARIABLES_ROOT(25)="RHS_ROOT" VARIABLES_ROOT(24)="rootpad2" VARIABLES_ROOT(23)="QR_TAU" VARIABLES_ROOT(22)="SCHUR_POINTER" VARIABLES_ROOT(21)="RHS_CNTR_MASTER_ROOT" VARIABLES_ROOT(20)="rootpad1" VARIABLES_ROOT(19)="IPIV" VARIABLES_ROOT(18)="RG2L_COL" VARIABLES_ROOT(17)="RG2L_ROW" VARIABLES_ROOT(16)="rootpad0" VARIABLES_ROOT(15)="LPIV" VARIABLES_ROOT(14)="CNTXT_BLACS" VARIABLES_ROOT(13)="DESCRIPTOR" VARIABLES_ROOT(12)="TOT_ROOT_SIZE" VARIABLES_ROOT(11)="ROOT_SIZE" VARIABLES_ROOT(10)="RHS_NLOC" VARIABLES_ROOT(9)="SCHUR_LLD" VARIABLES_ROOT(8)="SCHUR_NLOC" VARIABLES_ROOT(7)="SCHUR_MLOC" VARIABLES_ROOT(6)="MYCOL" VARIABLES_ROOT(5)="MYROW" VARIABLES_ROOT(4)="NPCOL" VARIABLES_ROOT(3)="NPROW" VARIABLES_ROOT(2)="NBLOCK" VARIABLES_ROOT(1)="MBLOCK" OOC_INDICES=(/147,148,150,151/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(16) SIZE_ARITH_DEP = id%KEEP(35) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOT(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOT(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(trim(mode).EQ."memory_save") then elseif(trim(mode).EQ."save") then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="DMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (trim(mode).EQ."restore_ooc") THEN BASIC_CHECK = .true. ENDIF CALL DMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(trim(mode).EQ."fake_restore") then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("OOC_NB_FILES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILE_TYPE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAMES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAME_LENGTH") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(trim(mode).EQ."restore_ooc") then goto 200 endif DO i1=1,NBVARIABLES TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("COMM") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("SYM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SYM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SYM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%PAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%PAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("JOB") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("N") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%N if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%N if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ICNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_SUBTREES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP8") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) read(unit,iostat=err) id%KEEP8 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) read(unit,iostat=err) id%KEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DKEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("A") CASE("IRN") CASE("JCN") CASE("COLSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COLSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%COLSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COLSCA)) THEN write(unit,iostat=err) size(id%COLSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%COLSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COLSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%COLSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COLSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("ROWSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ROWSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ROWSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ROWSCA)) THEN write(unit,iostat=err) size(id%ROWSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%ROWSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ROWSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%ROWSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ROWSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("NZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IRN_loc") CASE("JCN_loc") CASE("A_loc") CASE("NELT") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPTR") CASE("ELTVAR") CASE("A_ELT") CASE("PERM_IN") CASE("BLKPTR") CASE("BLKVAR") CASE("RHS") CASE("REDRHS") CASE("RHS_SPARSE") CASE("SOL_loc") CASE("RHS_loc") CASE("IRHS_SPARSE") CASE("IRHS_PTR") CASE("ISOL_loc") CASE("IRHS_loc") CASE("LRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ_RHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_RHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_RHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRHS_loc") CASE("Nloc_RHS") CASE("LSOL_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LSOL_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LSOL_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LREDRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LREDRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LREDRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SYM_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%SYM_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SYM_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SYM_PERM)) THEN write(unit,iostat=err) size(id%SYM_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SYM_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SYM_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SYM_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SYM_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("UNS_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SIZE_SCHUR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR") CASE("SCHUR_CINTERFACE") CASE("LISTVAR_SCHUR") CASE("MAPPING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("VERSION_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TMPDIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WRITE_PROBLEM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MAX_SURF_MASTER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INST_Number") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INST_Number if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INST_Number if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_NODES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID_NODES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID_NODES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID_NODES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_LOAD") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROCS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROCS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROCS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NSLAVES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NSLAVES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NSLAVES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASS_IRECV") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ASS_IRECV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%ASS_IRECV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Deficiency") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%Deficiency if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%Deficiency if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LNA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LNA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LNA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBSA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("STEP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%STEP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%STEP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%STEP)) THEN write(unit,iostat=err) size(id%STEP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%STEP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%STEP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES(i1),id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%STEP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%STEP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ND_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Step2node") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRERE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DAD_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FILS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FILS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FILS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FILS)) THEN write(unit,iostat=err) size(id%FILS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FILS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FILS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FILS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FILS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRAR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(trim(mode).EQ."restore") then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTPTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTELT") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NA") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTLUST_S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRFAC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array_INT8_1,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE") CASE("INTARR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%INTARR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(27)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%INTARR)) THEN write(unit,iostat=err) id%KEEP8(27) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%INTARR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%INTARR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%INTARR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%INTARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DBLARR") CASE("NELT_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LELTVAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LELTVAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LELTVAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPROC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I4_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I8_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CANDIDATES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ISTEP_TO_INIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FUTURE_NIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TAB_POS_IN_PERE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I_AM_CAND") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_DIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_ROW") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_ROW,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_ROW,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_ROW ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_ROW) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_ROW(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_ROW endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL_ALLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_COL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_COL ELSE write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%POSINRHSCOMP_COL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_COL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_COL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%POSINRHSCOMP_COL=>id%POSINRHSCOMP_ROW endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHSCOMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%RHSCOMP)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%RHSCOMP)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSCOMP ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%RHSCOMP) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSCOMP(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSCOMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_SUBTREE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_TRAV") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_ROOT_SBTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_FIRST_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_NB_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST_SEQ") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SBTR_ID") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHED_DEP") CASE("SCHED_GRP") CASE("CROIX_MANU") CASE("WK_USER") CASE("NBSA_LOCAL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LWK_USER") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("CB_SON_SIZE") CASE("INSTANCE_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_MAX_NB_NODES_FOR_ZONE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_INODE_SEQUENCE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_SIZE_OF_BLOCK") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_VADDR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TOTAL_NB_NODES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILES") CASE("OOC_NB_FILE_TYPE") CASE("OOC_FILE_NAMES") CASE("OOC_FILE_NAME_LENGTH") CASE("PIVNUL_LIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SUP_PROC") CASE("IPTR_WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("root") DO i2=1,NBVARIABLES_ROOT TMP_STRING2 = VARIABLES_ROOT(i2) SELECT CASE(TMP_STRING2) CASE("MBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then NbRecords_ROOT(i2)=1 SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TOT_ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DESCRIPTOR") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=size(id%root%DESCRIPTOR,1) & *SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT* & size(id%root%DESCRIPTOR,1) read(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTXT_BLACS") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPIV") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RG2L_ROW") CASE("RG2L_COL") CASE("IPIV") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%IPIV)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%IPIV)) THEN write(unit,iostat=err) size(id%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_INT allocate(id%root%IPIV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_CNTR_MASTER_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%RHS_CNTR_MASTER_ROOT,1) & *SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN write(unit,iostat=err) & size(id%root%RHS_CNTR_MASTER_ROOT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_CNTR_MASTER_ROOT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_ARITH_DEP allocate(id%root%RHS_CNTR_MASTER_ROOT(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_POINTER") CASE("QR_TAU") CASE("RHS_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size(id%root%RHS_ROOT,1) & *size(id%root%RHS_ROOT,2)*SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_ROOT)) THEN write(unit,iostat=err) size(id%root%RHS_ROOT,1) & ,size(id%root%RHS_ROOT,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_ROOT ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_ROOT) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size_array1*size_array2 & *SIZE_ARITH_DEP allocate(id%root%RHS_ROOT(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("QR_RCOND") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL read(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("yes") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("gridinit_done") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SVD_U") CASE("SVD_VT") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("rootpad0","rootpad1","rootpad2","rootpad", & "rootpad3","rootpad4") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_ROOT(i2)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_ROOT(i2)=NbRecords_ROOT(i2)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_ROOT(i2) & +SIZE_GEST_ROOT(i2) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES_ROOT(i2)+ & DIFF_SIZE_ALLOC_READ_ROOT(i2) size_read=size_read+SIZE_VARIABLES_ROOT(i2) & +int(SIZE_GEST_ROOT(i2),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO CASE("NBGRP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBGRP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBGRP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRGROUPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%LRGROUPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%LRGROUPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%LRGROUPS)) THEN write(unit,iostat=err) size(id%LRGROUPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LRGROUPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%LRGROUPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%LRGROUPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LRGROUPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FDM_F_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("BLRARRAY_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL DMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL DMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL DMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L0_OMP_FACTORS") CASE("SCHED_SBTR") CASE("LPOOL_A_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPOOL_B_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_PHYS_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_VIRT_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_MAPPING") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_FACTORS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("THREAD_LA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IPOOL_A_L0_OMP") CASE("IPOOL_B_L0_OMP") CASE("PHYS_L0_OMP") CASE("VIRT_L0_OMP") CASE("VIRT_L0_OMP_MAPPING") CASE("PERM_L0_OMP") CASE("PTR_LEAFS_L0_OMP") CASE("L0_OMP_MAPPING") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASSOCIATED_OOC_FILES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE("SAVE_DIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SAVE_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MPITOOMP_PROCS_MAP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MPITOOMP_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MPITOOMP_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MPITOOMP_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MPITOOMP_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MPITOOMP_PROCS_MAP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MPITOOMP_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("METIS_OPTIONS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("pad0","pad1","pad2","pad3","pad4","pad5","pad6","pad7", & "pad11","pad111", "pad12","pad13","pad14","pad15","pad16") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO 200 continue if(trim(mode).EQ."memory_save") then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+sum(SIZE_VARIABLES_ROOT) & +SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOT) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOT) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if !defined(MUMPS_F2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOT)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(trim(mode).EQ."save") then elseif(trim(mode).EQ."restore") then if(id%root%gridinit_done) then id%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( id%root%CNTXT_BLACS, 'R', & id%root%NPROW, id%root%NPCOL ) id%root%gridinit_done = .TRUE. endif elseif(trim(mode).EQ."fake_restore") then elseif(trim(mode).EQ."restore_ooc") then endif 100 continue deallocate(VARIABLES, VARIABLES_ROOT) RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_STRUCTURE END MODULE DMUMPS_SAVE_RESTORE MUMPS_5.4.1/src/zmumps_ooc_buffer.F0000664000175000017500000004333414102210525017347 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC COMPLEX(kind=8), DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE ZMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE ZMUMPS_OOC_NEXT_HBUF SUBROUTINE ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL ZMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL ZMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE ZMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE ZMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE ZMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL ZMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL ZMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE ZMUMPS_INIT_OOC_BUF SUBROUTINE ZMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_END_OOC_BUF SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL ZMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE ZMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK COMPLEX(kind=8) BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE ZMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL ZMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE ZMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE ZMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL ZMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL ZMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE ZMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE ZMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE ZMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' ZMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL ZMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'ZMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL ZMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL zcopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL zcopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL zcopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE ZMUMPS_COPY_LU_TO_BUFFER END MODULE ZMUMPS_OOC_BUFFER MUMPS_5.4.1/src/sfac_front_LU_type1.F0000664000175000017500000012133314102210521017461 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC1_LU_M CONTAINS SUBROUTINE SMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & , PERM & ) USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_OOC USE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW REAL, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) REAL A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) REAL UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL REAL, POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC REAL :: ZERO PARAMETER (ZERO=0.0E0) INCLUDE 'mumps_headers.h' INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U) CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL SMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif CALL SMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL SMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL SMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL SMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL SMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0)) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL SMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) END SUBROUTINE SMUMPS_FAC1_LU END MODULE SMUMPS_FAC1_LU_M MUMPS_5.4.1/src/sfac_sol_l0omp_m.F0000664000175000017500000003332614102210522017034 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: SMUMPS_INIT_L0_OMP_FACTORS & , SMUMPS_FREE_L0_OMP_FACTORS & , SMUMPS_SAVE_RESTORE_L0FACARRAY CONTAINS SUBROUTINE SMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE SMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE SMUMPS_FREE_L0_OMP_FACTORS SUBROUTINE SMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE SMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (SMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (trim(mode) .EQ. "memory_save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (trim(mode) .EQ. "save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (trim(mode) .EQ. "restore") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if !defined(MUMPS_F2003) IF (trim(mode).EQ."memory_save") THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."save") THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."restore") THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_L0FAC END MODULE SMUMPS_FACSOL_L0OMP_M MUMPS_5.4.1/src/zfac_asm_master_ELT_m.F0000664000175000017500000020432114102210525017774 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE ZMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) !$ USE OMP_LIB USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_IS_DYNAMIC, & ZMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & ZMUMPS_BLR_ASM_NIV1 USE ZMUMPS_LR_DATA_M, ONLY : ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_NFS4FATHER USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 COMPLEX(kind=8), TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in ZMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress ZMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL ZMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL ZMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL ZMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) IF (IS_DYNAMIC_CB) THEN CALL ZMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL ZMUMPS_BUF_SEND_MAPLIG( INODE, NFRONT, & NASS1, NFS4FATHER,ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, & SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING ZMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING ZMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE ZMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_IS_DYNAMIC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX(kind=8), TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX(kind=8) ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = (0.0D0,0.0D0) ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL ZMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL ZMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL ZMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress ZMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL ZMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL ZMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL ZMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL ZMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL ZMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & ZMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))=cmplx( & max(dble(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))), & kind=kind(A) & ) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = cmplx( & max( MAXARR, dble(A(APOSMAX+int(I-1,8)))), & kind=kind(A) & ) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL ZMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL ZMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL ZMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL ZMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL ZMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING ZMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV2_ELT END MODULE ZMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.4.1/src/zsol_root_parallel.F0000664000175000017500000000742014102210525017525 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT COMPLEX(kind=8) RHS_SEQ( SIZE_ROOT *NRHS) COMPLEX(kind=8) A( LOCAL_M, LOCAL_N ) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS COMPLEX(kind=8), ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR EXTERNAL numroc INTEGER numroc INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = numroc(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL ZMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL ZMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) RETURN END SUBROUTINE ZMUMPS_ROOT_SOLVE SUBROUTINE ZMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) COMPLEX(kind=8), intent (in) :: A( LOCAL_M, LOCAL_N ) COMPLEX(kind=8), intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL pzgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL pzgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pzpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_2D_BCYCLIC MUMPS_5.4.1/src/zstatic_ptr_m.F0000664000175000017500000000211514102210525016475 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_STATIC_PTR_M PUBLIC :: ZMUMPS_TMP_PTR, ZMUMPS_GET_TMP_PTR COMPLEX(kind=8), DIMENSION(:), POINTER, SAVE :: ZMUMPS_TMP_PTR CONTAINS SUBROUTINE ZMUMPS_SET_STATIC_PTR(ARRAY) COMPLEX(kind=8), DIMENSION(:), TARGET :: ARRAY ZMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE ZMUMPS_SET_STATIC_PTR SUBROUTINE ZMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_F2003) COMPLEX(kind=8), DIMENSION(:), POINTER, INTENT(OUT) :: PTR #else COMPLEX(kind=8), DIMENSION(:), POINTER :: PTR #endif PTR => ZMUMPS_TMP_PTR RETURN END SUBROUTINE ZMUMPS_GET_TMP_PTR END MODULE ZMUMPS_STATIC_PTR_M MUMPS_5.4.1/src/zmumps_load.F0000664000175000017500000066471314102210525016167 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_LOAD implicit none PUBLIC :: ZMUMPS_LOAD_SET_INICOST, ZMUMPS_LOAD_INIT, & ZMUMPS_LOAD_SET_SLAVES, ZMUMPS_LOAD_UPDATE, & ZMUMPS_LOAD_END, ZMUMPS_LOAD_PROCESS_MESSAGE, & ZMUMPS_LOAD_LESS, ZMUMPS_LOAD_LESS_CAND, & ZMUMPS_LOAD_SET_SLAVES_CAND, ZMUMPS_LOAD_MASTER_2_ALL, & ZMUMPS_LOAD_RECV_MSGS, ZMUMPS_LOAD_MEM_UPDATE, & ZMUMPS_LOAD_SET_PARTITION, & ZMUMPS_SPLIT_PREP_PARTITION, ZMUMPS_SPLIT_POST_PARTITION, & ZMUMPS_SPLIT_PROPAGATE_PARTI, ZMUMPS_LOAD_POOL_UPD_NEW_POOL, & ZMUMPS_LOAD_SBTR_UPD_NEW_POOL, ZMUMPS_LOAD_POOL_CHECK_MEM, & ZMUMPS_LOAD_SET_SBTR_MEM, & ZMUMPS_REMOVE_NODE, ZMUMPS_UPPER_PREDICT & ,ZMUMPS_LOAD_SEND_MD_INFO, & ZMUMPS_LOAD_CLEAN_MEMINFO_POOL, ZMUMPS_LOAD_COMP_MAXMEM_POOL, & ZMUMPS_LOAD_CHK_MEMCST_POOL, ZMUMPS_CHECK_SBTR_COST, & ZMUMPS_FIND_BEST_NODE_FOR_MEM, & ZMUMPS_LOAD_INIT_SBTR_STRUCT DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE, PRIVATE :: LOAD_FLOPS INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: BUF_LOAD_RECV INTEGER, SAVE, PRIVATE :: LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES INTEGER, SAVE, PRIVATE :: K50, K69, K35 INTEGER(8), SAVE, PRIVATE :: MAX_SURF_MASTER LOGICAL, SAVE, PRIVATE :: BDC_MEM, BDC_POOL, BDC_SBTR, & BDC_POOL_MNG, & BDC_M2_MEM,BDC_M2_FLOPS,BDC_MD,REMOVE_NODE_FLAG, & REMOVE_NODE_FLAG_MEM DOUBLE PRECISION, SAVE, PRIVATE :: REMOVE_NODE_COST, & REMOVE_NODE_COST_MEM INTEGER, SAVE, PRIVATE :: SBTR_WHICH_M DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, TARGET, SAVE, PRIVATE :: WLOAD DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM LOGICAL, SAVE, PRIVATE :: IS_MUMPS_LOAD_ENABLED PUBLIC:: MUMPS_LOAD_ENABLE, MUMPS_LOAD_DISABLE INTEGER(8), SAVE, PRIVATE :: CHECK_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, TARGET, PRIVATE :: & IDWLOAD DOUBLE PRECISION, SAVE, PRIVATE :: COST_SUBTREE DOUBLE PRECISION, SAVE, PRIVATE :: ALPHA DOUBLE PRECISION, SAVE, PRIVATE :: BETA INTEGER, SAVE, PRIVATE :: MYID, NPROCS, COMM_LD INTEGER, SAVE, PRIVATE :: COMM_NODES DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE :: POOL_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, PRIVATE, & SAVE :: SBTR_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: SBTR_CUR INTEGER, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: NB_SON DOUBLE PRECISION, & PRIVATE, SAVE :: SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: PEAK_SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: MAX_PEAK_STK DOUBLE PRECISION, SAVE, & PRIVATE :: POOL_LAST_COST_SENT DOUBLE PRECISION, SAVE, & PRIVATE :: MIN_DIFF INTEGER, SAVE :: POS_ID,POS_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: CB_COST_ID INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE & :: CB_COST_MEM PUBLIC :: CB_COST_ID, CB_COST_MEM,POS_MEM,POS_ID DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: LU_USAGE INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE::MD_MEM, TAB_MAXS DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE ::MEM_SUBTREE INTEGER :: NB_SUBTREES,NIV1_FLAG INTEGER, PRIVATE :: INDICE_SBTR,INDICE_SBTR_ARRAY INTEGER :: POOL_NIV2_SIZE INTEGER,SAVE :: INSIDE_SUBTREE PUBLIC :: NB_SUBTREES,MEM_SUBTREE,INSIDE_SUBTREE,NIV1_FLAG DOUBLE PRECISION, SAVE, PRIVATE :: DM_SUMLU, & DM_THRES_MEM DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE , PRIVATE:: DM_MEM INTEGER, SAVE, PRIVATE :: POOL_SIZE,ID_MAX_M2 DOUBLE PRECISION, SAVE, PRIVATE :: MAX_M2,TMP_M2 INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, PRIVATE:: POOL_NIV2 DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE :: POOL_NIV2_COST, NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: CHK_LD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: & PROCNODE_LOAD, STEP_TO_NIV2_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: KEEP_LOAD INTEGER, SAVE, PRIVATE :: N_LOAD INTEGER(8), DIMENSION(:), POINTER, SAVE, PRIVATE:: KEEP8_LOAD INTEGER, DIMENSION(:),POINTER, SAVE :: & FILS_LOAD, STEP_LOAD, & FRERE_LOAD, ND_LOAD, & NE_LOAD,DAD_LOAD INTEGER, DIMENSION(:,:),POINTER, SAVE, PRIVATE :: CAND_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, & PRIVATE :: MY_FIRST_LEAF,MY_NB_LEAF, MY_ROOT_SBTR INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_FIRST_POS_IN_POOL DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_PEAK_ARRAY, & SBTR_CUR_ARRAY DOUBLE PRECISION,DIMENSION(:),POINTER, SAVE :: COST_TRAV INTEGER, DIMENSION(:),POINTER, SAVE :: DEPTH_FIRST_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD PUBLIC :: DEPTH_FIRST_LOAD,COST_TRAV, FILS_LOAD,STEP_LOAD, & FRERE_LOAD, ND_LOAD,NE_LOAD,DAD_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD INTEGER, SAVE :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST PUBLIC :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST CONTAINS SUBROUTINE MUMPS_LOAD_ENABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .TRUE. RETURN END SUBROUTINE MUMPS_LOAD_ENABLE SUBROUTINE MUMPS_LOAD_DISABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .FALSE. RETURN END SUBROUTINE MUMPS_LOAD_DISABLE SUBROUTINE ZMUMPS_LOAD_SET_INICOST( COST_SUBTREE_ARG, K64, DK15, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K375 DOUBLE PRECISION, INTENT(IN) :: DK15 INTEGER(8)::MAXS DOUBLE PRECISION :: T64, T66 LOGICAL :: AVOID_LOAD_MESSAGES T64 = max ( dble(K64), dble(1) ) T64 = min ( T64, dble(1000) ) T66 = max (dble(DK15), dble(100)) MIN_DIFF = ( T64 / dble(1000) )* & T66 * dble(1000000) DM_THRES_MEM = dble(MAXS/300_8) COST_SUBTREE = COST_SUBTREE_ARG AVOID_LOAD_MESSAGES = .FALSE. IF (K375.EQ.1) THEN AVOID_LOAD_MESSAGES = .TRUE. ENDIF IF (AVOID_LOAD_MESSAGES) THEN MIN_DIFF = MIN_DIFF * 1000.D0 DM_THRES_MEM = DM_THRES_MEM * 1000_8 ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_SET_INICOST SUBROUTINE ZMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND, ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, SLAVES_LIST, & SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SIZE_SLAVES_LIST, SLAVEF, & KEEP(500) INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), CAND(SLAVEF+1), & FILS(N) INTEGER, intent(out) :: NBSPLIT, NUMORG_SPLIT INTEGER, intent(inout) :: SLAVES_LIST(SIZE_SLAVES_LIST), & COPY_CAND(SLAVEF+1) INTEGER :: IN, LP, II INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT = NBSPLIT + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG_SPLIT = NUMORG_SPLIT + 1 II = FILS(II) ENDDO END DO SLAVES_LIST(1:NBSPLIT) = CAND(1:NBSPLIT) COPY_CAND(1:SIZE_SLAVES_LIST-NBSPLIT) = & CAND(1+NBSPLIT:SIZE_SLAVES_LIST) COPY_CAND(SIZE_SLAVES_LIST-NBSPLIT+1:SLAVEF) = -1 COPY_CAND(SLAVEF+1) = SIZE_SLAVES_LIST-NBSPLIT RETURN END SUBROUTINE ZMUMPS_SPLIT_PREP_PARTITION SUBROUTINE ZMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & TAB_POS, NSLAVES_NODE & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SLAVEF, NCB, & KEEP(500), NBSPLIT INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N) INTEGER, intent(inout) :: TAB_POS ( SLAVEF+2 ), NSLAVES_NODE INTEGER :: IN, LP, II, NUMORG, NBSPLIT_LOC, I INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT DO I= NSLAVES_NODE+1, 1, -1 TAB_POS(I+NBSPLIT) = TAB_POS(I) END DO LP = ICNTL(1) IN = INODE NBSPLIT_LOC = 0 NUMORG = 0 TAB_POS(1) = 1 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT_LOC = NBSPLIT_LOC + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG = NUMORG + 1 II = FILS(II) ENDDO TAB_POS(NBSPLIT_LOC+1) = NUMORG + 1 END DO DO I = NBSPLIT+2, NBSPLIT+NSLAVES_NODE+1 TAB_POS(I) = TAB_POS(I) + NUMORG ENDDO NSLAVES_NODE = NSLAVES_NODE + NBSPLIT TAB_POS (NSLAVES_NODE+2:SLAVEF+1) = -9999 TAB_POS ( SLAVEF+2 ) = NSLAVES_NODE RETURN END SUBROUTINE ZMUMPS_SPLIT_POST_PARTITION SUBROUTINE ZMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND, SIZE_CAND, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES_NODE, & SLAVES_LIST, SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, TYPESPLIT, IFSON, N, SLAVEF, & KEEP(500), & NSLSON, SIZE_SLAVES_LIST, SIZE_CAND INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N), INIV2, & SON_SLAVE_LIST (NSLSON), & ISTEP_TO_INIV2(KEEP(71)), & CAND(SIZE_CAND) INTEGER, intent(out) :: NSLAVES_NODE INTEGER, intent(inout) :: & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(out) :: SLAVES_LIST (SIZE_SLAVES_LIST) INTEGER :: IN, LP, I, NSLAVES_SONS, & INIV2_FILS, ISHIFT LP = ICNTL(1) IN = INODE INIV2_FILS = ISTEP_TO_INIV2( STEP( IFSON )) NSLAVES_SONS = TAB_POS_IN_PERE (SLAVEF+2, INIV2_FILS) TAB_POS_IN_PERE (1,INIV2) = 1 ISHIFT = TAB_POS_IN_PERE (2, INIV2_FILS) -1 DO I = 2, NSLAVES_SONS TAB_POS_IN_PERE (I,INIV2) = & TAB_POS_IN_PERE (I+1,INIV2_FILS) - ISHIFT SLAVES_LIST(I-1) = SON_SLAVE_LIST (I) END DO TAB_POS_IN_PERE(NSLAVES_SONS+1:SLAVEF+1,INIV2) = -9999 NSLAVES_NODE = NSLAVES_SONS - 1 TAB_POS_IN_PERE (SLAVEF+2, INIV2) = NSLAVES_NODE RETURN END SUBROUTINE ZMUMPS_SPLIT_PROPAGATE_PARTI SUBROUTINE ZMUMPS_LOAD_SET_PARTITION( & NCBSON_MAX, SLAVEF, & KEEP,KEEP8,ICNTL, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,INODE &) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: SLAVEF, NFRONT INTEGER, intent (inout) ::NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER i INTEGER LP,MP INTEGER(8) DUMMY1 INTEGER DUMMY2 INTEGER TMP_ARRAY(2) LP=ICNTL(4) MP=ICNTL(2) IF ( KEEP(48) == 0 .OR. KEEP(48) .EQ. 3 ) THEN CALL ZMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) ELSE IF ( KEEP(48) == 4 ) THEN CALL ZMUMPS_SET_PARTI_ACTV_MEM( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'probleme de partition dans &ZMUMPS_LOAD_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN IF (KEEP(375).EQ.1) THEN GOTO 458 ENDIF CALL ZMUMPS_SET_PARTI_FLOP_IRR( & NCBSON_MAX, & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & MP,LP) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'problem with partition in &ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO GOTO 457 458 CONTINUE IF ( KEEP(375).EQ.1 )THEN TMP_ARRAY(1)=0 TMP_ARRAY(2)=0 ENDIF CALL ZMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS,TMP_ARRAY,DUMMY1,DUMMY2 & ) ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF 457 CONTINUE RETURN END SUBROUTINE ZMUMPS_LOAD_SET_PARTITION SUBROUTINE ZMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER ITEMP, NMB_OF_CAND, NSLAVES_LESS DOUBLE PRECISION MSG_SIZE LOGICAL FORCE_CAND INTEGER MUMPS_REG_GET_NSLAVES EXTERNAL MUMPS_REG_GET_NSLAVES IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in ZMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in ZMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF MSG_SIZE = dble( NFRONT - NCB ) * dble(NCB) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF (FORCE_CAND) THEN ITEMP=ZMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=ZMUMPS_LOAD_LESS(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_REG_GET_NSLAVES(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND, & KEEP(375), KEEP(119)) CALL MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL ZMUMPS_LOAD_SET_SLAVES_CAND(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL ZMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_PARTI_REGULAR SUBROUTINE ZMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) USE ZMUMPS_BUF USE ZMUMPS_STRUC_DEF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC INTEGER(8) :: I8SIZE INTEGER allocok, IERR, IERR_MPI, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_DBLE(2) INTEGER WHAT INTEGER(8) MEMORY_MD, LA CALL MUMPS_LOAD_ENABLE() STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP8_LOAD=>id%KEEP8 FILS_LOAD=>id%FILS FRERE_LOAD=>id%FRERE_STEPS DAD_LOAD=>id%DAD_STEPS PROCNODE_LOAD=>id%PROCNODE_STEPS STEP_LOAD=>id%STEP NE_LOAD=>id%NE_STEPS N_LOAD=id%N ROOT_CURRENT_SUBTREE=-9999 MEMORY_MD=MEMORY_MD_ARG LA=MAXS MAX_SURF_MASTER=id%MAX_SURF_MASTER+ & (int(id%KEEP(12),8)*int(id%MAX_SURF_MASTER,8)/int(100,8)) COMM_LD = id%COMM_LOAD COMM_NODES = id%COMM_NODES MAX_PEAK_STK = 0.0D0 K69 = id%KEEP(69) IF ( id%KEEP(47) .le. 0 .OR. id%KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in ZMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( id%KEEP(47) >= 2 ) BDC_POOL = ( id%KEEP(47) >= 3 ) BDC_SBTR = ( id%KEEP(47) >= 4 ) BDC_M2_MEM = ( ( id%KEEP(80) == 2 .OR. id%KEEP(80) == 3 ) & .AND. id%KEEP(47) == 4 ) BDC_M2_FLOPS = ( id%KEEP(80) == 1 & .AND. id%KEEP(47) .GE. 1 ) BDC_MD = (id%KEEP(86)==1) SBTR_WHICH_M = id%KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (id%KEEP(80) .LT. 0 .OR. id%KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((id%KEEP(80) == 2 .OR. id%KEEP(80)==3).AND. id%KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in ZMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF IF (id%KEEP(81) == 1 .AND. id%KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_LOAD_INIT" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((id%KEEP(81) == 1).AND.(id%KEEP(47) >= 2)) IF(id%KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(id%KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(id%KEEP(76).EQ.6)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST DEPTH_FIRST_SEQ_LOAD=>id%DEPTH_FIRST_SEQ SBTR_ID_LOAD=>id%SBTR_ID ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN POOL_NIV2_SIZE=max(1,min(id%NBSA+id%KEEP(262),id%NA(1))) ALLOCATE(NIV2(id%NSLAVES), NB_SON(id%KEEP(28)), & POOL_NIV2(POOL_NIV2_SIZE), & POOL_NIV2_COST(POOL_NIV2_SIZE), & stat=allocok) DO i = 1, id%KEEP(28) NB_SON(i)=id%NE_STEPS(i) ENDDO NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + id%KEEP(28) + 200 RETURN ENDIF ENDIF K50 = id%KEEP(50) CALL MPI_COMM_RANK( COMM_LD, MYID, IERR_MPI ) NPROCS = id%NSLAVES DM_SUMLU=ZERO POOL_SIZE=0 IF(BDC_MD)THEN IF ( allocated(MD_MEM) ) DEALLOCATE(MD_MEM) ALLOCATE( MD_MEM( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(TAB_MAXS) ) DEALLOCATE(TAB_MAXS) ALLOCATE( TAB_MAXS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF TAB_MAXS=0_8 IF ( allocated(LU_USAGE) ) DEALLOCATE(LU_USAGE) ALLOCATE( LU_USAGE( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((id%KEEP(81).EQ.2).OR.(id%KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_MEM=int(0,8) ALLOCATE(CB_COST_ID(2000*3), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_ID=0 POS_MEM=1 POS_ID=1 ENDIF ALLOCATE(FUTURE_NIV2(NPROCS), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN ENDIF DO i = 1, NPROCS FUTURE_NIV2(i) = id%FUTURE_NIV2(i) IF(BDC_MD)THEN IF(FUTURE_NIV2(i).EQ.0)THEN MD_MEM(i-1)=999999999_8 ENDIF ENDIF ENDDO DELTA_MEM=ZERO DELTA_LOAD=ZERO CHECK_MEM=0_8 IF(BDC_SBTR.OR.BDC_POOL_MNG)THEN NB_SUBTREES=id%NBSA_LOCAL IF (allocated(MEM_SUBTREE)) DEALLOCATE(MEM_SUBTREE) ALLOCATE(MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF DO i=1,id%NBSA_LOCAL MEM_SUBTREE(i)=id%MEM_SUBTREE(i) ENDDO MY_FIRST_LEAF=>id%MY_FIRST_LEAF MY_NB_LEAF=>id%MY_NB_LEAF MY_ROOT_SBTR=>id%MY_ROOT_SBTR IF (allocated(SBTR_FIRST_POS_IN_POOL)) & DEALLOCATE(SBTR_FIRST_POS_IN_POOL) ALLOCATE(SBTR_FIRST_POS_IN_POOL(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF INSIDE_SUBTREE=0 PEAK_SBTR_CUR_LOCAL = dble(0) SBTR_CUR_LOCAL = dble(0) IF (allocated(SBTR_PEAK_ARRAY)) DEALLOCATE(SBTR_PEAK_ARRAY) ALLOCATE(SBTR_PEAK_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_CUR_ARRAY=dble(0) INDICE_SBTR_ARRAY=1 NIV1_FLAG=0 INDICE_SBTR=1 ENDIF IF ( allocated(LOAD_FLOPS) ) DEALLOCATE( LOAD_FLOPS ) ALLOCATE( LOAD_FLOPS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(WLOAD) ) DEALLOCATE( WLOAD ) ALLOCATE( WLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(IDWLOAD) ) DEALLOCATE( IDWLOAD ) ALLOCATE( IDWLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( BDC_MEM ) THEN IF ( allocated(DM_MEM) ) DEALLOCATE( DM_MEM ) ALLOCATE( DM_MEM( 0:NPROCS-1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF END IF IF ( BDC_POOL ) THEN IF ( allocated(POOL_MEM) ) DEALLOCATE(POOL_MEM) ALLOCATE( POOL_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF POOL_MEM = dble(0) POOL_LAST_COST_SENT = dble(0) END IF IF ( BDC_SBTR ) THEN IF ( allocated(SBTR_MEM) ) DEALLOCATE(SBTR_MEM) ALLOCATE( SBTR_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(SBTR_CUR) ) DEALLOCATE(SBTR_CUR) ALLOCATE( SBTR_CUR(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF K34_LOC=id%KEEP(34) CALL MUMPS_SIZE_C(SIZE_DBLE(1),SIZE_DBLE(2),I8SIZE) K35 = int(I8SIZE) BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35 + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 ENDIF LBUF_LOAD_RECV = (BUF_LOAD_SIZE+K34_LOC)/K34_LOC LBUF_LOAD_RECV_BYTES = LBUF_LOAD_RECV * K34_LOC IF ( allocated(BUF_LOAD_RECV) ) DEALLOCATE(BUF_LOAD_RECV) ALLOCATE( BUF_LOAD_RECV( LBUF_LOAD_RECV), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL ZMUMPS_BUF_ALLOC_LOAD_BUFFER( BUF_LOAD_SIZE, IERR ) IF ( IERR .LT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = BUF_LOAD_SIZE RETURN END IF DO i = 0, NPROCS - 1 LOAD_FLOPS( i ) = ZERO END DO IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO ENDIF CALL ZMUMPS_INIT_ALPHA_BETA(id%KEEP(69)) IF(BDC_MD)THEN MAX_SBTR=0.0D0 IF(BDC_SBTR)THEN DO i=1,id%NBSA_LOCAL MAX_SBTR=max(id%MEM_SUBTREE(i),MAX_SBTR) ENDDO ENDIF MD_MEM(MYID)=MEMORY_MD WHAT=8 CALL ZMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & dble(MEMORY_MD),dble(0) ,MYID, id%KEEP, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * & dble(max(id%KEEP(5),id%KEEP(6))) * dble(id%KEEP(127))) IF (id%KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(id%KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF IF (id%KEEP(375).EQ.1) THEN MEMORY_SENT=dble(LA) ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL ZMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & MEMORY_SENT, & dble(0),MYID, id%KEEP, IERR ) ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_INIT SUBROUTINE ZMUMPS_LOAD_UPDATE( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG INTEGER CHECK_FLOPS INTEGER IERR DOUBLE PRECISION ZERO, SEND_MEM, SEND_LOAD,SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN IF (INC_LOAD == 0.0D0) THEN IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN ENDIF IF((CHECK_FLOPS.NE.0).AND. & (CHECK_FLOPS.NE.1).AND.(CHECK_FLOPS.NE.2))THEN WRITE(*,*)MYID,': Bad value for CHECK_FLOPS' CALL MUMPS_ABORT() ENDIF IF(CHECK_FLOPS.EQ.1)THEN CHK_LD=CHK_LD+INC_LOAD ELSE IF(CHECK_FLOPS.EQ.2)THEN RETURN ENDIF ENDIF IF ( PROCESS_BANDE ) THEN RETURN ENDIF LOAD_FLOPS( MYID ) = max( LOAD_FLOPS( MYID ) + INC_LOAD, ZERO) IF(BDC_M2_FLOPS.AND.REMOVE_NODE_FLAG)THEN IF(INC_LOAD.NE.REMOVE_NODE_COST)THEN IF(INC_LOAD.GT.REMOVE_NODE_COST)THEN DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 ELSE DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_LOAD = DELTA_LOAD + INC_LOAD 888 CONTINUE IF ( DELTA_LOAD > MIN_DIFF .OR. DELTA_LOAD < -MIN_DIFF) THEN SEND_LOAD = DELTA_LOAD IF (BDC_MEM) THEN SEND_MEM = DELTA_MEM ELSE SEND_MEM = ZERO END IF IF(BDC_SBTR)THEN SBTR_TMP=SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF 111 CONTINUE CALL ZMUMPS_BUF_SEND_UPDATE_LOAD( BDC_SBTR,BDC_MEM, & BDC_MD,COMM_LD, NPROCS, & SEND_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_UPDATE SUBROUTINE ZMUMPS_LOAD_MEM_UPDATE( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLUS) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLUS LOGICAL, INTENT(IN) :: PROCESS_BANDE_ARG, SSARBR INTEGER IERR, KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION ZERO, SEND_MEM, SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs INTEGER(8) :: INC_MEM LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG IF ( PROCESS_BANDE .AND. NEW_LU .NE. 0_8) THEN WRITE(*,*) " Internal Error in ZMUMPS_LOAD_MEM_UPDATE." WRITE(*,*) " NEW_LU must be zero if called from PROCESS_BANDE" CALL MUMPS_ABORT() ENDIF DM_SUMLU = DM_SUMLU + dble(NEW_LU) IF(KEEP_LOAD(201).EQ.0)THEN CHECK_MEM = CHECK_MEM + INC_MEM ELSE CHECK_MEM = CHECK_MEM + INC_MEM - NEW_LU ENDIF IF ( MEM_VALUE .NE. CHECK_MEM ) THEN WRITE(*,*)MYID, & ':Problem with increments in ZMUMPS_LOAD_MEM_UPDATE', & CHECK_MEM, MEM_VALUE, INC_MEM,NEW_LU CALL MUMPS_ABORT() ENDIF IF (PROCESS_BANDE) THEN RETURN ENDIF IF(BDC_POOL_MNG) THEN IF(SBTR_WHICH_M.EQ.0)THEN IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM-NEW_LU) ELSE IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM) ENDIF ENDIF IF ( .NOT. BDC_MEM ) THEN RETURN ENDIF IF (BDC_SBTR .AND. SSARBR) THEN IF((SBTR_WHICH_M.EQ.0).AND.(KEEP(201).NE.0))THEN SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM-NEW_LU) ELSE SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM) ENDIF SBTR_TMP = SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF IF ( NEW_LU > 0_8 ) THEN INC_MEM = INC_MEM - NEW_LU ENDIF DM_MEM( MYID ) = DM_MEM(MYID) + dble(INC_MEM) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MYID)) IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(dble(INC_MEM).NE.REMOVE_NODE_COST_MEM)THEN IF(dble(INC_MEM).GT.REMOVE_NODE_COST_MEM)THEN DELTA_MEM = DELTA_MEM + & (dble(INC_MEM)-REMOVE_NODE_COST_MEM) GOTO 888 ELSE DELTA_MEM = DELTA_MEM - & (REMOVE_NODE_COST_MEM-dble(INC_MEM)) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_MEM = DELTA_MEM + dble(INC_MEM) 888 CONTINUE IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND.(abs(DELTA_MEM) & .GE.0.2d0*dble(LRLUS))))THEN IF ( abs(DELTA_MEM) > DM_THRES_MEM ) THEN SEND_MEM = DELTA_MEM 111 CONTINUE CALL ZMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, & DELTA_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO DELTA_MEM = ZERO ENDIF ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG_MEM)THEN REMOVE_NODE_FLAG_MEM=.FALSE. ENDIF END SUBROUTINE ZMUMPS_LOAD_MEM_UPDATE INTEGER FUNCTION ZMUMPS_LOAD_LESS( K69, MEM_DISTRIB,MSG_SIZE ) IMPLICIT NONE INTEGER i, NLESS, K69 INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION LREF DOUBLE PRECISION MSG_SIZE NLESS = 0 DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO WLOAD(1:NPROCS) = LOAD_FLOPS(0:NPROCS-1) IF(BDC_M2_FLOPS)THEN DO i=1,NPROCS WLOAD(i)=WLOAD(i)+NIV2(i) ENDDO ENDIF IF(K69 .gt. 1) THEN CALL ZMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,IDWLOAD,NPROCS) ENDIF LREF = LOAD_FLOPS(MYID) DO i=1, NPROCS IF (WLOAD(i).LT.LREF) NLESS=NLESS+1 ENDDO ZMUMPS_LOAD_LESS = NLESS RETURN END FUNCTION ZMUMPS_LOAD_LESS SUBROUTINE ZMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB,MSG_SIZE,DEST, & NSLAVES) IMPLICIT NONE INTEGER NSLAVES INTEGER DEST(NSLAVES) INTEGER, DIMENSION(0:NPROCS - 1) :: MEM_DISTRIB INTEGER i,J,NBDEST DOUBLE PRECISION MSG_SIZE IF ( NSLAVES.eq.NPROCS-1 ) THEN J = MYID+1 DO i=1,NSLAVES J=J+1 IF (J.GT.NPROCS) J=1 DEST(i) = J - 1 ENDDO ELSE DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO CALL MUMPS_SORT_DOUBLES(NPROCS, WLOAD, IDWLOAD) NBDEST = 0 DO i=1, NSLAVES J = IDWLOAD(i) IF (J.NE.MYID) THEN NBDEST = NBDEST+1 DEST(NBDEST) = J ENDIF ENDDO IF (NBDEST.NE.NSLAVES) THEN DEST(NSLAVES) = IDWLOAD(NSLAVES+1) ENDIF IF(BDC_MD)THEN J=NSLAVES+1 do i=NSLAVES+1,NPROCS IF(IDWLOAD(i).NE.MYID)THEN DEST(J)= IDWLOAD(i) J=J+1 ENDIF end do ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_SET_SLAVES SUBROUTINE ZMUMPS_LOAD_END( INFO1, NSLAVES, IERR ) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT(IN) :: INFO1 INTEGER, INTENT(IN) :: NSLAVES INTEGER, INTENT(OUT) :: IERR INTEGER :: DUMMY_COMMUNICATOR IERR=0 DUMMY_COMMUNICATOR = -999 CALL ZMUMPS_CLEAN_PENDING( INFO1, KEEP_LOAD(1), BUF_LOAD_RECV(1), & LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES, DUMMY_COMMUNICATOR, COMM_LD, & NSLAVES, & .FALSE., & .TRUE. & ) DEALLOCATE( LOAD_FLOPS ) DEALLOCATE( WLOAD ) DEALLOCATE( IDWLOAD ) DEALLOCATE(FUTURE_NIV2) IF(BDC_MD)THEN DEALLOCATE(MD_MEM) DEALLOCATE(LU_USAGE) DEALLOCATE(TAB_MAXS) ENDIF IF ( BDC_MEM ) DEALLOCATE( DM_MEM ) IF ( BDC_POOL) DEALLOCATE( POOL_MEM ) IF ( BDC_SBTR) THEN DEALLOCATE( SBTR_MEM ) DEALLOCATE( SBTR_CUR ) DEALLOCATE(SBTR_FIRST_POS_IN_POOL) NULLIFY(MY_FIRST_LEAF) NULLIFY(MY_NB_LEAF) NULLIFY(MY_ROOT_SBTR) ENDIF IF(KEEP_LOAD(76).EQ.4)THEN NULLIFY(DEPTH_FIRST_LOAD) ENDIF IF(KEEP_LOAD(76).EQ.5)THEN NULLIFY(COST_TRAV) ENDIF IF((KEEP_LOAD(76).EQ.4).OR.(KEEP_LOAD(76).EQ.6))THEN NULLIFY(DEPTH_FIRST_LOAD) NULLIFY(DEPTH_FIRST_SEQ_LOAD) NULLIFY(SBTR_ID_LOAD) ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN DEALLOCATE(NB_SON,POOL_NIV2,POOL_NIV2_COST, NIV2) END IF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN DEALLOCATE(CB_COST_MEM) DEALLOCATE(CB_COST_ID) ENDIF NULLIFY(ND_LOAD) NULLIFY(KEEP_LOAD) NULLIFY(KEEP8_LOAD) NULLIFY(FILS_LOAD) NULLIFY(FRERE_LOAD) NULLIFY(PROCNODE_LOAD) NULLIFY(STEP_LOAD) NULLIFY(NE_LOAD) NULLIFY(CAND_LOAD) NULLIFY(STEP_TO_NIV2_LOAD) NULLIFY(DAD_LOAD) IF (BDC_SBTR.OR.BDC_POOL_MNG) THEN DEALLOCATE(MEM_SUBTREE) DEALLOCATE(SBTR_PEAK_ARRAY) DEALLOCATE(SBTR_CUR_ARRAY) ENDIF CALL ZMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) DEALLOCATE(BUF_LOAD_RECV) RETURN END SUBROUTINE ZMUMPS_LOAD_END RECURSIVE SUBROUTINE ZMUMPS_LOAD_RECV_MSGS(COMM) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGLEN, MSGSOU,COMM INTEGER IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR_MPI ) IF (FLAG) THEN KEEP_LOAD(65)=KEEP_LOAD(65)+1 KEEP_LOAD(267)=KEEP_LOAD(267)-1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in ZMUMPS_LOAD_RECV_MSGS", & MSGTAG CALL MUMPS_ABORT() ENDIF CALL MPI_GET_COUNT(STATUS, MPI_PACKED, MSGLEN, IERR_MPI) IF ( MSGLEN > LBUF_LOAD_RECV_BYTES ) THEN write(*,*) "Internal error 2 in ZMUMPS_LOAD_RECV_MSGS", & MSGLEN, LBUF_LOAD_RECV_BYTES CALL MUMPS_ABORT() ENDIF CALL MPI_RECV( BUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES, & MPI_PACKED, MSGSOU, MSGTAG, COMM_LD, STATUS, IERR_MPI) CALL ZMUMPS_LOAD_PROCESS_MESSAGE( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_RECV_MSGS RECURSIVE SUBROUTINE ZMUMPS_LOAD_PROCESS_MESSAGE & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, WHAT, NSLAVES, i INTEGER IERR_MPI DOUBLE PRECISION LOAD_RECEIVED INTEGER INODE_RECEIVED,NCB_RECEIVED DOUBLE PRECISION SURF INTEGER, POINTER, DIMENSION (:) :: LIST_SLAVES DOUBLE PRECISION, POINTER, DIMENSION (:) :: LOAD_INCR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WHAT, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) IF ( WHAT == 0 ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MSGSOU)) END IF IF(BDC_SBTR)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_CUR(MSGSOU)=LOAD_RECEIVED ENDIF IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(KEEP_LOAD(201).EQ.0)THEN LU_USAGE(MSGSOU)=LOAD_RECEIVED ENDIF ENDIF ELSEIF (( WHAT == 1).OR.(WHAT.EQ.19)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) + & LOAD_INCR(i) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(LIST_SLAVES(i))) END DO END IF IF(WHAT.EQ.19)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) CALL ZMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE_RECEIVED) CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES WRITE(*,*)MYID,':',LIST_SLAVES(i),'->',LOAD_INCR(i) CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(LOAD_INCR(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF NULLIFY( LIST_SLAVES ) NULLIFY( LOAD_INCR ) ELSE IF (WHAT == 2 ) THEN IF ( .not. BDC_POOL ) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) POOL_MEM(MSGSOU)=LOAD_RECEIVED ELSE IF ( WHAT == 3 ) THEN IF ( .NOT. BDC_SBTR) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED ELSE IF (WHAT == 4) THEN FUTURE_NIV2(MSGSOU+1)=0 IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SURF, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF IF(BDC_M2_MEM.OR.BDC_M2_FLOPS)THEN ENDIF ELSE IF (WHAT == 5) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 7 in ZMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN CALL ZMUMPS_PROCESS_NIV2_MEM_MSG(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL ZMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE_RECEIVED) ENDIF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & KEEP_LOAD(199)).EQ.1 & )THEN CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MSGSOU,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB_RECEIVED,8)* & int(NCB_RECEIVED,8) POS_MEM=POS_MEM+1 ENDIF ENDIF ELSE IF ( WHAT == 6 ) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 8 in ZMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSEIF(WHAT == 17)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_MD)THEN DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED ELSEIF(BDC_POOL)THEN POOL_MEM(MSGSOU)=LOAD_RECEIVED ENDIF ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED ENDIF ELSEIF ( WHAT == 7 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 4 &in ZMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF END DO ELSEIF ( WHAT == 8 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 5 &in ZMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF ELSEIF ( WHAT == 9 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 6 &in ZMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) TAB_MAXS(MSGSOU)=int(LOAD_RECEIVED,8) ELSE WRITE(*,*) "Internal error 1 in ZMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE ZMUMPS_LOAD_PROCESS_MESSAGE integer function ZMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB,CAND, & K69, & SLAVEF,MSG_SIZE, & NMB_OF_CAND ) implicit none integer, intent(in) :: K69, SLAVEF INTEGER, intent(in) :: CAND(SLAVEF+1) INTEGER, DIMENSION(0:NPROCS - 1), intent(in) :: MEM_DISTRIB INTEGER, intent(out) :: NMB_OF_CAND integer i,nless DOUBLE PRECISION lref DOUBLE PRECISION MSG_SIZE nless = 0 NMB_OF_CAND=CAND(SLAVEF+1) do i=1,NMB_OF_CAND WLOAD(i)=LOAD_FLOPS(CAND(i)) IF(BDC_M2_FLOPS)THEN WLOAD(i)=WLOAD(i)+NIV2(CAND(i)+1) ENDIF end do IF(K69 .gt. 1) THEN CALL ZMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE, & CAND,NMB_OF_CAND) ENDIF lref = LOAD_FLOPS(MYID) do i=1, NMB_OF_CAND if (WLOAD(i).lt.lref) nless=nless+1 end do ZMUMPS_LOAD_LESS_CAND = nless return end function ZMUMPS_LOAD_LESS_CAND subroutine ZMUMPS_LOAD_SET_SLAVES_CAND & (MEM_DISTRIB,CAND, & & SLAVEF, & nslaves_inode, DEST) implicit none integer, intent(in) :: nslaves_inode, SLAVEF integer, intent(in) :: CAND(SLAVEF+1) integer, dimension(0:NPROCS - 1), intent(in) :: MEM_DISTRIB integer, intent(out) :: DEST(CAND(SLAVEF+1)) integer i,j,NMB_OF_CAND external MUMPS_SORT_DOUBLES NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in ZMUMPS_LOAD_SET_SLAVES_CAND', & nslaves_inode, NPROCS, NMB_OF_CAND CALL MUMPS_ABORT() end if if (nslaves_inode.eq.NPROCS-1) then j=MYID+1 do i=1,nslaves_inode if(j.ge.NPROCS) j=0 DEST(i)=j j=j+1 end do else do i=1,NMB_OF_CAND IDWLOAD(i)=i end do call MUMPS_SORT_DOUBLES(NMB_OF_CAND, & WLOAD(1),IDWLOAD(1) ) do i=1,nslaves_inode DEST(i)= CAND(IDWLOAD(i)) end do IF(BDC_MD)THEN do i=nslaves_inode+1,NMB_OF_CAND DEST(i)= CAND(IDWLOAD(i)) end do ENDIF end if return end subroutine ZMUMPS_LOAD_SET_SLAVES_CAND SUBROUTINE ZMUMPS_INIT_ALPHA_BETA(K69) IMPLICIT NONE INTEGER K69 IF (K69 .LE. 4) THEN ALPHA = 0.0d0 BETA = 0.0d0 RETURN ENDIF IF (K69 .EQ. 5) THEN ALPHA = 0.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 6) THEN ALPHA = 0.5d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 7) THEN ALPHA = 0.5d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 8) THEN ALPHA = 1.0d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 9) THEN ALPHA = 1.0d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 10) THEN ALPHA = 1.0d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 11) THEN ALPHA = 1.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 12) THEN ALPHA = 1.5d0 BETA = 100000.0d0 RETURN ENDIF ALPHA = 1.5d0 BETA = 150000.0d0 RETURN END SUBROUTINE ZMUMPS_INIT_ALPHA_BETA SUBROUTINE ZMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,ARRAY_ADM,LEN) IMPLICIT NONE INTEGER i,LEN INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION MSG_SIZE,FORBIGMSG INTEGER ARRAY_ADM(LEN) DOUBLE PRECISION MY_LOAD FORBIGMSG = 1.0d0 IF (K69 .lt.2) THEN RETURN ENDIF IF(BDC_M2_FLOPS)THEN MY_LOAD=LOAD_FLOPS(MYID)+NIV2(MYID+1) ELSE MY_LOAD=LOAD_FLOPS(MYID) ENDIF IF((MSG_SIZE * dble(K35) ) .gt. 3200000.0d0) THEN FORBIGMSG = 2.0d0 ENDIF IF (K69 .le. 4) THEN DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i)/MY_LOAD ELSE IF ( MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1 ) THEN WLOAD(i) = WLOAD(i) * & dble(MEM_DISTRIB(ARRAY_ADM(i))) & * FORBIGMSG & + dble(2) ENDIF ENDIF ENDDO RETURN ENDIF DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i) / MY_LOAD ELSE IF(MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1) THEN WLOAD(i) = (WLOAD(i) + & ALPHA * MSG_SIZE * dble(K35) + & BETA) * FORBIGMSG ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ARCHGENWLOAD SUBROUTINE ZMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: MYID, SLAVEF, COMM, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES( NSLAVES ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER NCB, NFRONT, NBROWS_SLAVE INTEGER i, IERR,WHAT,INODE, allocok LOGICAL :: EXIT_FLAG DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: FLOPS_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: CB_BAND ALLOCATE(MEM_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of MEM_INCREMENT ' & // 'in routine ZMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(FLOPS_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of FLOPS_INCREMENT ' & // 'in routine ZMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(CB_BAND(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of CB_BAND ' & // 'in routine ZMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in ZMUMPS_LOAD_MASTER_2_ALL" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL ZMUMPS_BUF_SEND_NOT_MSTR(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),KEEP,IERR) IF (IERR == -1 ) THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in ZMUMPS_LOAD_MASTER_2_ALL", & NSLAVES, TAB_POS(SLAVEF+2) CALL MUMPS_ABORT() ENDIF NCB = TAB_POS(NSLAVES+1) - 1 NFRONT = NCB + NASS DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) IF ( KEEP(50) == 0 ) THEN FLOPS_INCREMENT( i ) = (dble(NBROWS_SLAVE)*dble( NASS ))+ & dble(NBROWS_SLAVE) * dble(NASS) * & dble(2*NFRONT-NASS-1) ELSE FLOPS_INCREMENT( i ) = dble(NBROWS_SLAVE) * dble(NASS ) * & dble( 2 * ( NASS + TAB_POS(i+1) - 1 ) & - NBROWS_SLAVE - NASS + 1 ) ENDIF IF ( BDC_MEM ) THEN IF ( KEEP(50) == 0 ) THEN MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT) ELSE MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble( NASS + TAB_POS(i+1) - 1 ) END IF ENDIF IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN CB_BAND(i)=dble(-999999) ELSE IF ( KEEP(50) == 0 ) THEN CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT-NASS) ELSE CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(TAB_POS(i+1)-1) END IF ENDIF END DO IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(CB_BAND(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF 111 CONTINUE CALL ZMUMPS_BUF_BCAST_ARRAY(BDC_MEM, COMM, MYID, SLAVEF, & FUTURE_NIV2, & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = LOAD_FLOPS(LIST_SLAVES(i)) & + FLOPS_INCREMENT(i) IF ( BDC_MEM ) THEN DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) & + MEM_INCREMENT(i) END IF ENDDO ENDIF 100 CONTINUE DEALLOCATE(MEM_INCREMENT,FLOPS_INCREMENT,CB_BAND) RETURN END SUBROUTINE ZMUMPS_LOAD_MASTER_2_ALL SUBROUTINE ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL, SLAVEF, COMM, MYID INTEGER N, KEEP(500) INTEGER(8) KEEP8(150) INTEGER POOL( LPOOL ), PROCNODE( KEEP(28) ), STEP( N ) INTEGER ND( KEEP(28) ), FILS( N ) INTEGER i, INODE, NELIM, NFR, LEVEL, IERR, WHAT DOUBLE PRECISION COST LOGICAL :: EXIT_FLAG INTEGER NBINSUBTREE,NBTOP,INSUBTREE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF(BDC_MD)THEN RETURN ENDIF IF((KEEP(76).EQ.0).OR.(KEEP(76).EQ.2))THEN IF(NBTOP.NE.0)THEN DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE IF(KEEP(76).EQ.1)THEN IF(INSUBTREE.EQ.1)THEN DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE WRITE(*,*) & 'Internal error: Unknown pool management strategy' CALL MUMPS_ABORT() ENDIF ENDIF 20 CONTINUE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS(i) GOTO 10 ENDIF NFR = ND( STEP(INODE) ) LEVEL = MUMPS_TYPENODE( PROCNODE(STEP(INODE)), KEEP(199) ) IF (LEVEL .EQ. 1) THEN COST = dble( NFR ) * dble( NFR ) ELSE IF ( KEEP(50) == 0 ) THEN COST = dble( NFR ) * dble( NELIM ) ELSE COST = dble( NELIM ) * dble( NELIM ) ENDIF ENDIF 30 CONTINUE IF ( abs(POOL_LAST_COST_SENT-COST).GT.DM_THRES_MEM ) THEN WHAT = 2 111 CONTINUE CALL ZMUMPS_BUF_BROADCAST( WHAT, & COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_POOL_UPD_NEW_POOL SUBROUTINE ZMUMPS_LOAD_SBTR_UPD_NEW_POOL( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL,MYID,SLAVEF,COMM,INODE INTEGER POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER WHAT,IERR LOGICAL OK DOUBLE PRECISION COST LOGICAL FLAG, EXIT_FLAG EXTERNAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_LOAD(STEP_LOAD(INODE)), KEEP(199)) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)))THEN IF(NE_LOAD(STEP_LOAD(INODE)).EQ.0)THEN RETURN ENDIF ENDIF FLAG=.FALSE. IF(INDICE_SBTR.LE.NB_SUBTREES)THEN IF(INODE.EQ.MY_FIRST_LEAF(INDICE_SBTR))THEN FLAG=.TRUE. ENDIF ENDIF IF(FLAG)THEN SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY)=MEM_SUBTREE(INDICE_SBTR) SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY)=SBTR_CUR(MYID) INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY+1 WHAT = 3 IF(dble(MEM_SUBTREE(INDICE_SBTR)).GE.DM_THRES_MEM)THEN 111 CONTINUE CALL ZMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in ZMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF SBTR_MEM(MYID)=SBTR_MEM(MYID)+ & dble(MEM_SUBTREE(INDICE_SBTR)) INDICE_SBTR=INDICE_SBTR+1 IF(INSIDE_SUBTREE.EQ.0)THEN INSIDE_SUBTREE=1 ENDIF ELSE IF(INODE.EQ.MY_ROOT_SBTR(INDICE_SBTR-1))THEN WHAT = 3 COST=-SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY-1) IF(abs(COST).GE.DM_THRES_MEM)THEN 112 CONTINUE CALL ZMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in ZMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY-1 SBTR_MEM(MYID)=SBTR_MEM(MYID)- & SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY) SBTR_CUR(MYID)=SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY) IF(INDICE_SBTR_ARRAY.EQ.1)THEN SBTR_CUR(MYID)=dble(0) INSIDE_SUBTREE=0 ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_LOAD_SBTR_UPD_NEW_POOL SUBROUTINE ZMUMPS_SET_PARTI_ACTV_MEM & (SLAVEF,KEEP,KEEP8,PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47, K48, K50 INTEGER(8) :: K821 DOUBLE PRECISION DK821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS INTEGER(8)::TOTAL_MEM LOGICAL FORCE_CAND DOUBLE PRECISION TEMP(SLAVEF),PEAK INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME IF (KEEP8(21) .GT. 0_8) THEN write(*,*)MYID, & ": Internal Error 1 in ZMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF K821=abs(KEEP8(21)) DK821=dble(K821) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF(K48.NE.4)THEN WRITE(*,*)'ZMUMPS_COMPUTE_PARTI_ACTV_MEM_K821 & should be called with KEEP(48) different from 4' CALL MUMPS_ABORT() ENDIF KMIN=1 KMAX=int(K821/int(NFRONT,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=DM_MEM(PROCS(i)) IDWLOAD(i)=PROCS(i) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = DM_MEM(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) TOTAL_MEM=int(NCB,8)*int(NFRONT,8) SOMME=dble(0) J=1 PEAK=dble(0) DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN PEAK=max(PEAK,WLOAD(i)) TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_SBTR)THEN TEMP(J)=TEMP(J)+SBTR_MEM(IDWLOAD(i))- & SBTR_CUR(IDWLOAD(i)) ENDIF IF(BDC_POOL)THEN TEMP(J)=TEMP(J)+POOL_MEM(TEMP_ID(J)) ENDIF IF(BDC_M2_MEM)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) IF(K50.EQ.0)THEN PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT)*dble(NFRONT-NCB)) ELSE PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT-NCB)*dble(NFRONT-NCB)) ENDIF PEAK=max(PEAK,TEMP(OTHERS)) SOMME=dble(0) DO i=1,NUMBER_OF_PROCS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(SOMME.LE.dble(TOTAL_MEM)) THEN GOTO 096 ENDIF 096 CONTINUE SOMME=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(dble(TOTAL_MEM).GE.SOMME) THEN AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,OTHERS IF(K50.EQ.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC IF(X.LE.0) THEN WRITE(*,*)"Internal Error 2 in & ZMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 111 IF(NCB.EQ.ACC) GOTO 111 ENDDO 111 CONTINUE IF((ACC.GT.NCB))THEN X=0 DO i=1,OTHERS X=X+NB_ROWS(i) ENDDO WRITE(*,*)'NCB=',NCB,',SOMME=',X WRITE(*,*)MYID, & ": Internal Error 3 in ZMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF IF((NCB.NE.ACC))THEN IF(K50.NE.0)THEN IF(CHOSEN.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+ADDITIONNAL_ROWS ELSE TMP_SUM=dble(TOTAL_MEM)/dble(NUMBER_OF_PROCS) CHOSEN=0 ACC=0 DO i=1,OTHERS X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 002 IF(NCB.EQ.ACC) GOTO 002 ENDDO 002 CONTINUE IF(ACC.LT.NCB)THEN NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+(NCB-ACC) ENDIF ENDIF GOTO 333 ENDIF ADDITIONNAL_ROWS=NCB-ACC DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 222 ENDIF ENDDO 222 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 333 CONTINUE IF(NB_ROWS(CHOSEN).EQ.0) CHOSEN=CHOSEN-1 GOTO 889 ELSE DO i=OTHERS,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(dble(TOTAL_MEM).GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i DO J=1,i IF(TEMP(J).EQ.TEMP(i)) THEN SMALL_SET=J GOTO 123 ENDIF ENDDO 123 CONTINUE IF(i.EQ.1)THEN NB_ROWS(i)=NCB CHOSEN=1 GOTO 666 ENDIF 323 CONTINUE AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 4 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 5 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ':Internal error 6 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LT.OTHERS)THEN SMALL_SET=REF+1 REF=SMALL_SET GOTO 323 ELSE NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+NCB-ACC GOTO 666 ENDIF ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 X=int(ADDITIONNAL_ROWS/(i-1)) IF((X.EQ.0).AND.(ADDITIONNAL_ROWS.NE.0))THEN DO WHILE ((J.LT.i).AND.(ADDITIONNAL_ROWS.GT.0)) NB_ROWS(J)=NB_ROWS(J)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 J=J+1 ENDDO IF(ADDITIONNAL_ROWS.NE.0)THEN WRITE(*,*)MYID, & ':Internal error 7 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF GOTO 047 ENDIF IF((TEMP(1)+dble((NB_ROWS(1)+X)*NFRONT)).LE. & TEMP(i))THEN DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=X IF((AFFECTED+NB_ROWS(J)).GT. & KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED J=J+1 ENDDO ELSE DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))*dble(NFRONT)))) & /dble(NFRONT)) IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO ENDIF i=i+1 ENDDO 047 CONTINUE IF((ADDITIONNAL_ROWS.EQ.0).AND. & (i.LT.NUMBER_OF_PROCS))THEN CHOSEN=i-1 ELSE CHOSEN=i-2 ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))* & dble(NFRONT))))/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO i=i+1 ENDDO CHOSEN=i-2 ENDIF CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN IF(K50.NE.0) THEN IF((TEMP(i)+dble(NB_ROWS(i)) & *dble(X+NB_ROWS(i)+NFRONT-NCB)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF IF(K50.EQ.0) THEN IF((TEMP(i)+dble(NB_ROWS(i))*dble(NFRONT)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO ENDIF 889 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN IF(X.EQ.1)THEN WRITE(*,*)MYID, & ':Internal error 12 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 DO i=1,CHOSEN SLAVES_LIST(i)=TEMP_ID(i) TAB_POS(i)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*) & 'Internal error 14 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*) & 'Internal error 15 in ZMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF END SUBROUTINE ZMUMPS_SET_PARTI_ACTV_MEM SUBROUTINE ZMUMPS_SET_PARTI_FLOP_IRR & (NCBSON_MAX,SLAVEF,KEEP,KEEP8, & PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID,INODE,MP,LP) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: MP,LP INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47,K48, K50,K83,K69 INTEGER(8) :: K821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM,DELTA,A,B,C,MASTER_WORK INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS,NELIM INTEGER(8) X8 LOGICAL FORCE_CAND,SMP DOUBLE PRECISION BANDE_K821 INTEGER NB_SAT,NB_ZERO DOUBLE PRECISION TEMP(SLAVEF),TOTAL_COST, MAX_MEM_ALLOW INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) INTEGER NSLAVES_REF,NCB_FILS EXTERNAL MPI_WTIME,MUMPS_GETKMIN INTEGER MUMPS_GETKMIN INTEGER POS_MIN_LOAD,SIZE_MY_SMP,WHAT,ADDITIONNAL_ROWS_SPECIAL LOGICAL HAVE_TYPE1_SON DOUBLE PRECISION MIN_LOAD,MAX_LOAD,TEMP_MAX_LOAD DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION BUF_SIZE,NELIM_MEM_SIZE DOUBLE PRECISION MEM_SIZE_STRONG(SLAVEF),MEM_SIZE_WEAK(SLAVEF) K821=abs(KEEP8(21)) TEMP_MAX_LOAD=dble(0) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) K83=KEEP(83) K69=0 NCB_FILS=NCBSON_MAX IF(int(NCB_FILS,8)*int(min(NCB,NCB_FILS),8).GT.K821)THEN HAVE_TYPE1_SON=.TRUE. ELSE HAVE_TYPE1_SON=.FALSE. ENDIF SMP=(K69.NE.0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF NELIM=NFRONT-NCB KMAX=int(K821/int(NCB,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=LOAD_FLOPS(PROCS(i)) IDWLOAD(i)=PROCS(i) WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = LOAD_FLOPS(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Negative load ', & WLOAD(i) ENDIF ENDIF WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF KMAX=int(NCB/OTHERS) KMIN=MUMPS_GETKMIN(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) IF(K50.EQ.0)THEN TOTAL_COST=dble( NELIM ) * dble ( NCB ) + & dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE TOTAL_COST=dble(NELIM) * dble ( NCB ) * & dble(NFRONT+1) ENDIF CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM,K50, & 2,MASTER_WORK) SOMME=dble(0) J=1 IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.GT.K83))THEN MASTER_WORK=dble(KEEP(88))*MASTER_WORK/dble(100) ENDIF IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.LE.K83))THEN MASTER_WORK=dble(KEEP(87))*MASTER_WORK/dble(100) ENDIF IF(MASTER_WORK.LT.dble(1))THEN MASTER_WORK=dble(1) ENDIF NSLAVES_REF=int(TOTAL_COST/MASTER_WORK)+1 IF(FORCE_CAND)THEN NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS) ELSE NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS-1) ENDIF DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_M2_FLOPS)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) SOMME=dble(0) TMP_SUM=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) TMP_SUM=TMP_SUM+TEMP(i) ENDDO TMP_SUM=(TMP_SUM/dble(OTHERS))+ & (TOTAL_COST/dble(OTHERS)) SIZE_MY_SMP=OTHERS MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 IF(.NOT.SMP) MAX_LOAD=TEMP(OTHERS) IF(SMP)THEN J=1 DO i=1,OTHERS IF(MEM_DISTRIB(TEMP_ID(i)).EQ.1)THEN IF(TEMP(i).LE.TMP_SUM)THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ELSE ENDIF ENDIF ENDDO MAX_LOAD=WLOAD(J-1) SIZE_MY_SMP=J-1 DO i=1,OTHERS IF((MEM_DISTRIB(TEMP_ID(i)).NE.1).OR. & ((MEM_DISTRIB(TEMP_ID(i)).EQ.1).AND. & (TEMP(i).GE.TMP_SUM)))THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ENDIF ENDDO TEMP=WLOAD TEMP_ID=IDWLOAD ENDIF IF(BDC_MD)THEN BUF_SIZE=dble(K821) IF (KEEP(201).EQ.2) THEN A=dble(int((dble(KEEP(100))/dble(2))/dble(NELIM))) IF(K50.EQ.0)THEN BUF_SIZE=min(BUF_SIZE,A*dble(NCB)) ELSE BUF_SIZE=min(BUF_SIZE,A*A) ENDIF ENDIF BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS A=dble(MD_MEM(TEMP_ID(i)))/ & dble(NELIM) A=A*dble(NFRONT) IF(K50.EQ.0)THEN B=dble(int(dble(NCB)/dble(NUMBER_OF_PROCS))+1)* & dble(NFRONT) ELSE WHAT = 5 CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) B=dble(X8)+(dble(J)*dble(NELIM)) ENDIF NELIM_MEM_SIZE=A+B MEM_SIZE_WEAK(i)=NELIM_MEM_SIZE IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF IF(min(MEM_SIZE_STRONG(i),MEM_SIZE_WEAK(i)).LT.dble(0))THEN IF(MEM_SIZE_STRONG(i).LT.0.0d0)THEN MEM_SIZE_STRONG(i)=dble(0) ELSE MEM_SIZE_WEAK(i)=dble(0) ENDIF ENDIF ENDDO ELSE BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF MEM_SIZE_STRONG(i)=max(dble(0),MEM_SIZE_STRONG(i)) MEM_SIZE_WEAK(i)=huge(MEM_SIZE_WEAK(i)) ENDDO ENDIF IF((((NUMBER_OF_PROCS.LE.K83).AND.FORCE_CAND).AND. & (TOTAL_COST.GE.SOMME)).OR. & (.NOT.FORCE_CAND).OR. & (((NUMBER_OF_PROCS+1).GT.K83).AND.FORCE_CAND))THEN REF=NSLAVES_REF SMALL_SET=NSLAVES_REF IF(.NOT.SMP)THEN DO i=NSLAVES_REF,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(TOTAL_COST.GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) 450 CONTINUE SOMME=dble(0) DO J=1,X SOMME=SOMME+(TEMP(X)-TEMP(J)) ENDDO IF(SOMME.GT.TOTAL_COST)THEN X=X-1 GOTO 450 ELSE IF(X.LT.SIZE_MY_SMP) THEN REF=X SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) J=X+1 MAX_LOAD=TEMP(X) TMP_SUM=MAX_LOAD DO i=X+1,OTHERS IF(TEMP(i).GT.MAX_LOAD)THEN SOMME=SOMME+(dble(i-1)*(TEMP(i)-MAX_LOAD)) TMP_SUM=MAX_LOAD MAX_LOAD=TEMP(i) ELSE SOMME=SOMME+(MAX_LOAD-TEMP(i)) ENDIF IF(i.EQ.NSLAVES_REF)THEN SMALL_SET=NSLAVES_REF REF=SMALL_SET GOTO 323 ENDIF IF(SOMME.GT.TOTAL_COST)THEN REF=i-1 SMALL_SET=i-1 MAX_LOAD=TMP_SUM GOTO 323 ENDIF ENDDO ENDIF ENDIF ENDIF 323 CONTINUE MAX_LOAD=dble(0) DO i=1,SMALL_SET MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO TEMP_MAX_LOAD=MAX_LOAD NB_ROWS=0 TMP_SUM=dble(0) CHOSEN=0 ACC=0 NB_SAT=0 NB_ZERO=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) X=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 1 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF TMP_SUM=MAX_LOAD IF(K50.EQ.0)THEN MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM)* & dble(2*NFRONT-NELIM-1)))) ELSE MAX_LOAD=max(MAX_LOAD, & TEMP(i)+(dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ACC)-NB_ROWS(i) & -NELIM+1)) ENDIF IF(TMP_SUM.LT.MAX_LOAD)THEN ENDIF IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 2 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ': Internal error 3 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LE.OTHERS)THEN IF((NB_SAT.EQ.SMALL_SET).AND.(SMALL_SET.LT. & NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ADDITIONNAL_ROWS_SPECIAL=NCB-ACC DO i=1,SMALL_SET MAX_LOAD=TEMP_MAX_LOAD ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS-NELIM & +1) SOMME=SOMME/dble(SMALL_SET-NB_SAT) NB_ROWS=0 NB_ZERO=0 ACC=0 CHOSEN=0 NB_SAT=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO J=1,SMALL_SET A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=(dble(NELIM)*dble(NELIM+2*ACC+1)) C=-(MAX_LOAD-TEMP(J)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) X=X+1 IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 4 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE NB_ZERO=NB_ZERO+1 X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN NB_ZERO=NB_ZERO+1 X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X TMP_SUM=MAX_LOAD TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(J)+(dble(NELIM) * & dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(NCB.EQ.ACC) GOTO 666 ENDDO IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF(NB_ZERO.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF((NB_SAT+NB_ZERO).EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF ENDDO 434 CONTINUE ADDITIONNAL_ROWS=NCB-ACC IF(ADDITIONNAL_ROWS.NE.0)THEN IF(ADDITIONNAL_ROWS.LT.KMIN)THEN i=CHOSEN J=ACC 436 CONTINUE IF(NB_ROWS(i).NE.0)THEN J=J-NB_ROWS(i) A=dble(1) B=dble(J+2) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(J+2+NELIM) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(J+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(NB_ROWS(i).NE.KMAX)THEN IF(NCB-J.LE.KMAX)THEN NB_ROWS(i)=+NCB-J ADDITIONNAL_ROWS=0 ENDIF ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(i)+ & (dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(i) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF ELSE i=i-1 IF(i.NE.0)GOTO 436 ENDIF IF(ADDITIONNAL_ROWS.NE.0)THEN i=CHOSEN IF(i.NE.SMALL_SET)THEN i=i+1 IF(NB_ROWS(i).NE.0)THEN WRITE(*,*)MYID, & ': Internal error 5 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF CHOSEN=i ENDIF ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X ACC=ACC+X ADDITIONNAL_ROWS=NCB-ACC ELSE IF((TEMP(i).GT.MAX_LOAD))THEN MAX_LOAD=TEMP(i) NB_SAT=0 ACC=0 NB_ROWS=0 DO J=1,i A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(J)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 6 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF ACC=ACC+X MAX_LOAD=max(MAX_LOAD, & TEMP(J)+ & (dble(NELIM)*dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(NCB.EQ.ACC) GOTO 741 IF(NCB-ACC.LT.KMIN) GOTO 210 ENDDO 210 CONTINUE ENDIF 741 CONTINUE i=i+1 ADDITIONNAL_ROWS=NCB-ACC ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)*dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 7 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=min(KMAX,KMIN) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 488 ENDDO 488 CONTINUE ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 8 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=KMIN ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 477 ENDDO 477 CONTINUE IF(ACC.NE.NCB)THEN NB_SAT=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN NB_SAT=NB_SAT+1 ENDIF ACC=ACC+NB_ROWS(i) IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 834 ENDDO 834 CONTINUE ENDIF IF(ACC.NE.NCB)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS-NB_SAT) ACC=0 DO i=1,CHOSEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN GOTO 102 ENDIF A=dble(NELIM) B=dble(NELIM)* & dble(NELIM+2*(ACC+NB_ROWS(i))+1) C=-(SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(1) B=dble(ACC+NELIM) C=dble(-BANDE_K821) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 9 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC+X+NB_ROWS(i)).GT.NCB)THEN IF((NCB-ACC).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NCB-ACC ENDIF ELSE IF((NB_ROWS(i)+X).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+X ENDIF ENDIF 102 CONTINUE ACC=ACC+NB_ROWS(i) IF(NCB.EQ.ACC) THEN CHOSEN=i GOTO 666 ENDIF IF(NCB-ACC.LT.KMIN) THEN CHOSEN=i GOTO 007 ENDIF ENDDO 007 CONTINUE DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ACC=ACC+1 IF(ACC.EQ.NCB)GOTO 666 ENDDO IF(ACC.LT.NCB)THEN IF(SMP)THEN NB_ROWS(1)=NB_ROWS(1)+NCB-ACC ELSE NB_ROWS(POS_MIN_LOAD)= & NB_ROWS(POS_MIN_LOAD)+NCB-ACC ENDIF ENDIF ENDIF GOTO 666 ENDIF ENDIF GOTO 666 ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 IF(NB_SAT.EQ.SMALL_SET) GOTO 777 DO i=1,SMALL_SET IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & (dble(NFRONT+1))) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF WLOAD(i)=MAX_MEM_ALLOW ENDDO CALL MUMPS_SORT_DOUBLES(SMALL_SET, WLOAD, IDWLOAD) NB_ZERO=0 IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LT.NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LE.NUMBER_OF_PROCS))GOTO 777 AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) DO i=1,SMALL_SET KMAX=int(WLOAD(i)/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN GOTO 912 ENDIF IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GT.KMAX)THEN IF(NB_ROWS(IDWLOAD(i)).GT.KMAX)THEN ENDIF ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX NB_SAT=NB_SAT+1 IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.NE.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM) * & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))* & dble(NELIM))* & dble(2*NFRONT-NELIM-1))) GOTO 777 ENDIF ENDIF AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) ELSE IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GE.KMIN)THEN X=min(AFFECTED,ADDITIONNAL_ROWS) NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE X=int((MAX_LOAD-TEMP(IDWLOAD(i)))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X+AFFECTED.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ELSE X=AFFECTED+X ENDIF IF(X.GE.KMIN)THEN NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & X ELSE NB_ZERO=NB_ZERO+1 ENDIF ENDIF ENDIF 912 CONTINUE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM)* & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(SMALL_SET.LT.NUMBER_OF_PROCS)THEN IF(MAX_LOAD.GT.TEMP(SMALL_SET+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(SMALL_SET.EQ.NB_SAT)GOTO 777 IF(ADDITIONNAL_ROWS.EQ.0)THEN CHOSEN=SMALL_SET GOTO 049 ENDIF ENDDO 777 CONTINUE IF((NB_ZERO.NE.0).AND.(ADDITIONNAL_ROWS.GE.KMIN))THEN J=NB_ZERO 732 CONTINUE X=int(ADDITIONNAL_ROWS/(J)) IF(X.LT.KMIN)THEN J=J-1 GOTO 732 ENDIF IF(X*J.LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,SMALL_SET AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(i).EQ.0)THEN IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(X.GT.KMAX)THEN X=KMAX ENDIF IF(X.GT.KMIN)THEN NB_ROWS(i)=X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) ENDIF ENDIF ENDDO ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) AFFECTED=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF ELSE IF((TEMP(i).GT.MAX_LOAD))THEN IF(NB_SAT.EQ.i-1) GOTO 218 X=(ADDITIONNAL_ROWS/(i-1-NB_SAT)) ACC=1 DO J=1,i-1 TMP_SUM=((dble(NELIM) * dble(NB_ROWS(J)+X)) & +(dble(NB_ROWS(J)+X)*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) IF((TEMP(J)+TMP_SUM).GT.MAX_LOAD)THEN ACC=0 ENDIF ENDDO IF(ACC.EQ.1)THEN MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ELSE MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF TMP_SUM=((dble(NELIM)* dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 10 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ENDIF ENDIF 218 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN IF(NB_ROWS(i)+1.GE.KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 ENDIF MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((ADDITIONNAL_ROWS.NE.0))THEN IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN i=CHOSEN+1 ELSE IF(CHOSEN.NE.NUMBER_OF_PROCS)THEN WRITE(*,*)MYID, & ': Internal error 11 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF i=CHOSEN ENDIF DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(TEMP(i).LE.MAX_LOAD)THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) AFFECTED=X IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 12 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF IF(i.NE.NUMBER_OF_PROCS) GOTO 624 ELSE IF((TEMP(i).GT.MAX_LOAD))THEN X=int(ADDITIONNAL_ROWS/i-1) X=max(X,1) IF((MAX_LOAD+((dble(NELIM)* & dble(X))+(dble( & X)*dble(NELIM))*dble( & (2*NFRONT-NELIM-1)))).LE.TEMP(i))THEN AFFECTED=X POS=1 ELSE POS=0 ENDIF MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) MAX_MEM_ALLOW=BANDE_K821 IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(POS.EQ.0)THEN TMP_SUM=((dble(NELIM) * & dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((TEMP(i)-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT- & NELIM))) ELSE X=int(TMP_SUM) ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((X+NB_ROWS(J)).GT.KMAX)THEN X=KMAX-NB_ROWS(J) ELSE IF((NB_ROWS(J)+X).LT. & KMIN)THEN X=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF J=J+1 ENDDO ENDIF 624 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ACC=0 DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 13 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((X+NB_ROWS(i)).GE.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF((X+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ACC=ACC+1 ELSE ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN CHOSEN=CHOSEN+1 ENDIF IF(ACC.EQ.0)THEN ACC=1 ENDIF X=int(ADDITIONNAL_ROWS/ACC) X=max(X,1) ACC=0 DO i=1,CHOSEN J=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(J)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN J=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(J)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) J=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).LT.KMAX)THEN IF((min(X,J)+NB_ROWS(i)).GE.KMAX)THEN IF((KMAX-NB_ROWS(i)).GT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ENDIF ELSE IF((min(X,J)+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+min(X,J) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & min(X,J) ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(ACC.GT.0)THEN DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT. & ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF(NB_ROWS(i).EQ.0)THEN IF(min(KMIN,KMAX).LT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=min(KMIN,KMAX) ADDITIONNAL_ROWS= & ADDITIONNAL_ROWS- & min(KMIN,KMAX) ENDIF ELSE NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO ENDIF DO i=1,CHOSEN IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-dble(NB_ROWS(i)*NFRONT)) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 049 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO i=1,CHOSEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(i)=NB_ROWS(i)+X IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 049 CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO GOTO 890 ELSE IF((KEEP(83).GE.NUMBER_OF_PROCS).AND.FORCE_CAND)THEN MAX_LOAD=dble(0) DO i=1,OTHERS MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO ACC=0 CHOSEN=0 X=1 DO i=1,OTHERS ENDDO DO i=2,OTHERS IF(TEMP(i).EQ.TEMP(1))THEN X=X+1 ELSE GOTO 329 ENDIF ENDDO 329 CONTINUE TMP_SUM=TOTAL_COST/dble(X) TEMP_MAX_LOAD=dble(0) DO i=1,OTHERS IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i))) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN SOMME=MAX_LOAD-TEMP(i) ELSE SOMME=TMP_SUM ENDIF X=int(SOMME/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GT.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=min(KMIN,KMAX) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN C=-(MAX_LOAD-TEMP(i)) ELSE C=-TMP_SUM ENDIF DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 14 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GT.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LE.min(KMIN,KMAX))THEN IF(KMAX.LT.KMIN)THEN X=0 ELSE X=min(KMIN,KMAX) ENDIF ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD,TEMP(i)) NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(ACC.EQ.NCB) GOTO 541 ENDDO 541 CONTINUE IF(ACC.LT.NCB)THEN IF(K50.EQ.0)THEN ADDITIONNAL_ROWS=NCB-ACC DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)).LT.KMAX)THEN IF(ADDITIONNAL_ROWS.GT.(KMAX-NB_ROWS(J)))THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(J)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)+X).GT.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(J)=NB_ROWS(J)+X ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,NUMBER_OF_PROCS IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-(dble(NB_ROWS(i))* & dble(NFRONT))) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 889 ENDDO GOTO 994 ELSE ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC ENDIF ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC 994 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(OTHERS)) IF((X*OTHERS).LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,OTHERS NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X IF(ADDITIONNAL_ROWS.LT.X)X=ADDITIONNAL_ROWS ENDDO CHOSEN=OTHERS ENDIF ENDIF 889 CONTINUE MAX_LOAD=TEMP_MAX_LOAD 890 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*)MYID, & ': Internal error 15 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 X=1 DO i=1,J IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(X)=TEMP_ID(i) TAB_POS(X)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*)MYID, & ': Internal error 16 in ZMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in ZMUMPS_SET_PARTI_FLOP_IRR', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE ZMUMPS_SET_PARTI_FLOP_IRR SUBROUTINE ZMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(KEEP(28)), POOL(LPOOL), PROCNODE(KEEP(28)) LOGICAL UPPER INTEGER J DOUBLE PRECISION MEM_COST INTEGER NBINSUBTREE,i,NBTOP EXTERNAL ZMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR LOGICAL ZMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'ZMUMPS_LOAD_POOL_CHECK_MEM must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=ZMUMPS_LOAD_GET_MEM(INODE) IF((DM_MEM(MYID)+dble(MEM_COST)+ PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL) & .GT.MAX_PEAK_STK)THEN DO i=NBTOP-1,1,-1 INODE = POOL( LPOOL - 2 - i) MEM_COST=ZMUMPS_LOAD_GET_MEM(INODE) IF((INODE.LT.0).OR.(INODE.GT.N)) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF IF((DM_MEM(MYID)+dble(MEM_COST)+PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL).LE. & MAX_PEAK_STK) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF ENDDO IF(NBINSUBTREE.NE.0)THEN INODE = POOL( NBINSUBTREE ) IF(.NOT.MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*) & 'Internal error 1 in ZMUMPS_LOAD_POOL_CHECK_MEM' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE ZMUMPS_LOAD_POOL_CHECK_MEM SUBROUTINE ZMUMPS_LOAD_SET_SBTR_MEM(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'ZMUMPS_LOAD_SET_SBTR_MEM & should be called when K81>0 and K47>2' ENDIF IF(WHAT)THEN PEAK_SBTR_CUR_LOCAL=PEAK_SBTR_CUR_LOCAL+ & dble(MEM_SUBTREE(INDICE_SBTR)) IF(.NOT.BDC_SBTR) INDICE_SBTR=INDICE_SBTR+1 ELSE PEAK_SBTR_CUR_LOCAL=dble(0) SBTR_CUR_LOCAL=dble(0) ENDIF END SUBROUTINE ZMUMPS_LOAD_SET_SBTR_MEM DOUBLE PRECISION FUNCTION ZMUMPS_LOAD_GET_MEM( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFR = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) IF (LEVEL .EQ. 1) THEN COST = dble(NFR) * dble(NFR) ELSE IF ( K50 == 0 ) THEN COST = dble(NFR) * dble(NELIM) ELSE COST = dble(NELIM) * dble(NELIM) ENDIF ENDIF ZMUMPS_LOAD_GET_MEM=COST RETURN END FUNCTION ZMUMPS_LOAD_GET_MEM RECURSIVE SUBROUTINE ZMUMPS_NEXT_NODE(FLAG,COST,COMM) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG, EXIT_FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF(FLAG)THEN WHAT=17 IF(BDC_M2_FLOPS)THEN TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) ELSE IF(BDC_M2_MEM)THEN IF(BDC_POOL.AND.(.NOT.BDC_MD))THEN TO_BE_SENT=max(TMP_M2,POOL_LAST_COST_SENT) POOL_LAST_COST_SENT=TO_BE_SENT ELSE IF(BDC_MD)THEN DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM ELSE TO_BE_SENT=dble(0) ENDIF ENDIF ELSE WHAT=6 TO_BE_SENT=dble(0) ENDIF 111 CONTINUE CALL ZMUMPS_BUF_BROADCAST( WHAT, & COMM, NPROCS, & FUTURE_NIV2, & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_NEXT_NODE SUBROUTINE ZMUMPS_UPPER_PREDICT(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE ZMUMPS_BUF IMPLICIT NONE INTEGER INODE,NSTEPS,MYID,SLAVEF,COMM,N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE(NSTEPS),NE(NSTEPS),STEP(N),PROCNODE(NSTEPS) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_PROCNODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER i,NCB,NELIM INTEGER MUMPS_PROCNODE INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE LOGICAL :: EXIT_FLAG IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in ZMUMPS_UPPER_PREDICT' CALL MUMPS_ABORT() ENDIF IF((INODE.LT.0).OR.(INODE.GT.N)) THEN RETURN ENDIF i=INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NCB=ND_LOAD(STEP_LOAD(INODE))-NELIM + KEEP_LOAD(253) WHAT=5 FATHER_NODE=DAD_LOAD(STEP_LOAD(INODE)) IF (FATHER_NODE.EQ.0) THEN RETURN ENDIF IF((FRERE(STEP(FATHER_NODE)).EQ.0).AND. & ((FATHER_NODE.EQ.KEEP(38)).OR. & (FATHER_NODE.EQ.KEEP(20))))THEN RETURN ENDIF IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(FATHER_NODE)), & KEEP(199))) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),KEEP(199)) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL ZMUMPS_PROCESS_NIV2_MEM_MSG(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL ZMUMPS_PROCESS_NIV2_FLOPS_MSG(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)).EQ.1)THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MYID,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB,8)*int(NCB,8) POS_MEM=POS_MEM+1 ENDIF ENDIF GOTO 666 ENDIF 111 CONTINUE CALL ZMUMPS_BUF_SEND_FILS(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP,MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 666 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in ZMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE RETURN END SUBROUTINE ZMUMPS_UPPER_PREDICT SUBROUTINE ZMUMPS_REMOVE_NODE(INODE,NUM_CALL) IMPLICIT NONE DOUBLE PRECISION MAXI INTEGER i,J,IND_MAXI INTEGER INODE,NUM_CALL IF(BDC_M2_MEM)THEN IF(((NUM_CALL.EQ.1).AND.(BDC_MD)).OR. & ((NUM_CALL.EQ.2).AND.(.NOT.BDC_MD)))THEN RETURN ENDIF ENDIF IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0).AND. & ((INODE.EQ.KEEP_LOAD(38)).OR. & (INODE.EQ.KEEP_LOAD(20)))) THEN RETURN ENDIF DO i=POOL_SIZE,1,-1 IF(POOL_NIV2(i).EQ.INODE) GOTO 666 ENDDO NB_SON(STEP_LOAD(INODE))=-1 RETURN 666 CONTINUE IF(BDC_M2_MEM)THEN IF(POOL_NIV2_COST(i).EQ.MAX_M2)THEN TMP_M2=MAX_M2 MAXI=dble(0) IND_MAXI=-9999 DO J=POOL_SIZE,1,-1 IF(J.NE.i) THEN IF(POOL_NIV2_COST(J).GT.MAXI)THEN MAXI=POOL_NIV2_COST(J) IND_MAXI=J ENDIF ENDIF ENDDO MAX_M2=MAXI J=IND_MAXI REMOVE_NODE_FLAG_MEM=.TRUE. REMOVE_NODE_COST_MEM=TMP_M2 CALL ZMUMPS_NEXT_NODE(REMOVE_NODE_FLAG,MAX_M2,COMM_LD) NIV2(MYID+1)=MAX_M2 ENDIF ELSEIF(BDC_M2_FLOPS)THEN REMOVE_NODE_COST=POOL_NIV2_COST(i) REMOVE_NODE_FLAG=.TRUE. CALL ZMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & -POOL_NIV2_COST(i),COMM_LD) NIV2(MYID+1)=NIV2(MYID+1)-POOL_NIV2_COST(i) ENDIF DO J=i+1,POOL_SIZE POOL_NIV2(J-1)=POOL_NIV2(J) POOL_NIV2_COST(J-1)=POOL_NIV2_COST(J) ENDDO POOL_SIZE=POOL_SIZE-1 END SUBROUTINE ZMUMPS_REMOVE_NODE RECURSIVE SUBROUTINE ZMUMPS_PROCESS_NIV2_MEM_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in ZMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &ZMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & ZMUMPS_LOAD_GET_MEM(INODE) POOL_SIZE=POOL_SIZE+1 IF(POOL_NIV2_COST(POOL_SIZE).GT.MAX_M2)THEN MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL ZMUMPS_NEXT_NODE(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_NIV2_MEM_MSG RECURSIVE SUBROUTINE ZMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in ZMUMPS_PROCESS_NIV2_FLOPS_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &ZMUMPS_PROCESS_NIV2_FLOPS_MSG',POOL_NIV2_SIZE, & POOL_SIZE CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & ZMUMPS_LOAD_GET_FLOPS_COST(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL ZMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & POOL_NIV2_COST(POOL_SIZE), & COMM_LD) NIV2(MYID+1)=POOL_NIV2_COST(POOL_SIZE)+NIV2(MYID+1) ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_NIV2_FLOPS_MSG DOUBLE PRECISION FUNCTION ZMUMPS_LOAD_GET_FLOPS_COST(INODE) USE MUMPS_FUTURE_NIV2 INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION COST i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFRONT = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) COST=dble(0) CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) ZMUMPS_LOAD_GET_FLOPS_COST=COST RETURN END FUNCTION ZMUMPS_LOAD_GET_FLOPS_COST INTEGER FUNCTION ZMUMPS_LOAD_GET_CB_FREED( INODE ) IMPLICIT NONE INTEGER INODE,NELIM,NFR,SON,IN,i INTEGER COST_CB COST_CB=0 i = INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i DO i=1, NE_LOAD(STEP_LOAD(INODE)) NFR = ND_LOAD( STEP_LOAD(SON) ) + KEEP_LOAD(253) IN=SON NELIM = 0 20 CONTINUE IF ( IN > 0 ) THEN NELIM = NELIM + 1 IN = FILS_LOAD(IN) GOTO 20 ENDIF COST_CB=COST_CB+((NFR-NELIM)*(NFR-NELIM)) SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO ZMUMPS_LOAD_GET_CB_FREED=COST_CB RETURN END FUNCTION ZMUMPS_LOAD_GET_CB_FREED SUBROUTINE ZMUMPS_LOAD_SEND_MD_INFO(SLAVEF,NMB_OF_CAND, & LIST_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE ZMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_OF_CAND(NMB_OF_CAND) INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES(NSLAVES) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: DELTA_MD INTEGER, DIMENSION(:), ALLOCATABLE :: IPROC2POSINDELTAMD INTEGER, DIMENSION(:), ALLOCATABLE :: P_TO_UPDATE INTEGER NBROWS_SLAVE,i,WHAT,IERR INTEGER :: NP_TO_UPDATE, K LOGICAL FORCE_CAND LOGICAL :: EXIT_FLAG MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF CALL ZMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NMB_OF_CAND,NASS) ALLOCATE(IPROC2POSINDELTAMD(0:SLAVEF-1), & DELTA_MD(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & P_TO_UPDATE(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) "PB ALLOC IN ZMUMPS_LOAD_SEND_MD_INFO", & SLAVEF, NMB_OF_CAND, NSLAVES CALL MUMPS_ABORT() ENDIF IPROC2POSINDELTAMD = -99 NP_TO_UPDATE = 0 DO i = 1, NSLAVES NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_SLAVES(i)) = NP_TO_UPDATE NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD(NP_TO_UPDATE)=-dble(NBROWS_SLAVE)* & dble(NASS) P_TO_UPDATE(NP_TO_UPDATE) = LIST_SLAVES(i) ENDDO DO i = 1, NMB_OF_CAND K = IPROC2POSINDELTAMD(LIST_OF_CAND(i)) IF ( K > 0 ) THEN DELTA_MD(K)=DELTA_MD(K)+FCT_COST ELSE NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_OF_CAND(i)) = NP_TO_UPDATE DELTA_MD (NP_TO_UPDATE) = FCT_COST P_TO_UPDATE(NP_TO_UPDATE) = LIST_OF_CAND(i) ENDIF ENDDO WHAT=7 111 CONTINUE CALL ZMUMPS_BUF_BCAST_ARRAY(.FALSE., COMM_LD, MYID, SLAVEF, & FUTURE_NIV2, & NP_TO_UPDATE, P_TO_UPDATE,0, & DELTA_MD, & DELTA_MD, & DELTA_MD, & WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in ZMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF ENDDO ENDIF 100 CONTINUE DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) RETURN END SUBROUTINE ZMUMPS_LOAD_SEND_MD_INFO SUBROUTINE ZMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NSLAVES,NELIM) IMPLICIT NONE INTEGER INODE,NSLAVES,NFR,NELIM,IN DOUBLE PRECISION MEM_COST,FCT_COST NFR=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) IN = INODE FCT_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NELIM) MEM_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NFR) END SUBROUTINE ZMUMPS_LOAD_GET_ESTIM_MEM_COST SUBROUTINE ZMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN RETURN ENDIF IF(POS_ID.GT.1)THEN i=INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i IF(POS_ID.LT.NE_LOAD(STEP_LOAD(INODE))*3)THEN i=1 ENDIF DO i=1, NE_LOAD(STEP_LOAD(INODE)) J=1 DO WHILE (J.LT.POS_ID) IF(CB_COST_ID(J).EQ.SON)GOTO 295 J=J+3 ENDDO 295 CONTINUE IF(J.GE.POS_ID)THEN IF ( MUMPS_PROCNODE( & PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) .EQ. MYID ) THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 ENDIF ELSE GOTO 666 ENDIF ENDIF NSLAVES_TEMP=CB_COST_ID(J+1) POS_TEMP=CB_COST_ID(J+2) DO K=J,POS_ID-1 CB_COST_ID(K)=CB_COST_ID(K+3) ENDDO K=POS_TEMP DO WHILE (K.LE.POS_MEM-1) CB_COST_MEM(K)=CB_COST_MEM(K+2*NSLAVES_TEMP) K=K+1 ENDDO POS_MEM=POS_MEM-2*NSLAVES_TEMP POS_ID=POS_ID-3 IF((POS_MEM.LT.1).OR.(POS_ID.LT.1))THEN WRITE(*,*)MYID,': negative pos_mem or pos_id' CALL MUMPS_ABORT() ENDIF 666 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO ENDIF END SUBROUTINE ZMUMPS_LOAD_CLEAN_MEMINFO_POOL SUBROUTINE ZMUMPS_LOAD_CHK_MEMCST_POOL(FLAG) IMPLICIT NONE LOGICAL FLAG INTEGER i DOUBLE PRECISION MEM FLAG=.FALSE. DO i=0,NPROCS-1 MEM=DM_MEM(i)+LU_USAGE(i) IF(BDC_SBTR)THEN MEM=MEM+SBTR_MEM(i)-SBTR_CUR(i) ENDIF IF((MEM/dble(TAB_MAXS(i))).GT.0.8d0)THEN FLAG=.TRUE. GOTO 666 ENDIF ENDDO 666 CONTINUE END SUBROUTINE ZMUMPS_LOAD_CHK_MEMCST_POOL SUBROUTINE ZMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IMPLICIT NONE INTEGER NBINSUBTREE,INSUBTREE,NBTOP DOUBLE PRECISION MIN_COST LOGICAL SBTR INTEGER i DOUBLE PRECISION TMP_COST,TMP_MIN TMP_MIN=huge(TMP_MIN) DO i=0,NPROCS-1 IF(i.NE.MYID)THEN IF(BDC_SBTR)THEN TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i))-(SBTR_MEM(i)-SBTR_CUR(i))) ELSE TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))- & (DM_MEM(i)+LU_USAGE(i))) ENDIF ENDIF ENDDO IF(NBINSUBTREE.GT.0)THEN IF(INSUBTREE.EQ.1)THEN TMP_COST=dble(TAB_MAXS(MYID))-(DM_MEM(MYID)+ & LU_USAGE(MYID)) & -(SBTR_MEM(MYID)-SBTR_CUR(MYID)) ELSE SBTR=.FALSE. GOTO 777 ENDIF ENDIF TMP_MIN=min(TMP_COST,TMP_MIN) IF(TMP_MIN.GT.MIN_COST) SBTR=.TRUE. 777 CONTINUE END SUBROUTINE ZMUMPS_CHECK_SBTR_COST SUBROUTINE ZMUMPS_LOAD_COMP_MAXMEM_POOL(INODE,MAX_MEM,PROC) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION MAX_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_ON_PROCS, & RECV_BUF LOGICAL, DIMENSION(:), ALLOCATABLE :: CONCERNED DOUBLE PRECISION MAX_SENT_MSG IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF ALLOCATE( MEM_ON_PROCS(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in ZMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF RECV_BUF=dble(0) MAX_SENT_MSG=dble(0) i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i NFRONT=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) NCB=NFRONT-NELIM IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN NCAND=CAND_LOAD(NPROCS+1, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) ENDIF DO i=0,NPROCS-1 IF(i.EQ.MYID)THEN MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i)+ & ZMUMPS_LOAD_GET_MEM(INODE)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF CONCERNED(i)=.TRUE. ELSE MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF IF(BDC_M2_MEM)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-NIV2(i+1) ENDIF ENDIF IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN IF(BDC_MD.AND.(KEEP_LOAD(48).EQ.5))THEN DO J=1,NCAND IF(CAND_LOAD(J, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) & .EQ.i)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)- & ((dble(NFRONT)*dble(NCB))/dble(NCAND)) CONCERNED(i)=.TRUE. GOTO 666 ENDIF ENDDO ENDIF ENDIF 666 CONTINUE ENDDO DO K=1, NE_LOAD(STEP_LOAD(INODE)) i=1 DO WHILE (i.LE.POS_ID) IF(CB_COST_ID(i).EQ.SON)GOTO 295 i=i+3 ENDDO 295 CONTINUE IF(i.GE.POS_ID)THEN IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': ',SON,'has not been found & in ZMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF GOTO 777 ENDIF NSLAVES=CB_COST_ID(i+1) POS=CB_COST_ID(i+2) DO i=1,NSLAVES SLAVE=int(CB_COST_MEM(POS)) IF(.NOT.CONCERNED(SLAVE))THEN MEM_ON_PROCS(SLAVE)=MEM_ON_PROCS(SLAVE)+ & dble(CB_COST_MEM(POS+1)) ENDIF DO J=0,NPROCS-1 IF(CONCERNED(J))THEN IF(SLAVE.NE.J)THEN RECV_BUF(J)=max(RECV_BUF(J), & dble(CB_COST_MEM(POS+1))) ENDIF ENDIF ENDDO POS=POS+2 ENDDO 777 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO MAX_MEM=huge(MAX_MEM) WRITE(*,*)'NPROCS=',NPROCS,MAX_MEM DO i=0,NPROCS-1 IF(MAX_MEM.GT.MEM_ON_PROCS(i))THEN PROC=i ENDIF MAX_MEM=min(MEM_ON_PROCS(i),MAX_MEM) ENDDO DEALLOCATE(MEM_ON_PROCS) DEALLOCATE(CONCERNED) DEALLOCATE(RECV_BUF) END SUBROUTINE ZMUMPS_LOAD_COMP_MAXMEM_POOL SUBROUTINE ZMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER i,NBTOP,INSUBTREE,NBINSUBTREE,NODE,FATHER,SON,J INTEGER SBTR_NB_LEAF,POS,K,allocok,L INTEGER, ALLOCATABLE, DIMENSION (:) :: TMP_SBTR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF((KEEP_LOAD(47).EQ.4).AND. & ((NBINSUBTREE.NE.0)))THEN DO J=INDICE_SBTR,NB_SUBTREES NODE=MY_ROOT_SBTR(J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 110 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 110 ENDIF SON=-i i=SON 120 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN SBTR_NB_LEAF=MY_NB_LEAF(J) POS=SBTR_FIRST_POS_IN_POOL(J) IF(POOL(POS+SBTR_NB_LEAF).NE.MY_FIRST_LEAF(J))THEN WRITE(*,*)MYID,': The first leaf is not ok' CALL MUMPS_ABORT() ENDIF ALLOCATE (TMP_SBTR(SBTR_NB_LEAF), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*)MYID,': Not enough space & for allocation' CALL MUMPS_ABORT() ENDIF POS=SBTR_FIRST_POS_IN_POOL(J) DO K=1,SBTR_NB_LEAF TMP_SBTR(K)=POOL(POS+K-1) ENDDO DO K=POS+1,NBINSUBTREE-SBTR_NB_LEAF POOL(K)=POOL(K+SBTR_NB_LEAF) ENDDO POS=1 DO K=NBINSUBTREE-SBTR_NB_LEAF+1,NBINSUBTREE POOL(K)=TMP_SBTR(POS) POS=POS+1 ENDDO DO K=INDICE_SBTR,J SBTR_FIRST_POS_IN_POOL(K)=SBTR_FIRST_POS_IN_POOL(K) & -SBTR_FIRST_POS_IN_POOL(J) ENDDO SBTR_FIRST_POS_IN_POOL(J)=NBINSUBTREE-SBTR_NB_LEAF POS=MY_FIRST_LEAF(J) L=MY_NB_LEAF(J) DO K=INDICE_SBTR,J MY_FIRST_LEAF(J)=MY_FIRST_LEAF(J+1) MY_NB_LEAF(J)=MY_NB_LEAF(J+1) ENDDO MY_FIRST_LEAF(INDICE_SBTR)=POS MY_NB_LEAF(INDICE_SBTR)=L INODE=POOL(NBINSUBTREE) DEALLOCATE(TMP_SBTR) RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 120 ENDIF ENDDO ENDIF DO J=NBTOP,1,-1 NODE=POOL(LPOOL-2-J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 11 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 11 ENDIF SON=-i i=SON 12 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN INODE=NODE RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 12 ENDIF ENDDO END SUBROUTINE ZMUMPS_FIND_BEST_NODE_FOR_MEM SUBROUTINE ZMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_ROOTSSARBR LOGICAL MUMPS_ROOTSSARBR IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_ROOTSSARBR( & PROCNODE_LOAD(STEP_LOAD(POOL(POS+1))), & KEEP(199))) POS=POS+1 ENDDO SBTR_FIRST_POS_IN_POOL(i)=POS+1 POS=POS+MY_NB_LEAF(i) ENDDO END SUBROUTINE ZMUMPS_LOAD_INIT_SBTR_STRUCT END MODULE ZMUMPS_LOAD SUBROUTINE ZMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & PROCS, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1) INTEGER, intent(in) :: SUP_PROC_ARG(2) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX INTEGER(8), intent(out):: MAX_SURF LOGICAL :: FORCE_LDLTRegular_NIV2 INTEGER NSLAVES,ACC INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1)) INTEGER TMP_NROW,X,K LOGICAL SUP,MEM_CSTR DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA, & LOAD_CORR INTEGER IDWLOAD(SLAVEF) INTEGER(8) MEM_CONSTRAINT(2) K50=KEEP(50) FORCE_LDLTRegular_NIV2 = .FALSE. MAX_SURF=0 NB_ROW_MAX=0 NELIM=NFRONT-NCB NB_SUP=0 TOTAL_LOAD=0.0D0 SUP=.FALSE. IF(SUP_PROC_ARG(1).NE. & 0)THEN MEM_CONSTRAINT(1)=TAB_MAXS_ARG(PROCS(1)) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(1))/100.0D0 NB_SUP=NB_SUP+1 ENDIF IF(SUP_PROC_ARG(2).NE. & 0)THEN MEM_CONSTRAINT(2)=TAB_MAXS_ARG(PROCS(PROCS(SLAVEF+1))) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(2))/100.0D0 NB_SUP=NB_SUP+1 ENDIF TOTAL_LOAD=TOTAL_LOAD+(PROCS(SLAVEF+1)-NB_SUP) IF(K50.EQ.0)THEN MAX_LOAD=dble( NELIM ) * dble ( NCB ) + * dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE MAX_LOAD=dble(NELIM) * dble ( NCB ) * * dble(NFRONT+1) ENDIF TMP=min(MAX_LOAD,MAX_LOAD/TOTAL_LOAD) J=1 DO i=1,PROCS(SLAVEF+1) IF((NB_SUP.GT.0).AND.(i.EQ.1))THEN CYCLE ELSEIF((NB_SUP.EQ.2).AND.(i.EQ.PROCS(SLAVEF+1)))THEN CYCLE ENDIF IDWLOAD(J)=PROCS(i) J=J+1 ENDDO DO i=1,NB_SUP IF(i.EQ.1)THEN IDWLOAD(J)=PROCS(1) ELSE IDWLOAD(J)=PROCS(PROCS(SLAVEF+1)) ENDIF J=J+1 ENDDO IF ((K50.EQ.0).OR.FORCE_LDLTRegular_NIV2) THEN ACC=0 J=PROCS(SLAVEF+1)-NB_SUP+1 DO i=1,NB_SUP VAR=dble(SUP_PROC_ARG(i))/100.0D0 TMP_NROW=int(dble(MEM_CONSTRAINT(i))/dble(NFRONT)) NB_ROWS(J)=int(max((VAR*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM)), & dble(1))) IF(NB_ROWS(J).GT.TMP_NROW)THEN NB_ROWS(J)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(J)) THEN NB_ROWS(J)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(J) J=J+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF DO i=1,PROCS(SLAVEF+1)-NB_SUP VAR=1.0D0 TMP_NROW=int((dble(TAB_MAXS_ARG(IDWLOAD(i))))/dble(NFRONT)) NB_ROWS(i)=int((dble(VAR)*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(i)) THEN NB_ROWS(i)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE TMP_NROW=(NCB-ACC)/(PROCS(SLAVEF+1)-NB_SUP)+1 DO i=1,PROCS(SLAVEF+1)-NB_SUP NB_ROWS(i)=NB_ROWS(i)+TMP_NROW ACC=ACC+TMP_NROW IF(ACC.GT.NCB) THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+ & (NCB-(ACC-TMP_NROW)) EXIT ENDIF ENDDO ENDIF ENDIF ELSE ACC=0 i=PROCS(SLAVEF+1)-NB_SUP+1 X=NCB LOAD_CORR=0.0D0 MEM_CSTR=.FALSE. DO J=1,NB_SUP VAR=DBLE(SUP_PROC_ARG(J))/DBLE(100) A=1.0D0 B=dble(X+NELIM) C=-dble(max(MEM_CONSTRAINT(J),0_8)) DELTA=((B*B)-(4*A*C)) TMP_NROW=int((-B+sqrt(DELTA))/(2*A)) A=dble(-NELIM) B=dble(NELIM)*(dble(-NELIM)+dble(2*(X+NELIM)+1)) C=-(VAR*TMP) DELTA=(B*B-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW MEM_CSTR=.TRUE. ENDIF IF(ACC+NB_ROWS(i).GT.NCB)THEN NB_ROWS(i)=NCB-ACC ACC=NCB X=0 EXIT ENDIF X=X-NB_ROWS(i) ACC=ACC+NB_ROWS(i) LOAD_CORR=LOAD_CORR+(dble(NELIM) * dble (NB_ROWS(i)) * * dble(2*(X+NELIM) - NELIM - NB_ROWS(i) + 1)) i=i+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF IF((PROCS(SLAVEF+1).NE.NB_SUP).AND.MEM_CSTR)THEN TMP=(MAX_LOAD-LOAD_CORR)/(PROCS(SLAVEF+1)-NB_SUP) ENDIF X=ACC ACC=0 DO i=1,PROCS(SLAVEF+1)-NB_SUP IF (KEEP(375) .EQ. 1) THEN VAR=1.0D0 A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(VAR*TMP) ELSE A=1.0D0 B=dble(ACC+NELIM) C=-TMP ENDIF DELTA=((B*B)-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NCB-ACC-X.LT.NB_ROWS(i))THEN NB_ROWS(i)=NCB-ACC-X ACC=NCB-X EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO ACC=ACC+X IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE NB_ROWS(PROCS(SLAVEF+1)-NB_SUP)= & NB_ROWS(PROCS(SLAVEF+1) & -NB_SUP)+NCB-ACC ENDIF ENDIF ENDIF 777 CONTINUE NSLAVES=0 ACC=1 J=1 K=1 DO i=1,PROCS(SLAVEF+1) IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(J)=IDWLOAD(i) TAB_POS(J)=ACC ACC=ACC+NB_ROWS(i) NB_ROW_MAX=max(NB_ROW_MAX,NB_ROWS(i)) IF(K50.EQ.0)THEN MAX_SURF=max(int(NB_ROWS(i),8)*int(NCB,8),int(0,8)) ELSE MAX_SURF=max(int(NB_ROWS(i),8)*int(ACC,8),int(0,8)) ENDIF NSLAVES=NSLAVES+1 J=J+1 ELSE SLAVES_LIST(PROCS(SLAVEF+1)-K+1)=IDWLOAD(i) K=K+1 ENDIF ENDDO TAB_POS(SLAVEF+2) = NSLAVES TAB_POS(NSLAVES+1)= NCB+1 NSLAVES_NODE=NSLAVES END SUBROUTINE ZMUMPS_SET_PARTI_REGULAR MUMPS_5.4.1/src/sana_aux_ELT.F0000664000175000017500000010761014102210521016120 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES, LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,L1,L2,NCMPA,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL SMUMPS_ANA_G11_ELT, SMUMPS_ANA_G12_ELT, & SMUMPS_ANA_G1_ELT, SMUMPS_ANA_G2_ELT, & SMUMPS_ANA_G2_ELTNEW, & SMUMPS_ANA_J1_ELT, SMUMPS_ANA_J2_ELT, & SMUMPS_ANA_K, & SMUMPS_ANA_LNEW, SMUMPS_ANA_M, & MUMPS_AMD_ELT #if defined(OLDDFS) EXTERNAL SMUMPS_ANA_L #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 4*N GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min0(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min0(10,ELTPTR(NELT+1)-1) IF (LDIAG.EQ.4) K = ELTPTR(NELT+1)-1 IF (K.GT.0) WRITE (MP,99995) (ELTVAR(I),I=1,K) K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP(I,1),I=1,K) ENDIF 10 L1 = 1 L2 = L1 + N IF (LIW .LT. 3*N) THEN INFO(1) = -2002 INFO(2) = LIW ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL SMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL SMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL SMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4*N+4, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL SMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL SMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in SMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL SMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL SMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+K) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+IKEEP(K,1)).EQ.1) THEN GOTO 40 ELSE IW(L1+IKEEP(K,1)) = 1 ENDIF ENDDO CALL SMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL SMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in SMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL SMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF #if defined(OLDDFS) CALL SMUMPS_ANA_L(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, KEEP(60)) #else CALL SMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+N),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY) #endif DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL SMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL SMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) KEEP(210)=0 IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) KEEP(210)=1 IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL SMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE SMUMPS_ANA_F_ELT SUBROUTINE SMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine SMUMPS_NODEL ***') END SUBROUTINE SMUMPS_NODEL SUBROUTINE SMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G1_ELT SUBROUTINE SMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G2_ELTNEW SUBROUTINE SMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G2_ELT SUBROUTINE SMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_J1_ELT SUBROUTINE SMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE SMUMPS_ANA_J2_ELT SUBROUTINE SMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE SMUMPS_ANA_DIST_ELEMENTS SUBROUTINE SMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ELTPROC SUBROUTINE SMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine SMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine SMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine SMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE SMUMPS_FRTELT SUBROUTINE SMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD,LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL SMUMPS_SUPVAR LP = 6 CALL SMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3*N+3+1),3*N+3,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from SMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3*N+3+1+I) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(N+1:2*N) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(N+J).NE.I)) THEN IW(N+J) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G11_ELT SUBROUTINE SMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_ANA_G12_ELT SUBROUTINE SMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LIW,LP,N,NELT,NSUP,NZ INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER FLAG,NEW,VARS EXTERNAL SMUMPS_SUPVARB INFO(1) = 0 INFO(2) = 0 INFO(3) = 0 INFO(4) = 0 IF (N.LT.1) GO TO 10 IF (NELT.LT.1) GO TO 20 IF (NZ.LT.ELTPTR(NELT+1)-1) GO TO 30 IF (LIW.LT.6) THEN INFO(4) = 3*N + 3 GO TO 40 END IF NEW = 1 VARS = NEW + LIW/3 FLAG = VARS + LIW/3 CALL SMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP,LIW/3-1, & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = 3*N + 3 GO TO 40 ELSE INFO(4) = 3*NSUP + 3 END IF GO TO 50 10 INFO(1) = -1 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 20 INFO(1) = -2 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 30 INFO(1) = -3 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 40 INFO(1) = -4 IF (LP.GT.0) THEN WRITE (LP,FMT=9000) INFO(1) WRITE (LP,FMT=9010) INFO(4) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from SMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE SMUMPS_SUPVAR SUBROUTINE SMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE SMUMPS_SUPVARB MUMPS_5.4.1/src/zana_driver.F0000664000175000017500000056430214102210526016133 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C SUBROUTINE ZMUMPS_ANA_DRIVER(id) USE ZMUMPS_LOAD USE MUMPS_STATIC_MAPPING USE ZMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE ZMUMPS_PARALLEL_ANALYSIS USE ZMUMPS_ANA_LR USE ZMUMPS_LR_CORE USE ZMUMPS_LR_STATS USE MUMPS_LR_COMMON USE ZMUMPS_ANA_AUX_M USE MUMPS_ANA_BLK_M, ONLY: COMPACT_GRAPH_T, LMATRIX_T IMPLICIT NONE C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) C C Purpose C ======= C C Performs analysis and (if required) Max-trans on the master, then C broadcasts information to the slaves. Also includes mapping. C C C Parameters C ========== C TYPE(ZMUMPS_STRUC), TARGET :: id C C Local variables C =============== C C C Pointers inside integer array, various data INTEGER IKEEP, NE, NA INTEGER I, allocok C Other locals INTEGER NB_NIV2, IDEST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LOCAL_M, LOCAL_N INTEGER numroc EXTERNAL numroc INTEGER IRANK INTEGER MP, LP, MPG LOGICAL PROK, PROKG, LISTVAR_SCHUR_2BE_FREED, LPOK INTEGER SIZE_SCHUR_PASSED INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER TOTAL_MBYTES INTEGER(8) SBUF_RECOLD8, MIN_BUF_SIZE8 INTEGER MIN_BUF_SIZE INTEGER(8) MAX_SIZE_FACTOR_TMP INTEGER LEAF, INODE, ISTEP, INN, LPTRAR INTEGER NBLEAF, NBROOT, MYROW_CHECK, INIV2 DOUBLE PRECISION TIMEG INTEGER(8) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO INTEGER :: MAXFR_UNDER_L0 DOUBLE PRECISION :: COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0 C to store the size of the sequencial peak of stack C (or an estimation for not calling REORDER_TREE_N ) DOUBLE PRECISION :: PEAK INTEGER(8):: SIZECB_UNDER_L0, SIZECB_UNDER_L0_IF_LRCB LOGICAL :: ABOVE_L0 C C INTEGER WORKSPACE C INTEGER, ALLOCATABLE, DIMENSION(:):: IPOOL INTEGER :: LIPOOL INTEGER, ALLOCATABLE, TARGET, DIMENSION(:) :: PAR2_NODES INTEGER, DIMENSION(:), POINTER :: PAR2_NODESPTR INTEGER, ALLOCATABLE, DIMENSION(:) :: PROCNODE INTEGER, DIMENSION(:), ALLOCATABLE :: IWtemp INTEGER, DIMENSION(:), ALLOCATABLE :: XNODEL, NODEL INTEGER, DIMENSION(:), POINTER :: SSARBR C Element matrix entry INTEGER, POINTER :: NELT, LELTVAR INTEGER, DIMENSION(:), POINTER :: KEEP, INFO, INFOG INTEGER(8), DIMENSION(:), POINTER :: KEEP8 INTEGER(8) :: ENTRIES_IN_FACTORS_LOC_MASTERS DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFO DOUBLE PRECISION, DIMENSION(:), POINTER :: RINFOG INTEGER, DIMENSION(:), POINTER :: ICNTL LOGICAL :: I_AM_SLAVE, PERLU_ON, COND INTEGER :: OOC_STRAT, BLR_STRAT INTEGER :: IDUMMY INTEGER, TARGET :: IDUMMY_ARRAY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_loc_PTR INTEGER, POINTER, DIMENSION(:) :: IRN_PTR INTEGER, POINTER, DIMENSION(:) :: JCN_PTR INTEGER, POINTER, DIMENSION(:) :: SIZEOFBLOCKS_PTR INTEGER, POINTER, DIMENSION(:) :: UNS_PERM_PTR LOGICAL :: BDUMMY INTEGER(8) :: K8_33relaxed, K8_34relaxed, K8_35relaxed, & K8_50relaxed LOGICAL :: SUM_OF_PEAKS INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER, EXTERNAL :: MUMPS_ENCODE_TPN_IPROC INTEGER :: PROCNODE_VALUE INTEGER K,J, IFS INTEGER SIZE_TEMP_MEM,SIZE_DEPTH_FIRST,SIZE_COST_TRAV LOGICAL IS_BUILD_LOAD_MEM_CALLED LOGICAL PRINT_MAXAVG DOUBLE PRECISION, DIMENSION (:,:), ALLOCATABLE :: TEMP_MEM INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_ROOT INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_LEAF INTEGER, DIMENSION (:,:), ALLOCATABLE :: TEMP_SIZE INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH_FIRST_SEQ INTEGER, DIMENSION (:), ALLOCATABLE :: SBTR_ID DOUBLE PRECISION, DIMENSION (:), ALLOCATABLE :: COST_TRAV_TMP INTEGER(8) :: TOTAL_BYTES, ITMP8 INTEGER :: SIZE_PAR2_NODESPTR INTEGER :: LSIZEOFBLOCKS_PTR LOGICAL :: READY_FOR_ANA_F INTEGER, ALLOCATABLE, DIMENSION(:) :: MAPCOL LOGICAL :: BLKPTR_ALLOCATED, BLKVAR_ALLOCATED INTEGER :: IB, BLKSIZE INTEGER :: IBcurrent, IPOS, IPOSB, II C Internal work arrays: C DOF2BLOCK(idof)=inode, idof in [1,N], inode in [1,NBLK] C SIZEBLOCK(1:NBLK) (for node valuation) INTEGER, TARGET, DIMENSION(:), allocatable:: SIZEOFBLOCKS INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK INTEGER :: NBRECORDS INTEGER(8) :: NSEND8, NLOCAL8 C LMAT_BLOCK: in case of centralized matrix, C to store on MASTER the cleaned Lmatrix C used to compute GCOMP C LMAT_BLOCK might also be saved to C be used during grouping C LUMAT : in case of distributed matrix C to store distributed the cleaned LU matrix C LUMAT might also be saved to C be used for MPI based grouping C LUMAT_REMAP : in case of distributed matrix C it is used to remap LUMAT C C GCOMP : Graph "ready" to be called by orderings C TYPE(LMATRIX_T) :: LMAT_BLOCK, LUMAT, LUMAT_REMAP LOGICAL :: GCOMP_PROVIDED TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(COMPACT_GRAPH_T) :: GCOMP_DIST INTEGER, POINTER, DIMENSION(:) :: & NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, & STEPPTR, LRGROUPSPTR INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: IKEEPALLOC INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK2ALLOC ! Used because of multithreaded SIM_NP_ INTEGER :: locMYID, locMYID_NODES LOGICAL, POINTER :: locI_AM_CAND(:) INTEGER(kind=8) :: NZ8, LIW8 C NBLK : id%N or order of blocked matrix INTEGER :: NBLK INTEGER :: LIW_ELT C INTERFACE C Explicit interface because of pointer arguments: SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE ZMUMPS_LR_DATA_M, only : ZMUMPS_BLR_STRUC_TO_MOD, & ZMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Beginning of executable statements C IS_BUILD_LOAD_MEM_CALLED=.FALSE. KEEP => id%KEEP KEEP8 => id%KEEP8 INFO => id%INFO RINFO => id%RINFO INFOG => id%INFOG RINFOG => id%RINFOG ICNTL => id%ICNTL NELT => id%NELT LELTVAR => id%LELTVAR KEEP(264) = 0 ! reinitialise out-of-range status (0=yes) KEEP(265) = 0 ! reinitialise dupplicates (0=yes) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) NULLIFY ( NFSIZPTR, & FILSPTR, & FREREPTR, NE_STEPSPTR, & IKEEP1, IKEEP2, IKEEP3, STEPPTR, LRGROUPSPTR, & SSARBR, SIZEOFBLOCKS_PTR, IRN_loc_PTR, JCN_loc_PTR, & IRN_PTR, JCN_PTR, & PAR2_NODESPTR ) IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) nullify(id%UNS_PERM) IDUMMY = 1 BDUMMY = .FALSE. C Set default value that witl be reset in C case of blocked format matrices NBLK = id%N GCOMP_PROVIDED = .FALSE. BLKPTR_ALLOCATED = .FALSE. BLKVAR_ALLOCATED = .FALSE. C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IF ( PROK ) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MP, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MP, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MP, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MP, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MP, '(A)') 'Type of parallelism: Host not working' END IF END IF IF ( PROKG .AND. (MP.NE.MPG)) THEN IF ( KEEP(50) .eq. 0 ) THEN WRITE(MPG, '(A)') 'L U Solver for unsymmetric matrices' ELSE IF ( KEEP(50) .eq. 1 ) THEN WRITE(MPG, '(A)') & 'L D L^T Solver for symmetric positive definite matrices' ELSE WRITE(MPG, '(A)') & 'L D L^T Solver for general symmetric matrices' END IF IF ( KEEP(46) .eq. 1 ) THEN WRITE(MPG, '(A)') 'Type of parallelism: Working host' ELSE WRITE(MPG, '(A)') 'Type of parallelism: Host not working' END IF END IF IF (PROK) WRITE( MP, 110 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 110 ) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C ---------------------------------------- C Free some memory from factorization, C if allocated, at least large arrays. C This will also limit the amount of useless C data saved to disk in case of save-restore C ---------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF NULLIFY(id%S) KEEP8(24) = 0_8 ! reinitialize last used size of WK_USER IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C also avoid keeping BLR factors allocated if analysis C called after a previous BLR factorization without C an intermediate JOB=-2 call. CALL ZMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C -------------------------------------------- C If analysis redone, suppress old, C meaningless, Step2node array. C This is necessary since we could otherwise C end up having a wrong Step2node during solve C -------------------------------------------- IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Decode API (ICNTL parameters, mainly) C and check consistency of the KEEP array. C Note: ZMUMPS_ANA_CHECK_KEEP also sets C some INFOG parameters CALL ZMUMPS_ANA_CHECK_KEEP(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ------------------------------------------- C Broadcast KEEP(60) since we need to broadcast C related information C ------------------------------------------ CALL MPI_BCAST( KEEP(60), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C broadcast also size of schur IF (id%KEEP(60) .NE. 0 ) THEN CALL MPI_BCAST( KEEP(116), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF IF (id%KEEP(60) .EQ. 2 .or. id%KEEP(60). EQ. 3) THEN CALL MPI_BCAST( id%NPROW, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NPCOL, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%MBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NBLOCK, 1, & MPI_INTEGER, MASTER, id%COMM, IERR ) C Note that ZMUMPS_INIT_ROOT_ANA will C then use that information. ENDIF C ---------------------------------------------- C Broadcast KEEP(54) now to know if the C structure of the graph is intially distributed C and should be assembled on the master C Broadcast KEEP(55) now to know if the C matrix is in assembled or elemental format C ---------------------------------------------- CALL MPI_BCAST( KEEP(54), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast KEEP(69) now to know if C we will need to communicate during analysis C ---------------------------------------------- CALL MPI_BCAST( KEEP(69), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast Out of core strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast analysis strategy (used only on master so far) C ---------------------------------------------- CALL MPI_BCAST( KEEP(244), 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C --------------------------- C Fwd in facto C Broadcast KEEP(251,252,253) defined on master so far CALL MPI_BCAST( KEEP(251), 3, MPI_INTEGER,MASTER,id%COMM,IERR) C CALL MPI_BCAST( id%KEEP(490), 5, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------------- C Broadcast N C ---------------------------------------------- CALL MPI_BCAST( id%N, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C ---------------------------------------------- C Broadcast NZ for assembled entry C ---------------------------------------------- IF ( KEEP(55) .EQ. 0) THEN IF ( KEEP(54) .eq. 3 ) THEN C Compute total number of non-zeros CALL MPI_ALLREDUCE( id%KEEP8(29), id%KEEP8(28), 1, & MPI_INTEGER8, & MPI_SUM, id%COMM, IERR ) ELSE C Broadcast NZ from the master node CALL MPI_BCAST( id%KEEP8(28), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) END IF ELSE C Broadcast NA_ELT <=> KEEP8(30) for elemental entry CALL MPI_BCAST( id%KEEP8(30), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) ENDIF IF( id%KEEP(54).EQ.3) THEN C test IRN_loc and JCN_loc allocated on working procs IF (I_AM_SLAVE .AND. id%KEEP8(29).GT.0 .AND. & ( (.NOT. associated(id%IRN_loc)) .OR. & (.NOT. associated(id%JCN_loc)) ) & ) THEN id%INFO(1) = -22 id%INFO(2) = 16 ENDIF ENDIF IF ( associated(id%MEM_DIST) ) THEN DEALLOCATE( id%MEM_DIST ) ENDIF allocate( id%MEM_DIST( 0:id%NSLAVES-1 ), STAT=IERR ) IF ( IERR .GT. 0 ) THEN INFO(1) = -7 INFO(2) = id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'MEM_DIST' END IF END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 id%MEM_DIST(0:id%NSLAVES-1) = 0 CALL MUMPS_INIT_ARCH_PARAMETERS( & id%COMM,id%COMM_NODES,KEEP(69),KEEP(46), & id%NSLAVES,id%MEM_DIST,INFO) C ======================== C Write problem to a file, C if requested by the user C ======================== CALL ZMUMPS_DUMP_PROBLEM(id) C ================= C ANALYSIS BY BLOCK C ================= IF ( id%MYID .EQ. MASTER ) THEN IF (KEEP(13).NE.0) THEN C Analysis by block with block data provided by user C C Check if block structure is centralized or distributed IF (.NOT.associated(id%BLKVAR)) THEN C BLKVAR is identity and implicitly centralized KEEP(14) = 0 ELSE IF (size(id%BLKVAR).EQ.id%N) THEN C Centralized block stucture KEEP(14) = 0 ELSE C Distributed block stucture KEEP(14) = 1 IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR with centralized matrix. Size of id%BLKVAR ", & "should be equal to id%N instead of ", & size(id%BLKVAR) ENDIF id%INFO(1) = -57 id%INFO(2) = 3 ENDIF ENDIF IF (KEEP(13).GE.1) THEN C BLKPTR provided by user C check input data IF ( .NOT.associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " id%BLKPTR should be provided by user on host " ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF ( (id%NBLK.LE.0).OR.(id%NBLK.GT.id%N) & .OR. (id%NBLK+1.NE.size(id%BLKPTR)) & ) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ERROR incorrect value of id%NBLK:", id%NBLK ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF NBLK=id%NBLK IF (id%BLKPTR(id%NBLK+1)-1.NE.id%N) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(id%NBLK+1)-1 ", & "should be equal to id%N instead of ", & id%BLKPTR(id%NBLK+1)-1 ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF IF (id%BLKPTR(1).NE.1) THEN IF ( LPOK ) THEN WRITE(LP,'(A,A,I8)') & " ERROR id%BLKPTR(1)", & "should be equal to 1 instead of ", & id%BLKPTR(1) ENDIF id%INFO(1) = -57 id%INFO(2) = 2 ENDIF ELSE IF (KEEP(13).LT.0) THEN C regular blocks in BLKVAR of size -KEEP(13) C mod(id%N,-KEEP(13)) has already been checked NBLK = id%N/(-KEEP(13)) ENDIF C end of KEEP(13).NE.0 ENDIF C end of id%MYID .EQ. MASTER ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 500 C C Broadcast KEEP(13-14), NBLK CALL MPI_BCAST( KEEP(13), 2, MPI_INTEGER, MASTER, id%COMM, IERR ) CALL MPI_BCAST( NBLK, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C C =========================== IF (KEEP(13).NE.0) THEN C { BEGIN preparation ANA_BLK C =========================== IF ( ( (KEEP(54).NE.3).AND.(id%MYID.EQ.MASTER) ) & .OR. (KEEP(54).EQ.3) ) THEN C ---------------------------------------- C Allocate SIZEOFBLOCKS, DOF2BLOCK C ---------------------------------------- IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) allocate(SIZEOFBLOCKS(NBLK), DOF2BLOCK(id%N), & STAT=allocok) C IF (allocok.NE.0) THEN id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N+NBLK IF ( LPOK ) WRITE(LP, 150) ' SIZEOFBLOCKS, DOF2BLOCK' ENDIF C IF (id%MYID.EQ.MASTER.AND.allocok.EQ.0) THEN C BLKPTR and BLKVAR needed for ZMUMPS_EXPAND_TREE C allocate then if not associated IF (.NOT.associated(id%BLKPTR)) THEN BLKPTR_ALLOCATED = .TRUE. allocate(id%BLKPTR(NBLK+1), STAT=allocok) IF (allocok.NE.0) THEN BLKPTR_ALLOCATED = .TRUE. id%INFO( 1 ) = -7 id%INFO( 2 ) = NBLK+1 IF ( LPOK ) WRITE(LP, 150) ' id%BLKPTR ' ENDIF ENDIF IF (.NOT.associated(id%BLKVAR).AND.allocok.EQ.0) THEN allocate(id%BLKVAR(id%N), STAT=allocok) BLKVAR_ALLOCATED = .TRUE. IF (allocok.NE.0) THEN BLKVAR_ALLOCATED = .FALSE. id%INFO( 1 ) = -7 id%INFO( 2 ) = id%N IF ( LPOK ) WRITE(LP, 150) ' id%BLKVAR ' ENDIF ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF (INFO(1).LT.0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN C ----------------------------------------- C Compute SIZEOFBLOCKS, DOF2BLOCK on MASTER C based on id%BLKPTR and id%BLKVAR C and compute id%BLKPTR and id%BLKVAR if not C provided by user C ----------------------------------------- IF (BLKVAR_ALLOCATED) THEN C implicitly id%BLKVAR(I)=I DO I=1, id%N id%BLKVAR(I)=I ENDDO ENDIF IF (BLKPTR_ALLOCATED) THEN IB=0 BLKSIZE=-KEEP(13) DO I=1, id%N, BLKSIZE IB=IB+1 id%BLKPTR(IB) = I ENDDO id%BLKPTR(NBLK+1) = id%N+1 ENDIF C CALL MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, id%N, id%BLKPTR(1), id%BLKVAR(1), & SIZEOFBLOCKS, DOF2BLOCK) ENDIF C ======================= IF (KEEP(54).NE.3) THEN C ======================= C --------------------- C Matrix structure available on host C --------------------- KEEP(14) = 0 IF (id%MYID.EQ.MASTER) THEN C Store input matrix (IRN/JCN) as a cleaned blocked Lmatrix C of nodes (indices \in [1,NBLK]) IF (id%KEEP8(28) .EQ. 0_8) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( id%MYID, & NBLK, id%N, id%KEEP8(28), IRN_PTR(1), JCN_PTR(1), & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT_BLOCK ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C IF (id%MYID.EQ.MASTER) THEN C From LMAT_BLOCK build GCOMP format wich requires C symmetrizing the Lmatrix CALL MUMPS_AB_LMAT_TO_CLEAN_G ( id%MYID, .TRUE., & .TRUE., ! not relevant because unfold is true & LMAT_BLOCK, GCOMP, & INFO(1), ICNTL(1)) GCOMP_PROVIDED = .TRUE. IF (KEEP(494).EQ.0) THEN CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ==== ELSE C ==== C ------------------------------- C Matrix structure is distributed C and since KEEP(13).NE.0 then C ordering is centralized since C ------------------------------- C IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY id%KEEP8(29) = 0_8 ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF C C Given distributed matrix IRN_loc_PTR, JCN_loc_PTR C build distributed cleaned graph GCOMP and C save distributed LUMAT in case of grouping C IF (id%NPROCS.EQ.1) THEN C Centralized cleaned graph is ready C call directly with GCOMP READY_FOR_ANA_F = .TRUE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP, READY_FOR_ANA_F) GCOMP_PROVIDED = .TRUE. ELSE READY_FOR_ANA_F = .FALSE. CALL MUMPS_AB_DCOORD_TO_DCOMPG ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & DOF2BLOCK(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & LUMAT, GCOMP_DIST, READY_FOR_ANA_F) ENDIF C C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C ===== ENDIF C ===== IF (allocated(DOF2BLOCK)) THEN C DOF2BLOCK reused on master if pivot order given by user IF ( (id%MYID.EQ.MASTER).AND. (KEEP(256) .NE. 1)) THEN DEALLOCATE(DOF2BLOCK) ENDIF ENDIF C ======================== ENDIF C } END preparation ANA_BLK C ========================= C ==================================================== C TEST FOR SEQUENTIAL OR PARALLEL ANALYSIS (KEEP(244)) C ==================================================== IF ( (KEEP(244).EQ.1) .AND. (KEEP(54) .eq. 3) ) THEN C ----------------------------------------------- C Sequential analysis: C Collect on the host -- if matrix is distributed C at analysis -- all integer information needed C to perform ordering C ----------------------------------------------- IF (KEEP(13).NE.0) THEN IF (id%NPROCS.NE.1) THEN CALL MUMPS_AB_GATHER_GRAPH( & id%ICNTL(1), KEEP(1), id%COMM, id%MYID, id%NPROCS, & id%INFO(1), & GCOMP_DIST, GCOMP) GCOMP_PROVIDED = .TRUE. C CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) ENDIF ELSE CALL ZMUMPS_GATHER_MATRIX(id) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF 1234 CONTINUE IF (KEEP(244) .EQ. 1) THEN C Sequential analysis : Schur IF ( id%MYID .eq. MASTER ) THEN C Prepare arguments for call to ZMUMPS_ANA_F and C ZMUMPS_ANA_F_ELT in case id%SCHUR was not allocated C by user. The objective is to avoid passing a null C pointer. C FIXME Block fomat for Schur IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN SIZE_SCHUR_PASSED = 1 LISTVAR_SCHUR_2BE_FREED=.TRUE. allocate( id%LISTVAR_SCHUR( 1 ), STAT=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) & 'PB allocating an array of size 1 for Schur!! ' INFO(1)=-7 INFO(2)=1 END IF ELSE SIZE_SCHUR_PASSED=id%SIZE_SCHUR LISTVAR_SCHUR_2BE_FREED = .FALSE. END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF ((id%MYID.EQ.MASTER).AND.(KEEP(244) .EQ. 1) & .AND. (id%N.EQ.NBLK) & ) THEN C Sequential analysis : maximum transversal on master IF ((KEEP(50).NE.1).AND. & .NOT.((KEEP(23).EQ.7).AND.KEEP(50).EQ.0) & ) THEN C (KEEP(23).EQ.7).AND.KEEP(50).EQ.0) : C For unsymmetric matrix, if automatic setting is requested C default setting of Maximum Transversal is decided during C ZMUMPS_ANA_F and is based on matrix unsymmetry. C Thus in this case we skip ZMUMPS_ANA_O IF ( ( KEEP(23) .NE. 0 ) .OR. C Automatic choice for scaling does not force Maxtrans C Only when scaling is explicitly asked during analysis C (KEEP(52)=-2) ZMUMPS_ANA_O is called & KEEP(52) .EQ. -2 ) THEN C C Maximum Trans. algorithm called on original matrix. C We compute a permutation of the original matrix to C have a zero free diagonal C KEEP(23)=7 means that automatic choice C of max trans value will be done during analysis C Permutation is held in UNS_PERM(1, ...,N). C Maximum transversal is not available for element C entry format C UNS_PERM that might be set to C to permutation computed during Max transversal ALLOCATE(id%UNS_PERM(id%N),IKEEPALLOC(3*id%N), & WORK2ALLOC(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=5*id%N ELSE CALL ZMUMPS_ANA_O(id%N, id%KEEP8(28), KEEP(23), & id%UNS_PERM, IKEEPALLOC, id%IRN, id%JCN, id%A, & id%ROWSCA, id%COLSCA, & WORK2ALLOC, id%KEEP, id%ICNTL, id%INFO, id%INFOG) IF (allocated(WORK2ALLOC)) DEALLOCATE(WORK2ALLOC) IF (KEEP(23).EQ.0) THEN C Maximum tranversal did not produce a permutation IF (associated( id%UNS_PERM )) & DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF C Check if IKEEPALLOC needed for ANA_F IF (KEEP(23).EQ.0.AND.(KEEP(95).EQ.1)) THEN IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) ENDIF ENDIF IF (INFO(1) .LT. 0) THEN C Fatal error C Permutation was not computed; reset keep(23) KEEP(23) = 0 ELSE ENDIF ELSE KEEP(23) = 0 C Switch off C compressed/contrained ordering id%KEEP(95) = 1 END IF ENDIF C END OF MAX-TRANS ON THE MASTER ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C IF ( KEEP(244) .EQ. 1) THEN C Sequential analysis: allocate data for ordering on MASTER IF (id%MYID.EQ.MASTER) THEN C allocate IKEEPALLOC and TREE related pointers C IKEEPALLOC might have been allocated in ZMUMPS_ANA_O C and IKEEPALLOC(1:N) might hold information to C be given to ANA_F. IF (allocated(IKEEPALLOC)) THEN ALLOCATE( FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=3*NBLK ENDIF ELSE ALLOCATE(IKEEPALLOC(NBLK+2*id%N), & FILSPTR(NBLK), FREREPTR(NBLK), & NFSIZPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=4*NBLK+2*id%N ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF C IF (KEEP(244) .EQ. 1) THEN C Sequential analysis IF ( id%MYID .eq. MASTER ) THEN C BEGINNING OF ANALYSIS ON THE MASTER C ------------------------------------------------------ C For element entry (KEEP(55).ne.0), we do not know NZ, C and so the whole allocation of IW cannot be done at this C point and more workspace is declared/allocated/used C inside ZMUMPS_ANA_F_ELT. C ------------------------------------------------------ C IF (KEEP(55) .EQ. 0) THEN C ---------------- C Assembled format C ---------------- NZ8=id%KEEP8(28) C Compute LIW8: C For local orderings a contiguous space IW C of size LIW8 must be provided. C IW must hold the graph (with double adjacency C list) and and extra space of size the number of C nodes in the graph: C ==> LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 C In case of analysis by block and C However, when GCOMP is provided directly then C IW is not allocated C ==> LIW8 = 0 C In this case C size(LCOMP%ADJ)>= 2_8*NZ8+int(NBLK,8)+1_8 C should hold IF (KEEP(13).NE.0) THEN C Compact graph is provided on entry to ZMUMPS_ANA_F NZ8=0_8 ! GCOMP is provided on entry ENDIF IF (NZ8.EQ.0_8) THEN LIW8 = 0_8 ELSE LIW8 = 2_8 * NZ8 + int(NBLK,8) + 1_8 ENDIF C ELSE C ---------------- C Elemental format C ---------------- C Only available for AMD, METIS, and given ordering #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) COND = (KEEP(60) .NE. 0) .OR. (KEEP(256) .EQ. 5) #else COND = (KEEP(60) .NE. 0) #endif IF( COND ) THEN C C C we suppress supervariable detection when Schur C is active or when METIS is applied C Workspaces for FLAG(N), and either LEN(N) or some pointers(N+1) LIW_ELT = id%N + id%N + 1 ELSE C Spaces FLAG(N), LEN(N), N+3, SVAR(0:N), LIW_ELT = id%N + id%N + id%N + 3 + id%N + 1 ENDIF C ENDIF C We must ensure that an array of order C 3*N is available for ZMUMPS_ANA_LNEW IF (KEEP(55) .EQ. 0) THEN IF (LIW8.LT.3_8*int(NBLK,8)) LIW8 = 3_8*int(NBLK,8) ELSE IF (LIW_ELT.LT.3*id%N) LIW_ELT = 3*id%N ENDIF C IF ( KEEP(256) .EQ. 1 ) THEN C It has been checked that id%PERM_IN is associated but C values of pivot order will be checked later and C should be checked here too C PERM_IN( I ) = position of I in the pivot order IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) C Build inverse permutation and check PERM_IN DO I = 1, id%N IKEEP2(I) = 0 ENDDO DO I = 1, id%N IF ( id%PERM_IN(I) .LT.1 .OR. & id%PERM_IN(I) .GT. id%N ) THEN C PERM_IN entry is out-of-range INFO(1) = -4 INFO(2) = I GOTO 10 ELSE IF ( IKEEP2(id%PERM_IN(I)) .NE. 0 ) THEN C Duplicate entry in PERM_IN was found INFO(1) = -4 INFO(2) = I GOTO 10 ELSE C Store entry in inverse permutation IKEEP2(id%PERM_IN( I )) = I ENDIF ENDDO IF ((KEEP(55) .EQ. 0).AND.(KEEP(13).NE.0) & .AND.(KEEP(13).NE.-1) & ) THEN C Build blocked permutation: C IKEEPALLOC(IB)= IBPos where IB, IBPos \in [1:NBLK] C IKEEP2 holds inverse permutation IPOSB = 0 IPOS = 1 DO WHILE (IPOS.LE.id%N) IPOSB = IPOSB+1 I = IKEEP2(IPOS) IBcurrent = DOF2BLOCK(I) BLKSIZE = SIZEOFBLOCKS(IBcurrent) IKEEPALLOC(IBcurrent) = IPOSB IF (BLKSIZE.GT.1) THEN DO II = 1, BLKSIZE-1 IPOS = IPOS+1 I = IKEEP2(IPOS) IB = DOF2BLOCK(I) IF (IB.NE.IBcurrent) THEN INFO(1)= -4 INFO(2)= I GOTO 10 ENDIF ENDDO ENDIF IPOS = IPOS+1 ENDDO C IF PERM_IN is correct then C on exit last position should be NBLK IF (IPOSB.NE.NBLK) THEN INFO(1)= -4 C N+1 to indicate "global" error INFO(2)= id%N+1 GOTO 10 ENDIF ELSE DO I = 1, id%N IKEEPALLOC( I ) = id%PERM_IN( I ) END DO ENDIF IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) END IF INFOG(1) = 0 INFOG(2) = 0 C Initialize structural symmetry value to not yet computed. INFOG(8) = -1 IF (KEEP(55) .EQ. 0) THEN IKEEP1 => IKEEPALLOC(1:NBLK) IKEEP2 => IKEEPALLOC(NBLK+1:NBLK+id%N) IKEEP3 => IKEEPALLOC(NBLK+id%N+1:NBLK+2*id%N) C id%UNS_PERM corresponds to argument PIV C in ZMUMPS_ANA_F, it should be an assumed-shape C array rather than a possibly null pointer: IF (associated(id%UNS_PERM)) THEN UNS_PERM_PTR => id%UNS_PERM ELSE UNS_PERM_PTR => IDUMMY_ARRAY ENDIF IF (KEEP(13).EQ.0) THEN CALL ZMUMPS_ANA_F(id%N, NZ8, & id%IRN, id%JCN, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) ELSE IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY CALL ZMUMPS_ANA_F(NBLK, NZ8, & IRN_loc_PTR, JCN_loc_PTR, & LIW8, IKEEP1, IKEEP2, IKEEP3, & KEEP(256), NFSIZPTR, & FILSPTR, FREREPTR, & id%LISTVAR_SCHUR, SIZE_SCHUR_PASSED, & id%ICNTL, id%INFOG, id%KEEP,id%KEEP8,id%NSLAVES, & UNS_PERM_PTR, & id%CNTL(4), id%COLSCA, id%ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & , id%N, SIZEOFBLOCKS, GCOMP_PROVIDED, GCOMP & ) IF (GCOMP_PROVIDED) CALL MUMPS_AB_FREE_GCOMP(GCOMP) C ENDIF INFOG(7) = KEEP(256) C UNS_PERM_PTR was only used locally C for the call to ZMUMPS_ANA_F NULLIFY(UNS_PERM_PTR) ELSE allocate( XNODEL ( id%N+1 ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = id%N + 1 IF ( LPOK ) THEN WRITE(LP, 150) 'XNODEL' END IF GOTO 10 ENDIF IF (LELTVAR.ne.id%ELTPTR(NELT+1)-1) THEN C -- internal error INFO(1) = -2002 INFO(2) = id%ELTPTR(NELT+1)-1 GOTO 10 ENDIF allocate( NODEL ( LELTVAR ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LELTVAR IF ( LPOK ) THEN WRITE(LP, 150) 'NODEL' END IF GOTO 10 ENDIF CALL ZMUMPS_ANA_F_ELT(id%N, NELT, & id%ELTPTR(1), id%ELTVAR(1), LIW_ELT, & IKEEPALLOC(1), & KEEP(256), NFSIZPTR(1), FILSPTR(1), & FREREPTR(1), id%LISTVAR_SCHUR(1), & SIZE_SCHUR_PASSED, & ICNTL(1), INFOG(1), KEEP(1),KEEP8(1), & id%NSLAVES, & XNODEL(1), NODEL(1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , id%METIS_OPTIONS(1) #endif & ) INFOG(7)=KEEP(256) C C XNODEL and NODEL as output to ZMUMPS_ANA_F_ELT C be used in ZMUMPS_FRTELT and thus C cannot be deallocated at this point C ENDIF IF ( LISTVAR_SCHUR_2BE_FREED ) THEN C We do not want to have LISTVAR_SCHUR C allocated of size 1 if Schur is off. DEALLOCATE( id%LISTVAR_SCHUR ) NULLIFY ( id%LISTVAR_SCHUR ) LISTVAR_SCHUR_2BE_FREED = .TRUE. ENDIF C ------------------------------ C Significant error codes should C always be in INFO(1/2) C ------------------------------ INFO(1)=INFOG(1) INFO(2)=INFOG(2) C save statistics in KEEP array. KEEP(28) = INFOG(6) IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N C -- if (id%myid.eq.master) ENDIF C -- if sequential analysis ENDIF C 10 CONTINUE IF (KEEP(244).EQ.1) THEN CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 ENDIF IF ((KEEP(244).EQ.1).AND.(KEEP(55).EQ.0)) THEN C Sequential analysis on assembled matrix C check if max transversal should be called CALL MPI_BCAST(KEEP(23),1,MPI_INTEGER,MASTER,id%COMM,IERR) IF ( (KEEP(23).LE.-1).AND.(KEEP(23).GE.-6) ) THEN C -- Perform max transversal KEEP(23) = -KEEP(23) IF (id%MYID.EQ.MASTER) THEN IF (.NOT. associated(id%A)) KEEP(23) = 1 IF (associated(id%UNS_PERM)) DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FILSPTR) ) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF IF (associated(FREREPTR) ) THEN DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) ENDIF IF (associated(NFSIZPTR) ) THEN DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF ENDIF GOTO 1234 ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(244).EQ.1).AND. (KEEP(55).EQ.0)) THEN C Sequential ordering on assembled matrix IF ((KEEP(54).EQ.3).AND.KEEP(494).EQ.0) THEN IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF ENDIF ENDIF ENDIF IF (KEEP(244).NE.1) THEN C Parallel analysis IKEEP = 1 NA = IKEEP + id%N NE = IKEEP + 2 * id%N IF (id%MYID .EQ. MASTER) THEN ALLOCATE( IKEEPALLOC(3*id%N), WORK2ALLOC(4*id%N), & FILSPTR(id%N), FREREPTR(id%N), NFSIZPTR(id%N), & stat=IERR) ELSE C Because our purpose is to minimize the peak memory consumption, C we can afford to allocate on processes other than host ALLOCATE(IKEEPALLOC(3*id%N),WORK2ALLOC(4*id%N), stat=IERR ) ENDIF IF (IERR.GT.0) THEN INFO(1) = -7 IF (id%MYID .EQ. MASTER) THEN INFO( 2 ) = 10*id%N ELSE INFO( 2 ) = 7*id%N ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 CALL ZMUMPS_ANA_F_PAR(id, & IKEEPALLOC, & WORK2ALLOC, & NFSIZPTR, & FILSPTR, & FREREPTR) DEALLOCATE(WORK2ALLOC) IF(id%MYID .NE. MASTER) THEN DEALLOCATE(IKEEPALLOC) ENDIF KEEP(28) = INFOG(6) END IF C Allocated PROCNODE on MASTER IF (id%MYID.EQ.MASTER) THEN allocok = 0 allocate(PROCNODE(NBLK), STAT=allocok) IF (allocok .ne. 0) THEN INFO(1) = -7 INFO(2) = NBLK ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C Save ICNTL(14) value into KEEP(12) CALL MUMPS_GET_PERLU(KEEP(12),ICNTL(14), & KEEP(50),KEEP(54),ICNTL(6),KEEP(52)) CALL ZMUMPS_ANA_R(NBLK, FILSPTR(1), FREREPTR(1), & IKEEPALLOC(NE), IKEEPALLOC(NA)) C ********************************************************** C Continue with CALL to MAPPING routine C ********************* C BEGIN SEQUENTIAL CODE C No mapping computed C ********************* C C In sequential, if no special root C reset KEEP(20) and KEEP(38) to 0 C IF (id%NSLAVES .EQ. 1 & ) THEN id%NBSA = 0 IF ( (id%KEEP(60).EQ.0). & AND.(id%KEEP(53).EQ.0)) THEN C If Schur is on (keep(60).ne.0) C or if RR is on (keep (53) > 0 C then we keep root numbers C root node number in seq id%KEEP(20)=0 C root node number in paral id%KEEP(38)=0 ENDIF C No type 2 nodes: id%KEEP(56)=0 C All mapped on MPI process 0, and of type TPN=0 C (treated as if they were all root of subtree) PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(0, 0, KEEP(199)) DO I = 1, NBLK PROCNODE(I) = PROCNODE_VALUE END DO C It may also happen that KEEP(38) has already been set, C in the case of a distributed Schur complement (KEEP(60)=2 or 3). C In that case, PROCNODE should be set accordingly and KEEP(38) is C not modified. IF (id%KEEP(60) .EQ. 2 .OR. id%KEEP(60).EQ.3) THEN PROCNODE_VALUE = MUMPS_ENCODE_TPN_IPROC(3, 0, KEEP(199)) CALL ZMUMPS_SET_PROCNODE(id%KEEP(38), PROCNODE(1), & PROCNODE_VALUE, FILSPTR(1), NBLK) ENDIF C ******************* C END SEQUENTIAL CODE C ******************* ELSE C ***************************** C BEGIN MAPPING WITH CANDIDATES C (NSLAVES > 1) C ***************************** C C C peak is set by default to 1 largest front + One largest CB PEAK = dble(id%INFOG(5))*dble(id%INFOG(5)) + ! front matrix & dble(id%KEEP(2))*dble(id%KEEP(2)) ! cb bloc C IKEEP(1:N,1) can be used as a work space since it is set C to its final state by the SORT_PERM subroutine below. SSARBR => IKEEPALLOC(IKEEP:IKEEP+NBLK-1) C ====================================================== C Map nodes and assign candidates for dynamic scheduling C ====================================================== IF ((KEEP(13).NE.0).AND.(NBLK.NE.id%N)) THEN SIZEOFBLOCKS_PTR => SIZEOFBLOCKS(1:NBLK) LSIZEOFBLOCKS_PTR = NBLK ELSE SIZEOFBLOCKS_PTR => IDUMMY_ARRAY LSIZEOFBLOCKS_PTR = 1 IDUMMY_ARRAY(1) = -1 ENDIF CALL ZMUMPS_DIST_AVOID_COPIES( & NBLK,id%NSLAVES,ICNTL(1), & INFOG(1), & IKEEPALLOC(NE), & NFSIZPTR(1), & FREREPTR(1), & FILSPTR(1), & KEEP(1),KEEP8(1),PROCNODE(1), & SSARBR(1),id%NBSA,PEAK,IERR & , SIZEOFBLOCKS_PTR(1), LSIZEOFBLOCKS_PTR & ) NULLIFY(SSARBR) if(IERR.eq.-999) then write(6,*) ' Internal error during static mapping ' INFO(1) = IERR GOTO 11 ENDIF IF(IERR.NE.0) THEN INFO(1) = -135 INFO(2) = IERR GOTO 11 ENDIF CALL ZMUMPS_ANA_R(NBLK, FILSPTR(1), & FREREPTR(1), IKEEPALLOC(NE), & IKEEPALLOC(NA)) ENDIF 11 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C The following part is done in parallel CALL MPI_BCAST( id%NELT, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C postpone to after computation of id%SYM_PERM C computed after id%DAD_STEPS if (associated(id%FRTPTR)) DEALLOCATE(id%FRTPTR) if (associated(id%FRTELT)) DEALLOCATE(id%FRTELT) allocate( id%FRTPTR(1), id%FRTELT(1) ,STAT=allocok) IF (allocok .GT. 0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FRTPTR,FRTELT' END IF INFO(1)= -7 INFO(2)= 2 END IF ELSE C Element Entry: C ------------------------------- C COMPUTE THE LIST OF ELEMENTS THAT WILL BE ASSEMBLED C AT EACH NODE OF THE ELIMINATION TREE. ALSO COMPUTE C FOR EACH ELEMENT THE TREE NODE TO WHICH IT IS ASSIGNED. C C FRTPTR is an INTEGER array of length N+1 which need not be set by C the user. On output, FRTPTR(I) points in FRTELT to first element C in the list of elements assigned to node I in the elimination tree. C C FRTELT is an INTEGER array of length NELT which need not be set by C the user. On output, positions FRTELT(FRTPTR(I)) to C FRTELT(FRTPTR(I+1)-1) contain the list of elements assigned to C node I in the elimination tree. C LPTRAR = id%NELT+id%NELT+2 CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTPTR, id%N+1, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTPTR (Analysis)', ERRCODE=-7) CALL MUMPS_REALLOC(id%FRTELT, id%NELT, id%INFO, LP, & FORCE=.TRUE., STRING='id%FRTELT (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF(id%MYID .EQ. MASTER) THEN C In the elemental format case, PTRAR&friends are still C computed sequentially and then broadcasted CALL ZMUMPS_FRTELT( & id%N, NELT, id%ELTPTR(NELT+1)-1, FREREPTR(1), & FILSPTR(1), & IKEEPALLOC(NA), IKEEPALLOC(NE), XNODEL, & NODEL, id%FRTPTR(1), id%FRTELT(1), id%ELTPROC(1)) DO I=1, id%NELT+1 C PTRAR declared 64-bit id%PTRAR(id%NELT+I+1)=int(id%ELTPTR(I),8) ENDDO DEALLOCATE(XNODEL) DEALLOCATE(NODEL) END IF CALL MPI_BCAST( id%PTRAR(id%NELT+2), id%NELT+1, MPI_INTEGER8, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTPTR(1), id%N+1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRTELT(1), id%NELT, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C We switch again to sequential computations on the master node IF(id%MYID .EQ. MASTER) THEN IF ( INFO( 1 ) .LT. 0 ) GOTO 12 IF ( KEEP(55) .ne. 0 ) THEN C --------------------------------------- C Build ELTPROC: correspondance between elements and slave ranks C in COMM_NODES with special values -1 (all procs) and -2 and -3 C (no procs). This is used later to distribute the elements on C the processes at the beginning of the factorisation phase C --------------------------------------- CALL ZMUMPS_ELTPROC(NBLK, NELT, id%ELTPROC(1),id%NSLAVES, & PROCNODE(1), id%KEEP(1)) END IF NB_NIV2 = KEEP(56) IF ( NB_NIV2.GT.0 ) THEN C allocate(PAR2_NODES(NB_NIV2), & STAT=allocok) IF (allocok .GT.0) then INFO(1)= -7 INFO(2)= NB_NIV2 IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES' END IF GOTO 12 END IF ENDIF IF ((NB_NIV2.GT.0) .AND. (KEEP(24).EQ.0)) THEN INIV2 = 0 DO 777 INODE = 1, NBLK IF ( ( FREREPTR(INODE) .NE. NBLK ) .AND. & ( MUMPS_TYPENODE(PROCNODE(INODE),id%KEEP(199)) & .eq. 2) ) THEN INIV2 = INIV2 + 1 PAR2_NODES(INIV2) = INODE END IF 777 CONTINUE IF ( INIV2 .NE. NB_NIV2 ) THEN WRITE(*,*) "Internal Error 2 in ZMUMPS_ANA_DRIVER", & INIV2, NB_NIV2 CALL MUMPS_ABORT() ENDIF ENDIF IF ( (KEEP(24) .NE. 0) .AND. (NB_NIV2.GT.0) ) THEN C allocate array to store cadidates stategy C for each level two nodes IF ( associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate( id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & stat=allocok) if (allocok .gt.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 END IF CALL MUMPS_RETURN_CANDIDATES & (PAR2_NODES,id%CANDIDATES, & IERR) IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF C deallocation of variables of module mumps_static_mapping CALL MUMPS_END_ARCH_CV() IF(IERR.NE.0) THEN INFO(1) = -2002 GOTO 12 ENDIF ELSE IF (associated(id%CANDIDATES)) DEALLOCATE(id%CANDIDATES) allocate(id%CANDIDATES(1,1), stat=allocok) IF (allocok .NE. 0) THEN INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF GOTO 12 ENDIF ENDIF C******************************************************************* C --------------- 12 CONTINUE C --------------- * * =============================== * End of analysis phase on master * =============================== * END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 C C We now allocate and compute arrays in NSTEPS C on the master, as this makes more sense. C C Broadcast KEEP8(101) to be used in MUMPS_ANA_L0_OMP CALL MPI_BCAST( id%KEEP8(101), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C C ============================== C PREPARE DATA FOR FACTORIZATION C ============================== C ------------------ CALL MPI_BCAST( id%KEEP(1), 110, MPI_INTEGER, MASTER, & id%COMM, IERR ) C We also need to broadcast KEEP8(21) CALL MPI_BCAST( id%KEEP8(21), 1, MPI_INTEGER8, MASTER, & id%COMM, IERR ) C -------------------------------------------------- C Broadcast KEEP(205) which is outside the first 110 C KEEP entries but is needed for factorization. C -------------------------------------------------- CALL MPI_BCAST( id%KEEP(205), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C -------------- C Broadcast NBSA CALL MPI_BCAST( id%NBSA, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global MAXFRT (computed in ZMUMPS_ANA_M) C is needed on all the procs during ZMUMPS_ANA_DISTM C to evaluate workspace for solve. C We could also recompute it in ZMUMPS_ANA_DISTM IF (id%MYID==MASTER) KEEP(127)=INFOG(5) CALL MPI_BCAST( id%KEEP(127), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- C Global max panel size KEEP(226) CALL MPI_BCAST( id%KEEP(226), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ----------------- CALL MPI_BCAST( id%KEEP(464), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(471), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(475), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(482), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) CALL MPI_BCAST( id%KEEP(487), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C Number of leaves not belonging to L0 KEEP(262) C and KEEP(263) : inner or outer sends for blocked facto CALL MPI_BCAST( id%KEEP(262), 2, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ---------------------------------------- C Allocate new workspace on all processors C ---------------------------------------- IF (id%MYID.EQ.MASTER) THEN C id%STEP is of size NBLK because it C is computed on compressed graph and then extended C and broadcasted on all procs CALL MUMPS_REALLOC(id%STEP, NBLK, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ELSE C id%STEP is of size id%N because it C is received in extended form CALL MUMPS_REALLOC(id%STEP, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%STEP (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%PROCNODE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%PROCNODE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%NE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%NE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%ND_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%ND_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%FRERE_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%FRERE_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 CALL MUMPS_REALLOC(id%DAD_STEPS, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%DAD_STEPS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 C id%FILS is allocated before expand tree IF (KEEP(55) .EQ. 0) THEN LPTRAR = id%N+id%N CALL MUMPS_I8REALLOC(id%PTRAR, LPTRAR, id%INFO, LP, & FORCE=.TRUE., STRING='id%PTRAR (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 94 ENDIF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_REALLOC(id%LRGROUPS, NBLK, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ELSE CALL MUMPS_REALLOC(id%LRGROUPS, id%N, id%INFO, LP, & FORCE=.TRUE. & ,STRING='id%LRGROUPS (Analysis)', ERRCODE=-7) ENDIF IF(INFO(1).LT.0) GOTO 94 C Copy data for factorization and/or solve. C ================================ C COMPUTE ON THE MASTER, BROADCAST C TO OTHER PROCESSES C ================================ IF ( id%MYID .NE. MASTER .OR. id%KEEP(23) .EQ. 0 ) THEN IF ( associated( id%UNS_PERM ) ) THEN DEALLOCATE(id%UNS_PERM) ENDIF ENDIF 94 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( id%MYID .EQ. MASTER ) THEN C NA -> compressed NA containing only list C of leaves of the elimination tree and list of roots C (the two useful informations for factorization/solve). IF (NBLK.eq.1) THEN NBROOT = 1 NBLEAF = 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) .LT.0) THEN NBLEAF= NBLK NBROOT= NBLK ELSE IF (IKEEPALLOC(NA+NBLK-2) .LT.0) THEN NBLEAF = NBLK-1 NBROOT = IKEEPALLOC(NA+NBLK-1) ELSE NBLEAF = IKEEPALLOC(NA+NBLK-2) NBROOT = IKEEPALLOC(NA+NBLK-1) ENDIF id%LNA = 2+NBLEAF+NBROOT ENDIF CALL MPI_BCAST( id%LNA, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MUMPS_REALLOC(id%NA, id%LNA, id%INFO, LP, FORCE=.TRUE., & STRING='id%NA (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF (id%MYID .EQ.MASTER ) THEN C{ The structure of NA is the following: C NA(1) is the number of leaves. C NA(2) is the number of roots. C NA(3:2+NA(1)) are the leaves. C NA(3+NA(1):2+NA(1)+NA(2)) are the roots. id%NA(1) = NBLEAF id%NA(2) = NBROOT C C Initialize NA with the leaves and roots LEAF = 3 IF ( NBLK == 1 ) THEN id%NA(LEAF) = 1 LEAF = LEAF + 1 ELSE IF (IKEEPALLOC(NA+NBLK-1) < 0) THEN id%NA(LEAF) = - IKEEPALLOC(NA+NBLK-1)-1 LEAF = LEAF + 1 DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ELSE IF (IKEEPALLOC(NA+NBLK-2) < 0 ) THEN INODE = - IKEEPALLOC(NA+NBLK-2) - 1 id%NA(LEAF) = INODE LEAF =LEAF + 1 IF ( NBLEAF > 1 ) THEN DO I = 1, NBLEAF - 1 id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO ENDIF ELSE DO I = 1, NBLEAF id%NA(LEAF) = IKEEPALLOC(NA+I-1) LEAF = LEAF + 1 ENDDO END IF C C Build array STEP(1:id%N) to hold step numbers in C range 1..id%KEEP(28), allowing compression of C other arrays from id%N to id%KEEP(28) C (the number of nodes/steps in the assembly tree) ISTEP = 0 DO I = 1, NBLK IF ( FREREPTR(I) .ne. NBLK + 1 ) THEN C New node in the tree. c (Set step( inode_n ) = inode_nsteps for principal C variables and -inode_nsteps for internal variables C of the node) ISTEP = ISTEP + 1 id%STEP(I)=ISTEP INN = FILSPTR(I) DO WHILE ( INN .GT. 0 ) id%STEP(INN) = - ISTEP INN = FILSPTR(INN) END DO IF (FREREPTR(I) .eq. 0) THEN C Keep root nodes list in NA id%NA(LEAF) = I LEAF = LEAF + 1 ENDIF ENDIF END DO IF ( LEAF - 1 .NE. 2+NBROOT + NBLEAF ) THEN WRITE(*,*) 'Internal error 2 in ZMUMPS_ANA_DRIVER' CALL MUMPS_ABORT() ENDIF IF ( ISTEP .NE. id%KEEP(28) ) THEN write(*,*) 'Internal error 3 in ZMUMPS_ANA_DRIVER', & ISTEP, id%KEEP(28) CALL MUMPS_ABORT() ENDIF C ============ C SET PROCNODE, FRERE, NE C ============ C copies to NSTEP array should be ok DO I = 1, NBLK IF (FREREPTR(I) .NE. NBLK+1) THEN id%PROCNODE_STEPS(id%STEP(I)) = PROCNODE( I ) id%FRERE_STEPS(id%STEP(I)) = FREREPTR(I) id%NE_STEPS(id%STEP(I)) = IKEEPALLOC(NE+I-1) id%ND_STEPS(id%STEP(I)) = NFSIZPTR(I) ENDIF ENDDO C =============================== C Algorithm to compute array DAD_STEPS: C ---- C For each node set dad for all of its sons C plus, for root nodes set dad to zero. C C =============================== DO I = 1, NBLK C -- skip non principal nodes IF ( id%STEP(I) .LE. 0) CYCLE C -- (I) is a principal node IF (FREREPTR(I) .eq. 0) THEN C -- I is a root node and has no father id%DAD_STEPS(id%STEP(I)) = 0 ENDIF C -- Find first son node (IFS) IFS = FILSPTR(I) DO WHILE ( IFS .GT. 0 ) IFS= FILSPTR(IFS) END DO C -- IFS > 0 if I is not a leave node C -- Go through list of brothers of IFS if any IFS = -IFS DO WHILE (IFS.GT.0) C -- I is not a leave node and has a son node IFS id%DAD_STEPS(id%STEP(IFS)) = I IFS = FREREPTR(IFS) ENDDO END DO C C C Following arrays (PROCNODE and IKEEPALLOC) not used anymore C during analysis IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(IKEEPALLOC)) DEALLOCATE(IKEEPALLOC) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) NULLIFY(FREREPTR) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) NULLIFY(NFSIZPTR) ENDIF IF (KEEP(494).NE.0) THEN C{ IF (id%MYID.EQ.MASTER) THEN IF (PROKG) THEN CALL MUMPS_SECDEB(TIMEG) END IF ENDIF C ======================================================= C Compute a grouping of variables for LR approximations. C Grouping may be performed on a distributed matrix C ======================================================= C C I/ Prepare data before call to grouping IF ((KEEP(54).EQ.3).AND.(KEEP(13).NE.0)) THEN C Matrix is distributed on entry and compression computed IF (KEEP(487).NE.1) CALL MUMPS_ABORT() ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C CALL MUMPS_INIALIZE_REDIST_LUMAT ( & id%INFO, id%ICNTL, id%KEEP, id%COMM, id%MYID, NBLK, & LUMAT, id%PROCNODE_STEPS(1), id%KEEP(28), MAPCOL, & LUMAT_REMAP, NBRECORDS, id%STEP(1)) C INFO(1) has been broadcasted already in routine IF ( id%INFO(1).LT.0 ) GOTO 500 C C -- Redistribute LUMAT into LU_REMAP relying on procnode CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .FALSE., ! do not UNFOLD & .TRUE., ! MAPCOL in NSTEPS=> STEP array needed & id%INFO, id%ICNTL, id%COMM, id%MYID, NBLK, id%NPROCS, & LUMAT, MAPCOL, id%KEEP(28), id%STEP(1), NBLK, & LUMAT_REMAP, NBRECORDS, NSEND8, NLOCAL8 & ) CALL MUMPS_AB_FREE_LMAT(LUMAT) C Distribute SIZEOFBLOCKS that was defined only on master CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, & id%COMM, IERR ) C ELSE IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C ---> build LUMAT_REMAP on MASTER IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_AB_LMAT_TO_LUMAT ( & LMAT_BLOCK, LUMAT_REMAP, & INFO(1), ICNTL(1)) C --- LMAT_BLOCK not needed anymore CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C ELSE IF ((KEEP(54).EQ.3).AND.(KEEP(13).EQ.0) & .AND. KEEP(487).EQ.1) THEN C Matrix is distributed on entry and compression not requested C (this will be the case when ICNTL(15).EQ.0 and C // analysis, or Schur, etc...) C note that with distributed matrix and centralized ordering C compression is forced to limit memory peak) C Free centralized matrix before grouping to C limit memory peak IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF IF (.NOT. I_AM_SLAVE .OR. ! non-working master & id%KEEP8(29) .EQ. 0_8) THEN ! NNZ_loc or NZ_loc C Master non-working IRN_loc_PTR => IDUMMY_ARRAY JCN_loc_PTR => IDUMMY_ARRAY ELSE IRN_loc_PTR => id%IRN_loc JCN_loc_PTR => id%JCN_loc ENDIF ALLOCATE(MAPCOL(id%KEEP(28)), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C C Build MAPCOL and LUMAT_REMAP mapped according C to MAPCOL (outputs available on all MPI procs). CALL MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & id%MYID, id%NPROCS, id%COMM, & NBLK, id%N, & id%KEEP8(29), ! => NNZ_loc or NZ_loc & IRN_loc_PTR(1), JCN_loc_PTR(1), & id%PROCNODE_STEPS(1), id%KEEP(28), id%STEP(1), & id%ICNTL(1), id%INFO(1), id%KEEP(1), & MAPCOL, LUMAT_REMAP ) IF (INFO(1).GE.0) THEN C SIZEOFBLOCKS needed on all procs during MPI grouping ALLOCATE(SIZEOFBLOCKS(NBLK), stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NBLK ENDIF DO I=1, NBLK SIZEOFBLOCKS(I) = 1 ENDDO ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 ELSE IF ((KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2) & .AND. (KEEP(487).NE.1) & ) THEN C Grouping preparation on slaves: C If the input matrix is distributed and the parallel analysis is C chosen, the graph used to be centralized in order to compute the C clustering. C CALL ZMUMPS_GATHER_MATRIX(id) ENDIF C ============ C ============ C II/ GROUPING C ============ IF ((KEEP(54).EQ.3).AND.(KEEP(487).EQ.1)) THEN C Matrix is distributed on entry and halo of size 1 C Distributed memory based grouping is used IF (id%MYID.NE.MASTER) THEN ALLOCATE(FILSPTR(NBLK), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=NBLK ENDIF ENDIF C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C Distribute SIZEOFBLOCKS that was defined only on master C CALL MPI_BCAST( SIZEOFBLOCKS, NBLK, MPI_INTEGER, MASTER, C & id%COMM, IERR ) CALL ZMUMPS_AB_LR_MPI_GROUPING(NBLK, & MAPCOL, id%KEEP(28), & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), LPOK, LP, id%COMM, id%MYID, id%NPROCS) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (id%MYID.NE.MASTER) THEN DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ENDIF C ELSE IF (id%MYID.EQ.MASTER) THEN IF ((KEEP(54).NE.3).AND.(KEEP(13).NE.0) & .AND. (KEEP(487).EQ.1) ) THEN C Centralized matrix and LMAT_BLOCK available C --- build LUMAT C -- LR grouping exploiting LUMAT C -- centralized => MAPCOL not needed C FIXME 5.4: call to ZMUMPS_AB_LR_GROUPING "ready" to be C replaced by call to ZMUMPS_AB_LR_MPI_GROUPING C IDUMMY_ARRAY(1) = -1 CALL ZMUMPS_AB_LR_GROUPING(NBLK, & IDUMMY_ARRAY, 1, & id%KEEP(28), LUMAT_REMAP, FILSPTR, & id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, SIZEOFBLOCKS(1), id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP, id%MYID, id%COMM) ELSE C grouping based on centralized matrix IF (KEEP(469).EQ.0) THEN CALL ZMUMPS_LR_GROUPING(id%N, id%KEEP8(28), id%KEEP(28), & id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%NE_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, & id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ELSE CALL ZMUMPS_LR_GROUPING_NEW(id%N, id%KEEP8(28), & id%KEEP(28), id%IRN, & id%JCN, FILSPTR, id%FRERE_STEPS, & id%DAD_STEPS, id%STEP, id%NA, & id%LNA, id%LRGROUPS, id%KEEP(50), & id%ICNTL(1), id%KEEP(487), id%KEEP(488), & id%KEEP(490), id%KEEP(38), id%KEEP(20), id%KEEP(60), & id%INFO(1), id%INFO(2), & id%KEEP(264), id%KEEP(265), id%KEEP(482), id%KEEP(472), & id%KEEP(127), id%KEEP(469), id%KEEP(10), & id%KEEP(54), & LPOK, LP) ENDIF ENDIF ENDIF C ============ C III/ CLEANUP C ============ C Free LUMAT_REMAP is allocated CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF ( (KEEP(54).EQ.3) .AND. (KEEP(244).EQ.2).AND. & (KEEP(487).NE.1) ) THEN C Cleanup the irn and jcn arrays filled up by the C cmumps_gather_matrix above. It might have been done C during grouping IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF IF (PROKG) THEN CALL MUMPS_SECFIN(TIMEG) WRITE(MPG,145) TIMEG END IF C} Grouping: KEEP(494) .NE. 0 ENDIF IF (id%MYID.NE. MASTER) THEN CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 ENDIF C IF ((id%MYID.EQ.MASTER) .AND.(KEEP(13).NE.0)) THEN C{ =========== C Expand tree C =========== C Current tree is relative to the analysis by block. C Expand the tree on the master if compression is effective C (in all cases, grouping done or not) IF (NBLK.LT.id%N.OR.(.NOT.BLKVAR_ALLOCATED)) THEN C even if NBLK.EQ.N BLKVAR provided by user might hold C a permutation of the variables and this expand_tree_steps C should also be called C Expand FILSPTR, id%STEP into id%FILS, STEPPTR C and update arrays of size NSTEPS ALLOCATE(STEPPTR(id%N), LRGROUPSPTR(id%N), stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-7 INFO(2)=id%N GOTO 97 ENDIF IF (NB_NIV2.EQ.0) THEN IDUMMY_ARRAY(1) = -9999 PAR2_NODESPTR => IDUMMY_ARRAY(1:1) SIZE_PAR2_NODESPTR=1 ELSE PAR2_NODESPTR => PAR2_NODES(1:NB_NIV2) SIZE_PAR2_NODESPTR=NB_NIV2 ENDIF CALL MUMPS_REALLOC(id%FILS, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%FILS (Analysis)', ERRCODE=-7) IF(INFO(1).LT.0) GOTO 97 CALL ZMUMPS_EXPAND_TREE_STEPS (id%ICNTL, & id%N, NBLK, id%BLKPTR(1), id%BLKVAR(1), & FILSPTR(1), id%FILS(1), id%KEEP(28), & id%STEP(1), STEPPTR(1), & PAR2_NODESPTR(1), SIZE_PAR2_NODESPTR, & id%DAD_STEPS(1), id%FRERE_STEPS(1), & id%NA(1), id%LNA, id%LRGROUPS(1), LRGROUPSPTR(1), & id%KEEP(20), id%KEEP(38) & ) NULLIFY(PAR2_NODESPTR) DEALLOCATE(id%STEP) id%STEP=>STEPPTR NULLIFY(STEPPTR) DEALLOCATE(id%LRGROUPS) id%LRGROUPS=>LRGROUPSPTR NULLIFY(LRGROUPSPTR) DEALLOCATE(FILSPTR) NULLIFY(FILSPTR) ELSE if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF C} ENDIF IF ((id%N.EQ.NBLK).AND.associated(FILSPTR)) THEN C id%FILS has not been initialized if (associated(id%FILS)) DEALLOCATE(id%FILS) id%FILS=>FILSPTR NULLIFY(FILSPTR) ENDIF 97 CONTINUE CALL MUMPS_REALLOC(id%SYM_PERM, id%N, id%INFO, LP, & FORCE=.TRUE., & STRING='id%SYM_PERM (Analysis)', ERRCODE=-7) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), id%COMM, id%MYID ) IF ( INFO(1) < 0 ) GOTO 500 IF (id%MYID.EQ.MASTER) THEN C ================================================================= C Reorder the tree using a variant of Liu's algorithm. Note that C REORDER_TREE MUST always be called since it sorts NA (the list of C leaves) in a valid order in the sense of a depth-first traversal. C ================================================================= CALL ZMUMPS_REORDER_TREE(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),id%NSLAVES,PEAK,id%KEEP(90) & ) IF(id%KEEP(261).EQ.1)THEN CALL MUMPS_SORT_STEP(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%INFO(1), & id%ICNTL(1),id%PROCNODE_STEPS(1),id%NSLAVES & ) ENDIF C Compute and export some global information on the tree needed by C dynamic schedulers during the factorization. The type of C information depends on the selected strategy. IF ((id%KEEP(76).GE.4).OR.(id%KEEP(76).GE.6).OR. & (id%KEEP(47).EQ.4).OR.((id%KEEP(81).GT.0) & .AND.(id%KEEP(47).GE.2)))THEN IS_BUILD_LOAD_MEM_CALLED=.TRUE. IF ((id%KEEP(47) .EQ. 4).OR. & (( id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%NSLAVES.GT.1) THEN C NBSA is the total number of subtrees and C is an upperbound of the local number of C subtrees SIZE_TEMP_MEM = id%NBSA ELSE C Only one processor, NA(2) is the number of leaves SIZE_TEMP_MEM = id%NA(2) ENDIF ELSE SIZE_TEMP_MEM = 1 ENDIF IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN SIZE_DEPTH_FIRST=id%KEEP(28) ELSE SIZE_DEPTH_FIRST=1 ENDIF allocate(TEMP_MEM(SIZE_TEMP_MEM,id%NSLAVES),STAT=allocok) IF (allocok .NE.0) THEN INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_MEM' END IF GOTO 80 !! FIXME propagate error END IF allocate(TEMP_LEAF(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_LEAF' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 !! FIXME propagate error end if allocate(TEMP_SIZE(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_SIZE' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(TEMP_ROOT(SIZE_TEMP_MEM,id%NSLAVES), & stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'TEMP_ROOT' END IF INFO(1)= -7 INFO(2)= SIZE_TEMP_MEM*id%NSLAVES GOTO 80 end if allocate(DEPTH_FIRST(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'DEPTH_FIRST_SEQ' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if ALLOCATE(SBTR_ID(SIZE_DEPTH_FIRST),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'SBTR_ID' END IF INFO(1)= -7 INFO(2)= SIZE_DEPTH_FIRST GOTO 80 end if IF(id%KEEP(76).EQ.5)THEN C We reuse the same variable as before SIZE_COST_TRAV=id%KEEP(28) ELSE SIZE_COST_TRAV=1 ENDIF allocate(COST_TRAV_TMP(SIZE_COST_TRAV),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'COST_TRAV_TMP' END IF INFO(1)= -7 INFO(2)= SIZE_COST_TRAV GOTO 80 END IF IF(id%KEEP(76).EQ.5)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=5 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=6 ENDIF ENDIF IF(id%KEEP(76).EQ.4)THEN IF(id%KEEP(70).EQ.0)THEN id%KEEP(70)=3 ENDIF IF(id%KEEP(70).EQ.1)THEN id%KEEP(70)=4 ENDIF ENDIF CALL ZMUMPS_BUILD_LOAD_MEM_INFO(id%N, id%FRERE_STEPS(1), & id%STEP(1),id%FILS(1), id%NA(1), id%LNA, & id%NE_STEPS(1), id%ND_STEPS(1), id%DAD_STEPS(1), & id%KEEP(28), .TRUE., id%KEEP(28), id%KEEP(70), & id%KEEP(50), id%INFO(1), id%ICNTL(1),id%KEEP(47), & id%KEEP(81),id%KEEP(76),id%KEEP(215), & id%KEEP(234), id%KEEP(55), id%KEEP(199), & id%PROCNODE_STEPS(1),TEMP_MEM,id%NSLAVES, & SIZE_TEMP_MEM, PEAK,id%KEEP(90),SIZE_DEPTH_FIRST, & SIZE_COST_TRAV,DEPTH_FIRST(1),DEPTH_FIRST_SEQ(1), & COST_TRAV_TMP(1), & TEMP_LEAF,TEMP_SIZE,TEMP_ROOT,SBTR_ID(1) & ) END IF ENDIF IF (id%MYID.EQ.MASTER) THEN CALL ZMUMPS_SORT_PERM(id%N, id%NA(1), id%LNA, & id%NE_STEPS(1), id%SYM_PERM(1), & id%FILS(1), id%DAD_STEPS(1), & id%STEP(1), id%KEEP(28), & id%KEEP(60), id%KEEP(20), id%KEEP(38), & id%INFO(1) ) ENDIF C Root principal variable C for scalapack (KEEP(38)) might have been updated C since root variables might have been permuted C and/or expanded (MUMPS_EXPAND_TREE) in case of compressed graph C It should thus be redistributed to all procs IF(((KEEP(494).NE.0).OR.KEEP(13).NE.0) & .AND.(id%KEEP(38).GT.0)) & THEN ! grouping at analysis (1 => LR CALL MPI_BCAST( id%KEEP(38), 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) ENDIF 80 CONTINUE C Broadcast errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C --------------------------------------------------- C Broadcast information computed on the master to C the slaves. C The matrix itself with numerical values and C integer data for the arrowhead/element description C will be received at the beginning of FACTO. C --------------------------------------------------- CALL MPI_BCAST( id%FILS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%NA(1), id%LNA, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%STEP(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%PROCNODE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DAD_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%FRERE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR) CALL MPI_BCAST( id%NE_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%ND_STEPS(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SYM_PERM(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF(KEEP(494).NE.0) THEN CALL MPI_BCAST( id%LRGROUPS(1), id%N, MPI_INTEGER, & MASTER, id%COMM, IERR ) END IF IF (KEEP(55) .EQ. 0) THEN C Assembled matrix format. Fill up the id%PTRAR array C Broadcast id%SYM_PERM needed to fill up id%PTRAR C At the end of ANA_N_DIST, id%PTRAR is already on every processor C because it is computed in a distributed way. C No need to broadcast it again CALL ZMUMPS_ANA_N_DIST(id, id%PTRAR) IF(id%MYID .EQ. MASTER) THEN C ----------------------------------- C For distributed structure on entry, C we can now deallocate the complete C structure IRN / JCN. C ----------------------------------- IF ( (KEEP(244) .EQ. 1) .AND. (KEEP(54) .EQ. 3) ) THEN C IRN and JCN might have already been deallocated IF (associated(id%IRN)) THEN DEALLOCATE(id%IRN) NULLIFY(id%IRN) ENDIF IF (associated(id%JCN)) THEN DEALLOCATE(id%JCN) NULLIFY(id%JCN) ENDIF END IF END IF ENDIF C C Store size of the stack memory for each C of the sequential subtree. IF((id%KEEP(76).EQ.4).OR.(id%KEEP(76).EQ.6))THEN IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= id%KEEP(28) IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%DEPTH_FIRST(1:id%KEEP(28))=DEPTH_FIRST(1:id%KEEP(28)) id%DEPTH_FIRST_SEQ(1:id%KEEP(28))= & DEPTH_FIRST_SEQ(1:id%KEEP(28)) id%SBTR_ID(1:KEEP(28))=SBTR_ID(1:KEEP(28)) ENDIF CALL MPI_BCAST( id%DEPTH_FIRST(1), id%KEEP(28), MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%DEPTH_FIRST_SEQ(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) CALL MPI_BCAST( id%SBTR_ID(1), id%KEEP(28), & MPI_INTEGER,MASTER, id%COMM, IERR ) ELSE IF(associated(id%DEPTH_FIRST)) THEN DEALLOCATE(id%DEPTH_FIRST) ENDIF allocate(id%DEPTH_FIRST(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST' END IF GOTO 87 END IF IF(associated(id%DEPTH_FIRST_SEQ)) THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) ENDIF ALLOCATE(id%DEPTH_FIRST_SEQ(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF IF(associated(id%SBTR_ID)) THEN DEALLOCATE(id%SBTR_ID) ENDIF ALLOCATE(id%SBTR_ID(1),stat=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= 1 IF ( LPOK ) THEN WRITE(LP, 150) 'id%DEPTH_FIRST_SEQ' END IF GOTO 87 END IF id%SBTR_ID(1)=0 id%DEPTH_FIRST(1)=0 id%DEPTH_FIRST_SEQ(1)=0 ENDIF IF(id%KEEP(76).EQ.5)THEN IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(id%KEEP(28)),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV' END IF INFO(1)= -7 INFO(2)= id%KEEP(28) GOTO 87 END IF IF(id%MYID.EQ.MASTER)THEN id%COST_TRAV(1:id%KEEP(28))= & dble(COST_TRAV_TMP(1:id%KEEP(28))) ENDIF CALL MPI_BCAST( id%COST_TRAV(1), id%KEEP(28), & MPI_DOUBLE_PRECISION,MASTER, id%COMM, IERR ) ELSE IF(associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) ENDIF allocate(id%COST_TRAV(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%COST_TRAV(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF id%COST_TRAV(1)=0.0d0 ENDIF IF (id%KEEP(47) .EQ. 4 .OR. & ((id%KEEP(81) .GT. 0).AND.(id%KEEP(47).GE.2))) THEN IF(id%MYID .EQ. MASTER)THEN DO K=1,id%NSLAVES DO J=1,SIZE_TEMP_MEM IF(TEMP_MEM(J,K) < 0.0D0) GOTO 666 ENDDO 666 CONTINUE J=J-1 IF (id%KEEP(46) == 1) THEN IDEST = K - 1 ELSE IDEST = K ENDIF IF (IDEST .NE. MASTER) THEN CALL MPI_SEND(J,1,MPI_INTEGER,IDEST,0, & id%COMM,IERR) CALL MPI_SEND(TEMP_MEM(1,K),J,MPI_DOUBLE_PRECISION, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_LEAF(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_SIZE(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) CALL MPI_SEND(TEMP_ROOT(1,K),J,MPI_INTEGER, & IDEST, 0, id%COMM,IERR) ELSE IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%NBSA_LOCAL = J id%MEM_SUBTREE(1:J)=TEMP_MEM(1:J,1) IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_ROOT_SBTR(1:J)=TEMP_ROOT(1:J,1) IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_FIRST_LEAF(1:J)=TEMP_LEAF(1:J,1) IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(J),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= J GOTO 87 END IF id%MY_NB_LEAF(1:J)=TEMP_SIZE(1:J,1) ENDIF ENDDO ELSE CALL MPI_RECV(id%NBSA_LOCAL,1,MPI_INTEGER, & MASTER,0,id%COMM,STATUS, IERR) IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_FIRST_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(id%NBSA_LOCAL),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'MY_NB_LEAF' END IF INFO(1)= -7 INFO(2)= id%NBSA_LOCAL GOTO 87 END IF CALL MPI_RECV(id%MEM_SUBTREE(1),id%NBSA_LOCAL, & MPI_DOUBLE_PRECISION,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_FIRST_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_NB_LEAF(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) CALL MPI_RECV(id%MY_ROOT_SBTR(1),id%NBSA_LOCAL, & MPI_INTEGER,MASTER,0, & id%COMM,STATUS,IERR) ENDIF ELSE id%NBSA_LOCAL = -999999 IF(associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) ENDIF allocate(id%MEM_SUBTREE(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MEM_SUBTREE(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) ENDIF allocate(id%MY_ROOT_SBTR(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_ROOT_SBTR(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) ENDIF allocate(id%MY_FIRST_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_FIRST_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF IF(associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) ENDIF allocate(id%MY_NB_LEAF(1),stat=allocok) IF (allocok .ne.0) then IF ( LPOK ) THEN WRITE(LP, 150) 'id%MY_NB_LEAF(1)' END IF INFO(1)= -7 INFO(2)= 1 GOTO 87 END IF ENDIF IF(id%MYID.EQ.MASTER)THEN IF(IS_BUILD_LOAD_MEM_CALLED)THEN DEALLOCATE(TEMP_MEM) DEALLOCATE(TEMP_SIZE) DEALLOCATE(TEMP_ROOT) DEALLOCATE(TEMP_LEAF) DEALLOCATE(COST_TRAV_TMP) DEALLOCATE(DEPTH_FIRST) DEALLOCATE(DEPTH_FIRST_SEQ) DEALLOCATE(SBTR_ID) ENDIF ENDIF 87 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C NB_NIV2 = KEEP(56) ! KEEP(1:110) was broadcast earlier C NB_NIV2 is now available on all processors. IF ( NB_NIV2.GT.0 ) THEN C Allocate arrays on slaves if (id%MYID.ne.MASTER) then IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) ENDIF allocate(PAR2_NODES(NB_NIV2), & id%CANDIDATES(id%NSLAVES+1,NB_NIV2), & STAT=allocok) IF (allocok .ne.0) then INFO(1)= -7 INFO(2)= NB_NIV2*(id%NSLAVES+1) IF ( LPOK ) THEN WRITE(LP, 150) 'PAR2_NODES/id%CANDIDATES' END IF end if end if CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 CALL MPI_BCAST(PAR2_NODES(1),NB_NIV2, & MPI_INTEGER, MASTER, id%COMM, IERR ) IF (KEEP(24) .NE.0 ) THEN CALL MPI_BCAST(id%CANDIDATES(1,1), & (NB_NIV2*(id%NSLAVES+1)), & MPI_INTEGER, MASTER, id%COMM, IERR ) ENDIF ENDIF IF ( associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF IF ( associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (NB_NIV2.EQ.0) THEN C allocate dummy arrays C ISTEP_TO_INIV2 will never be used C Add a parameter SIZE_ISTEP_TO_INIV2 and make C it always available in a keep(71) id%KEEP(71) = 1 ELSE id%KEEP(71) = id%KEEP(28) ENDIF allocate(id%ISTEP_TO_INIV2(id%KEEP(71)), & id%I_AM_CAND(max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF IF ( NB_NIV2 .GT.0 ) THEN C If BLR grouping was performed then PAR2_NODES(INIV2) C might then point to a non principal variable C for which STEP might be negative C id%ISTEP_TO_INIV2 = -9999 DO INIV2 = 1, NB_NIV2 INN = PAR2_NODES(INIV2) id%ISTEP_TO_INIV2(abs(id%STEP(INN))) = INIV2 END DO CALL ZMUMPS_BUILD_I_AM_CAND( id%NSLAVES, KEEP(79), & NB_NIV2, id%MYID_NODES, & id%CANDIDATES(1,1), id%I_AM_CAND(1) ) ENDIF IF ( I_AM_SLAVE ) THEN IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF allocate(id%FUTURE_NIV2(id%NSLAVES), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'FUTURE_NIV2' END IF INFO(1)= -7 INFO(2)= id%NSLAVES GOTO 321 ENDIF id%FUTURE_NIV2=0 DO INIV2 = 1, NB_NIV2 IDEST = MUMPS_PROCNODE( & id%PROCNODE_STEPS(abs(id%STEP(PAR2_NODES(INIV2)))), & id%KEEP(199)) id%FUTURE_NIV2(IDEST+1)=id%FUTURE_NIV2(IDEST+1)+1 ENDDO C Allocate id%TAB_POS_IN_PERE, C TAB_POS_IN_PERE is an array of size (id%NSLAVES+2,NB_NIV2) C where NB_NIV2 is the number of type 2 nodes in the tree. IF ( associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF allocate(id%TAB_POS_IN_PERE(id%NSLAVES+2,max(NB_NIV2,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'id%ISTEP_TO_INIV2' WRITE(LP, 150) 'id%TAB_POS_IN_PERE' END IF INFO(1)= -7 IF (NB_NIV2.EQ.0) THEN INFO(2)= 2 ELSE INFO(2)= id%KEEP(28)+NB_NIV2*(id%NSLAVES+2) END IF GOTO 321 ENDIF END IF C deallocate PAR2_NODES that was computed C on master and broadcasted on all slaves IF (NB_NIV2.GT.0) DEALLOCATE (PAR2_NODES) 321 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(38) .NE. 0 ) THEN C ------------------------- C Initialize root structure C ------------------------- CALL ZMUMPS_INIT_ROOT_ANA( id%MYID, & id%NSLAVES, id%N, id%root, & id%COMM_NODES, KEEP( 38 ), id%FILS(1), & id%KEEP(50), id%KEEP(46), & id%KEEP(51) & , id%KEEP(60), id%NPROW, id%NPCOL, id%MBLOCK, id%NBLOCK & ) ELSE id%root%yes = .FALSE. END IF IF ( KEEP(38) .NE. 0 .and. I_AM_SLAVE ) THEN C ----------------------------------------------- C Check if at least one processor belongs to the C root. In the case where all of them have MYROW C equal to -1, this could be a problem due to the C BLACS. (mpxlf90_r and IBM BLACS). C ----------------------------------------------- CALL MPI_ALLREDUCE(id%root%MYROW, MYROW_CHECK, 1, & MPI_INTEGER, MPI_MAX, id%COMM_NODES, IERR) IF ( MYROW_CHECK .eq. -1) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( id%root%MYROW .LT. -1 .OR. & id%root%MYCOL .LT. -1 ) THEN INFO(1) = -25 INFO(2) = 0 END IF IF ( LPOK .AND. INFO(1) == -25 ) THEN WRITE(LP, '(A)') & 'Problem with your version of the BLACS.' WRITE(LP, '(A)') 'Try using a BLACS version from netlib.' ENDIF END IF C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 IF ( I_AM_SLAVE ) THEN C{ C C IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ANA_DIST_ARROWHEADS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), id%PTRAR(1), & id%PTRAR(id%N +1), & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & KEEP(1),KEEP8(1), ICNTL(1), id ) ELSE CALL ZMUMPS_ANA_DIST_ELEMENTS( id%MYID, & id%NSLAVES, id%N, id%PROCNODE_STEPS(1), & id%STEP(1), & id%PTRAR(1), & id%PTRAR(id%NELT+2 ), & id%NELT, & id%FRTPTR(1), id%FRTELT(1), & KEEP(1), KEEP8(1), ICNTL(1), id%KEEP(50) ) ENDIF C} ENDIF C ----------------------------------------- C Perform some local analysis on the slaves C to estimate the size of the working space C for factorization C ----------------------------------------- IF ( I_AM_SLAVE ) THEN C{ locI_AM_CAND => id%I_AM_CAND locMYID_NODES = id%MYID_NODES locMYID = id%MYID C =================================================== C Precompute estimates of local_m,local_n C (number of rows/columns mapped on each processor) C in case of parallel root node. C and allocate CANDIDATES C =================================================== C IF ( id%root%yes ) THEN LOCAL_M = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%MBLOCK, id%root%MYROW, 0, & id%root%NPROW ) LOCAL_M = max(1, LOCAL_M) LOCAL_N = numroc( id%ND_STEPS(id%STEP(KEEP(38))), & id%root%NBLOCK, id%root%MYCOL, 0, & id%root%NPCOL ) ELSE LOCAL_M = 0 LOCAL_N = 0 END IF IF ( KEEP(60) .EQ. 2 .OR. KEEP(60) .EQ. 3 ) THEN C Return minimum nb rows/cols to user id%SCHUR_MLOC=LOCAL_M id%SCHUR_NLOC=LOCAL_N C Also store them in root structure for convenience id%root%SCHUR_MLOC=LOCAL_M id%root%SCHUR_NLOC=LOCAL_N ENDIF IF ( .NOT. associated(id%CANDIDATES)) THEN ALLOCATE(id%CANDIDATES(id%NSLAVES+1,1), stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'CANDIDATES' END IF INFO(1)= -7 INFO(2)= id%NSLAVES+1 ENDIF ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C -- Allocate and initialise IPOOL with leaves C -- on which stats are performed IF ( I_AM_SLAVE ) THEN C{ LIPOOL = id%NA(1) C LIPOOL is number of leaf nodes and can be 0 C (for ex AboveL0 with nbthreads is 1) ALLOCATE( IPOOL(max(LIPOOL,1)), & stat=allocok) IF (allocok .gt.0) THEN IF ( LPOK ) THEN WRITE(LP, 150) 'Allocation IPOOL' END IF INFO(1)= -7 INFO(2)= LIPOOL ENDIF C} ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C{ C Initialize IPOOL with leaves of complete tree DO I=1, LIPOOL IPOOL(I) = id%NA(3+I-1) ENDDO ABOVE_L0 =.FALSE. SIZECB_UNDER_L0 = 0_8 SIZECB_UNDER_L0_IF_LRCB = 0_8 MAX_FRONT_SURFACE_LOCAL_L0 = 0_8 MAX_SIZE_FACTOR_L0 = 0_8 ENTRIES_IN_FACTORS_UNDER_L0= 0_8 ENTRIES_IN_FACTORS_MASTERS_LO = 0_8 MAXFR_UNDER_L0 = 0 COST_SUBTREES_UNDER_L0 = 0.0D0 OPSA_UNDER_L0 = 0.0D0 C NE_STEPSPTR => id%NE_STEPS KEEP(139) = MAXFR_UNDER_L0 CALL ZMUMPS_ANA_DISTM( locMYID_NODES, id%N, id%STEP(1), & id%FRERE_STEPS(1), id%FILS(1), IPOOL, LIPOOL, NE_STEPSPTR(1), & id%DAD_STEPS(1), id%ND_STEPS(1), id%PROCNODE_STEPS(1), & id%NSLAVES, ABOVE_L0,SIZECB_UNDER_L0,SIZECB_UNDER_L0_IF_LRCB, & MAXFR_UNDER_L0, MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_L0, OPSA_UNDER_L0, KEEP8(53), KEEP8(54), & KEEP8(11), KEEP(26), KEEP(15), KEEP8(12), KEEP8(14), & KEEP8(32), KEEP8(33), KEEP8(34), KEEP8(35), KEEP8(50), & KEEP8(36), KEEP8(47), KEEP8(37), KEEP8(38), KEEP8(39), & KEEP8(40), KEEP8(41), KEEP8(42), KEEP8(43), KEEP8(44), KEEP8(45), & KEEP8(46), KEEP8(51), KEEP8(52), KEEP(224),KEEP(225),KEEP(27), & RINFO(1),id%CNTL(1), KEEP(1), KEEP8(1), LOCAL_M, LOCAL_N, & SBUF_RECOLD8, SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, & SBUF_REC_LR, id%COST_SUBTREES, KEEP(28), locI_AM_CAND(1), & max(KEEP(56),1), id%ISTEP_TO_INIV2(1), id%CANDIDATES(1,1), & INFO(1), INFO(2), KEEP8(15),MAX_SIZE_FACTOR_TMP, & KEEP8(9), ENTRIES_IN_FACTORS_LOC_MASTERS, & id%root%yes, id%root%NPROW, id%root%NPCOL & ) IF (ALLOCATED(IPOOL)) DEALLOCATE(IPOOL) NULLIFY(NE_STEPSPTR) C SUM_NIRNEC under L0 OMP KEEP(137)=0 C SUM_NIRNEC_OOC under L0 OMP KEEP(138)=0 C DKEEP(15) is used for dynamic load balancing only C it corresponds to the number of local operations C (in Millions) id%DKEEP(15) = RINFO(1)/1000000.0 IF(ASSOCIATED(locI_AM_CAND)) NULLIFY(locI_AM_CAND) id%MAX_SURF_MASTER = KEEP8(15) C KEEP8(19)=MAX_SIZE_FACTOR_TMP KEEP( 29 ) = KEEP(15) + 3* max(KEEP(12),10) & * ( KEEP(15) / 100 + 1) C Relaxed value of size of IS is not needed internally; C we save it directly in INFO(19) INFO( 19 ) = KEEP(225) + 3* max(KEEP(12),10) & * ( KEEP(225) / 100 + 1) C ================================= C Size of S (relaxed with ICNTL(14) C =========================== C size of S relaxed (FR, IC) C =========================== KEEP8(13) = KEEP8(12) + int(KEEP(12),8) * & ( KEEP8(12) / 100_8 + 1_8 ) C size of S relaxed (FR or LR LU, OOC) KEEP8(17) = KEEP8(14) + int(KEEP(12),8) * & ( KEEP8(14) /100_8 +1_8) C size of S relaxed (LR LU, IC) K8_33relaxed = KEEP8(33) + int(KEEP(12),8) * & ( KEEP8(33) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_34relaxed = KEEP8(34) + int(KEEP(12),8) * & ( KEEP8(34) /100_8 +1_8) C size of S relaxed (LR LU+CB, OOC) K8_35relaxed = KEEP8(35) + int(KEEP(12),8) * & ( KEEP8(35) /100_8 +1_8) C size of S relaxed (LR CB, IC) K8_50relaxed = KEEP8(50) + int(KEEP(12),8) * & ( KEEP8(50) /100_8 +1_8) C KEEP8( 22 ) is the OLD maximum size of receive buffer C that includes CB related communications. C KEEP( 43 ) : min size for send buffer C KEEP( 44 ) : min size for receive buffer C KEEP(43-44) kept for allocating buffers during C factorization phase CALL MUMPS_ALLREDUCEI8 ( SBUF_RECOLD8, KEEP8(22), MPI_MAX, & id%COMM_NODES ) C We do a max with KEEP(27)=maxfront because for small C buffers, we need at least one row of cb to be sent/ C received. SBUF_SEND_FR = max(SBUF_SEND_FR,KEEP(27)) SBUF_SEND_LR = max(SBUF_SEND_LR,KEEP(27)) SBUF_REC_FR = max(SBUF_REC_FR ,KEEP(27)) SBUF_REC_LR = max(SBUF_REC_LR ,KEEP(27)) CALL MPI_ALLREDUCE (SBUF_REC_FR, KEEP(44), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) CALL MPI_ALLREDUCE (SBUF_REC_LR, KEEP(380), 1, & MPI_INTEGER, MPI_MAX, & id%COMM_NODES, IERR) IF (KEEP(48)==5) THEN KEEP(43)=KEEP(44) KEEP(379)=KEEP(380) ELSE KEEP(43)=SBUF_SEND_FR KEEP(379)=SBUF_SEND_LR ENDIF C MIN_BUF_SIZE8 = KEEP8(22) / int(KEEP(238),8) MIN_BUF_SIZE8 = min( MIN_BUF_SIZE8, int(huge (KEEP(43)),8)) MIN_BUF_SIZE = int( MIN_BUF_SIZE8 ) C KEEP(44) = max(KEEP(44), MIN_BUF_SIZE) KEEP(380) = max(KEEP(380), MIN_BUF_SIZE) KEEP(43) = max(KEEP(43), MIN_BUF_SIZE) KEEP(379) = max(KEEP(379), MIN_BUF_SIZE) IF ( PROK ) THEN WRITE(MP,'(A,I16) ') & ' Estimated INTEGER space for factors :', & KEEP(26) WRITE(MP,'(A,I16) ') & ' INFO(3), est. complex space to store factors:', & KEEP8(11) WRITE(MP,'(A,I16) ') & ' Estimated number of entries in factors :', & KEEP8(9) WRITE(MP,'(A,I16) ') & ' Current value of space relaxation parameter :', & KEEP(12) WRITE(MP,'(A,I16) ') & ' Estimated size of IS (In Core factorization):', & KEEP(29) WRITE(MP,'(A,I16) ') & ' Estimated size of S (In Core factorization):', & KEEP8(13) WRITE(MP,'(A,I16) ') & ' Estimated size of S (OOC factorization) :', & KEEP8(17) END IF C} ELSE C --------------------- C Master is not working C --------------------- ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 KEEP8(13) = 0_8 KEEP(29) = 0 KEEP8(17)= 0_8 INFO(19) = 0 KEEP8(11) = 0_8 KEEP8(81) = 0_8 KEEP8(82) = 0_8 KEEP(26) = 0 KEEP(27) = 0 RINFO(1) = 0.0D0 K8_33relaxed = 0_8 K8_34relaxed = 0_8 K8_35relaxed = 0_8 K8_50relaxed = 0_8 END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C -------------------------------------- C KEEP8( 26 ) : Real arrowhead size C KEEP8( 27 ) : Integer arrowhead size C INFO(3)/KEEP8( 11 ) : Estimated real space needed for factors C INFO(4)/KEEP( 26 ) : Estimated integer space needed for factors C INFO(5)/KEEP( 27 ) : Estimated max front size C KEEP8(109) : Estimated number of entries in factor C (based on ENTRIES_IN_FACTORS_LOC_MASTERS computed C during ZMUMPS_ANA_DISTM, where we assume C that each master of a node computes C the complete factor size. C -------------------------------------- C note that summing ENTRIES_IN_FACTORS_LOC_MASTERS or C ENTRIES_IN_FACTORS_LOC_MASTERS should lead to the same result CALL MUMPS_ALLREDUCEI8( ENTRIES_IN_FACTORS_LOC_MASTERS, & KEEP8(109), MPI_SUM, id%COMM) CALL MUMPS_ALLREDUCEI8( KEEP8(19), KEEP8(119), & MPI_MAX, id%COMM) CALL MPI_ALLREDUCE( KEEP(27), KEEP(127), 1, & MPI_INTEGER, MPI_MAX, & id%COMM, IERR) CALL MPI_ALLREDUCE( KEEP(26), KEEP(126), 1, & MPI_INTEGER, MPI_SUM, & id%COMM, IERR) C NRLADU related: KEEP8(11) holds factors above and under L0 CALL MUMPS_REDUCEI8( KEEP8(11), & KEEP8(111), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4( KEEP8(111), INFOG(3) ) C NRLADU_if_LR_LU related: KEEP8(32) holds factors above C and under L0 C convert it in Megabytes RINFO(5) = dble(KEEP8(32) & *int(KEEP(35),8))/1D6 CALL MUMPS_REDUCEI8( KEEP8(32), & ITMP8, MPI_SUM, & MASTER, id%COMM ) C in Megabytes IF (id%MYID.EQ.MASTER) THEN RINFOG(15) = dble(ITMP8*int(KEEP(35),8))/1D6 ENDIF C -------------- C Flops estimate C -------------- CALL MPI_ALLREDUCE( RINFO(1), RINFOG(1), 1, & MPI_DOUBLE_PRECISION, MPI_SUM, & id%COMM, IERR) C CALL MUMPS_SETI8TOI4( KEEP8(11), INFO(3) ) INFO ( 4 ) = KEEP( 26 ) INFO ( 5 ) = KEEP( 27 ) INFO ( 7 ) = KEEP( 29 ) CALL MUMPS_SETI8TOI4( KEEP8(13), INFO(8) ) CALL MUMPS_SETI8TOI4( KEEP8(17), INFO(20) ) CALL MUMPS_SETI8TOI4( KEEP8(9), INFO(24) ) C CALL MUMPS_SETI8TOI4( K8_33relaxed, INFO(29) ) CALL MUMPS_SETI8TOI4( K8_34relaxed, INFO(32) ) CALL MUMPS_SETI8TOI4( K8_35relaxed, INFO(33) ) CALL MUMPS_SETI8TOI4( K8_50relaxed, INFO(36) ) INFOG( 4 ) = KEEP( 126 ) INFOG( 5 ) = KEEP( 127 ) CALL MUMPS_SETI8TOI4( KEEP8(109), INFOG(20) ) CALL ZMUMPS_DIAG_ANA(id%MYID, id%COMM, KEEP(1), KEEP8(1), & INFO(1), INFOG(1), RINFO(1), RINFOG(1), ICNTL(1)) C -------------------------- C COMPUTE MEMORY ESTIMATIONS IF (PROK) WRITE( MP, 112 ) IF (PROKG .AND. (MPG.NE.MP)) WRITE( MPG, 112 ) C -------------------------- C ========================= C IN-CORE MEMORY STATISTICS C ========================= C OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression IF (KEEP(201) .NE. -1) OOC_STRAT=0 ! We want in-core statistics PERLU_ON = .FALSE. ! switch off PERLU to compute KEEP8(2) CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(2) = TOTAL_BYTES C C PERLU_ON = .TRUE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) IF ( PROK ) THEN WRITE(MP,'(A,I12) ') & ' Estimated space in MBytes for IC factorization (INFO(15)):', & TOTAL_MBYTES END IF id%INFO(15) = TOTAL_MBYTES C C Centralize memory statistics on the host C C INFOG(16) = after analysis, est. mem size in Mbytes for facto, C for the processor using largest memory C INFOG(17) = after analysis, est. mem size in Mbytes for facto, C sum over all processors C INFOG(18/19) = idem at facto. C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(15), id%INFOG(16), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(16)):', & id%INFOG(16) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(17)):' & ,id%INFOG(17) END IF C ========================================= C NOW COMPUTE OUT-OF-CORE MEMORY STATISTICS C (except when OOC_STRAT is equal to -1 in C which case IC and OOC statistics are C identical) C ========================================= OOC_STRAT = KEEP(201) BLR_STRAT = 0 ! no BLR compression #if defined(OLD_OOC_NOPANEL) IF (OOC_STRAT .NE. -1) OOC_STRAT=2 #else IF (OOC_STRAT .NE. -1) OOC_STRAT=1 #endif PERLU_ON = .FALSE. ! PERLU NOT taken into account C Used to compute KEEP8(3) (minimum number of bytes for OOC) CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) KEEP8(3) = TOTAL_BYTES C PERLU_ON = .TRUE. ! PERLU taken into account CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & id%MYID, id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .FALSE., & OOC_STRAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, .FALSE., & .FALSE. ! UNDER_L0_OMP & ) id%INFO(17) = TOTAL_MBYTES C CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(17), id%INFOG(26), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(26)):', & id%INFOG(26) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(27)):' & ,id%INFOG(27) END IF IF (KEEP(494).NE.0) THEN C ========================================= C NOW COMPUTE BLR statistics C ========================================= SUM_OF_PEAKS = .TRUE. CALL ZMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, & KEEP(1), KEEP8(1), & id%MYID, id%COMM, & id%N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), id%NSLAVES, & id%INFO, id%INFOG, PROK, MP, PROKG, MPG & ) C END IF C ------------------------- C Define a specific mapping C for the user C ------------------------- IF ( id%MYID. eq. MASTER .AND. KEEP(54) .eq. 1 ) THEN IF (associated( id%MAPPING)) THEN DEALLOCATE( id%MAPPING) ENDIF allocate( id%MAPPING(id%KEEP8(28)), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28), INFO(2)) IF ( LPOK ) THEN WRITE(LP, 150) 'id%MAPPING' END IF GOTO 92 END IF allocate(IWtemp( id%N ), stat=allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-7 INFO(2)=id%N IF ( LPOK ) THEN WRITE(LP, 150) 'IWtemp(N)' END IF GOTO 92 END IF IF ( id%KEEP8(28) .EQ. 0_8 ) THEN IRN_PTR => IDUMMY_ARRAY JCN_PTR => IDUMMY_ARRAY ELSE IRN_PTR => id%IRN JCN_PTR => id%JCN ENDIF CALL ZMUMPS_BUILD_MAPPING( & id%N, id%MAPPING(1), id%KEEP8(28), & IRN_PTR(1),JCN_PTR(1), id%PROCNODE_STEPS(1), & id%STEP(1), & id%NSLAVES, id%SYM_PERM(1), & id%FILS(1), IWtemp, id%KEEP(1),id%KEEP8(1), & id%root%MBLOCK, id%root%NBLOCK, & id%root%NPROW, id%root%NPCOL ) DEALLOCATE( IWtemp ) 92 CONTINUE END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 C 500 CONTINUE C Deallocate allocated working space IF (allocated(PROCNODE)) DEALLOCATE(PROCNODE) IF (allocated(XNODEL)) DEALLOCATE(XNODEL) IF (allocated(NODEL)) DEALLOCATE(NODEL) IF (allocated(IPOOL)) DEALLOCATE(IPOOL) IF (allocated(SIZEOFBLOCKS)) DEALLOCATE(SIZEOFBLOCKS) IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT_BLOCK) CALL MUMPS_AB_FREE_LMAT(LUMAT) CALL MUMPS_AB_FREE_LMAT(LUMAT_REMAP) CALL MUMPS_AB_FREE_GCOMP(GCOMP) CALL MUMPS_AB_FREE_GCOMP(GCOMP_DIST) C Standard deallocations (error or not) IF (associated(NFSIZPTR)) DEALLOCATE(NFSIZPTR) IF (associated(FREREPTR)) DEALLOCATE(FREREPTR) IF (associated(FILSPTR)) DEALLOCATE(FILSPTR) IF (associated(id%BLKPTR).AND.BLKPTR_ALLOCATED) THEN DEALLOCATE(id%BLKPTR) nullify(id%BLKPTR) ENDIF IF (associated(id%BLKVAR).AND.BLKVAR_ALLOCATED) THEN DEALLOCATE(id%BLKVAR) nullify(id%BLKVAR) ENDIF KEEP8(26)=max(1_8,KEEP8(26)) KEEP8(27)=max(1_8,KEEP8(27)) RETURN 110 FORMAT(/' ****** ANALYSIS STEP ********'/) 112 FORMAT(/' MEMORY ESTIMATIONS ... '/ & ' Estimations with standard Full-Rank (FR) factorization:') 145 FORMAT(' ELAPSED TIME SPENT IN BLR CLUSTERING =',F12.4) 150 FORMAT( & /' ** FAILURE DURING ZMUMPS_ANA_DRIVER, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_ANA_DRIVER SUBROUTINE ZMUMPS_ANA_CHECK_KEEP(id) C This subroutine decodes the control parameters, C stores them in the KEEP array, and performs a C consistency check on the KEEP array. USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id C internal variables INTEGER :: LP, MP, MPG, I INTEGER :: MASTER LOGICAL :: PROK, PROKG, LPOK PARAMETER( MASTER = 0 ) LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) C Re-intialize few KEEPs entries corresponding C to stat that are incremented such C the number of split nodes: id%KEEP(61)=0 IF (id%MYID.eq.MASTER) THEN id%KEEP(256) = id%ICNTL(7) ! copy ordering option id%KEEP(252) = id%ICNTL(32) IF (id%KEEP(252) < 0 .OR. id%KEEP(252) > 1 ) THEN id%KEEP(252) = 0 ENDIF C Which factors to store id%KEEP(251) = id%ICNTL(31) IF (id%KEEP(251) < 0 .OR. id%KEEP(251) > 2 ) THEN id%KEEP(251)=0 ENDIF C For unsymmetric matrices, if forward solve C performed during facto, C no reason to store L factors at all. Reset C KEEP(251) accordingly... except if the user C tells that no solve is needed. IF (id%KEEP(50) .EQ. 0 .AND. id%KEEP(252).EQ.1) THEN IF (id%KEEP(251) .NE. 1) id%KEEP(251) = 2 ENDIF C Symmetric case, even if no backward needed, C store all factors IF (id%KEEP(50) .NE.0 .AND. id%KEEP(251) .EQ. 2) THEN id%KEEP(251) = 0 ENDIF C Case of solve not needed: IF (id%KEEP(251) .EQ. 1) THEN id%KEEP(201) = -1 C In that case, id%ICNTL(22) will C be ignored in future phases ELSE C Reset id%KEEP(201) -- typically for the case C of a previous analysis with KEEP(201)=-1 id%KEEP(201) = 0 ENDIF IF (id%KEEP(252).EQ.1) THEN id%KEEP(253) = id%NRHS IF (id%KEEP(253) .LE. 0) THEN id%INFO(1)=-42 id%INFO(2)=id%NRHS RETURN ENDIF ELSE id%KEEP(253) = 0 ENDIF ENDIF IF ( (id%KEEP(24).NE.0) .AND. & id%NSLAVES.eq.1 ) THEN id%KEEP(24) = 0 END IF IF ( (id%KEEP(24).EQ.0) .AND. & id%NSLAVES.GT.1 ) THEN id%KEEP(24) = 8 ENDIF IF ( (id%KEEP(24).NE.0) .AND. (id%KEEP(24).NE.1) .AND. & (id%KEEP(24).NE.8) .AND. (id%KEEP(24).NE.10) .AND. & (id%KEEP(24).NE.12) .AND. (id%KEEP(24).NE.14) .AND. & (id%KEEP(24).NE.16) .AND. (id%KEEP(24).NE.18)) THEN id%KEEP(24) = 8 END IF C**************************************************** C C The master is doing most of the work C C NOTE: Treatment of the errors on the master= C Go to the next SPMD part of the code in which C the first statement must be a call to PROPINFO C C**************************************************** C ========================================= C Check (raise error or modify) some input C parameters or KEEP values on the master. C ========================================= id%KEEP8(21) = int(id%KEEP(85),8) IF ( id%MYID .EQ. MASTER ) THEN C -- OOC/Incore strategy IF (id%KEEP(201).NE.-1) THEN id%KEEP(201)=id%ICNTL(22) IF (id%KEEP(201) .GT. 0) THEN #if defined(OLD_OOC_NOPANEL) id%KEEP(201)=2 #else id%KEEP(201)=1 #endif ENDIF ENDIF C ---------------------------- C Save id%ICNTL(18) (distributed C matrix on entry) in id%KEEP(54) C ---------------------------- id%KEEP(54) = id%ICNTL(18) IF ( id%KEEP(54) .LT. 0 .or. id%KEEP(54).GT.3 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(18).' WRITE(MPG, *) ' Used 0 ie matrix not distributed' END IF id%KEEP(54) = 0 END IF IF ( id%KEEP(54) .EQ. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Option id%ICNTL(18)=1 is obsolete.' WRITE(MPG, *) ' We recommend not to use it.' WRITE(MPG, *) ' It will disappear in a future release' END IF END IF C ----------------------------------------- C Save id%ICNTL(5) (matrix format) in id%KEEP(55) C ----------------------------------------- id%KEEP(55) = id%ICNTL(5) IF ( id%KEEP(55) .LT. 0 .OR. id%KEEP(55) .GT. 1 ) THEN IF ( PROKG ) THEN WRITE(MPG, *) ' Out-of-range value for id%ICNTL(5).' WRITE(MPG, *) ' Used 0 ie matrix is assembled' END IF id%KEEP(55) = 0 END IF id%KEEP(60) = id%ICNTL(19) IF ( id%KEEP( 60 ) .LE. 0 ) id%KEEP( 60 ) = 0 IF ( id%KEEP( 60 ) .GT. 3 ) id%KEEP( 60 ) = 0 IF (id%KEEP(60) .NE. 0 .AND. id%SIZE_SCHUR == 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Schur option ignored because SIZE_SCHUR=0' ENDIF id%KEEP(60)=0 END IF C --------------------------------------- C Save SIZE_SCHUR in a KEEP, for possible C check at factorization and solve phases C --------------------------------------- IF ( id%KEEP(60) .NE.0 ) THEN id%KEEP(116) = id%SIZE_SCHUR IF (id%SIZE_SCHUR .LT. 0 .OR. id%SIZE_SCHUR .GE. id%N) THEN id%INFO(1)=-49 id%INFO(2)=id%SIZE_SCHUR RETURN ENDIF C List of Schur variables provided by user. IF ( .NOT. associated( id%LISTVAR_SCHUR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 8 RETURN ELSE IF (size(id%LISTVAR_SCHUR) 0 .AND. id%NBLOCK > 0 .AND. & id%NPROW > 0 .AND. id%NPCOL > 0 ) THEN IF (id%NPROW *id%NPCOL .LE. id%NSLAVES) THEN C We will eventually have to "symmetrize the C Schur complement. For that NBLOCK and MBLOCK C must be equal. IF (id%MBLOCK .NE. id%NBLOCK ) THEN id%INFO(1)=-31 id%INFO(2)=id%MBLOCK - id%NBLOCK RETURN ENDIF ENDIF ENDIF ENDIF C Check the ordering strategy and compatibility with C other control parameters id%KEEP(244) = id%ICNTL(28) id%KEEP(245) = id%ICNTL(29) #if ! defined(parmetis) && ! defined(parmetis3) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 2)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("ParMETIS not available.")') END IF RETURN END IF #endif #if ! defined(ptscotch) IF ((id%KEEP(244) .EQ. 2) .AND. (id%KEEP(245) .EQ. 1)) THEN id%INFO(1) = -38 IF ( LPOK ) THEN WRITE(LP,'("PT-SCOTCH not available.")') END IF RETURN END IF #endif C Analysis strategy is set to automatic in case of out-of-range values. IF((id%KEEP(244) .GT. 2) .OR. & (id%KEEP(244) .LT. 0)) id%KEEP(244)=0 IF(id%KEEP(244) .EQ. 0) THEN ! Automatic C One could check for availability of parallel ordering C tools, or for possible options incompatible with // C analysis to decide (e.g. avoid returning an error if C // analysis not compatible with some option but user C lets MUMPS decide to choose sequential or paralllel C analysis) C Current strategy for automatic is sequential analysis id%KEEP(244) = 1 ELSE IF (id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(55) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(5), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if the")') WRITE(LP, & '("matrix is not assembled")') ENDIF RETURN ELSE IF(id%KEEP(60) .NE. 0) THEN id%INFO(1) = -39 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(19), ICNTL(28)")') WRITE(LP, & '("Parallel analysis is not possible if SCHUR")') WRITE(LP, & '("complement must be returned")') ENDIF RETURN END IF C In the case where there are too few processes to do C the parallel analysis we simply revert to sequential version IF(id%NSLAVES .LT. 2) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Too few processes. & Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN C Scotch necessarily available because pt-scotch C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN C Metis necessarily available because parmetis C is, otherwise an error would have occurred IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF C In the case where there the input matrix is too small to do C the parallel analysis we simply revert to sequential version IF(id%N .LE. 50) THEN id%KEEP(244) = 1 IF(PROKG) WRITE(MPG, & '("Input matrix is too small for the parallel & analysis. Reverting to sequential analysis")',advance='no') IF(id%KEEP(245) .EQ. 1) THEN IF(PROKG) WRITE(MPG, '(" with SCOTCH.")') id%KEEP(256) = 3 ELSE IF(id%KEEP(245) .EQ. 2) THEN IF(PROKG) WRITE(MPG, '(" with Metis.")') id%KEEP(256) = 5 ELSE IF(PROKG) WRITE(MPG, '(".")') id%KEEP(256) = 7 END IF END IF END IF id%INFOG(32) = id%KEEP(244) IF ( (id%KEEP(244) .EQ. 1) .AND. & (id%KEEP(256) .EQ. 1) ) THEN C ordering given, PERM_IN must be of size N IF ( .NOT. associated( id%PERM_IN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN ELSE IF ( size( id%PERM_IN ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 3 RETURN END IF ENDIF C Check KEEP(9-10) for level 2 IF (id%KEEP(9) .LE. 1 ) id%KEEP(9) = 500 IF ( id%KEEP8(21) .GT. 0_8 ) THEN IF ((id%KEEP8(21).LE.1_8) .OR. & (id%KEEP8(21).GT.int(id%KEEP(9),8))) & id%KEEP8(21) = int(min(id%KEEP(9),100),8) ENDIF C IF (id%KEEP(48). EQ. 1 ) id%KEEP(48) = -12345 C IF ( (id%KEEP(48).LT.0) .OR. (id%KEEP(48).GT.5) ) THEN id%KEEP(48)=5 ENDIF C Schur C Given ordering must be compatible with Schur variables. IF ( (id%KEEP(60) .NE. 0) .AND. (id%KEEP(256) .EQ. 1) ) THEN DO I = 1, id%SIZE_SCHUR IF (id%PERM_IN(id%LISTVAR_SCHUR(I)) & .EQ. id%N-id%SIZE_SCHUR+I) & CYCLE C ------------------------------- C Problem with PERM_IN: -22/3 C Above constrained explained in C doc of PERM_IN in user guide. C ------------------------------- id%INFO(1) = -4 id%INFO(2) = id%LISTVAR_SCHUR(I) RETURN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Ignoring user-ordering, because incompatible with Schur.' WRITE(MPG,'(A)') ' ** id%ICNTL(7) treated as 0.' END IF EXIT ENDDO END IF C C Note that schur is not compatible with C C 1/Max-trans DONE C 2/Null space C 3/Ordering given DONE C 4/Scaling C 5/Iterative Refinement C 6/Error analysis C 7/Parallel Analysis C C Graph modification prior to ordering (id%ICNTL(12) option) C id%KEEP (95) will hold the eventually modified value of id%ICNTL(12) C id%KEEP(95) = id%ICNTL(12) C reset to usual ordering (KEEP(95)=1) C - when matrix is not general symmetric C - for out-of-range values IF (id%KEEP(50).NE.2) id%KEEP(95) = 1 IF ((id%KEEP(95).GT.3).OR.(id%KEEP(95).LT.0)) id%KEEP(95) = 1 C MAX-TRANS C C id%KEEP (23) will hold the eventually modified value of id%ICNTL(6) C (maximum transversal if >= 1) C id%KEEP(23) = id%ICNTL(6) C C C -------------------------------------------- C Avoid max-trans unsymmetric permutation in case of C matrix is symmetric with SYM=1 or C ordering is given, C or matrix is in element form, or Schur is asked C or initial matrix is distributed C -------------------------------------------- IF (id%KEEP(23).LT.0.OR.id%KEEP(23).GT.7) id%KEEP(23) = 0 C still forbid max trans for SYM=1 case IF ( id%KEEP(50) .EQ. 1 ) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not needed with SYM=1 factorization' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) ignored: not needed with SYM=1 factorization' END IF ENDIF id%KEEP(95) = 1 END IF C IF (id%KEEP(60) .GT. 0) THEN IF (id%KEEP(23) .NE. 0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Max-trans not allowed because of Schur' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Scaling during analysis not allowed because of Schur' ENDIF id%KEEP(52) = 0 ENDIF C also forbid compressed/constrained ordering... IF (id%KEEP(95) .GT. 1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option not allowed because of Schur' END IF ENDIF id%KEEP(95) = 1 END IF IF ( (id%KEEP(23) .NE. 0) .AND. (id%KEEP(256).EQ.1)) THEN id%KEEP(23) = 0 IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because ordering is given' END IF END IF IF ( id%KEEP(256) .EQ. 1 ) THEN IF (id%KEEP(95) > 1 .AND. PROKG) THEN WRITE(MPG,'(A)') & ' ** ICNTL(12) option incompatible with given ordering' END IF id%KEEP(95) = 1 END IF IF (id%KEEP(54) .NE. 0) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'because matrix is distributed' END IF id%KEEP(23) = 0 ENDIF IF (id%KEEP(52).EQ.-2) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Scaling (ICNTL(8)) during analysis not ', & 'allowed because matrix is distributed)' ENDIF ENDIF id%KEEP(52) = 0 IF (id%KEEP(95) .GT. 1 .AND. MPG.GT.0) THEN WRITE(MPG,'(A,A)') & ' ** ICNTL(12) option not allowed because matrix is ', & 'distributed' ENDIF id%KEEP(95) = 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN IF( id%KEEP(23) .NE. 0 ) THEN IF (PROKG) THEN WRITE(MPG,'(A,A)') & ' ** Maximum transversal (ICNTL(6)) not allowed ', & 'for matrices in elemental format' END IF id%KEEP(23) = 0 ENDIF IF (PROKG .AND. id%KEEP(52).EQ.-2) THEN WRITE(MPG,'(A)') & ' ** Scaling (ICNTL(8)) not allowed ', & 'for matrices in elemental format' ENDIF id%KEEP(52) = 0 id%KEEP(95) = 1 ENDIF C In the case where parallel analysis is done, column permutation C is not allowed IF(id%KEEP(244) .EQ. 2) THEN IF(id%KEEP(23) .EQ. 7) THEN C Automatic hoice: set it to 0 id%KEEP(23) = 0 ELSE IF (id%KEEP(23) .GT. 0) THEN id%INFO(1) = -39 id%KEEP(23) = 0 IF (LPOK) THEN WRITE(LP, & '("Incompatible values for ICNTL(6), ICNTL(28)")') WRITE(LP, & '("Maximum transversal not allowed & in parallel analysis")') ENDIF RETURN END IF END IF C -------------------------------------------- C Avoid distributed entry for element matrix. C -------------------------------------------- IF ( id%KEEP(54) .NE. 0 .AND. id%KEEP(55) .NE. 0 ) THEN id%KEEP(54) = 0 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ** Distributed entry not available for element matrix' END IF ENDIF C ---------------------------------- C Choice of symbolic analysis option C ---------------------------------- IF (id%ICNTL(58).NE.1 .and. id%ICNTL(58).NE.2 & .and. id%ICNTL(58).NE.3 ) THEN id%KEEP(106)=1 C Automatic choice leads to new symbolic C factorization except(see below) if KEEP(256)==1. ELSE id%KEEP(106)=id%ICNTL(58) IF (id%KEEP(106).EQ.3) THEN C option not available id%KEEP(106)=1 ENDIF ENDIF C modify input parameters to avoid incompatible C input data between ordering, scaling and maxtrans C note that if id%ICNTL(12)/id%KEEP(95) = 0 then C the automatic choice will be done in ANA_O IF(id%KEEP(50) .EQ. 2) THEN C LDLT case IF( .NOT. associated(id%A) ) THEN C constraint ordering can be computed only if values are C given to analysis IF(id%KEEP(95) .EQ. 3) THEN id%KEEP(95) = 2 ENDIF ENDIF IF(id%KEEP(95) .EQ. 3 .AND. id%KEEP(256) .NE. 2) THEN C if constraint and ordering is not AMF then use compress IF (PROK) WRITE(MP,*) & 'WARNING: ZMUMPS_ANA_O constrained ordering not ', & 'available with selected ordering' id%KEEP(95) = 2 ENDIF IF(id%KEEP(95) .EQ. 3) THEN C if constraint ordering required then we need to compute scaling C and max trans C NOTE that if we enter this condition then C id%A is associated because of the test above: C (IF( .NOT. associated(id%A) ) THEN) id%KEEP(23) = 5 id%KEEP(52) = -2 ELSE IF(id%KEEP(95) .EQ. 2 .AND. & (id%KEEP(23) .EQ. 0 .OR. id%KEEP(23) .EQ. 7) ) THEN C compressed ordering requires max trans but not necessary scaling IF( associated(id%A) ) THEN id%KEEP(23) = 5 ELSE C we can do compressed ordering without C information on the numerical values: C a maximum transversal already provides C information on the location of off-diagonal C nonzeros which can be candidates for 2x2 C pivots id%KEEP(23) = 1 ENDIF ELSE IF(id%KEEP(95) .EQ. 1) THEN id%KEEP(23) = 0 ELSE IF(id%KEEP(95) .EQ. 0 .AND. id%KEEP(23) .EQ. 0) THEN C if max trans desactivated then the automatic choice for type of ord C is set to 1, which means that we will use usual ordering C (no constraints or compression) id%KEEP(95) = 1 ENDIF ELSE id%KEEP(95) = 1 ENDIF C -------------------------------- C Save ICNTL(56) (QR) in KEEP(53) C Will be broadcasted to all other C nodes in routine ZMUMPS_BDCAST C -------------------------------- id%KEEP(53)=0 IF(id%KEEP(86).EQ.1)THEN C Force the exchange of both the memory and flops information during C the factorization IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF IF(id%KEEP(48).EQ.5)THEN IF(id%KEEP(50).EQ.0)THEN id%KEEP(87)=50 id%KEEP(88)=50 ELSE id%KEEP(87)=70 id%KEEP(88)=70 ENDIF ENDIF IF((id%NSLAVES.EQ.1).AND.(id%KEEP(76).GT.3))THEN id%KEEP(76)=2 ENDIF IF(id%KEEP(81).GT.0)THEN IF(id%KEEP(47).LT.2) id%KEEP(47)=2 ENDIF C C -- Save Block Low Rank input parameter id%KEEP(494) = id%ICNTL(35) IF (id%KEEP(494).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(494)= 2 ENDIF IF ( id%KEEP(494).EQ.4) id%KEEP(494)=0 IF ((id%KEEP(494).LT.0).OR.(id%KEEP(494).GT.4)) THEN C Out of range values treated as 0 id%KEEP(494) = 0 ENDIF IF(id%KEEP(494).NE.0) THEN C test BLR incompatibilities C id%KEEP(464) = id%ICNTL(38) IF (id%KEEP(464).LT.0.OR.(id%KEEP(464).GT.1000)) THEN C Out of range values treated as 0 id%KEEP(464) = 0 ENDIF C LR is incompatible with elemental matrices, forbid it at analysis IF (id%KEEP(55).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible " & ,"with elemental matrices" C BLR for elt entry might be developed in the future id%INFO(1)=-800 id%INFO(2)=5 RETURN ENDIF C C LR incompatible with forward in facto IF (id%KEEP(252).NE.0) THEN IF (LPOK) WRITE(LP,*) & " *** BLR feature currently incompatible" & ," with forward during factorization" id%INFO(1) = -43 id%INFO(2) = 35 RETURN ENDIF C ENDIF C IF(id%KEEP(494).NE.0) THEN C id%KEEP(469)=0,1,2,3,4 IF ((id%KEEP(469).GT.4).OR.(id%KEEP(469).LT.0)) THEN id%KEEP(469)=0 ENDIF C Not implemented yet IF (id%KEEP(469).EQ.4) id%KEEP(469)=0 C id%KEEP(471)=-1,0,1 IF ((id%KEEP(471).LT.-1).AND.(id%KEEP(471).GT.1)) THEN id%KEEP(471)=-1 ENDIF C id%KEEP(472)=0 or 1 IF ((id%KEEP(472).NE.0).AND.(id%KEEP(472).NE.1)) THEN id%KEEP(472)=1 ENDIF C id%KEEP(475)=0,1,2,3 IF ((id%KEEP(475).GT.3).OR.(id%KEEP(475).LT.0)) THEN id%KEEP(475)=0 ENDIF C id%KEEP(482)=0,1,2,3 IF ((id%KEEP(482).GT.3).OR.(id%KEEP(482).LT.0)) THEN id%KEEP(482)=0 ENDIF IF((id%KEEP(487).LT.0)) THEN id%KEEP(487)= 2 ! default value ENDIF C id%KEEP(488)>0 IF((id%KEEP(488).LE.0)) THEN id%KEEP(488)= 8*id%KEEP(6) ENDIF C id%KEEP(490)>0 IF((id%KEEP(490).LE.0)) THEN id%KEEP(490) = 128 ENDIF C KEEP(491)>0 IF((id%KEEP(491).LE.0)) THEN id%KEEP(491) = 1000 ENDIF ENDIF C id%KEEP(13) = 0 C Analysis by Blocks id%KEEP(13) = id%ICNTL(15) IF (id%KEEP(13).GT.1) THEN CV0 out-of range values id%KEEP(13) = 0 ENDIF IF (id%KEEP(13).LT.0) THEN IF (mod(id%N,-id%KEEP(13)) .NE.0) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with N=", id%N ENDIF id%INFO(1) = -57 id%INFO(2) = 1 ENDIF IF (associated(id%BLKPTR)) THEN IF ( LPOK ) THEN WRITE(LP,'(A,I8)') & " ICNTL(15)=", id%ICNTL(15), & " is incompatible with BLKPTR provided by user" ENDIF id%INFO(1) = -57 id%INFO(2) = 4 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) & ) & THEN IF ((id%KEEP(54).EQ.3).AND.(id%KEEP(244).NE.2)) THEN id%KEEP(13)=-1 ENDIF ENDIF IF ( (id%KEEP(13).EQ.0 ) .AND. & (.NOT. associated(id%BLKPTR)) .AND. & (.NOT. associated(id%BLKVAR)) .AND. & (id%KEEP(244).NE.2) & ) & THEN C unsymmetic assembled matrices with or without BLR, C also in case of centralized matrix (if C matrix is distributed, then KEEP(13) has C been set to -1 in the block above) IF (id%KEEP(50).EQ.0.AND. id%KEEP(55).EQ.0) THEN C Respect decision taken for Maxtrans C since it will be switch off because C if one activates the analysis by block IF ( (id%KEEP(23).LT.0) .OR. (id%KEEP(23).GT.7) & ) THEN id%KEEP(13)=-1 ENDIF ENDIF ENDIF IF ( (id%KEEP(13).EQ.0) .AND. & (id%KEEP(55).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with elemental matrices" C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(106).NE.1) & ) THEN IF (PROKG) WRITE(MPG,'(A,A,I4)') & " ** Analysis by block compatible ", & "ONLY with SYMQAMD based symbolic factorization ", & id%KEEP(106) C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(244).EQ.2) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with parallel ordering " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF ( (id%KEEP(13).NE.0) .AND. & (id%KEEP(60).NE.0) & ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & " ** Analysis by block is incompatible ", & "with Schur " C switch off analysis by block id%KEEP(13)= 0 ENDIF IF (id%KEEP(13).NE.0) THEN C Maximum transversal not compatible with analysis by block IF (id%KEEP(23).NE.0) THEN C in case of automatic choice (id%KEEP(27).EQ.7) C do not print message IF (PROKG.AND.id%KEEP(23).NE.7) WRITE(MPG,'(A,A)') & " ** Maximum transversal (ICNTL(6)) ", & "not compatible with analysis by block" C switch off max transversal id%KEEP(23)= 0 ENDIF C - compression for LDLT IF (id%KEEP(95).NE.1) THEN C in case of automatic choice (id%KEEP(95).EQ.0) C do not print message IF (PROKG.AND.id%KEEP(95).NE.0) WRITE(MPG,'(A,A)') & " ** ICNTL(12) not compatible with ", & " analysis by block" C switch off 2x2 preprocessing for symmetric matrices id%KEEP(95) = 1 ENDIF ENDIF C C end id%MYID.EQ.MASTER END IF RETURN END SUBROUTINE ZMUMPS_ANA_CHECK_KEEP SUBROUTINE ZMUMPS_GATHER_MATRIX(id) C This subroutine gathers a distributed matrix C on the host node USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(ZMUMPS_STRUC) :: id C local variables INTEGER, ALLOCATABLE :: REQPTR(:,:) INTEGER(8), ALLOCATABLE :: MATPTR(:) INTEGER(8), ALLOCATABLE :: MATPTR_cp(:) INTEGER(8) :: IBEG8, IEND8 INTEGER :: INDX INTEGER :: LP, MP, MPG, I, K INTEGER(8) :: I8 LOGICAL :: PROK, PROKG C C messages are split into blocks of size BLOCKSIZE C (smaller than IOVFLO (=2^31-1)) C on all processors INTEGER(4) :: IOVFLO INTEGER :: BLOCKSIZE INTEGER :: MAX_NBBLOCK_loc, NBBLOCK_loc INTEGER :: SIZE_SENT, NRECV LOGICAL :: OMP_FLAG, I_AM_SLAVE INTEGER(8) :: NZ_loc8 C for validation only: INTEGER :: NB_BLOCKS, NB_BLOCK_SENT LP = id%ICNTL( 1 ) MP = id%ICNTL( 2 ) MPG = id%ICNTL( 3 ) C LP : errors C MP : INFO PROK = (( MP .GT. 0 ).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) C iovflo = huge(INTEGER, kind=4) IOVFLO = huge(IOVFLO) C we do not want too large messages BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) IF ( id%KEEP(46) .EQ. 0 .AND. id%MYID .EQ. MASTER ) THEN C host-node mode: master has no entries. id%KEEP8(29) = 0_8 END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------- C Allocate small arrays for pointers C into arrays IRN/JCN C ----------------------------------- ALLOCATE( MATPTR( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF ALLOCATE( MATPTR_cp( id%NPROCS ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%NPROCS IF ( LP .GT. 0 ) THEN WRITE(LP, 150) ' array MATPTR' END IF GOTO 13 END IF C ----------------------------------- C Allocate a small array for requests C ----------------------------------- ALLOCATE( REQPTR( id%NPROCS-1, 2 ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 2 * (id%NPROCS-1) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array REQPTR' END IF GOTO 13 END IF C -------------------- C Allocate now IRN/JCN C -------------------- ALLOCATE( id%IRN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array IRN' END IF GOTO 13 END IF ALLOCATE( id%JCN( id%KEEP8(28) ), STAT = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SETI8TOI4(id%KEEP8(28),id%INFO(2)) IF ( LP .GT. 0 ) THEN WRITE(LP, 150) 'array JCN' END IF GOTO 13 END IF END IF 13 CONTINUE C Propagate errors CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) < 0 ) RETURN C ------------------------------------- C Get numbers of non-zeros for everyone C and count total and maximum C nb of blocks of size BLOCKSIZE C that slaves will sent C ------------------------------------- IF ( id%MYID .EQ. MASTER ) THEN C each block will correspond to 2 messages (IRN_LOC,JCN_LOC) NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, id%NPROCS - 1 CALL MPI_RECV( MATPTR( I+1 ), 1, & MPI_INTEGER8, I, & COLLECT_NZ, id%COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(MATPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc END DO IF ( id%KEEP(46) .eq. 0 ) THEN MATPTR( 1 ) = 1_8 ELSE NZ_loc8=id%KEEP8(29) MATPTR( 1 ) = NZ_loc8 + 1_8 END IF C -------------- C Build pointers C -------------- DO I = 2, id%NPROCS MATPTR( I ) = MATPTR( I ) + MATPTR( I-1 ) END DO ELSE NZ_loc8=id%KEEP8(29) CALL MPI_SEND( NZ_loc8, 1, MPI_INTEGER8, MASTER, & COLLECT_NZ, id%COMM, IERR ) END IF IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------------- C Bottleneck is here master; use synchronous send C for slaves, but asynchronous receives on master C Then while master receives indices do the local C copies for better overlap. C (If master has other things to do, he could try C to do them here.) C ------------------------------------ C copy pointers to position in IRN/JCN MATPTR_cp = MATPTR IF ( id%KEEP8(29) .NE. 0_8 ) THEN OMP_FLAG = ( id%KEEP8(29).GE.50000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1,id%KEEP8(29) id%IRN(I8) = id%IRN_loc(I8) id%JCN(I8) = id%JCN_loc(I8) ENDDO !$OMP END PARALLEL DO ENDIF C C Compute position for each block to be received C and store it. NB_BLOCKS = 0 C at least one slave will send MAX_NBBLOCK_loc C couple of messages (IRN_loc/JCN_loc) DO K = 1, MAX_NBBLOCK_loc C Post irecv for all messages from proc I C that have been sent NRECV = 0 DO I = 1, id%NPROCS - 1 C Check if message was sent IBEG8 = MATPTR_cp( I ) IF ( IBEG8 .LT. MATPTR(I+1)) THEN C Count number of request in NRECV NRECV = NRECV + 2 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & MATPTR(I+1)-1_8) C update pointer for receiving messages C from proc I in MATPTR_cp: MATPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 C CALL MPI_IRECV( id%IRN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_IRN, id%COMM, REQPTR(I,1), IERR ) C CALL MPI_IRECV( id%JCN(IBEG8), SIZE_SENT, MPI_INTEGER, & I, COLLECT_JCN, id%COMM, REQPTR(I,2), IERR ) ELSE REQPTR( I,1 ) = MPI_REQUEST_NULL REQPTR( I,2 ) = MPI_REQUEST_NULL ENDIF END DO C Wait set of messages corresponding to current block C ( we dont exploit the fact that C messages are not overtaking C (if sent by one source to the same destination) ) C C Loop on only non MPI_REQUEST_NULL requests DO I = 1, NRECV CALL MPI_WAITANY & ( 2 * (id%NPROCS-1), REQPTR( 1, 1 ), INDX, & STATUS, IERR ) ENDDO C C process next block END DO DEALLOCATE( REQPTR ) DEALLOCATE( MATPTR ) DEALLOCATE( MATPTR_cp ) C end of reception by master ELSE C ----------------------------- C Send only if size is not zero C ----------------------------- IF ( id%KEEP8(29) .NE. 0_8 ) THEN NZ_loc8=id%KEEP8(29) C send by blocks of size BLOCKSIZE DO I8=1_8, NZ_loc8, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZ_loc8-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZ_loc8-I8+1_8) ENDIF CALL MPI_SEND( id%IRN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_IRN, id%COMM, IERR ) CALL MPI_SEND( id%JCN_loc(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & COLLECT_JCN, id%COMM, IERR ) END DO END IF END IF RETURN 150 FORMAT( &/' ** FAILURE DURING ZMUMPS_GATHER_MATRIX, DYNAMIC ALLOCATION OF', & A30) END SUBROUTINE ZMUMPS_GATHER_MATRIX SUBROUTINE ZMUMPS_DUMP_PROBLEM(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C If id%WRITE_PROBLEM has been set by the user, C possibly on all processors in case of distributed C matrix, open a file and dumps the matrix and/or C the right hand side. In case the last characters C of id.WRITE_PROBLEM are "bin" (uppercase letters C are also accepted), then the matrix is written C in binary stream format (a C routine is called to C avoid depending on the access='stream' mode that C is only available since Fortran 2003). In that case, C a small header file is also written. C Otherwise, this subroutine calls C ZMUMPS_DUMP_MATRIX (to write the matrix in C matrix-market format) and ZMUMPS_DUMP_RHS. C The routine should be called on all MPI processes. C C Examples: C 1/ WRITE_PROBLEM='mymatrix.txt', centralized matrix C mymatrix.txt contains the matrix in matrix-market format C 2/ WRITE_PROBLEM='mymatrix.txt', distributed matrix C mymatrix.txt contains the portion of the matrix C on process , in matrix-market format C 3/ WRITE_PROBLEM='mymatrix.bin', centralized matrix C mymatrix.bin contains the matrix in binary format C mymatrix.header contains a short description in text format, C with the first line identical to the one of C a matrix-market format C 4/ WRITE_PROBLEM='mymatrix.bin', distributed matrix C mymatrix.bin contains the portion of the matrix C on process , in binary format C C mymatrix.header contains a short description in text format, C with the first line identical to matrix-market format C C If a centralized, dense, RHS is available, it is also written, C either in matrix-market or binary format (if WRITE_PROBLEM C has a .bin extension). In that case the filename for the RHS C is WRITE_PROBLEM//".rhs". If written in binary form, information C on the RHS is also provided in the header file. C INCLUDE 'mpif.h' C C Arguments C ========= C TYPE(ZMUMPS_STRUC) :: id C C Local variables C =============== C INTEGER :: MASTER, IERR, I INTEGER :: IUNIT LOGICAL :: IS_ELEMENTAL LOGICAL :: IS_DISTRIBUTED LOGICAL :: NAME_INITIALIZED INTEGER :: DO_WRITE, DO_WRITE_CHECK CHARACTER(LEN=20) :: IDSTR LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: L LOGICAL :: BINARY_FORMAT, DUMP_RHS, & DUMP_BLKPTR, DUMP_BLKVAR INTEGER :: IS_A_PROVIDED, IS_A_PROVIDED_GLOB COMPLEX(kind=8), TARGET :: A_DUMMY(1) INTEGER, TARGET :: IRN_DUMMY(1), JCN_DUMMY(1) INTEGER, POINTER, DIMENSION(:) :: IRN_PASSED, JCN_PASSED COMPLEX(kind=8), POINTER, DIMENSION(:) :: A_PASSED PARAMETER( MASTER = 0 ) IUNIT = 69 I_AM_SLAVE = ( id%MYID .NE. MASTER .OR. & ( id%MYID .EQ. MASTER .AND. & id%KEEP(46) .EQ. 1 ) ) I_AM_MASTER = (id%MYID.EQ.MASTER) NAME_INITIALIZED = id%WRITE_PROBLEM(1:20) & .NE. "NAME_NOT_INITIALIZED" BINARY_FORMAT = .FALSE. L=len_trim(id%WRITE_PROBLEM) IF (L.GT.4) THEN IF ( id%WRITE_PROBLEM(L-3:L-3) .EQ. '.' .AND. & ( id%WRITE_PROBLEM(L-2:L-2) .EQ. 'b' .OR. & id%WRITE_PROBLEM(L-2:L-2) .EQ. 'B' ) .AND. & ( id%WRITE_PROBLEM(L-1:L-1) .EQ. 'i' .OR. & id%WRITE_PROBLEM(L-1:L-1) .EQ. 'I' ) .AND. & ( id%WRITE_PROBLEM(L:L) .EQ. 'n' .OR. & id%WRITE_PROBLEM(L:L) .EQ. 'N' ) ) THEN BINARY_FORMAT = .TRUE. ENDIF ENDIF C Check if RHS should also be dumped DUMP_RHS = id%MYID.EQ.MASTER .AND. & associated(id%RHS) .AND. NAME_INITIALIZED DUMP_RHS = DUMP_RHS .AND. id%NRHS .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%N .GE. 1 DUMP_RHS = DUMP_RHS .AND. id%ICNTL(20) .EQ. 0 C Check if BLKPTR and/or BLKVAR should also be dumped DUMP_BLKPTR = .FALSE. DUMP_BLKVAR = .FALSE. C Remark: if id%KEEP(54) = 1 or 2, the structure C is centralized at analysis. Since ZMUMPS_DUMP_PROBLEM C is called at analysis phase, we define IS_DISTRIBUTED C as below, which implies that the structure of the problem C is distributed in IRN_loc/JCN_loc at analysis. C equal to IS_DISTRIBUTED = (id%KEEP(54) .EQ. 3) IS_ELEMENTAL = (id%KEEP(55) .NE. 0) IF (id%MYID.EQ.MASTER .AND. .NOT. IS_DISTRIBUTED) THEN C ==================== C Matrix is assembled C and centralized C ==================== IF (NAME_INITIALIZED) THEN IF ( BINARY_FORMAT ) THEN IF (id%KEEP8(28) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY IS_A_PROVIDED = 1 ELSE IF (associated(id%A)) THEN A_PASSED=>id%A IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN JCN_PASSED => id%JCN IS_A_PROVIDED = 0 ENDIF OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL ZMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(28), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED, & trim(id%WRITE_PROBLEM)//char(0) ) ELSE OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)) CALL ZMUMPS_DUMP_MATRIX( id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! = .FALSE., centralized & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF ELSE IF (id%KEEP(54).EQ.3) THEN C ===================== C Matrix is distributed C ===================== IF ( .NOT.NAME_INITIALIZED & .OR. .NOT. I_AM_SLAVE )THEN DO_WRITE = 0 ELSE DO_WRITE = 1 ENDIF CALL MPI_ALLREDUCE(DO_WRITE, DO_WRITE_CHECK, 1, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) C ----------------------------------------- C If yes, each processor writes its share C of the matrix in a file in matrix market C format (otherwise nothing written). We C append the process id to the filename. C Safer in case all filenames are the C same if all processors share the same C file system. C ----------------------------------------- IF (DO_WRITE_CHECK.EQ.id%NSLAVES .AND. I_AM_SLAVE) THEN WRITE(IDSTR,'(I9)') id%MYID_NODES IF (BINARY_FORMAT) THEN IF (id%KEEP8(29) .EQ. 0_8) THEN C Special case of empty matrix A_PASSED => A_DUMMY IRN_PASSED => IRN_DUMMY JCN_PASSED => JCN_DUMMY C (consider that A is provided when NNZ_loc=0) IS_A_PROVIDED = 1 ELSE IF (associated(id%A_loc)) THEN A_PASSED=>id%A_loc IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 1 ELSE A_PASSED => A_DUMMY IRN_PASSED => id%IRN_loc JCN_PASSED => id%JCN_loc IS_A_PROVIDED = 0 ENDIF CALL MPI_ALLREDUCE( IS_A_PROVIDED, & IS_A_PROVIDED_GLOB, 1, & MPI_INTEGER, MPI_PROD, id%COMM_NODES, IERR ) C IS_A_PROVIDED_GLOB = 1 => dump numerical values C IS_A_PROVIDED_GLOB = 0 => some processes did not provide C numerical values, dump only pattern, C and indicate this in the header IF ( id%MYID_NODES.EQ.0) THEN C Print header on first MPI worker (only one global header C file in case of distributed matrix), replacing the .bin C extension by a .header extension OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.header' ) CALL ZMUMPS_DUMP_HEADER( IUNIT, id%N, & IS_A_PROVIDED_GLOB, id%KEEP(50), IS_DISTRIBUTED, & id%NSLAVES, id%KEEP8(28), DUMP_RHS, id%NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, id%NBLK, id%ICNTL(15) ) CLOSE( IUNIT ) ENDIF CALL MUMPS_DUMPMATBINARY_C( id%N, id%KEEP8(29), & id%KEEP(35), & IRN_PASSED(1), JCN_PASSED(1), A_PASSED(1), & IS_A_PROVIDED_GLOB, & trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))//char(0) ) ELSE OPEN(IUNIT, & FILE=trim(id%WRITE_PROBLEM)//trim(adjustl(IDSTR))) CALL ZMUMPS_DUMP_MATRIX(id, & IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, ! =.TRUE., distributed & IS_ELEMENTAL, ! Elemental or not & .FALSE.) CLOSE(IUNIT) ENDIF ENDIF C ELSE ... C Nothing written in other cases. ENDIF C =============== C Right-hand side C =============== IF ( DUMP_RHS ) THEN IF (BINARY_FORMAT) THEN C dump RHS in binary format CALL MUMPS_DUMPRHSBINARY_C( id%N, id%NRHS, id%LRHS, id%RHS(1), & id%KEEP(35), & trim(id%WRITE_PROBLEM)//'.rhs'//char(0) ) ELSE C dump RHS in matrix-market format OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM) //".rhs") CALL ZMUMPS_DUMP_RHS(IUNIT, id) CLOSE(IUNIT) ENDIF ENDIF IF ( DUMP_BLKPTR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkptr' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkptr' ) ELSE ! just append '.blkptr' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkptr") ENDIF WRITE(IUNIT,'(I9)') id%NBLK DO I=1,id%NBLK+1 WRITE(IUNIT,'(I9)') id%BLKPTR(I) ENDDO CLOSE(IUNIT) ENDIF IF ( DUMP_BLKVAR ) THEN IF (BINARY_FORMAT) THEN ! suppress trailing '.bin' and use '.blkvar' OPEN( IUNIT, FILE=id%WRITE_PROBLEM(1:L-4)//'.blkvar' ) ELSE ! just append '.blkvar' OPEN(IUNIT,FILE=trim(id%WRITE_PROBLEM)//".blkvar") ENDIF DO I=1,id%N WRITE(IUNIT,'(I9)') id%BLKVAR(I) ENDDO CLOSE(IUNIT) ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_PROBLEM SUBROUTINE ZMUMPS_DUMP_HEADER( IUNIT, N, IS_A_PROVIDED_GLOB, & SYM, IS_DISTRIBUTED, NSLAVES, NNZTOT, DUMP_RHS, NRHS, & DUMP_BLKPTR, DUMP_BLKVAR, NBLK, ICNTL15 ) C C Purpose: C ======= C C Write a small header file, similar to matrix-market headers, C to accompany a matrix written in binary format. C INTEGER, INTENT(IN) :: IUNIT, N, IS_A_PROVIDED_GLOB , SYM, NSLAVES INTEGER(8), INTENT(IN) :: NNZTOT LOGICAL, INTENT(IN) :: IS_DISTRIBUTED, DUMP_RHS INTEGER, INTENT(IN) :: NRHS LOGICAL, INTENT(IN) :: DUMP_BLKPTR, DUMP_BLKVAR INTEGER, INTENT(IN) :: NBLK INTEGER, INTENT(IN) :: ICNTL15 C C Local declarations: C ================== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH C 1/ write a line identical to first line of matrix-market header IF ( IS_A_PROVIDED_GLOB .EQ. 1 ) THEN ARITH='complex' ELSE ARITH='pattern' ENDIF IF (SYM .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,'(A,A,A,A)') '%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) C 2/ indicate if matrix is distributed or centralized, C then describe binary file content and format IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,FMT='(A,I5,A)') & '% Matrix is distributed (MPI ranks=',NSLAVES,')' ELSE WRITE(IUNIT,FMT='(A)') & '% Matrix is centralized' ENDIF WRITE(IUNIT,FMT='(A)') & '% Unformatted stream IO (no record boundaries):' IF (ARITH(1:7).EQ.'pattern') THEN IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') & '% N,NNZ,IRN(1:NNZ),JCN(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% (numerical values not provided)' ELSE IF (IS_DISTRIBUTED) THEN WRITE(IUNIT,'(A)') & '% N,NNZ_loc,IRN_loc(1:NNZ_loc),JCN_loc(1:NNZ_loc),'// & 'A_loc(1:NNZ_loc)' ELSE WRITE(IUNIT,'(A)') '% N/NNZ/IRN(1:NNZ),JCN(1:NNZ),A(1:NNZ)' ENDIF WRITE(IUNIT,'(A)') '% Double complex storage' ENDIF IF ( IS_DISTRIBUTED ) THEN WRITE(IUNIT,'(A,/,A)') & '% N,IRN_loc(i),JCN_loc(i): 32 bits', & '% NNZ_loc: 64 bits' ELSE WRITE(IUNIT,'(A,/,A)') & '% N,IRN(i),JCN(i): 32 bits', & '% NNZ: 64 bits' ENDIF WRITE(IUNIT,FMT='(A,I12)') '% Matrix order: N=',N WRITE(IUNIT,FMT='(A,I12)') '% Matrix nonzeros: NNZ=',NNZTOT IF (DUMP_RHS) THEN WRITE(IUNIT,FMT='(A)') '%' WRITE(IUNIT,FMT='(A,/,A,I10,A,I5)') & '% A RHS was also written to disk by columns in binary form.', & '% Size: N rows x NRHS columns with N=',N,' NRHS=',NRHS WRITE(IUNIT,FMT='(A,I12,A)') & '% Total:',int(N,8)*int(NRHS,8),' scalar values.' WRITE(IUNIT,'(A)') '% Double complex storage' ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_HEADER SUBROUTINE ZMUMPS_DUMP_MATRIX & (id, IUNIT, I_AM_SLAVE, I_AM_MASTER, & IS_DISTRIBUTED, IS_ELEMENTAL, PATTERN_ONLY ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C This subroutine dumps a routine in matrix-market format C if the matrix is assembled, and in "MUMPS" format (see C example in the MUMPS users'guide, if the matrix is C centralized and elemental). C The routine can be called on all processors. In case of C distributed assembled matrix, each processor writes its C share as a matrix market file on IUNIT (IUNIT may have C different values on different processors). C C C C Arguments (input parameters) C ============================ C C IUNIT: should be set to the Fortran unit where C data should be written. C I_AM_SLAVE: .TRUE. except on a non working master C IS_DISTRIBUTED: .TRUE. if matrix is distributed, C i.e., if IRN_loc/JCN_loc are provided. C IS_ELEMENTAL : .TRUE. if matrix is elemental C id : main MUMPS structure C LOGICAL, intent(in) :: I_AM_SLAVE, & I_AM_MASTER, & IS_DISTRIBUTED, & IS_ELEMENTAL, & PATTERN_ONLY INTEGER, intent(in) :: IUNIT TYPE(ZMUMPS_STRUC), intent(in) :: id C C Local variables: C =============== C CHARACTER (LEN=10) :: SYMM CHARACTER (LEN=8) :: ARITH INTEGER(8) :: I8, NNZ_i C C Executable statements: C ===================== IF (I_AM_MASTER .AND. .NOT. IS_DISTRIBUTED .AND. & .NOT. IS_ELEMENTAL) THEN C ================== C CENTRALIZED MATRIX C ================== IF (id%KEEP8(28) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ, id%NZ, NNZ_i) ELSE NNZ_i=id%KEEP8(28) ENDIF IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN C Write header line: ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8), & dble(id%A(I8)), aimag(id%A(I8)) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8), & dble(id%A(I8)), aimag(id%A(I8)) ENDIF ENDDO ELSE C pattern only DO I8=1_8,id%KEEP8(28) IF (id%KEEP(50).NE.0 .AND. id%IRN(I8).LT.id%JCN(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN(I8), id%IRN(I8) ELSE WRITE(IUNIT,*) id%IRN(I8), id%JCN(I8) ENDIF ENDDO ENDIF ELSE IF ( IS_DISTRIBUTED .AND. I_AM_SLAVE ) THEN C ================== C DISTRIBUTED MATRIX C ================== IF (id%KEEP8(29) .EQ. 0_8) THEN CALL MUMPS_GET_NNZ_INTERNAL(id%NNZ_loc, id%NZ_loc, NNZ_i) ELSE NNZ_i=id%KEEP8(29) ENDIF IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN ARITH='complex' ELSE ARITH='pattern ' ENDIF IF (id%KEEP(50) .eq. 0) THEN SYMM="general" ELSE SYMM="symmetric" END IF WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix coordinate ', & trim(ARITH)," ",trim(SYMM) WRITE(IUNIT,*) id%N, id%N, NNZ_i IF ((associated(id%A_loc)).AND.(.NOT.PATTERN_ONLY)) THEN DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8), & dble(id%A_loc(I8)), aimag(id%A_loc(I8)) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8), & dble(id%A_loc(I8)), aimag(id%A_loc(I8)) ENDIF ENDDO ELSE DO I8=1_8,NNZ_i IF (id%KEEP(50).NE.0 .AND. & id%IRN_loc(I8).LT.id%JCN_loc(I8)) THEN C permute upper diag entry WRITE(IUNIT,*) id%JCN_loc(I8), id%IRN_loc(I8) ELSE WRITE(IUNIT,*) id%IRN_loc(I8), id%JCN_loc(I8) ENDIF ENDDO ENDIF ELSE IF (IS_ELEMENTAL .AND. I_AM_MASTER) THEN C ================== C ELEMENTAL MATRIX C ================== WRITE(IUNIT,*) id%N," :: N" WRITE(IUNIT,*) id%NELT," :: NELT" WRITE(IUNIT,*) size(id%ELTVAR)," :: NELTVAR" WRITE(IUNIT,*) size(id%A_ELT)," :: NELTVL" WRITE(IUNIT,*) id%ELTPTR(:)," ::ELTPTR" WRITE(IUNIT,*) id%ELTVAR(:)," ::ELTVAR" IF(.NOT.PATTERN_ONLY) THEN WRITE(IUNIT,*) id%A_ELT(:) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_MATRIX SUBROUTINE ZMUMPS_DUMP_RHS(IUNIT, id) C C Purpose: C ======= C Dumps a dense, centralized, C right-hand side in matrix market format on unit C IUNIT. Should be called on the host only. C USE ZMUMPS_STRUC_DEF IMPLICIT NONE C Arguments C ========= TYPE(ZMUMPS_STRUC), intent(in) :: id INTEGER, intent(in) :: IUNIT C C Local variables C =============== C CHARACTER (LEN=8) :: ARITH INTEGER :: I, J INTEGER(8) :: LD_RHS8, K8 C C Executable statements C ===================== C IF (associated(id%RHS)) THEN ARITH='complex' WRITE(IUNIT,FMT=*)'%%MatrixMarket matrix array ', & trim(ARITH), & ' general' WRITE(IUNIT,*) id%N, id%NRHS IF ( id%NRHS .EQ. 1 ) THEN LD_RHS8 = int(id%N,8) ELSE LD_RHS8 = int(id%LRHS,8) ENDIF DO J = 1, id%NRHS DO I = 1, id%N K8=int(J-1,8)*LD_RHS8+int(I,8) WRITE(IUNIT,*) dble(id%RHS(K8)), aimag(id%RHS(K8)) ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DUMP_RHS SUBROUTINE ZMUMPS_BUILD_I_AM_CAND( NSLAVES, K79, & NB_NIV2, MYID_NODES, & CANDIDATES, I_AM_CAND ) IMPLICIT NONE C C Purpose: C ======= C Given a list of candidate processors per node, C returns an array of booleans telling whether the C processor is candidate or not for a given node. C C K79 holds splitting strategy (KEEP(79)). If K79>1 then C TPYE4,5,6 nodes might have been introduced and C in this case "hidden" slaves should be taken C into account to enable dynamic redistribution C of the hidden slaves while climbing the chain of C split nodes. The master of the first node in the C chain requires a special treatment and is thus here C not considered as a slave. C INTEGER, intent(in) :: NSLAVES, NB_NIV2, MYID_NODES, K79 INTEGER, intent(in) :: CANDIDATES( NSLAVES+1, NB_NIV2 ) LOGICAL, intent(out):: I_AM_CAND( NB_NIV2 ) INTEGER I, INIV2, NCAND IF (K79.GT.0) THEN C Because of potential restarting the number of C candidates that will be used to distribute C arrowheads have to include all possible candidates. DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) C check if some hidden slaves are there C Note that if hidden candidates exists (type 5 or 6 nodes) then C in position CANDIDATES (NCAND+1,INIV2) must be the master C of the first node in the chain (type 4) that we skip here because C a special treatment (it has to be "considered as a master" for all C nodes in the list) is needed. DO I=1, NSLAVES IF (CANDIDATES(I,INIV2).LT.0) EXIT ! end of extra slaves IF (I.EQ.NCAND+1) CYCLE ! skip master of associated TYPE 4 node IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ELSE DO INIV2=1, NB_NIV2 I_AM_CAND(INIV2)=.FALSE. NCAND = CANDIDATES(NSLAVES+1,INIV2) DO I=1, NCAND IF (CANDIDATES(I,INIV2).EQ.MYID_NODES) THEN I_AM_CAND(INIV2)=.TRUE. EXIT ENDIF ENDDO END DO ENDIF RETURN END SUBROUTINE ZMUMPS_BUILD_I_AM_CAND MUMPS_5.4.1/src/dfac_asm_ELT.F0000664000175000017500000002375214102210522016063 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) DOUBLE PRECISION :: A(LA) DOUBLE PRECISION :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL DMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE DMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: INTARR(LINTARR) DOUBLE PRECISION, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE DMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.4.1/src/sfac_distrib_ELT.F0000664000175000017500000004646214102210521016764 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) REAL ELTVAL_LOC( LDBLARR ) REAL A( LA ) TYPE(SMUMPS_STRUC) :: id TYPE(SMUMPS_ROOT_STRUC) :: root INTEGER numroc EXTERNAL numroc INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER INODE INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) REAL VAL REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI REAL, DIMENSION( :, : ), ALLOCATABLE :: BUFR REAL, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 INTEGER, DIMENSION( : ), ALLOCATABLE, TARGET :: RG2LALLOC INTEGER, DIMENSION( : ), POINTER :: RG2L MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF IF (KEEP(46) .eq. 0 ) THEN ALLOCATE( RG2LALLOC( N ), stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = N GOTO 100 END IF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2LALLOC( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO RG2L => RG2LALLOC ELSE RG2L => root%RG2L_ROW END IF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL SMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL SMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL SMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in SMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL SMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_REAL, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_REAL, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL SMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL SMUMPS_ARROW_FILL_SEND_BUF( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL SMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_REAL, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE root%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) IF (KEEP(38).ne.0) THEN IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_ELT_DISTRIB SUBROUTINE SMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) REAL ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI REAL ZERO PARAMETER( ZERO = 0.0E0 ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(real(BUFR(1,I))+0.5E0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_REAL, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = real( NBRECR + SIZER ) END IF END DO RETURN END SUBROUTINE SMUMPS_ELT_FILL_BUF SUBROUTINE SMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE SMUMPS_MAXELT_SIZE SUBROUTINE SMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) REAL ELTVAL( SIZER ) REAL SELTVAL( LSELTVAL ) REAL ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE SMUMPS_SCALE_ELEMENT MUMPS_5.4.1/src/smumps_save_restore.F0000664000175000017500000126553314102210522017735 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SAVE_RESTORE USE SMUMPS_STRUC_DEF USE SMUMPS_SAVE_RESTORE_FILES USE SMUMPS_LR_DATA_M USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_REMOVE_SAVED(id) USE SMUMPS_OOC INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (SMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK,UNIT_OK,UNIT_OP LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (SMUMPS_STRUC) :: localid ierr = 0 call SMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN fileunit = 40 inquire (UNIT=fileunit,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = fileunit ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL SMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call SMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call SMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END SUBROUTINE SMUMPS_REMOVE_SAVED SUBROUTINE SMUMPS_RESTORE_OOC(localid) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: UNIT_OK,UNIT_OP TYPE (SMUMPS_STRUC) :: localid NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL SMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN IN=50 inquire(UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN localid%INFO(1) = -79 localid%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = 0 endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_SAVE_RESTORE_STRUCTURE(localid,IN,"restore_ooc" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE SMUMPS_RESTORE_OOC SUBROUTINE SMUMPS_COMPUTE_MEMORY_SAVE(id, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) INCLUDE 'mpif.h' INTEGER::NBVARIABLES,NBVARIABLES_ROOT INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (SMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE SMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE SMUMPS_SAVE(id) INCLUDE 'mpif.h' INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOT,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (SMUMPS_STRUC) :: id INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL SMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUT=60 inquire (UNIT=OUT,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUTINFO=70 inquire (UNIT=OUTINFO,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUTINFO ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,OUT,"save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFO(1) endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by SMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_F2003) write(OUTINFO,*) "Using MUMPS_F2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_SAVE SUBROUTINE SMUMPS_RESTORE(id) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (SMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL SMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN IN=80 inquire (UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL SMUMPS_SAVE_RESTORE_STRUCTURE(id,IN,"restore" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFO(1):" & , id%INFO(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else id%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_RESTORE SUBROUTINE SMUMPS_SAVE_RESTORE_STRUCTURE(id,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE SMUMPS_FACSOL_L0OMP_M, ONLY : SMUMPS_SAVE_RESTORE_L0FACARRAY IMPLICIT NONE INCLUDE 'mpif.h' INTEGER,intent(in)::unit,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=*),intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOT)::SIZE_VARIABLES_ROOT INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOT)::SIZE_GEST_ROOT INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER(len=30), allocatable, dimension(:)::VARIABLES CHARACTER(len=30), allocatable, dimension(:)::VARIABLES_ROOT CHARACTER(len=30) :: TMP_STRING1, TMP_STRING2 CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOT)::NbRecords_ROOT INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64 INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOT)::DIFF_SIZE_ALLOC_READ_ROOT INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC TYPE (SMUMPS_STRUC) :: id allocate(VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES(186)="ASSOCIATED_OOC_FILES" VARIABLES(185)="pad16" VARIABLES(184)="Deficiency" VARIABLES(183)="NB_SINGULAR_VALUES" VARIABLES(182)="SINGULAR_VALUES" VARIABLES(181)="MPITOOMP_PROCS_MAP" VARIABLES(180)="L0_OMP_MAPPING" VARIABLES(179)="PTR_LEAFS_L0_OMP" VARIABLES(178)="PERM_L0_OMP" VARIABLES(177)="VIRT_L0_OMP_MAPPING" VARIABLES(176)="VIRT_L0_OMP" VARIABLES(175)="PHYS_L0_OMP" VARIABLES(174)="IPOOL_A_L0_OMP" VARIABLES(173)="IPOOL_B_L0_OMP" VARIABLES(172)="I8_L0_OMP" VARIABLES(171)="I4_L0_OMP" VARIABLES(170)="THREAD_LA" VARIABLES(169)="LL0_OMP_FACTORS" VARIABLES(168)="LL0_OMP_MAPPING" VARIABLES(167)="L_VIRT_L0_OMP" VARIABLES(166)="L_PHYS_L0_OMP" VARIABLES(165)="LPOOL_B_L0_OMP" VARIABLES(164)="LPOOL_A_L0_OMP" VARIABLES(163)="L0_OMP_FACTORS" VARIABLES(162)="BLRARRAY_ENCODING" VARIABLES(161)="FDM_F_ENCODING" VARIABLES(160)="pad13" VARIABLES(159)="NBGRP" VARIABLES(158)="LRGROUPS" VARIABLES(157)="root" VARIABLES(156)="WORKING" VARIABLES(155)="IPTR_WORKING" VARIABLES(154)="pad14" VARIABLES(153)="SUP_PROC" VARIABLES(152)="PIVNUL_LIST" VARIABLES(151)="OOC_FILE_NAMES" VARIABLES(150)="OOC_FILE_NAME_LENGTH" VARIABLES(149)="pad12" VARIABLES(148)="OOC_NB_FILE_TYPE" VARIABLES(147)="OOC_NB_FILES" VARIABLES(146)="OOC_TOTAL_NB_NODES" VARIABLES(145)="OOC_VADDR" VARIABLES(144)="OOC_SIZE_OF_BLOCK" VARIABLES(143)="OOC_INODE_SEQUENCE" VARIABLES(142)="OOC_MAX_NB_NODES_FOR_ZONE" VARIABLES(141)="INSTANCE_NUMBER" VARIABLES(140)="CB_SON_SIZE" VARIABLES(139)="DKEEP" VARIABLES(138)="LWK_USER" VARIABLES(137)="NBSA_LOCAL" VARIABLES(136)="WK_USER" VARIABLES(135)="CROIX_MANU" VARIABLES(134)="SCHED_SBTR" VARIABLES(133)="SCHED_GRP" VARIABLES(132)="SCHED_DEP" VARIABLES(131)="SBTR_ID" VARIABLES(130)="DEPTH_FIRST_SEQ" VARIABLES(129)="DEPTH_FIRST" VARIABLES(128)="MY_NB_LEAF" VARIABLES(127)="MY_FIRST_LEAF" VARIABLES(126)="MY_ROOT_SBTR" VARIABLES(125)="COST_TRAV" VARIABLES(124)="MEM_SUBTREE" VARIABLES(123)="RHSCOMP" VARIABLES(122)="POSINRHSCOMP_COL" VARIABLES(121)="pad11" VARIABLES(120)="POSINRHSCOMP_COL_ALLOC" VARIABLES(119)="POSINRHSCOMP_ROW" VARIABLES(118)="MEM_DIST" VARIABLES(117)="I_AM_CAND" VARIABLES(116)="TAB_POS_IN_PERE" VARIABLES(115)="FUTURE_NIV2" VARIABLES(114)="ISTEP_TO_INIV2" VARIABLES(113)="CANDIDATES" VARIABLES(112)="ELTPROC" VARIABLES(111)="LELTVAR" VARIABLES(110)="NELT_loc" VARIABLES(109)="DBLARR" VARIABLES(108)="INTARR" VARIABLES(107)="PROCNODE" VARIABLES(106)="S" VARIABLES(105)="PTRFAC" VARIABLES(104)="PTLUST_S" VARIABLES(103)="Step2node" VARIABLES(102)="PROCNODE_STEPS" VARIABLES(101)="NA" VARIABLES(100)="PTRAR" VARIABLES(99)="FRTELT" VARIABLES(98)="FRTPTR" VARIABLES(97)="FILS" VARIABLES(96)="DAD_STEPS" VARIABLES(95)="FRERE_STEPS" VARIABLES(94)="ND_STEPS" VARIABLES(93)="NE_STEPS" VARIABLES(92)="STEP" VARIABLES(91)="NBSA" VARIABLES(90)="LNA" VARIABLES(89)="KEEP" VARIABLES(88)="IS" VARIABLES(87)="ASS_IRECV" VARIABLES(86)="NSLAVES" VARIABLES(85)="NPROCS" VARIABLES(84)="MYID" VARIABLES(83)="COMM_LOAD" VARIABLES(82)="MYID_NODES" VARIABLES(81)="COMM_NODES" VARIABLES(80)="INST_Number" VARIABLES(79)="MAX_SURF_MASTER" VARIABLES(78)="KEEP8" VARIABLES(77)="pad7" VARIABLES(76)="SAVE_PREFIX" VARIABLES(75)="SAVE_DIR" VARIABLES(74)="WRITE_PROBLEM" VARIABLES(73)="OOC_PREFIX" VARIABLES(72)="OOC_TMPDIR" VARIABLES(71)="VERSION_NUMBER" VARIABLES(70)="MAPPING" VARIABLES(69)="LISTVAR_SCHUR" VARIABLES(68)="SCHUR_CINTERFACE" VARIABLES(67)="SCHUR" VARIABLES(66)="SIZE_SCHUR" VARIABLES(65)="SCHUR_LLD" VARIABLES(64)="SCHUR_NLOC" VARIABLES(63)="SCHUR_MLOC" VARIABLES(62)="NBLOCK" VARIABLES(61)="MBLOCK" VARIABLES(60)="NPCOL" VARIABLES(59)="NPROW" VARIABLES(58)="UNS_PERM" VARIABLES(57)="SYM_PERM" VARIABLES(56)="METIS_OPTIONS" VARIABLES(55)="RINFOG" VARIABLES(54)="RINFO" VARIABLES(53)="CNTL" VARIABLES(52)="COST_SUBTREES" VARIABLES(51)="INFOG" VARIABLES(50)="INFO" VARIABLES(49)="ICNTL" VARIABLES(48)="pad6" VARIABLES(47)="LSOL_loc" VARIABLES(46)="LREDRHS" VARIABLES(45)="LRHS_loc" VARIABLES(44)="Nloc_RHS" VARIABLES(43)="NZ_RHS" VARIABLES(42)="NRHS" VARIABLES(41)="LRHS" VARIABLES(40)="IRHS_loc" VARIABLES(39)="ISOL_loc" VARIABLES(38)="IRHS_PTR" VARIABLES(37)="IRHS_SPARSE" VARIABLES(36)="RHS_loc" VARIABLES(35)="SOL_loc" VARIABLES(34)="RHS_SPARSE" VARIABLES(33)="REDRHS" VARIABLES(32)="RHS" VARIABLES(31)="BLKVAR" VARIABLES(30)="BLKPTR" VARIABLES(29)="pad5" VARIABLES(28)="NBLK" VARIABLES(27)="PERM_IN" VARIABLES(26)="pad4" VARIABLES(25)="A_ELT" VARIABLES(24)="ELTVAR" VARIABLES(23)="ELTPTR" VARIABLES(22)="pad3" VARIABLES(21)="NELT" VARIABLES(20)="pad2" VARIABLES(19)="A_loc" VARIABLES(18)="JCN_loc" VARIABLES(17)="IRN_loc" VARIABLES(16)="NNZ_loc" VARIABLES(15)="pad1" VARIABLES(14)="NZ_loc" VARIABLES(13)="pad0" VARIABLES(12)="ROWSCA" VARIABLES(11)="COLSCA" VARIABLES(10)="JCN" VARIABLES(9)="IRN" VARIABLES(8)="A" VARIABLES(7)="NNZ" VARIABLES(6)="NZ" VARIABLES(5)="N" VARIABLES(4)="JOB" VARIABLES(3)="PAR" VARIABLES(2)="SYM" VARIABLES(1)="COMM" allocate(VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES_ROOT(35)="rootpad4" VARIABLES_ROOT(34)="NB_SINGULAR_VALUES" VARIABLES_ROOT(33)="SINGULAR_VALUES" VARIABLES_ROOT(32)="SVD_VT" VARIABLES_ROOT(31)="SVD_U" VARIABLES_ROOT(30)="gridinit_done" VARIABLES_ROOT(29)="yes" VARIABLES_ROOT(28)="rootpad3" VARIABLES_ROOT(27)="QR_RCOND" VARIABLES_ROOT(26)="rootpad" VARIABLES_ROOT(25)="RHS_ROOT" VARIABLES_ROOT(24)="rootpad2" VARIABLES_ROOT(23)="QR_TAU" VARIABLES_ROOT(22)="SCHUR_POINTER" VARIABLES_ROOT(21)="RHS_CNTR_MASTER_ROOT" VARIABLES_ROOT(20)="rootpad1" VARIABLES_ROOT(19)="IPIV" VARIABLES_ROOT(18)="RG2L_COL" VARIABLES_ROOT(17)="RG2L_ROW" VARIABLES_ROOT(16)="rootpad0" VARIABLES_ROOT(15)="LPIV" VARIABLES_ROOT(14)="CNTXT_BLACS" VARIABLES_ROOT(13)="DESCRIPTOR" VARIABLES_ROOT(12)="TOT_ROOT_SIZE" VARIABLES_ROOT(11)="ROOT_SIZE" VARIABLES_ROOT(10)="RHS_NLOC" VARIABLES_ROOT(9)="SCHUR_LLD" VARIABLES_ROOT(8)="SCHUR_NLOC" VARIABLES_ROOT(7)="SCHUR_MLOC" VARIABLES_ROOT(6)="MYCOL" VARIABLES_ROOT(5)="MYROW" VARIABLES_ROOT(4)="NPCOL" VARIABLES_ROOT(3)="NPROW" VARIABLES_ROOT(2)="NBLOCK" VARIABLES_ROOT(1)="MBLOCK" OOC_INDICES=(/147,148,150,151/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(16) SIZE_ARITH_DEP = id%KEEP(35) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOT(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOT(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(trim(mode).EQ."memory_save") then elseif(trim(mode).EQ."save") then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="SMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (trim(mode).EQ."restore_ooc") THEN BASIC_CHECK = .true. ENDIF CALL SMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(trim(mode).EQ."fake_restore") then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("OOC_NB_FILES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILE_TYPE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAMES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAME_LENGTH") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(trim(mode).EQ."restore_ooc") then goto 200 endif DO i1=1,NBVARIABLES TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("COMM") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("SYM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SYM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SYM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%PAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%PAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("JOB") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("N") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%N if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%N if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ICNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_SUBTREES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP8") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) read(unit,iostat=err) id%KEEP8 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) read(unit,iostat=err) id%KEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DKEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("A") CASE("IRN") CASE("JCN") CASE("COLSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COLSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%COLSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COLSCA)) THEN write(unit,iostat=err) size(id%COLSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%COLSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COLSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%COLSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COLSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("ROWSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ROWSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ROWSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ROWSCA)) THEN write(unit,iostat=err) size(id%ROWSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%ROWSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ROWSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%ROWSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ROWSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("NZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IRN_loc") CASE("JCN_loc") CASE("A_loc") CASE("NELT") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPTR") CASE("ELTVAR") CASE("A_ELT") CASE("PERM_IN") CASE("BLKPTR") CASE("BLKVAR") CASE("RHS") CASE("REDRHS") CASE("RHS_SPARSE") CASE("SOL_loc") CASE("RHS_loc") CASE("IRHS_SPARSE") CASE("IRHS_PTR") CASE("ISOL_loc") CASE("IRHS_loc") CASE("LRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ_RHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_RHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_RHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRHS_loc") CASE("Nloc_RHS") CASE("LSOL_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LSOL_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LSOL_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LREDRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LREDRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LREDRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SYM_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%SYM_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SYM_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SYM_PERM)) THEN write(unit,iostat=err) size(id%SYM_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SYM_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SYM_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SYM_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SYM_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("UNS_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SIZE_SCHUR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR") CASE("SCHUR_CINTERFACE") CASE("LISTVAR_SCHUR") CASE("MAPPING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("VERSION_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TMPDIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WRITE_PROBLEM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MAX_SURF_MASTER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INST_Number") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INST_Number if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INST_Number if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_NODES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID_NODES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID_NODES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID_NODES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_LOAD") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROCS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROCS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROCS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NSLAVES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NSLAVES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NSLAVES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASS_IRECV") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ASS_IRECV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%ASS_IRECV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Deficiency") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%Deficiency if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%Deficiency if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LNA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LNA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LNA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBSA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("STEP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%STEP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%STEP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%STEP)) THEN write(unit,iostat=err) size(id%STEP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%STEP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%STEP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES(i1),id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%STEP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%STEP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ND_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Step2node") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRERE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DAD_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FILS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FILS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FILS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FILS)) THEN write(unit,iostat=err) size(id%FILS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FILS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FILS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FILS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FILS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRAR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(trim(mode).EQ."restore") then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTPTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTELT") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NA") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTLUST_S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRFAC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array_INT8_1,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE") CASE("INTARR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%INTARR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(27)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%INTARR)) THEN write(unit,iostat=err) id%KEEP8(27) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%INTARR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%INTARR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%INTARR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%INTARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DBLARR") CASE("NELT_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LELTVAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LELTVAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LELTVAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPROC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I4_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I8_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CANDIDATES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ISTEP_TO_INIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FUTURE_NIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TAB_POS_IN_PERE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I_AM_CAND") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_DIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_ROW") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_ROW,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_ROW,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_ROW ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_ROW) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_ROW(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_ROW endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL_ALLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_COL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_COL ELSE write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%POSINRHSCOMP_COL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_COL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_COL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%POSINRHSCOMP_COL=>id%POSINRHSCOMP_ROW endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHSCOMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%RHSCOMP)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%RHSCOMP)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSCOMP ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%RHSCOMP) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSCOMP(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSCOMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_SUBTREE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_TRAV") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_ROOT_SBTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_FIRST_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_NB_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST_SEQ") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SBTR_ID") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHED_DEP") CASE("SCHED_GRP") CASE("CROIX_MANU") CASE("WK_USER") CASE("NBSA_LOCAL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LWK_USER") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("CB_SON_SIZE") CASE("INSTANCE_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_MAX_NB_NODES_FOR_ZONE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_INODE_SEQUENCE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_SIZE_OF_BLOCK") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_VADDR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TOTAL_NB_NODES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILES") CASE("OOC_NB_FILE_TYPE") CASE("OOC_FILE_NAMES") CASE("OOC_FILE_NAME_LENGTH") CASE("PIVNUL_LIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SUP_PROC") CASE("IPTR_WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("root") DO i2=1,NBVARIABLES_ROOT TMP_STRING2 = VARIABLES_ROOT(i2) SELECT CASE(TMP_STRING2) CASE("MBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then NbRecords_ROOT(i2)=1 SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TOT_ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DESCRIPTOR") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=size(id%root%DESCRIPTOR,1) & *SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT* & size(id%root%DESCRIPTOR,1) read(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTXT_BLACS") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPIV") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RG2L_ROW") CASE("RG2L_COL") CASE("IPIV") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%IPIV)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%IPIV)) THEN write(unit,iostat=err) size(id%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_INT allocate(id%root%IPIV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_CNTR_MASTER_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%RHS_CNTR_MASTER_ROOT,1) & *SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN write(unit,iostat=err) & size(id%root%RHS_CNTR_MASTER_ROOT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_CNTR_MASTER_ROOT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_ARITH_DEP allocate(id%root%RHS_CNTR_MASTER_ROOT(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_POINTER") CASE("QR_TAU") CASE("RHS_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size(id%root%RHS_ROOT,1) & *size(id%root%RHS_ROOT,2)*SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_ROOT)) THEN write(unit,iostat=err) size(id%root%RHS_ROOT,1) & ,size(id%root%RHS_ROOT,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_ROOT ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_ROOT) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size_array1*size_array2 & *SIZE_ARITH_DEP allocate(id%root%RHS_ROOT(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("QR_RCOND") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL read(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("yes") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("gridinit_done") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SVD_U") CASE("SVD_VT") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("rootpad0","rootpad1","rootpad2","rootpad", & "rootpad3","rootpad4") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_ROOT(i2)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_ROOT(i2)=NbRecords_ROOT(i2)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_ROOT(i2) & +SIZE_GEST_ROOT(i2) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES_ROOT(i2)+ & DIFF_SIZE_ALLOC_READ_ROOT(i2) size_read=size_read+SIZE_VARIABLES_ROOT(i2) & +int(SIZE_GEST_ROOT(i2),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO CASE("NBGRP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBGRP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBGRP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRGROUPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%LRGROUPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%LRGROUPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%LRGROUPS)) THEN write(unit,iostat=err) size(id%LRGROUPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LRGROUPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%LRGROUPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%LRGROUPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LRGROUPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FDM_F_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("BLRARRAY_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL SMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL SMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL SMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L0_OMP_FACTORS") CASE("SCHED_SBTR") CASE("LPOOL_A_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPOOL_B_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_PHYS_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_VIRT_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_MAPPING") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_FACTORS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("THREAD_LA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IPOOL_A_L0_OMP") CASE("IPOOL_B_L0_OMP") CASE("PHYS_L0_OMP") CASE("VIRT_L0_OMP") CASE("VIRT_L0_OMP_MAPPING") CASE("PERM_L0_OMP") CASE("PTR_LEAFS_L0_OMP") CASE("L0_OMP_MAPPING") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASSOCIATED_OOC_FILES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE("SAVE_DIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SAVE_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MPITOOMP_PROCS_MAP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MPITOOMP_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MPITOOMP_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MPITOOMP_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MPITOOMP_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MPITOOMP_PROCS_MAP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MPITOOMP_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("METIS_OPTIONS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("pad0","pad1","pad2","pad3","pad4","pad5","pad6","pad7", & "pad11","pad111", "pad12","pad13","pad14","pad15","pad16") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO 200 continue if(trim(mode).EQ."memory_save") then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+sum(SIZE_VARIABLES_ROOT) & +SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOT) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOT) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if !defined(MUMPS_F2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOT)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(trim(mode).EQ."save") then elseif(trim(mode).EQ."restore") then if(id%root%gridinit_done) then id%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( id%root%CNTXT_BLACS, 'R', & id%root%NPROW, id%root%NPCOL ) id%root%gridinit_done = .TRUE. endif elseif(trim(mode).EQ."fake_restore") then elseif(trim(mode).EQ."restore_ooc") then endif 100 continue deallocate(VARIABLES, VARIABLES_ROOT) RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_STRUCTURE END MODULE SMUMPS_SAVE_RESTORE MUMPS_5.4.1/src/cooc_panel_piv.F0000664000175000017500000002770314102210526016606 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE CMUMPS_OOC). INTEGER FUNCTION CMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF CMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION CMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE CMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) COMPLEX THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL cswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE CMUMPS_PERMUTE_PANEL SUBROUTINE CMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine CMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE CMUMPS_GET_OOC_PERM_PTR SUBROUTINE CMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: CMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE CMUMPS_OOC_PP_SET_PTR SUBROUTINE CMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE CMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE CMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE CMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE CMUMPS_OOC ! To call CMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / CMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / CMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE CMUMPS_OOC_GET_PP_SIZES SUBROUTINE CMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the CMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.4.1/src/zfac_scalings_simScaleAbs.F0000664000175000017500000013652514102210526020705 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant ZMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. ZMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C ZMUMPS_SIMSCALEABSUNS and ZMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX(kind=8) A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS C IMPORTANT POINTERS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 DOUBLE PRECISION EPS C EXTERNALS EXTERNAL ZMUMPS_SIMSCALEABSUNS,ZMUMPS_SIMSCALEABSSYM, & ZMUMPS_INITREAL C MUST HAVE IT INTEGER I IF(SYM.EQ.0) THEN CALL ZMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL ZMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_SIMSCALEABS SUBROUTINE ZMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, INTSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX(kind=8) A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER REGISTRE(12) INTEGER IWRK(IWRKSZ) DOUBLE PRECISION ROWSCA(M) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION WRKRC(ISZWRKRC) DOUBLE PRECISION ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ITDCPTR, ISRRPTR INTEGER OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL ZMUMPS_CREATEPARTVEC, & ZMUMPS_NUMVOLSNDRCV, & ZMUMPS_SETUPCOMMS, & ZMUMPS_FINDNUMMYROWCOL, & ZMUMPS_CHKCONVGLO, & ZMUMPS_CHK1CONV, & ZMUMPS_FILLMYROWCOLINDICES, & ZMUMPS_INITREAL, & ZMUMPS_INITREALLST, & ZMUMPS_DOCOMMINF, & ZMUMPS_DOCOMM1N INTEGER ZMUMPS_CHKCONVGLO INTEGER ZMUMPS_CHK1CONV DOUBLE PRECISION ZMUMPS_ERRSCALOC DOUBLE PRECISION ZMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER RESZR, RESZC INTEGER INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR DOUBLE PRECISION ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG DOUBLE PRECISION INFERRROW, INFERRCOL, INFERRL, INFERRG INTEGER OORANGEIND INFERRG = -RONE ONEERRG = -RONE OORANGEIND = 0 MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL ZMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) C Compute sndrcv sizes, store them for later use CALL ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL ZMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) CALL ZMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZC = ICSNDRCVNUM + OCSNDRCVNUM + & ICSNDRCVVOL + OCSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYC INTSZ = INTSZR + INTSZC + MAXMN + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(5) = ICSNDRCVNUM REGISTRE(6) = OCSNDRCVNUM REGISTRE(7) = ICSNDRCVVOL REGISTRE(8) = OCSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(10) = INUMMYC REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) ICSNDRCVNUM = REGISTRE(5) OCSNDRCVNUM = REGISTRE(6) ICSNDRCVVOL = REGISTRE(7) OCSNDRCVVOL = REGISTRE(8) INUMMYR = REGISTRE(9) INUMMYC = REGISTRE(10) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL ZMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), INUMMYC, & IWRK(1+INUMMYR+INUMMYC), IWRKSZ-INUMMYR-INUMMYC ) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 C C MPI [-----------------] REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL ZMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL ZMUMPS_INITREAL(ROWSCA, M, RZERO) CALL ZMUMPS_INITREAL(COLSCA, N, RZERO) CALL ZMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL ZMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL ZMUMPS_INITREAL(ROWSCA, M, RONE) CALL ZMUMPS_INITREAL(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M C ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL ZMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL ZMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL ZMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO) CALL ZMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL ZMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL ZMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = ZMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols INFERRCOL = ZMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL ZMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = ZMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols INFERRCOL = ZMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL ZMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL ZMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = ZMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols ONEERRCOL = ZMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL ZMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = ZMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols ONEERRCOL = ZMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL ZMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL ZMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL ZMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL ZMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1+M), N, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) If(MYID.EQ.0) THEN DO I=1, N COLSCA(I) = WRKRC(I+M) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE ZMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, IWRKSZ, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX(kind=8) A_loc(NZ_loc) INTEGER PARTVEC(N), RSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) DOUBLE PRECISION SCA(N) INTEGER ISZWRKRC DOUBLE PRECISION WRKRC(ISZWRKRC) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR DOUBLE PRECISION ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 DOUBLE PRECISION EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND DOUBLE PRECISION ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL ZMUMPS_CREATEPARTVECSYM, & ZMUMPS_NUMVOLSNDRCVSYM, & ZMUMPS_SETUPCOMMSSYM, & ZMUMPS_FINDNUMMYROWCOLSYM, & ZMUMPS_CHKCONVGLOSYM, & ZMUMPS_CHK1CONV, & ZMUMPS_FILLMYROWCOLINDICESSYM, & ZMUMPS_DOCOMMINF, & ZMUMPS_DOCOMM1N, & ZMUMPS_INITREAL, & ZMUMPS_INITREALLST INTEGER ZMUMPS_CHKCONVGLOSYM INTEGER ZMUMPS_CHK1CONV DOUBLE PRECISION ZMUMPS_ERRSCALOC DOUBLE PRECISION ZMUMPS_ERRSCA1 INTRINSIC abs DOUBLE PRECISION RONE, RZERO PARAMETER(RONE=1.0D0,RZERO=0.0D0) C TMP VARS INTEGER INTSZR INTEGER MAXMN INTEGER I, IERROR DOUBLE PRECISION ONEERRL, ONEERRG DOUBLE PRECISION INFERRL, INFERRG INTEGER OORANGEIND OORANGEIND = 0 INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL ZMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) C CALL ZMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C CALL ZMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) C INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY DOUBLE PRECISION SPACE RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL ZMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C MPI [-----------------] REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL ZMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL ZMUMPS_INITREAL(SCA, N, RZERO) CALL ZMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL ZMUMPS_INITREAL(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL ZMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL ZMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL ZMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = ZMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = ZMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = & WRKRC(ITDRPTR-1+IC) + ELM ENDIF ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = WRKRC(ITDRPTR-1+IC) + ELM ENDIF ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = ZMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_DOUBLE_PRECISION, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = ZMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL ZMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL ZMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL ZMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_DOUBLE_PRECISION, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SIMSCALEABSSYM MUMPS_5.4.1/src/dfac_process_bf.F0000664000175000017500000000103114102210522016706 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE DMUMPS_PROCESS_BF_RETURN MUMPS_5.4.1/src/cfac_process_blocfacto.F0000664000175000017500000007765514102210523020304 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE CMUMPS_LOAD USE CMUMPS_LR_CORE USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_FAC_LR USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_HAVE_SET_K117 INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL, KEEP_BEGS_BLR_L LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX ONE,ALPHA PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: INFO_TMP(2) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL COMPLEX, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL,ALLOCATABLE,DIMENSION(:) :: RWORK COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL COMPLEX, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER :: allocok INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 NULLIFY(BEGS_BLR_U) I_HAVE_SET_K117 = .FALSE. DYNAMIC_ALLOC = .FALSE. FPERE = -1 POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) ENDIF CALL CMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL CMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NCOL ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL CMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 IF (DYNAMIC_ALLOC) THEN DO I = 1, NPIV IF (DYN_PIVINFO(I).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+DYN_PIVINFO(I)) IW(ICT11+DYN_PIVINFO(I)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + DYN_PIVINFO(I) - 1,8) CALL cswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ELSE DO I = 1, NPIV IF (IW(IPIV+I-1).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1)) IW(ICT11+IW(IPIV+I-1)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8) CALL cswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNAMIC_ALLOC) THEN CALL ctrsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A_PTR(LPOS2), NCOL1) ELSE CALL ctrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_L = NPARTSCB IF (IPANEL.EQ.1) THEN BEGS_BLR_COL=>BEGS_BLR_U ELSE ALLOCATE(BEGS_BLR_COL(size(BEGS_BLR_U)+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = size(BEGS_BLR_U)+IPANEL-1 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF BEGS_BLR_COL(1:IPANEL-1) = 1 DO I=1,size(BEGS_BLR_U) BEGS_BLR_COL(IPANEL+I-1) = BEGS_BLR_U(I) ENDDO ENDIF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IPANEL.NE.1) THEN DEALLOCATE(BEGS_BLR_COL) ENDIF IF (IFLAG.LT.0) GOTO 700 ELSE CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U) IF (LASTBL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL CMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ELSE CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL CMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN UPOS = 1_8+int(NPIV,8) IF (DYNAMIC_ALLOC) THEN CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL CMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE IF (DYNAMIC_ALLOC) THEN UPOS = int(NPIV+1,8) CALL cgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,DYN_BLOCFACTO(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL cgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF ENDIF IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV IF (LASTBL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) ) ENDIF IF ( .not. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8) DEALLOCATE(BLR_U) IF (KEEP(486).EQ.3) THEN CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8) DEALLOCATE(BLR_L) ELSE CALL UPD_MRY_LU_LRGAIN(BLR_L, 0, NPARTSCB, 'V') ENDIF ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV ENDIF FLOP1 = dble( NPIV1*NROW1 ) + & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1) & - & dble((NPIV1+NPIV)*NROW1 ) - & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1) CALL CMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 IF (NPIV.EQ.0) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) IF (COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_COL+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during CMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL CMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1) & ) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF CALL CMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_PROCESS_BLOCFACTO SUBROUTINE CMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE CMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in CMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_COMPLEX, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_COMPLEX, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_COMPLEX, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_MPI_UNPACK_LR MUMPS_5.4.1/src/sfac_scalings.F0000664000175000017500000002702714102210521016417 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) REAL, INTENT(IN) :: ASPK(NZ8) REAL COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER LWK_REAL REAL WK(LWK8) REAL WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I LOGICAL PROK REAL ONE PARAMETER( ONE = 1.0E0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROK) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROK) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROK) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL SMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN CALL SMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL SMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 410 INFO(1) = -5 INFO(2) = 5*N-LWK_REAL IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_A SUBROUTINE SMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 REAL VAL(NZ8) REAL RNOR(N),CNOR(N) REAL COLSCA(N),ROWSCA(N) REAL CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) REAL VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE SMUMPS_ROWCOL SUBROUTINE SMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 REAL, INTENT(IN) :: VAL(NZ8) REAL, INTENT(OUT) :: CNOR(N) REAL, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT REAL VDIAG INTEGER I,J INTEGER(8) :: K8 REAL ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE SMUMPS_FAC_Y SUBROUTINE SMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 REAL , INTENT(IN) :: VAL(NZ8) REAL , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT REAL :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt REAL ZERO, ONE PARAMETER(ZERO=0.0E0, ONE=1.0E0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE SMUMPS_FAC_V SUBROUTINE SMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL VAL(NZ8) REAL RNOR(N) REAL ROWSCA(N) INTEGER MPRINT REAL VDIAG INTEGER I,J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE SMUMPS_FAC_X SUBROUTINE SMUMPS_ANORMINF( id, ANORMINF, LSCAL ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE(SMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL INTEGER, DIMENSION (:), POINTER :: KEEP,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE REAL DUMMY(1) REAL ZERO PARAMETER( ZERO = 0.0E0) REAL, ALLOCATABLE :: SUMR(:), SUMR_LOC(:) INTEGER :: allocok, MTYPE, I INFO =>id%INFO KEEP =>id%KEEP KEEP8 =>id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN ALLOCATE( SUMR( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL SMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL SMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1), KEEP8(1), & id%COLSCA(1)) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL SMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, KEEP(1),KEEP8(1) ) ELSE CALL SMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL SMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL SMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1)) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = real(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE SMUMPS_ANORMINF MUMPS_5.4.1/src/mumps_scotch64.h0000664000175000017500000000404014102210474016535 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SCOTCH64_H #define MUMPS_SCOTCH64_H #include "mumps_common.h" #if defined(scotch) || defined(ptscotch) #include "scotch.h" #if ((SCOTCH_VERSION == 6) && (SCOTCH_RELEASE >= 1)) || (SCOTCH_VERSION >= 7) /* esmumpsv prototype with 64-bit integers weights of nodes in the graph are used on entry (nv) */ MUMPS_INT esmumpsv( const MUMPS_INT8 n, const MUMPS_INT8 iwlen, MUMPS_INT8 * const pe, const MUMPS_INT8 pfree, MUMPS_INT8 * const len, MUMPS_INT8 * const iw, MUMPS_INT8 * const nv, MUMPS_INT8 * const elen, MUMPS_INT8 * const last); #endif /* esmumps prototype with standard integers (weights of nodes not used on entry) */ MUMPS_INT esmumps( const MUMPS_INT8 n, const MUMPS_INT8 iwlen, MUMPS_INT8 * const pe, const MUMPS_INT8 pfree, MUMPS_INT8 * const len, MUMPS_INT8 * const iw, MUMPS_INT8 * const nv, MUMPS_INT8 * const elen, MUMPS_INT8 * const last); #define MUMPS_SCOTCH_64 \ F_SYMBOL(scotch_64,SCOTCH_64) void MUMPS_CALL MUMPS_SCOTCH_64( const MUMPS_INT8 * const n, const MUMPS_INT8 * const iwlen, MUMPS_INT8 * const petab, const MUMPS_INT8 * const pfree, MUMPS_INT8 * const lentab, MUMPS_INT8 * const iwtab, MUMPS_INT8 * const nvtab, MUMPS_INT8 * const elentab, MUMPS_INT8 * const lasttab, MUMPS_INT * const ncmpa, MUMPS_INT * const weightused, MUMPS_INT * const weightrequested ); #endif #endif MUMPS_5.4.1/src/zmumps_gpu.h0000664000175000017500000000114314102210474016066 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef ZMUMPS_GPU_H #define ZMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL zmumps_gpu_return(); #endif /* ZMUMPS_GPU_H */ MUMPS_5.4.1/src/zfac_process_end_facto_slave.F0000664000175000017500000002640314102210524021475 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE ZMUMPS_LR_DATA_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL ZMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL ZMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL ZMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL ZMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL ZMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in ZMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE ZMUMPS_END_FACTO_SLAVE MUMPS_5.4.1/src/zfac_process_root2son.F0000664000175000017500000003207714102210524020152 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & ZMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER I, LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, & LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV LIST_NELIM_ROW = IOLDPS + H_INODE + NPIV LIST_NELIM_COL = LIST_NELIM_ROW + NFRONT IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in ZMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NELIM_LOCAL = NELIM_ROOT DO I=1, NELIM root%RG2L_ROW(IW(LIST_NELIM_ROW)) = NELIM_LOCAL root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_ROW = LIST_NELIM_ROW + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) IF (IFLAG.LT.0 ) RETURN ENDIF IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) PTRFAC(STEP(INODE))=POSELT IF ( TYPE_SON .eq. 1 ) THEN NBROW = NFRONT - NPIV ELSE NBROW = NELIM END IF IF ( TYPE_SON .eq. 1 .OR. KEEP(50).EQ.0) THEN LDA = NFRONT ELSE LDA = NPIV+NBROW ENDIF CALL ZMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL ZMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL ZMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in ZMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) LIST_NELIM_COL = IOLDPS + H_INODE + NROW + NPIV NELIM_LOCAL = NELIM_ROOT DO I = 1, NELIM root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL root%RG2L_ROW(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL ZMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_ROOT2SON MUMPS_5.4.1/src/ssol_aux.F0000664000175000017500000013230314102210521015447 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) REAL W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE SMUMPS_FREETOPSO SUBROUTINE SMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) REAL W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE SMUMPS_COMPSO SUBROUTINE SMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER N, I, J, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8) KEEP8(150) INTEGER IRN(NZ8), ICN(NZ8) REAL A(NZ8) REAL Z(N) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SOL_X SUBROUTINE SMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL, INTENT(IN) :: A(NZ8) REAL, INTENT(IN) :: COLSCA(N) REAL, INTENT(OUT) :: Z(N) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER :: I, J INTEGER(8) :: K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_SCAL_X SUBROUTINE SMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) REAL, INTENT(IN) :: A(NZ8), RHS(N), X(N) REAL, INTENT(OUT) :: W(N) REAL, INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: ZERO = 0.0E0 REAL D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SOL_Y SUBROUTINE SMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N REAL, intent(in) :: W(N) REAL, intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE SMUMPS_SOL_MULR SUBROUTINE SMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) REAL W(N), X(N) REAL, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, real, sign INTEGER SMUMPS_IXAMAX EXTERNAL SMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN REAL TEMP SAVE ITER, J, JLAST, JUMP REAL ZERO, ONE PARAMETER( ZERO = 0.0E0 ) PARAMETER( ONE = 1.0E0 ) REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / real(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = sign( RONE,real(X(I)) ) IW(I) = nint(real(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = SMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, real(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = sign(RONE, real(X(I))) IW(I) = nint(real(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = SMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = ALTSGN * (RONE + real(I - 1) / real(N - 1)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0E0 * TEMP / real(3 * N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE SMUMPS_SOL_B SUBROUTINE SMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL, INTENT(IN) :: ASPK( NZ8 ) REAL, INTENT(IN) :: LHS( N ), WRHS( N ) REAL, INTENT(OUT):: RHS( N ) REAL, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: DZERO = 0.0E0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_QD2 SUBROUTINE SMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL A_ELT(NA_ELT8) REAL LHS( N ), WRHS( N ), RHS( N ) REAL W(N) CALL SMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL SMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE SMUMPS_ELTQD2 SUBROUTINE SMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL A_ELT(NA_ELT8) REAL TEMP REAL W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SOL_X_ELT SUBROUTINE SMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL COLSCA(N) REAL A_ELT(NA_ELT8) REAL W(N) REAL TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 REAL DZERO PARAMETER(DZERO = 0.0E0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_SOL_SCALX_ELT SUBROUTINE SMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) REAL A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) REAL W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR REAL ZERO REAL TEMP REAL TEMP2 PARAMETER( ZERO = 0.0E0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE SMUMPS_ELTYD SUBROUTINE SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE SMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR REAL A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=SMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL SMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE SMUMPS_BUILD_MAPPING_INFO(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(SMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE SMUMPS_BUILD_MAPPING_INFO SUBROUTINE SMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) REAL RHS(N) REAL X(N), Y(N) REAL R_W(N,2) REAL C_W(N) INTEGER LP, NOITER LOGICAL TESTConv REAL OMEGA(2) REAL ARRET INTEGER, intent(in) :: GRAIN REAL, PARAMETER :: CGCE=0.2E0 REAL, PARAMETER :: CTAU=1.0E3 INTEGER I, IMAX REAL OM1, OM2, DXMAX REAL TAU, DD REAL OLDOMG(2) REAL, PARAMETER :: ZERO=0.0E0 REAL, PARAMETER :: ONE=1.0E0 INTEGER SMUMPS_IXAMAX INTRINSIC abs, max SAVE OM1, OLDOMG IMAX = SMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * real(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE SMUMPS_SOL_OMEGA SUBROUTINE SMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) REAL RHS(N) REAL X(N), Y(N) REAL D(N) REAL R_W(N,2) REAL C_W(N) INTEGER LP REAL COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX REAL ERX, DXMAX REAL DXIMAX REAL, PARAMETER :: ZERO = 0.0E0 REAL, PARAMETER :: ONE = 1.0E0 INTEGER SMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = SMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = SMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL SMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL SMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL SMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL SMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE SMUMPS_SOL_LCOND SUBROUTINE SMUMPS_SOL_CPY_FS2RHSCOMP( JBDEB, JBFIN, NBROWS, & KEEP, RHSCOMP, NRHS, LRHSCOMP, FIRST_ROW_RHSCOMP, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSCOMP INTEGER :: FIRST_ROW_RHSCOMP INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LD_W, FIRST_ROW_W REAL :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSCOMP(FIRST_ROW_RHSCOMP+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_SOL_CPY_FS2RHSCOMP SUBROUTINE SMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSCOMP INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) REAL :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSCOMP(IPOSINRHSCOMP,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_SOL_BWD_GTHR SUBROUTINE SMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) REAL RES(N),LHS(N) REAL WRHS(N) REAL W(N) REAL RESMAX,RESL2,XNORM, SCLNRM REAL ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0E0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (MAX-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (MAX-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (MAX-NORM)=',1PD9.2) RETURN END SUBROUTINE SMUMPS_SOL_Q SUBROUTINE SMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) REAL ONE PARAMETER (ONE = 1.0E0) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE SMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) REAL ONE PARAMETER (ONE = 1.0E0) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL strsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE SMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY REAL, INTENT(IN) :: A(LA) REAL, INTENT(INOUT) :: WCB(LWCB) REAL, INTENT(IN) :: COEF_Y REAL ALPHA, ZERO, ONE PARAMETER (ZERO = 0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL sgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL sgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL sgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE SMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE SMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) USE SMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) REAL, INTENT(IN) :: WCB( LWCB ), A( LA ) REAL, INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: TempNROW, J1, J3, PANEL_SIZE, TYPEF INTEGER :: IPOSINRHSCOMP, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 REAL :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG REAL ONE PARAMETER (ONE = 1.0E0) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL TYPEF= TYPEF_U ENDIF PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE SMUMPS_SOLVE_LD_AND_RELOAD SUBROUTINE SMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) REAL, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_REAL, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_SCALING_LOC MUMPS_5.4.1/src/zfac_par_m.F0000664000175000017500000010337714102210525015730 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_PAR_M CONTAINS SUBROUTINE ZMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND, FILS, STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, & NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, & DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS ) !$ USE OMP_LIB USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_CBSTATIC2DYNAMIC, & ZMUMPS_DM_FREEALLDYNAMICCB USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_FAC_ASM_MASTER_M USE ZMUMPS_FAC_ASM_MASTER_ELT_M USE ZMUMPS_FAC1_LDLT_M USE ZMUMPS_FAC2_LDLT_M USE ZMUMPS_FAC1_LU_M USE ZMUMPS_FAC2_LU_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX(kind=8), INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX(kind=8), TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(N) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS, NASS, HF, XSIZE INTEGER(8) NFRONT8 INTEGER(8) :: POSELT INTEGER IPOSROOT, IPOSROOTROWINDICES INTEGER GLOBK109 INTEGER(8) :: LBUFRX COMPLEX(kind=8), POINTER, DIMENSION(:) :: BUFRX LOGICAL :: IS_BUFRX_ALLOCATED DOUBLE PRECISION FLOP1 INTEGER TYPE LOGICAL SON_LEVEL2, SET_IRECV, BLOCKING, & MESSAGE_RECEIVED LOGICAL AVOID_DELAYED LOGICAL LAST_CALL INTEGER MASTER_ROOT INTEGER LOCAL_M, LOCAL_N INTEGER LRHS_CNTR_MASTER_ROOT, FWD_LOCAL_N_RHS LOGICAL ROOT_OWNER EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR LOGICAL ZMUMPS_POOL_EMPTY EXTERNAL ZMUMPS_POOL_EMPTY, ZMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER numroc EXTERNAL numroc INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 STACK_RIGHT_AUTHORIZED = .TRUE. CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL ZMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF KEEP(429)=0 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. ZMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL ZMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL ZMUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL ZMUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL ZMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL ZMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL_LDLT_NIV2, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL ZMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL ZMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSE JOBASS = 0 CALL ZMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL ZMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in ZMUMPS_FAC_PAR", POSELT CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(STEP(INODE)) XSIZE = KEEP(IXSZ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF (KEEP(50).EQ.0) THEN CALL ZMUMPS_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL ZMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL ZMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL ZMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in ZMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' Stop END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in ZMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in ZMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL ZMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL ZMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL ZMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL ZMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL ZMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU IS_BUFRX_ALLOCATED = .FALSE. ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -9 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before ZMUMPS_FACTO_ROOT', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL ZMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (root%yes.AND.KEEP(60).EQ.0) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL ZMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in ZMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (root%yes. AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (MYID_NODES .EQ. MASTER_ROOT) THEN LRHS_CNTR_MASTER_ROOT = root%TOT_ROOT_SIZE*KEEP(253) ELSE LRHS_CNTR_MASTER_ROOT = 1 ENDIF ALLOCATE(root%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before ZMUMPS_FACTO_ROOT', & LRHS_CNTR_MASTER_ROOT CALL MUMPS_ABORT() ENDIF FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL ZMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & root%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & root%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) & ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF RETURN END SUBROUTINE ZMUMPS_FAC_PAR SUBROUTINE ZMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE ZMUMPS_CHANGE_HEADER END MODULE ZMUMPS_FAC_PAR_M MUMPS_5.4.1/src/zfac_sol_pool.F0000664000175000017500000004420014102210524016444 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE ZMUMPS_INIT_POOL_LAST3 SUBROUTINE ZMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL ZMUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE ZMUMPS_INSERT_POOL_N LOGICAL FUNCTION ZMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) ZMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION ZMUMPS_POOL_EMPTY SUBROUTINE ZMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, ZMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, ZMUMPS_POOL_EMPTY EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in ZMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( ZMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in ZMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in ZMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL ZMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL ZMUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL ZMUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in ZMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL ZMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL ZMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL ZMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL ZMUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE ZMUMPS_EXTRACT_POOL SUBROUTINE ZMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,MYID,SLAVEF,PROC,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),STEP(N),PROCNODE(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL ZMUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL ZMUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL ZMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL ZMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE ZMUMPS_MEM_CONS_MNG SUBROUTINE ZMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL ZMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL ZMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL ZMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE ZMUMPS_MEM_NODE_SELECT SUBROUTINE ZMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE ZMUMPS_GET_INODE_FROM_POOL MUMPS_5.4.1/src/dfac_sol_pool.F0000664000175000017500000004420014102210522016414 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE DMUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE DMUMPS_INIT_POOL_LAST3 SUBROUTINE DMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE DMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL DMUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE DMUMPS_INSERT_POOL_N LOGICAL FUNCTION DMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) DMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION DMUMPS_POOL_EMPTY SUBROUTINE DMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE DMUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, DMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, DMUMPS_POOL_EMPTY EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in DMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( DMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in DMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in DMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL DMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL DMUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL DMUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in DMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL DMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL DMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL DMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL DMUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE DMUMPS_EXTRACT_POOL SUBROUTINE DMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE DMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,MYID,SLAVEF,PROC,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),STEP(N),PROCNODE(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL DMUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL DMUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL DMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL DMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE DMUMPS_MEM_CONS_MNG SUBROUTINE DMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE DMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL DMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL DMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL DMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE DMUMPS_MEM_NODE_SELECT SUBROUTINE DMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE DMUMPS_GET_INODE_FROM_POOL MUMPS_5.4.1/src/send_driver.F0000664000175000017500000003735114102210525016131 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_END_DRIVER( id ) USE SMUMPS_OOC USE SMUMPS_STRUC_DEF USE SMUMPS_BUF IMPLICIT NONE include 'mpif.h' TYPE( SMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR INTEGER MASTER PARAMETER ( MASTER = 0 ) C Explicit needed because of pointer arguments INTERFACE SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES END INTERFACE I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C ---------------------------------- C Special stuff for implementations C where MPI_CANCEL does not exist or C is not correctly implemented. C At the moment, this is only C required for the slaves. C ---------------------------------- IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL SMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. id%root%yes ) THEN CALL blacs_gridexit( id%root%CNTXT_BLACS ) id%root%gridinit_done = .FALSE. END IF END IF IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. (This was the case on the C old SP2 in Bonn.) CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF C ----------------------------------- C Right-hand-side is always user data C We do not free it. C ----------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C C C C --------------------------------- C Allocated by SMUMPS, Used by user. C SMUMPS deallocates. User should C use them before SMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) C C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C ------------------------------------------------ C For hybrid host and element entry, C and DBLARR have not been allocated C on the master except if there was scaing. C ------------------------------------------------ IF (id%KEEP(46).eq.1 .and. & id%KEEP(55).ne.0 .and. & id%MYID .eq. MASTER .and. & id%KEEP(52) .eq. 0 ) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF IF (associated(id%INTARR)) THEN DEALLOCATE(id%INTARR) NULLIFY(id%INTARR) ENDIF IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF C IPIV is used both for ScaLAPACK and RR C Keep it outside SMUMPS_RR_FREE_POINTERS IF (associated(id%root%IPIV)) THEN DEALLOCATE(id%root%IPIV) NULLIFY(id%root%IPIV) ENDIF IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(id%root%RHS_ROOT))THEN DEALLOCATE(id%root%RHS_ROOT) NULLIFY(id%root%RHS_ROOT) ENDIF CALL SMUMPS_RR_FREE_POINTERS(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C id%CANDIDATES,id%I_AM_CAND and id%ISTEP_TO_INIV2 C can be allocated on non-working master C in the case of arrowheads distribution IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF c IF (id%KEEP(201).GT.0) THEN IF(associated (id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated (id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated (id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated (id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF IF(associated (id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF c ENDIF ! IF(id%KEEP(486).NE.0) THEN IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF CALL SMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%MPITOOMP_PROCS_MAP)) THEN DEALLOCATE(id%MPITOOMP_PROCS_MAP) NULLIFY(id%MPITOOMP_PROCS_MAP) ENDIF IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C ---------------------------------------------- C Deallocate S only after finishing the receives C (S is normally the largest memory available) C ---------------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) DEALLOCATE(id%S) ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL SMUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL SMUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C Mapping information used during solve IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF RETURN END SUBROUTINE SMUMPS_END_DRIVER SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE SMUMPS_LR_DATA_M, only : SMUMPS_BLR_STRUC_TO_MOD, & SMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL SMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL SMUMPS_BLR_END_MODULE(0, KEEP8, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES MUMPS_5.4.1/src/dfac_process_band.F0000664000175000017500000002621614102210522017237 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE DMUMPS_LOAD USE DMUMPS_LR_DATA_M, ONLY: DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_RECU = BUFR( 8 ) LRSTATUS = BUFR( 9 ) ESTIM_NFS4FATHER_ATSON = BUFR(10) IBUFR = 11 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL DMUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_RECU + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_RECU + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) CALL DMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_RECU : & IBUFR + NSLAVES_RECU + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) THEN write(6,*) " Internal error in DMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_RECU ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL DMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL DMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE DMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL DMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in DMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_TREAT_DESCBAND MUMPS_5.4.1/src/dfac_mem_free_block_cb.F0000664000175000017500000000600014102210522020157 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE DMUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER IPOSSHIFT INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL DMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE DMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.4.1/src/mumps_register_thread.h0000664000175000017500000000121714102210474020256 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_REGISTER_THREAD_H #define MUMPS_REGISTER_THREAD_H void mumps_register_thread_return(); { /* Registering tools will be available in the future. */ } #endif /* MUMPS_REGISTER_THREAD_H */ MUMPS_5.4.1/src/sfac_lr.F0000664000175000017500000030004114102210522015220 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_LR USE SMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL SMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO REAL, intent(inout) :: A(LA) REAL, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS POSELTD = 1_8 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL SMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J), BLR_LS(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO IF (IFLAG.LT.0) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL SMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J), BLR_LS(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif RETURN END SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR REAL, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if defined(BLR_MT) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL sgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL sgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL sgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR REAL, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & SMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL sgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL sgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL sgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP REAL, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL sgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL sgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL sgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL SMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) REAL :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if defined(BLR_MT) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), & BLR_L(IND_L), MIDBLK_COMPRESS, & MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(real(ACC_LRB%M*ACC_LRB%N)/real(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE REAL, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & SMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE SMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN REAL, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: NCB, MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) NCB = NFRONT - NASS ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'SMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC INTEGER :: FRONT_CB_BLR_SAVINGS LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) ACC_LRB => ACC_LUA(1) FRONT_CB_BLR_SAVINGS = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if defined(BLR_MT) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in SMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL SMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL SMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL SMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & LRB%M*LRB%N - LRB%M*LRB%K - LRB%N*LRB%K ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL SMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL SMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL SMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NFRONT-NASS, NFRONT-NASS, 0, 1, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, 0, 1, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif ENDIF END SUBROUTINE SMUMPS_BLR_UPD_CB_LEFT SUBROUTINE SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN, CBASM_TOFIX_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN LOGICAL,OPTIONAL,intent(in) :: CBASM_TOFIX_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I, ONLY_NELIM LOGICAL :: CBASM_TOFIX #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT REAL :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO = 0.0E0) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF IF (present(CBASM_TOFIX_IN)) THEN CBASM_TOFIX = CBASM_TOFIX_IN ELSE CBASM_TOFIX = .FALSE. ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP = BEGS_BLR_FIRST_OFFDIAG #if !defined(BLR_MT) IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(I)%N ELSE BIP = BIP + BLR_PANEL(I)%M ENDIF ENDDO ENDIF #endif #if defined(BLR_MT) LAST_IP = CURRENT_BLR+1 CHUNK = 1 !$OMP DO PRIVATE(POSELT_BLOCK, M, N, K, I) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN IF (CBASM_TOFIX) THEN POSELT_BLOCK = POSELT & + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) + int(BIP-1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21 & .AND..NOT.CBASM_TOFIX) THEN CALL sgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL sgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL sgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL sgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF (CBASM_TOFIX) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSEIF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ENDIF #endif ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE SMUMPS_DECOMPRESS_PANEL SUBROUTINE SMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U REAL, TARGET, DIMENSION(:) :: RWORK REAL, TARGET, DIMENSION(:,:) :: BLOCK REAL, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO, FRONT_CB_BLR_SAVINGS INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if defined(BLR_MT) INTEGER :: CHUNK #endif REAL, POINTER, DIMENSION(:) :: RWORK_THR REAL, POINTER, DIMENSION(:,:) :: BLOCK_THR REAL, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL SMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif FRONT_CB_BLR_SAVINGS = 0 OMP_NUM = 0 IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL SMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL sorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF END IF FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO #endif #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NROWS, NCOLS, SYM, NIV, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, SYM, NIV, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif END SUBROUTINE SMUMPS_COMPRESS_CB SUBROUTINE SMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, K480, & BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) REAL, TARGET, DIMENSION(:) :: RWORK REAL, TARGET, DIMENSION(:,:) :: BLOCK REAL, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTRINSIC maxval INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR REAL :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO = 0.0D0) INTEGER :: OMP_NUM REAL, POINTER, DIMENSION(:) :: RWORK_THR REAL, POINTER, DIMENSION(:,:) :: BLOCK_THR REAL, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if defined(BLR_MT) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN SMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (M.NE.BLR_PANEL(IP-CURRENT_BLR)%M) THEN write(*,*) 'Internal error in SMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & BLR_PANEL(IP-CURRENT_BLR)%M CALL MUMPS_ABORT() ENDIF IF (N.NE.BLR_PANEL(IP-CURRENT_BLR)%N) THEN write(*,*) 'Internal error in SMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & BLR_PANEL(IP-CURRENT_BLR)%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(real(M*N)/real(M+N)) IF (BLR_PANEL(IP-CURRENT_BLR)%K.GT.MAXRANK) THEN write(*,*) 'Internal error in SMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & BLR_PANEL(IP-CURRENT_BLR)%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL SMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) GOTO 3000 IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J), & JPVT_THR(J)) = & BLOCK_THR(1:MIN(RANK,J),J) IF(J.LT.RANK) BLR_PANEL(IP-CURRENT_BLR)% & R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO ENDDO CALL sorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = BLOCK_THR(1:M,I) END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS( & BLR_PANEL(IP-CURRENT_BLR), FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR), & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF 3000 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE SMUMPS_COMPRESS_PANEL SUBROUTINE SMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if defined(BLR_MT) INTEGER :: CHUNK #endif REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in SMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL SMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE SMUMPS_BLR_PANEL_LRTRSM END MODULE SMUMPS_FAC_LR MUMPS_5.4.1/src/zfac_process_blfac_slave.F0000664000175000017500000005230414102210524020621 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_FAC_LR USE ZMUMPS_LR_DATA_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY : ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if defined(BLR_MT) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: UDYNAMIC COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) DYNAMIC = .FALSE. POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) IF ( NPIV .LE. 0 ) THEN NPIV = - NPIV WRITE(*,*) MYID,':error, received negative NPIV in BLFAC' CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOLU, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL ZMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL ZMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL ZMUMPS_TREAT_DESCBAND(INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL ZMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL ZMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC) THEN CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL zgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL ZMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL ZMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (COMPRESS_CB) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL ZMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL ZMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.4.1/src/zana_LDLT_preprocess.F0000664000175000017500000007163314102210525017643 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE ZMUMPS_SET_CONSTRAINTS SUBROUTINE ZMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE ZMUMPS_EXPAND_PERMUTATION SUBROUTINE ZMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST INTRINSIC nint MP = ICNTL(2) IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE ZMUMPS_LDLT_COMPRESS SUBROUTINE ZMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) DOUBLE PRECISION :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 DOUBLE PRECISION :: BEST_SCORE,CUR_VAL,TMP,VAL DOUBLE PRECISION INITSCORE, ZMUMPS_UPDATESCORE, & ZMUMPS_UPDATE_INVERSE, ZMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM DOUBLE PRECISION ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = ZMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & ZMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = ZMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & ZMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = ZMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = ZMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = ZMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = ZMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE ZMUMPS_SYM_MWM FUNCTION ZMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE DOUBLE PRECISION ZMUMPS_UPDATESCORE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN ZMUMPS_UPDATESCORE = A+B ELSE ZMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION ZMUMPS_UPDATESCORE FUNCTION ZMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE DOUBLE PRECISION ZMUMPS_UPDATE_INVERSE DOUBLE PRECISION A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN ZMUMPS_UPDATE_INVERSE = A-B ELSE ZMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION ZMUMPS_UPDATE_INVERSE FUNCTION ZMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE DOUBLE PRECISION ZMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) DOUBLE PRECISION VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER ZMUMPS_METRIC2x2 = dble(INTER) / dble(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN ZMUMPS_METRIC2x2 = dble(L1+L2-2) ZMUMPS_METRIC2x2 = -(ZMUMPS_METRIC2x2**2)/2.0D0 ELSE IF(MERGE .EQ. 1) THEN ZMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L1-2) ELSE IF(MERGE .EQ. 2) THEN ZMUMPS_METRIC2x2 = - dble(L1+L2-4) * dble(L2-2) ELSE ZMUMPS_METRIC2x2 = - dble(L1-2) * dble(L2-2) ENDIF ELSE ZMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE ZMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE ZMUMPS_EXPAND_PERM_SCHUR SUBROUTINE ZMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0D0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE ZMUMPS_GNEW_SCHUR SUBROUTINE ZMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_GET_PERM_FROM_PE SUBROUTINE ZMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE ZMUMPS_GET_ELIM_TREE MUMPS_5.4.1/src/mumps_io_basic.h0000664000175000017500000001700114102210474016651 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_IO_BASIC_H #define MUMPS_IO_BASIC_H #include "mumps_compat.h" #include "mumps_c_types.h" #if ! defined(WITHOUT_PTHREAD) && defined(MUMPS_WIN32) # define WITHOUT_PTHREAD 1 #endif #if defined(_AIX) # if ! defined(_ALL_SOURCE) /* Macro needed for direct I/O on IBM AIX */ # define _ALL_SOURCE 1 # endif #endif #if ! defined (MUMPS_WIN32) # if ! defined(_XOPEN_SOURCE) /* Setting this macro avoids the warnings ("missing * prototype") related to the use of pread /pwrite */ # define _XOPEN_SOURCE 500 # endif #endif #define MAX_FILE_SIZE 1879048192 /* (2^31)-1-(2^27) */ /* */ /* Important Note : */ /* ================ */ /* On GNU systems, __USE_GNU must be defined to have */ /* access to the O_DIRECT I/O flag. */ /* */ #include #include #include #include #if ! defined (MUMPS_WIN32) # include # include # include # include # include # include #endif #if ! defined (MUMPS_WIN32) # define MUMPS_IO_FLAG_O_DIRECT 0 #endif /* Force WITH_PFUNC on architectures where we know that it should work */ #if (defined (sgi) || defined (__sgi)) || defined(_AIX) || (defined(sun) || defined(__sun)) || defined(_GNU_SOURCE) # undef WITH_PFUNC # define WITH_PFUNC #endif #define IO_SYNC 0 #define IO_ASYNC_TH 1 #define IO_ASYNC_AIO 2 #define IO_READ 1 #define IO_WRITE 0 #define UNITIALIZED "NAME_NOT_INITIALIZED" #define MUMPS_OOC_DEFAULT_DIR "/tmp" #if defined(MUMPS_WIN32) # define SEPARATOR "\\" #else # define SEPARATOR "/" #endif /* #define NB_FILE_TYPE_FACTO 1 */ /* #define NB_FILE_TYPE_SOLVE 1 */ #define my_max(x,y) ( (x) > (y) ? (x) : (y) ) #define my_ceil(x) ( (MUMPS_INT)(x) >= (x) ? (MUMPS_INT)(x) : ( (MUMPS_INT)(x) + 1 ) ) typedef struct __mumps_file_struct{ MUMPS_INT write_pos; MUMPS_INT current_pos; MUMPS_INT is_opened; #if ! defined (MUMPS_WIN32) MUMPS_INT file; #else FILE* file; #endif char name[351]; /* Should be large enough to hold tmpdir, prefix, suffix */ }mumps_file_struct; typedef struct __mumps_file_type{ #if ! defined (MUMPS_WIN32) MUMPS_INT mumps_flag_open; #else char mumps_flag_open[6]; #endif MUMPS_INT mumps_io_current_file_number; MUMPS_INT mumps_io_last_file_opened; MUMPS_INT mumps_io_nb_file_opened; MUMPS_INT mumps_io_nb_file; mumps_file_struct* mumps_io_pfile_pointer_array; mumps_file_struct* mumps_io_current_file; }mumps_file_type; /* Exported global variables */ #if ! defined (MUMPS_WIN32) # if defined (WITH_PFUNC) && ! defined (WITHOUT_PTHREAD) # include extern pthread_mutex_t mumps_io_pwrite_mutex; # endif /* extern MUMPS_INT* mumps_io_pfile_pointer_array; */ /* extern MUMPS_INT* mumps_io_current_file; */ /* #else /\*_WIN32*\/ */ /* extern FILE** mumps_io_current_file; */ /* extern FILE** mumps_io_pfile_pointer_array; */ #endif /* MUMPS_WIN32 */ /*extern mumps_file_struct* mumps_io_pfile_pointer_array; extern mumps_file_struct* mumps_io_current_file;*/ extern mumps_file_type* mumps_files; /* extern MUMPS_INT mumps_io_current_file_number; */ extern char* mumps_ooc_file_prefix; /* extern char** mumps_io_pfile_name; */ /* extern MUMPS_INT mumps_io_current_file_position; */ /* extern MUMPS_INT mumps_io_write_pos; */ /* extern MUMPS_INT mumps_io_last_file_opened; */ extern MUMPS_INT mumps_elementary_data_size; extern MUMPS_INT mumps_io_is_init_called; extern MUMPS_INT mumps_io_myid; extern MUMPS_INT mumps_io_max_file_size; /* extern MUMPS_INT mumps_io_nb_file; */ extern MUMPS_INT mumps_io_flag_async; extern MUMPS_INT mumps_io_k211; /* extern MUMPS_INT mumps_flag_open; */ extern MUMPS_INT directio_flag; extern MUMPS_INT mumps_directio_flag; extern MUMPS_INT mumps_io_nb_file_type; /* Exported functions */ MUMPS_INT mumps_set_file(MUMPS_INT type,MUMPS_INT file_number_arg); void mumps_update_current_file_position(mumps_file_struct* file_arg); MUMPS_INT mumps_compute_where_to_write(const double to_be_written,const MUMPS_INT type,long long vaddr,size_t already_written); MUMPS_INT mumps_prepare_pointers_for_write(double to_be_written,MUMPS_INT * pos_in_file, MUMPS_INT * file_number,const MUMPS_INT type,long long vaddr,size_t already_written); MUMPS_INT mumps_io_do_write_block(void * address_block,long long block_size,MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_io_do_read_block(void * address_block,long long block_size,MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_compute_nb_concerned_files(long long block_size,MUMPS_INT * nb_concerned_files,long long vaddr); MUMPS_INLINE MUMPS_INT mumps_gen_file_info(long long vaddr, MUMPS_INT * pos, MUMPS_INT * file); MUMPS_INT mumps_free_file_pointers(MUMPS_INT* step); MUMPS_INT mumps_init_file_structure(MUMPS_INT *_myid, long long *total_size_io,MUMPS_INT *size_element,MUMPS_INT *nb_file_type,MUMPS_INT *flag_tab); MUMPS_INT mumps_init_file_name(char* mumps_dir,char* mumps_file,MUMPS_INT* mumps_dim_dir,MUMPS_INT* mumps_dim_file,MUMPS_INT* _myid); void mumps_io_init_file_struct(MUMPS_INT* nb,MUMPS_INT which); MUMPS_INT mumps_io_alloc_file_struct(MUMPS_INT* nb,MUMPS_INT which); MUMPS_INT mumps_io_get_nb_files(MUMPS_INT* nb_files, const MUMPS_INT* type); MUMPS_INT mumps_io_get_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type); MUMPS_INT mumps_io_alloc_pointers(MUMPS_INT * nb_file_type, MUMPS_INT * dim); MUMPS_INT mumps_io_init_vars(MUMPS_INT* myid_arg,MUMPS_INT* size_element,MUMPS_INT* async_arg); MUMPS_INT mumps_io_set_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type); MUMPS_INT mumps_io_open_files_for_read(); MUMPS_INT mumps_io_set_last_file(MUMPS_INT* dim,MUMPS_INT* type); MUMPS_INT mumps_io_write__(void *file, void *loc_add, size_t write_size, MUMPS_INT where,MUMPS_INT type); #if ! defined (MUMPS_WIN32) MUMPS_INT mumps_io_write_os_buff__(void *file, void *loc_add, size_t write_size, MUMPS_INT where); MUMPS_INT mumps_io_write_direct_io__(void *file, void *loc_addr, size_t write_size, MUMPS_INT where,MUMPS_INT type); MUMPS_INT mumps_io_flush_write__(MUMPS_INT type); #else MUMPS_INT mumps_io_write_win32__(void *file, void *loc_add, size_t write_size, MUMPS_INT where); #endif MUMPS_INT mumps_io_read__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset,MUMPS_INT type); #if ! defined (MUMPS_WIN32) MUMPS_INT mumps_io_read_os_buff__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset); MUMPS_INT mumps_io_read_direct_io__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset,MUMPS_INT type); #else MUMPS_INT mumps_io_read_win32__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset); #endif MUMPS_INT mumps_compute_file_size(void *file,size_t *size); #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # if defined (WITH_PFUNC) MUMPS_INT mumps_io_protect_pointers(); MUMPS_INT mumps_io_unprotect_pointers(); MUMPS_INT mumps_io_init_pointers_lock(); MUMPS_INT mumps_io_destroy_pointers_lock(); # endif /* WITH_PFUNC */ #endif /* MUMPS_WIN32 */ #endif /* MUMPS_IO_BASIC_H */ MUMPS_5.4.1/src/sol_common.F0000664000175000017500000001350614102210475015772 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SOL_GET_NPIV_LIELL_IPOS ( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IMPLICIT NONE INTEGER, INTENT(IN) :: ISTEP, LIW, KEEP(500), N INTEGER, INTENT(IN) :: IW( LIW ) INTEGER, INTENT(IN) :: STEP( N ), PTRIST( KEEP(28) ) INTEGER, INTENT(OUT) :: NPIV, LIELL, IPOS INCLUDE 'mumps_headers.h' INTEGER :: SROOT IF (KEEP(38) .NE. 0) THEN SROOT = STEP(KEEP(38)) ELSE IF (KEEP(20) .NE. 0) THEN SROOT = STEP(KEEP(20)) ELSE SROOT = 0 ENDIF IPOS = PTRIST(ISTEP) IF (IPOS .LE. 0) THEN WRITE(*,*) "Internal error 1 in MUMPS_SOL_GET_NPIV_LIELL_IPOS", & ISTEP CALL MUMPS_ABORT() ENDIF NPIV = IW(IPOS+3+KEEP(IXSZ)) IF ( ISTEP.EQ.SROOT ) THEN IPOS = PTRIST(ISTEP) LIELL = IW(IPOS+3+KEEP(IXSZ)) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2+ KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) ENDIF RETURN END SUBROUTINE MUMPS_SOL_GET_NPIV_LIELL_IPOS SUBROUTINE MUMPS_BUILD_IRHS_loc(MYID_NODES, NSLAVES, N, & PTRIST, KEEP,KEEP8, IW, LIW, STEP, PROCNODE_STEPS, & IRHS_loc, ROW_OR_COL_INDICES) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID_NODES, NSLAVES, N, LIW INTEGER, INTENT(IN) :: PTRIST(KEEP(28)) INTEGER, INTENT(IN) :: IW(LIW), STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(OUT) :: IRHS_loc(KEEP(89)) INTEGER, INTENT(IN) :: ROW_OR_COL_INDICES INTEGER :: ISTEP INTEGER :: NPIV, LIELL, IPOS INTEGER :: IIRHS_loc INTEGER :: J1 INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE IIRHS_loc = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS ( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF ( ROW_OR_COL_INDICES .EQ. 0 .OR. KEEP(50).NE.0 ) THEN J1 = IPOS + 1 ELSE IF (ROW_OR_COL_INDICES .EQ. 1 ) THEN J1 = IPOS + LIELL + 1 ELSE WRITE(*,*) "Internal error 1 in MUMPS_BUILD_IRHS_loc", & ROW_OR_COL_INDICES CALL MUMPS_ABORT() ENDIF IF (IIRHS_loc+NPIV .GT. KEEP(89)) THEN WRITE(*,*) "Internal error 2 in MUMPS_BUILD_IRHS_loc", & IIRHS_loc, KEEP(89) CALL MUMPS_ABORT() ENDIF IRHS_loc(IIRHS_loc+1:IIRHS_loc+NPIV)=IW(J1:J1+NPIV-1) IIRHS_loc=IIRHS_loc+NPIV ENDIF ENDDO IF (IIRHS_loc .NE. KEEP(89)) THEN WRITE(*,*) "Internal error 3 in MUMPS_BUILD_IRHS_loc", & IIRHS_loc, KEEP(89) CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_BUILD_IRHS_loc SUBROUTINE MUMPS_SOL_RHSMAPINFO( N, Nloc_RHS, INFO23, & IRHS_loc, MAP_RHS_loc, & POSINRHSCOMP_FWD, & NSLAVES, MYID_NODES, COMM_NODES, & ICNTL, INFO ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, Nloc_RHS INTEGER, INTENT(IN) :: INFO23 INTEGER, INTENT(IN) :: IRHS_loc (max(1,Nloc_RHS)) INTEGER, INTENT(OUT) :: MAP_RHS_loc(max(1,Nloc_RHS)) INTEGER, INTENT(IN) :: POSINRHSCOMP_FWD (N) INTEGER, INTENT(IN) :: NSLAVES, MYID_NODES, COMM_NODES INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) INCLUDE 'mpif.h' INTEGER :: I, NFS_LOC, NFS_TOT, IERR_MPI, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: GLOBAL_MAPPING ALLOCATE(GLOBAL_MAPPING(N), stat=allocok) IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)= N ENDIF CALL MPI_ALLREDUCE(MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI) IF (allocok .NE. 0) RETURN NFS_LOC = 0 NFS_TOT = 0 DO I = 1, N IF (POSINRHSCOMP_FWD(I) .LE. 0) THEN GLOBAL_MAPPING(I) = 0 ELSE GLOBAL_MAPPING(I) = MYID_NODES NFS_LOC = NFS_LOC + 1 ENDIF ENDDO IF (NFS_LOC .NE. INFO23) THEN WRITE(*,*) "Internal error 1 in MUMPS_SOL_RHSMAPINFO", & NFS_LOC, INFO23 CALL MUMPS_ABORT() ENDIF CALL MPI_ALLREDUCE(NFS_LOC, NFS_TOT, 1, MPI_INTEGER, & MPI_SUM, COMM_NODES, IERR_MPI) IF (NFS_tot .NE. N) THEN WRITE(*,*) "Internal error 1 in MUMPS_SOL_RHSMAPINFO", & NFS_LOC, NFS_TOT, N CALL MUMPS_ABORT() ENDIF CALL MPI_ALLREDUCE(MPI_IN_PLACE, GLOBAL_MAPPING, N, MPI_INTEGER, & MPI_SUM, COMM_NODES, IERR_MPI) DO I = 1, Nloc_RHS IF (IRHS_loc(I) .GE.1 .AND. IRHS_loc(I) .LE. N) THEN MAP_RHS_loc(I) = GLOBAL_MAPPING(IRHS_loc(I)) ELSE MAP_RHS_loc(I) = -87878787 ENDIF ENDDO DEALLOCATE(GLOBAL_MAPPING) RETURN END SUBROUTINE MUMPS_SOL_RHSMAPINFO MUMPS_5.4.1/src/cfac_sol_pool.F0000664000175000017500000004420014102210523016414 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE CMUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE CMUMPS_INIT_POOL_LAST3 SUBROUTINE CMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE CMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL CMUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE CMUMPS_INSERT_POOL_N LOGICAL FUNCTION CMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) CMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION CMUMPS_POOL_EMPTY SUBROUTINE CMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE CMUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, CMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, CMUMPS_POOL_EMPTY EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in CMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( CMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in CMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in CMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL CMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL CMUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL CMUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in CMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL CMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL CMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL CMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL CMUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE CMUMPS_EXTRACT_POOL SUBROUTINE CMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE CMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,MYID,SLAVEF,PROC,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),STEP(N),PROCNODE(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL CMUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL CMUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL CMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL CMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE CMUMPS_MEM_CONS_MNG SUBROUTINE CMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE CMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL CMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL CMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL CMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE CMUMPS_MEM_NODE_SELECT SUBROUTINE CMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE CMUMPS_GET_INODE_FROM_POOL MUMPS_5.4.1/src/cfac_front_LU_type1.F0000664000175000017500000012136514102210524017451 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC1_LU_M CONTAINS SUBROUTINE CMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & , PERM & ) USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_OOC USE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW COMPLEX, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) REAL UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX, POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC COMPLEX :: ZERO PARAMETER (ZERO=(0.0E0,0.0E0)) INCLUDE 'mumps_headers.h' INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U) CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL CMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL CMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif CALL CMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL CMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL CMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL CMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL CMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL CMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0)) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) END SUBROUTINE CMUMPS_FAC1_LU END MODULE CMUMPS_FAC1_LU_M MUMPS_5.4.1/src/sfac_distrib_distentry.F0000664000175000017500000010044714102210521020357 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE SMUMPS_BUILD_MAPPING SUBROUTINE SMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (SMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR REAL DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTRAIW( N ), PTRARW( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, COMM, NBRECORDS INTEGER(8) :: LA INTEGER SLAVEF INTEGER ISTEP_TO_INIV2(KEEP(71)) INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) REAL A( LA ) TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I INTEGER(8) :: I18, IA8 INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS REAL VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER(8) :: IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI REAL, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI REAL, ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 INFO(2) = N * 2 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO I = 1, N I18 = PTRAIW( I ) IA8 = PTRARW( I ) IF ( IA8 .GT. 0_8 ) THEN DBLARR( IA8 ) = ZERO IW4( I, 1 ) = INTARR( I18 ) IW4( I, 2 ) = -INTARR( I18 + 1_8 ) INTARR( I18 + 2_8 ) = I END IF END DO EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA8, ISHIFT, IIW8, IS18, IS8, IAS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_REAL, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) INTARR(IS18+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,2) = IW4(IARR,2) - 1 ELSE ISHIFT = IW4(IARR,1) INTARR(PTRAIW(IARR)+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,1) = IW4(IARR,1) - 1 IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L_ROW(JSEND) JPOSROOT = root%RG2L_ROW(IARR ) ELSE IPOSROOT = root%RG2L_ROW(IARR ) JPOSROOT = root%RG2L_ROW(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JSEND IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ELSE IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JSEND IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ENDIF DEST=MASTER_NODE CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .GE. 0) THEN CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP, KEEP8 ) ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST = -3 CALL SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, &BUFI, BUFR, BUFRECI, BUFRECR, &NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, &SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, &N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, &PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, &IW4(1,1), root, KEEP,KEEP8 ) DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_REAL, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN END SUBROUTINE SMUMPS_REDISTRIBUTION SUBROUTINE SMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, N, & PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV, LOCAL_M, LOCAL_N INTEGER(8) :: LINTARR, LDBLARR INTEGER(8) :: LA, PTR_ROOT INTEGER BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) INTEGER BUFRECI( NBRECORDS * 2 + 1 ) INTEGER IREQI(SLAVEF), IREQR(SLAVEF), IACT(SLAVEF) INTEGER IW4( N, 2 ) INTEGER(8) PTRAIW( N ), PTRARW( N ) INTEGER PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR( LINTARR ) REAL DBLARR( LDBLARR ), A( LA ) LOGICAL SEND_ACTIVE(SLAVEF) REAL BUFR( NBRECORDS, 2, SLAVEF ) REAL BUFRECR( NBRECORDS ) REAL VAL INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R, MSGSOU LOGICAL FLAG, SEND_LOCAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( DEST .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST + 1 IEND = DEST + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_REAL, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF ELSE CALL MPI_WAIT( IREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. END IF END DO IF ( ISLAVE - 1 .ne. MYID ) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, ARR_INT, COMM, & IREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFR(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_R, & MPI_REAL, ISLAVE - 1, ARR_REAL, COMM, & IREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. ELSE SEND_LOCAL = .TRUE. END IF IACT( ISLAVE ) = 3 - IACT( ISLAVE ) BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 END IF IF ( DEST .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL SMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE SMUMPS_DIST_FILL_BUFFER SUBROUTINE SMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) REAL BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8) :: PTRAIW( N ), PTRARW( N ) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA REAL A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS REAL VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE SMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.4.1/src/sfac_process_bf.F0000664000175000017500000000103114102210521016724 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE SMUMPS_PROCESS_BF_RETURN MUMPS_5.4.1/src/dfac_scalings.F0000664000175000017500000002764314102210522016405 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FAC_A(N, NZ8, NSCA, & ASPK, IRN, ICN, COLSCA, ROWSCA, WK, LWK8, WK_REAL, & LWK_REAL, ICNTL, INFO) IMPLICIT NONE INTEGER N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER IRN(NZ8), ICN(NZ8) INTEGER ICNTL(60), INFO(80) DOUBLE PRECISION, INTENT(IN) :: ASPK(NZ8) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER(8), INTENT(IN) :: LWK8 INTEGER LWK_REAL DOUBLE PRECISION WK(LWK8) DOUBLE PRECISION WK_REAL(LWK_REAL) INTEGER MPG,LP INTEGER IWNOR INTEGER I LOGICAL PROK DOUBLE PRECISION ONE PARAMETER( ONE = 1.0D0 ) LP = ICNTL(1) MPG = ICNTL(2) MPG = ICNTL(3) PROK = ((MPG.GT.0).AND.(ICNTL(4).GE.2)) IF (PROK) THEN WRITE(MPG,101) ELSE MPG = 0 ENDIF 101 FORMAT(/' ****** SCALING OF ORIGINAL MATRIX '/) IF (NSCA.EQ.1) THEN IF (PROK) & WRITE (MPG,*) ' DIAGONAL SCALING ' ELSEIF (NSCA.EQ.3) THEN IF (PROK) & WRITE (MPG,*) ' COLUMN SCALING' ELSEIF (NSCA.EQ.4) THEN IF (PROK) & WRITE (MPG,*) ' ROW AND COLUMN SCALING (1 Pass)' ENDIF DO 10 I=1,N COLSCA(I) = ONE ROWSCA(I) = ONE 10 CONTINUE IF (5*N.GT.LWK_REAL) GOTO 410 IWNOR = 1 IF (NSCA.EQ.1) THEN CALL DMUMPS_FAC_V(N,NZ8,ASPK,IRN,ICN, & COLSCA,ROWSCA,MPG) ELSEIF (NSCA.EQ.3) THEN CALL DMUMPS_FAC_Y(N,NZ8,ASPK,IRN,ICN,WK_REAL(IWNOR), & COLSCA, MPG) ELSEIF (NSCA.EQ.4) THEN CALL DMUMPS_ROWCOL(N,NZ8,IRN,ICN,ASPK, & WK_REAL(IWNOR),WK_REAL(IWNOR+N),COLSCA,ROWSCA,MPG) ENDIF GOTO 500 410 INFO(1) = -5 INFO(2) = 5*N-LWK_REAL IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE(LP,*) '*** ERROR: Not enough space to scale matrix' GOTO 500 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_A SUBROUTINE DMUMPS_ROWCOL(N,NZ8,IRN,ICN,VAL, & RNOR,CNOR,COLSCA,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 DOUBLE PRECISION VAL(NZ8) DOUBLE PRECISION RNOR(N),CNOR(N) DOUBLE PRECISION COLSCA(N),ROWSCA(N) DOUBLE PRECISION CMIN,CMAX,RMIN,ARNOR,ACNOR INTEGER IRN(NZ8), ICN(NZ8) DOUBLE PRECISION VDIAG INTEGER MPRINT INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 50 J=1,N CNOR(J) = ZERO RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE IF (MPRINT.GT.0) THEN CMIN = CNOR(1) CMAX = CNOR(1) RMIN = RNOR(1) DO 111 I=1,N ARNOR = RNOR(I) ACNOR = CNOR(I) IF (ACNOR.GT.CMAX) CMAX=ACNOR IF (ACNOR.LT.CMIN) CMIN=ACNOR IF (ARNOR.LT.RMIN) RMIN=ARNOR 111 CONTINUE WRITE(MPRINT,*) '**** STAT. OF MATRIX PRIOR ROW&COL SCALING' WRITE(MPRINT,*) ' MAXIMUM NORM-MAX OF COLUMNS:',CMAX WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF COLUMNS:',CMIN WRITE(MPRINT,*) ' MINIMUM NORM-MAX OF ROWS :',RMIN ENDIF DO 120 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE / CNOR(J) ENDIF 120 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE / RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I) * RNOR(I) COLSCA(I) = COLSCA(I) * CNOR(I) 110 CONTINUE IF (MPRINT.GT.0) & WRITE(MPRINT,*) ' END OF SCALING BY MAX IN ROW AND COL' RETURN END SUBROUTINE DMUMPS_ROWCOL SUBROUTINE DMUMPS_FAC_Y(N,NZ8,VAL,IRN,ICN, & CNOR,COLSCA,MPRINT) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 DOUBLE PRECISION, INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION, INTENT(OUT) :: CNOR(N) DOUBLE PRECISION, INTENT(INOUT) :: COLSCA(N) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) INTEGER, INTENT(IN) :: MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DO 10 J=1,N CNOR(J) = ZERO 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.CNOR(J)) THEN CNOR(J) = VDIAG ENDIF 100 CONTINUE DO 110 J=1,N IF (CNOR(J).LE.ZERO) THEN CNOR(J) = ONE ELSE CNOR(J) = ONE/CNOR(J) ENDIF 110 CONTINUE DO 215 I=1,N COLSCA(I) = COLSCA(I) * CNOR(I) 215 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF COLUMN SCALING' RETURN END SUBROUTINE DMUMPS_FAC_Y SUBROUTINE DMUMPS_FAC_V(N,NZ8,VAL,IRN,ICN, & COLSCA,ROWSCA,MPRINT) INTEGER , INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ8 DOUBLE PRECISION , INTENT(IN) :: VAL(NZ8) DOUBLE PRECISION , INTENT(OUT) :: ROWSCA(N),COLSCA(N) INTEGER , INTENT(IN) :: IRN(NZ8),ICN(NZ8) INTEGER , INTENT(IN) :: MPRINT DOUBLE PRECISION :: VDIAG INTEGER :: I,J INTEGER(8) :: K8 INTRINSIC sqrt DOUBLE PRECISION ZERO, ONE PARAMETER(ZERO=0.0D0, ONE=1.0D0) DO 10 I=1,N ROWSCA(I) = ONE 10 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) IF ((I.GT.N).OR.(I.LE.0)) GOTO 100 J = ICN(K8) IF (I.EQ.J) THEN VDIAG = abs(VAL(K8)) IF (VDIAG.GT.ZERO) THEN ROWSCA(J) = ONE/(sqrt(VDIAG)) ENDIF ENDIF 100 CONTINUE DO 110 I=1,N COLSCA(I) = ROWSCA(I) 110 CONTINUE IF (MPRINT.GT.0) WRITE(MPRINT,*) ' END OF DIAGONAL SCALING' RETURN END SUBROUTINE DMUMPS_FAC_V SUBROUTINE DMUMPS_FAC_X(NSCA,N,NZ8,IRN,ICN,VAL, & RNOR,ROWSCA,MPRINT) INTEGER, INTENT(IN) :: N, NSCA INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION VAL(NZ8) DOUBLE PRECISION RNOR(N) DOUBLE PRECISION ROWSCA(N) INTEGER MPRINT DOUBLE PRECISION VDIAG INTEGER I,J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 DO 50 J=1,N RNOR(J) = ZERO 50 CONTINUE DO 100 K8=1_8,NZ8 I = IRN(K8) J = ICN(K8) IF ((I.LE.0).OR.(I.GT.N).OR. & (J.LE.0).OR.(J.GT.N)) GOTO 100 VDIAG = abs(VAL(K8)) IF (VDIAG.GT.RNOR(I)) THEN RNOR(I) = VDIAG ENDIF 100 CONTINUE DO 130 J=1,N IF (RNOR(J).LE.ZERO) THEN RNOR(J) = ONE ELSE RNOR(J) = ONE/RNOR(J) ENDIF 130 CONTINUE DO 110 I=1,N ROWSCA(I) = ROWSCA(I)* RNOR(I) 110 CONTINUE IF ( (NSCA.EQ.4) .OR. (NSCA.EQ.6) ) THEN DO 150 K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF (min(I,J).LT.1 .OR. I.GT.N .OR. J.GT.N) GOTO 150 VAL(K8) = VAL(K8) * RNOR(I) 150 CONTINUE ENDIF IF (MPRINT.GT.0) & WRITE(MPRINT,'(A)') ' END OF ROW SCALING' RETURN END SUBROUTINE DMUMPS_FAC_X SUBROUTINE DMUMPS_ANORMINF( id, ANORMINF, LSCAL ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MASTER, IERR PARAMETER( MASTER = 0 ) TYPE(DMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL INTEGER, DIMENSION (:), POINTER :: KEEP,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 LOGICAL :: I_AM_SLAVE DOUBLE PRECISION DUMMY(1) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0) DOUBLE PRECISION, ALLOCATABLE :: SUMR(:), SUMR_LOC(:) INTEGER :: allocok, MTYPE, I INFO =>id%INFO KEEP =>id%KEEP KEEP8 =>id%KEEP8 I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN ALLOCATE( SUMR( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN IF (.NOT.LSCAL) THEN CALL DMUMPS_SOL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1),KEEP8(1) ) ELSE CALL DMUMPS_SCAL_X(id%A(1), & id%KEEP8(28), id%N, & id%IRN(1), id%JCN(1), & SUMR, KEEP(1), KEEP8(1), & id%COLSCA(1)) ENDIF ELSE MTYPE = 1 IF (.NOT.LSCAL) THEN CALL DMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), SUMR, KEEP(1),KEEP8(1) ) ELSE CALL DMUMPS_SOL_SCALX_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), & id%A_ELT(1), & SUMR, KEEP(1),KEEP8(1), id%COLSCA(1)) ENDIF ENDIF ENDIF ELSE ALLOCATE( SUMR_LOC( id%N ), stat =allocok ) IF (allocok .GT.0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N RETURN ENDIF IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0 ) THEN IF (.NOT.LSCAL) THEN CALL DMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1) ) ELSE CALL DMUMPS_SCAL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & SUMR_LOC, id%KEEP(1),id%KEEP8(1), & id%COLSCA(1)) ENDIF ELSE SUMR_LOC = ZERO ENDIF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( SUMR_LOC, SUMR, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( SUMR_LOC, DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF DEALLOCATE (SUMR_LOC) ENDIF IF ( id%MYID .eq. MASTER ) THEN ANORMINF = dble(ZERO) IF (LSCAL) THEN DO I = 1, id%N ANORMINF = max(abs(id%ROWSCA(I) * SUMR(I)), & ANORMINF) ENDDO ELSE DO I = 1, id%N ANORMINF = max(abs(SUMR(I)), & ANORMINF) ENDDO ENDIF ENDIF CALL MPI_BCAST(ANORMINF, 1, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%MYID .eq. MASTER) DEALLOCATE (SUMR) RETURN END SUBROUTINE DMUMPS_ANORMINF MUMPS_5.4.1/src/csol_fwd.F0000664000175000017500000001450414102210523015416 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE CMUMPS_STATIC_PTR_M, ONLY : CMUMPS_SET_STATIC_PTR, & CMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS COMPLEX A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), LRHSCOMP COMPLEX, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL CMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL CMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL CMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL CMUMPS_SET_STATIC_PTR(A) CALL CMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL CMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error CMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL CMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE CMUMPS_SOL_R MUMPS_5.4.1/src/zmumps_save_restore_files.F0000664000175000017500000002617014102210525021120 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SAVE_RESTORE_FILES USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER :: LEN_SAVE_FILE PARAMETER( LEN_SAVE_FILE = 550) CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif #if defined(OOC_VERBOSE) write(*,*) 'First ooc file: ', & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH-2) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE ZMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="ZMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE ZMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 supp=200+MYID open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE ZMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix CHARACTER(len=255):: tmp_savedir,savedir CHARACTER(len=255):: tmp_saveprefix,saveprefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_savedir='' tmp_saveprefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_dir_C(len_save_dir,tmp_savedir) if(tmp_savedir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") then id%INFO(1) = -77 id%INFO(2) = 0 else savedir=trim(adjustl(tmp_savedir(1:len_save_dir))) len_save_dir=len_trim(savedir(1:len_save_dir)) endif ELSE savedir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(savedir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_prefix_C(len_save_prefix,tmp_saveprefix) if(tmp_saveprefix(1:len_save_prefix).EQ."NAME_NOT_INITIALIZED") & then saveprefix="save" len_save_prefix=len_trim(saveprefix) else saveprefix= & trim(adjustl(tmp_saveprefix(1:len_save_prefix))) len_save_prefix=len_trim(saveprefix(1:len_save_prefix)) endif ELSE saveprefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(saveprefix) ENDIF write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=savedir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(savedir))//"/" else SAVE_FILE=trim(adjustl(savedir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE ZMUMPS_GET_SAVE_FILES SUBROUTINE ZMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (ZMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE ZMUMPS_CHECK_FILE_NAME END MODULE ZMUMPS_SAVE_RESTORE_FILES SUBROUTINE ZMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE ZMUMPS_SAVE_FILES_RETURN MUMPS_5.4.1/src/zmumps_comm_buffer.F0000664000175000017500000040550314102210525017522 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_BUF PRIVATE PUBLIC :: ZMUMPS_BUF_TRY_FREE_CB, ZMUMPS_BUF_INIT, & ZMUMPS_BUF_INI_MYID, & ZMUMPS_BUF_ALLOC_CB , ZMUMPS_BUF_DEALL_CB , & ZMUMPS_BUF_ALLOC_SMALL_BUF, ZMUMPS_BUF_DEALL_SMALL_BUF, & ZMUMPS_BUF_ALLOC_LOAD_BUFFER,ZMUMPS_BUF_DEALL_LOAD_BUFFER, & ZMUMPS_BUF_SEND_CB, ZMUMPS_BUF_SEND_VCB, & ZMUMPS_BUF_SEND_1INT, ZMUMPS_BUF_SEND_DESC_BANDE, & ZMUMPS_BUF_SEND_MAPLIG, ZMUMPS_BUF_SEND_MAITRE2, & ZMUMPS_BUF_SEND_CONTRIB_TYPE2, & ZMUMPS_BUF_SEND_BLOCFACTO, ZMUMPS_BUF_SEND_BLFAC_SLAVE, & ZMUMPS_BUF_SEND_MASTER2SLAVE, & ZMUMPS_BUF_SEND_CONTRIB_TYPE3, ZMUMPS_BUF_SEND_RTNELIND, & ZMUMPS_BUF_SEND_ROOT2SLAVE, ZMUMPS_BUF_SEND_ROOT2SON, & ZMUMPS_BUF_SEND_BACKVEC,ZMUMPS_BUF_SEND_UPDATE_LOAD, & ZMUMPS_BUF_DIST_IRECV_SIZE, & ZMUMPS_BUF_BCAST_ARRAY, ZMUMPS_BUF_ALL_EMPTY, & ZMUMPS_BUF_BROADCAST, ZMUMPS_BUF_SEND_NOT_MSTR, & ZMUMPS_BUF_SEND_FILS ,ZMUMPS_BUF_DEALL_MAX_ARRAY & ,ZMUMPS_BUF_MAX_ARRAY_MINSIZE & ,ZMUMPS_BUF_TEST PUBLIC :: ZMUMPS_BLR_PACK_CB_LRB & ,ZMUMPS_MPI_PACK_LRB & ,ZMUMPS_MPI_UNPACK_LRB INTEGER NEXT, REQ, CONTENT, OVHSIZE PARAMETER( NEXT = 0, REQ = 1, CONTENT = 2, OVHSIZE = 2 ) INTEGER, SAVE :: SIZEofINT, SIZEofREAL, BUF_MYID TYPE ZMUMPS_COMM_BUFFER_TYPE INTEGER LBUF, HEAD, TAIL,LBUF_INT, ILASTMSG INTEGER, DIMENSION(:),POINTER :: CONTENT END TYPE ZMUMPS_COMM_BUFFER_TYPE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_CB TYPE ( ZMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_SMALL TYPE ( ZMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_LOAD INTEGER, SAVE :: SIZE_RBUF_BYTES INTEGER, SAVE :: BUF_LMAX_ARRAY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE ZMUMPS_BUF_TRY_FREE_CB() CALL ZMUMPS_BUF_TRY_FREE(BUF_CB) RETURN END SUBROUTINE ZMUMPS_BUF_TRY_FREE_CB SUBROUTINE ZMUMPS_BUF_TRY_FREE(B) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: B INCLUDE 'mpif.h' LOGICAL :: FLAG INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, & STATUS, IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF RETURN END SUBROUTINE ZMUMPS_BUF_TRY_FREE SUBROUTINE ZMUMPS_BUF_INI_MYID( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE ZMUMPS_BUF_INI_MYID SUBROUTINE ZMUMPS_BUF_INIT( IntSize, RealSize ) IMPLICIT NONE INTEGER IntSize, RealSize SIZEofINT = IntSize SIZEofREAL = RealSize NULLIFY(BUF_CB %CONTENT) NULLIFY(BUF_SMALL%CONTENT) NULLIFY(BUF_LOAD%CONTENT) BUF_CB%LBUF = 0 BUF_CB%LBUF_INT = 0 BUF_CB%HEAD = 1 BUF_CB%TAIL = 1 BUF_CB%ILASTMSG = 1 BUF_SMALL%LBUF = 0 BUF_SMALL%LBUF_INT = 0 BUF_SMALL%HEAD = 1 BUF_SMALL%TAIL = 1 BUF_SMALL%ILASTMSG = 1 BUF_LOAD%LBUF = 0 BUF_LOAD%LBUF_INT = 0 BUF_LOAD%HEAD = 1 BUF_LOAD%TAIL = 1 BUF_LOAD%ILASTMSG = 1 RETURN END SUBROUTINE ZMUMPS_BUF_INIT SUBROUTINE ZMUMPS_BUF_ALLOC_CB( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE ZMUMPS_BUF_ALLOC_CB SUBROUTINE ZMUMPS_BUF_ALLOC_SMALL_BUF( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE ZMUMPS_BUF_ALLOC_SMALL_BUF SUBROUTINE ZMUMPS_BUF_ALLOC_LOAD_BUFFER( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE ZMUMPS_BUF_ALLOC_LOAD_BUFFER SUBROUTINE ZMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_LOAD, IERR ) RETURN END SUBROUTINE ZMUMPS_BUF_DEALL_LOAD_BUFFER SUBROUTINE ZMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE ZMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF ALLOCATE(BUF_MAX_ARRAY(NFS4FATHER),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF BUF_LMAX_ARRAY=NFS4FATHER RETURN END SUBROUTINE ZMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE ZMUMPS_BUF_DEALL_CB( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_CB, IERR ) RETURN END SUBROUTINE ZMUMPS_BUF_DEALL_CB SUBROUTINE ZMUMPS_BUF_DEALL_SMALL_BUF( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_SMALL, IERR ) RETURN END SUBROUTINE ZMUMPS_BUF_DEALL_SMALL_BUF SUBROUTINE BUF_ALLOC( BUF, SIZE, IERR ) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE, IERR IERR = 0 BUF%LBUF = SIZE BUF%LBUF_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT IF ( associated ( BUF%CONTENT ) ) DEALLOCATE( BUF%CONTENT ) ALLOCATE( BUF%CONTENT( BUF%LBUF_INT ), stat = IERR ) IF (IERR .NE. 0) THEN NULLIFY( BUF%CONTENT ) IERR = -1 BUF%LBUF = 0 BUF%LBUF_INT = 0 END IF BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_ALLOC SUBROUTINE BUF_DEALL( BUF, IERR ) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER :: IERR INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( .NOT. associated ( BUF%CONTENT ) ) THEN BUF%HEAD = 1 BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END IF DO WHILE ( BUF%HEAD.NE.0 .AND. BUF%HEAD .NE. BUF%TAIL ) CALL MPI_TEST(BUF%CONTENT( BUF%HEAD + REQ ), FLAG, & STATUS, IERR_MPI) IF ( .not. FLAG ) THEN WRITE(*,*) '** Warning: trying to cancel a request.' WRITE(*,*) '** This might be problematic' CALL MPI_CANCEL( BUF%CONTENT( BUF%HEAD + REQ ), IERR_MPI ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), & IERR_MPI ) END IF BUF%HEAD = BUF%CONTENT( BUF%HEAD + NEXT ) END DO DEALLOCATE( BUF%CONTENT ) NULLIFY( BUF%CONTENT ) BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_DEALL SUBROUTINE ZMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) COMPLEX(kind=8) A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL ZMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_CB SUBROUTINE ZMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN COMPLEX(kind=8) CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) COMPLEX(kind=8) SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE ZMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, IPOSINRHSCOMP, NPIV COMPLEX(kind=8) W( max( 1, LDW * NRHS_B ) ) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_VCB SUBROUTINE ZMUMPS_BUF_SEND_1INT( I, DEST, TAG, COMM, & KEEP, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER IPOS, IREQ, MSG_SIZE, POSITION INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 CALL MPI_PACK_SIZE( 1, MPI_INTEGER, & COMM, MSG_SIZE, IERR_MPI ) CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in ZMUMPS_BUF_SEND_1INT', & ' Buf size (bytes)= ',BUF_SMALL%LBUF RETURN ENDIF POSITION=0 CALL MPI_PACK( I, 1, & MPI_INTEGER, BUF_SMALL%CONTENT( IPOS ), & MSG_SIZE, & POSITION, COMM, IERR_MPI ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_1INT SUBROUTINE ZMUMPS_BUF_ALL_EMPTY(CHECK_COMM_NODES, & CHECK_COMM_LOAD,FLAG) LOGICAL, INTENT(IN) :: CHECK_COMM_NODES, CHECK_COMM_LOAD LOGICAL, INTENT(OUT) :: FLAG LOGICAL FLAG1, FLAG2, FLAG3 FLAG = .TRUE. IF (CHECK_COMM_NODES) THEN CALL ZMUMPS_BUF_EMPTY( BUF_SMALL, FLAG1 ) CALL ZMUMPS_BUF_EMPTY( BUF_CB, FLAG2 ) FLAG = FLAG .AND. FLAG1 .AND. FLAG2 ENDIF IF ( CHECK_COMM_LOAD ) THEN CALL ZMUMPS_BUF_EMPTY( BUF_LOAD, FLAG3 ) FLAG = FLAG .AND. FLAG3 ENDIF RETURN END SUBROUTINE ZMUMPS_BUF_ALL_EMPTY SUBROUTINE ZMUMPS_BUF_EMPTY( B, FLAG ) TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL ZMUMPS_BUF_SIZE_AVAILABLE(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE ZMUMPS_BUF_EMPTY SUBROUTINE ZMUMPS_BUF_SIZE_AVAILABLE( B, SIZE_AV ) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER SIZE_AV INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END IF IF ( B%HEAD .LE. B%TAIL ) THEN SIZE_AV = max( B%LBUF_INT - B%TAIL, B%HEAD - 2 ) ELSE SIZE_AV = B%HEAD - B%TAIL - 1 END IF SIZE_AV = min(SIZE_AV - OVHSIZE, SIZE_AV) SIZE_AV = SIZE_AV * SIZEofINT RETURN END SUBROUTINE ZMUMPS_BUF_SIZE_AVAILABLE SUBROUTINE ZMUMPS_BUF_TEST() INTEGER :: IPOS, IREQ, IERR INTEGER, PARAMETER :: IONE=1 INTEGER :: MSG_SIZE INTEGER :: DEST2(1) DEST2=-10 MSG_SIZE=1 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2,.TRUE.) RETURN END SUBROUTINE ZMUMPS_BUF_TEST SUBROUTINE BUF_LOOK( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST, TEST_ONLY) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR LOGICAL, INTENT(IN), OPTIONAL :: TEST_ONLY INTEGER NDEST INTEGER, INTENT(IN) :: PDEST(max(1,NDEST)) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: MSG_SIZE_INT INTEGER :: IBUF LOGICAL :: FLAG INTEGER :: STATUS(MPI_STATUS_SIZE) IERR = 0 IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF MSG_SIZE_INT = ( MSG_SIZE + ( SIZEofINT - 1 ) ) / SIZEofINT MSG_SIZE_INT = MSG_SIZE_INT + OVHSIZE IF (present(TEST_ONLY)) RETURN FLAG = ( ( B%HEAD .LE. B%TAIL ) & .AND. ( & ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL ) & .OR. ( MSG_SIZE_INT .LE. B%HEAD - 2 ) ) ) & .OR. & ( ( B%HEAD .GT. B%TAIL ) & .AND. ( MSG_SIZE_INT .LE. B%HEAD - B%TAIL - 1 ) ) IF ( .NOT. FLAG & ) THEN IERR = -1 IF ( MSG_SIZE_INT .GT. B%LBUF_INT - 1 ) THEN IERR = -2 ENDIF IPOS = -1 IREQ = -1 RETURN END IF IF ( B%HEAD .LE. B%TAIL ) THEN IF ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL + 1 ) THEN IBUF = B%TAIL ELSE IF ( MSG_SIZE_INT .LE. B%HEAD - 1 ) THEN IBUF = 1 END IF ELSE IBUF = B%TAIL END IF B%CONTENT( B%ILASTMSG + NEXT ) = IBUF B%ILASTMSG = IBUF B%TAIL = IBUF + MSG_SIZE_INT B%CONTENT( IBUF + NEXT ) = 0 IPOS = IBUF + CONTENT IREQ = IBUF + REQ RETURN END SUBROUTINE BUF_LOOK SUBROUTINE BUF_ADJUST( BUF, SIZE ) IMPLICIT NONE TYPE ( ZMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE INTEGER SIZE_INT SIZE_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT SIZE_INT = SIZE_INT + OVHSIZE BUF%TAIL = BUF%ILASTMSG + SIZE_INT RETURN END SUBROUTINE BUF_ADJUST SUBROUTINE ZMUMPS_BUF_SEND_DESC_BANDE( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & ESTIM_NFS4FATHER_ATSON, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER, intent(in) :: INODE INTEGER, intent(in) :: NLIG, NCOL, NASS, NSLAVES INTEGER, intent(in) :: ESTIM_NFS4FATHER_ATSON INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER, INTENT(IN) :: IBC_SOURCE INTEGER LIST_SLAVES( NSLAVES ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: LRSTATUS INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 9 + NLIG + NCOL + NSLAVES + 1 ) SIZE_BYTES = SIZE_INT * SIZEofINT IF (SIZE_INT.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_BYTES, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = SIZE_INT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NBPROCFILS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NLIG POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCOL POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = LRSTATUS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ESTIM_NFS4FATHER_ATSON POSITION = POSITION + 1 IF (NSLAVES.GT.0) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = & LIST_SLAVES( 1: NSLAVES ) POSITION = POSITION + NSLAVES ENDIF BUF_CB%CONTENT( POSITION:POSITION + NLIG - 1 ) = ILIG POSITION = POSITION + NLIG BUF_CB%CONTENT( POSITION:POSITION + NCOL - 1 ) = ICOL POSITION = POSITION + NCOL POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE_BYTES ) THEN WRITE(*,*) 'Error in ZMUMPS_BUF_SEND_DESC_BANDE :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE_BYTES, & MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_DESC_BANDE SUBROUTINE ZMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) COMPLEX(kind=8) VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL ZMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 2 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_MAITRE2 SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, PERM, IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID, NPIV_CHECK ) USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_DATA_M IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT (in), OPTIONAL :: NPIV_CHECK INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ), PERM( max(1, NBROW )) INTEGER IW_CBSON( * ) COMPLEX(kind=8) A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER NBINT, L INTEGER(8) :: APOS, SHIFTCB_SON, LDA_SON8 INTEGER IPOS_IN_SLAVE INTEGER STATE_SON INTEGER INDICE_PERE, NROW, IPOS, IREQ, NOSLA INTEGER IONE, J, THIS_ROW_LENGTH INTEGER SIZE_DESC_BANDE, DESC_BANDE_BYTES LOGICAL RECV_BUF_SMALLER_THAN_SEND LOGICAL NOT_ENOUGH_SPACE INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & NBROWS_PACKET_2PACK, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+PERM(1)-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = PERM(1) + NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL ZMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(7+SLAVEF+KEEP(127)*2) SIZE_DESC_BANDE=SIZE_DESC_BANDE+int(dble(KEEP(12))* & dble(SIZE_DESC_BANDE)/100.0D0) SIZE_DESC_BANDE=max(SIZE_DESC_BANDE, & 7+NSLAVES_PERE+NFRONT_PERE+NFRONT_PERE-NASS_PERE) ENDIF DESC_BANDE_BYTES=SIZE_DESC_BANDE*SIZEofINT IF ( SIZE_AV .LT. SIZE_RBUF_BYTES-DESC_BANDE_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES-DESC_BANDE_BYTES ENDIF SIZE1=0 IF (NBROWS_ALREADY_SENT==0) THEN IF(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_DOUBLE_PRECISION, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN ONEorTWO = 1 ELSE ONEorTWO = 2 ENDIF IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + PERM(1) - LMAP + NBROWS_ALREADY_SENT - 1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 2 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( 1 + 2 * LROW + 2 * PERM(1) + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) NBROWS_PACKET_2PACK = NBROWS_PACKET IF (CB_IS_LR) THEN NBROWS_PACKET_2PACK = CURRENT_PANEL_SIZE CALL MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_REALS, CB_LRB, & NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND) NOT_ENOUGH_SPACE = (SIZE_AV.LT.SIZE_REALS) IF (.NOT.NOT_ENOUGH_SPACE) THEN NBROWS_PACKET = min(NBROWS_PACKET, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) ENDIF ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET_2PACK * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET_2PACK + ( NBROWS_PACKET_2PACK * & ( NBROWS_PACKET_2PACK + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET_2PACK CALL MPI_PACK_SIZE( SIZE_REALS, MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND .AND. & .NOT. CB_IS_LR) & THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_PACK_CB_LRB(CB_LRB, NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND, & PANEL_BEG_OFFSET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR) IF (KEEP(50).ne.0) THEN DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL ZMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/ZMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_OUT, & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND) USE ZMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND INTEGER, intent(out) :: SIZE_OUT INTEGER :: J TYPE(LRB_TYPE), POINTER :: LRB SIZE_OUT = 0 DO J=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J) IF (LRB%ISLR) THEN SIZE_OUT = SIZE_OUT + LRB%K*(LRB%M+LRB%N) ELSE SIZE_OUT = SIZE_OUT + LRB%M*LRB%N ENDIF ENDDO RETURN END SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB SUBROUTINE ZMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET, & BUF, LBUF, POSITION, COMM, IERR) USE ZMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET INTEGER, intent(out) :: IERR INTEGER, intent(in) :: COMM, LBUF INTEGER, intent(inout) :: POSITION INTEGER, intent(inout) :: BUF(:) INTEGER :: J, IERR_MPI INCLUDE 'mpif.h' IERR = 0 CALL MPI_PACK( NB_BLR_COLS-NB_COL_SHIFT, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( PANEL_BEG_OFFSET, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) DO J=1,NB_BLR_COLS-NB_COL_SHIFT CALL ZMUMPS_MPI_PACK_LRB( & CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J), & BUF, LBUF, POSITION, COMM, IERR ) ENDDO END SUBROUTINE ZMUMPS_BLR_PACK_CB_LRB SUBROUTINE ZMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, NSLAVES, SLAVES_PERE, & TROW, NCBSON, & COMM, IERR, & DEST, NDEST, SLAVEF, & & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) IMPLICIT NONE INTEGER INODE, NFRONT, NASS1, NCBSON, NSLAVES, & NDEST INTEGER SLAVEF, MYID, ISON INTEGER TROW( NCBSON ) INTEGER DEST( NDEST ) INTEGER SLAVES_PERE( NSLAVES ) INTEGER COMM, IERR INTEGER KEEP(500), N INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_AV, IDEST, NSEND, SIZE, NFS4FATHER INTEGER TROW_SIZE, POSITION, INDX, INIV2 INTEGER IPOS, IREQ INTEGER IONE PARAMETER ( IONE=1 ) INTEGER NASS_SON NASS_SON = -99998 IERR = 0 IF ( NDEST .eq. 1 ) THEN IF ( DEST(1).EQ.MYID ) GOTO 500 SIZE = SIZEofINT * ( 7 + NSLAVES + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+NCBSON-1 ) = & TROW( 1: NCBSON ) POSITION = POSITION + NCBSON POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) 'Error in ZMUMPS_BUF_SEND_MAPLIG :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( NDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) ELSE NSEND = 0 DO IDEST = 1, NDEST IF ( DEST( IDEST ) .ne. MYID ) NSEND = NSEND + 1 END DO SIZE = SIZEofINT * & ( ( OVHSIZE + 7 + NSLAVES )* NSEND + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL ZMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IDEST, NCBSON, & NDEST, & TROW_SIZE, INDX ) SIZE = SIZEofINT * ( NSLAVES + TROW_SIZE + 7 ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error ZMUMPS_BUF_SEND_MAPLIG', & 'IERR after BUF_LOOK=',IERR CALL MUMPS_ABORT() END IF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+TROW_SIZE-1 ) = & TROW( INDX: INDX + TROW_SIZE - 1 ) POSITION = POSITION + TROW_SIZE POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:', & 'Wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( IDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) END IF END DO END IF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_BUF_SEND_MAPLIG SUBROUTINE ZMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, & WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & & IERR ) USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) COMPLEX(kind=8), intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTBL LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE3, SIZET, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS INTEGER :: NBMSGS INTEGER, ALLOCATABLE, DIMENSION(:) :: RELAY_INFO INTEGER :: LRELAY_INFO, DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT IERR = 0 LRELAY_INFO = 0 NBMSGS = NDEST IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE( 4, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE( 1, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_DOUBLE_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LorU, SIZE3, COMM, IERR ) SIZE2 = SIZE2+SIZE3 ENDIF ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF END IF SSS = SSS + SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF ENDIF IF (LRELAY_INFO.GT.0) THEN CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , RELAY_INFO(2)) ELSE CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , PDEST) ENDIF IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NBMSGS - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NBMSGS - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NBMSGS - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NBMSGS POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTBL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF ( (NPIV.GT.0) & ) THEN IF (NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO CALL ZMUMPS_MPI_PACK_LR( BLR_LorU, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1), & SIZET, POSITION, COMM, IERR) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) DO IDEST = 1, NBMSGS IF (LRELAY_INFO .GT. 0) THEN DEST_BLOCFACTO = RELAY_INFO(IDEST+1) ELSE DEST_BLOCFACTO = PDEST(IDEST) ENDIF IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO SIZET = SIZET - ( NBMSGS - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE ZMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR ) USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE COMPLEX(kind=8) UIP21K( NPIV, * ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL COMPLEX(kind=8), intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZET, & IDEST, IPOSMSG, SSS, SSLR IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_COMPLEX, & COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR ELSE CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LS, SSLR, COMM, IERR ) SIZE2=SIZE2+SSLR ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SSS = SSS+SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL MUMPS_MPI_PACK_SCALE_LR( BLR_LS, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1 ), & SIZET, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR ) ELSE CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO SIZET = SIZET - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX(kind=8) VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL ZMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_DOUBLE_COMPLEX, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_DOUBLE_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW(INDCOL_SON( I )) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW( INDROW_SON( I ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = RG2L_COL( INDCOL_SON( J ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IPOS_ROOT = RG2L_ROW( INDCOL_SON( J ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = RG2L_COL( INDROW_SON( I ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_DOUBLE_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) RETURN END SUBROUTINE MUMPS_MPI_PACK_SCALE_LR END MODULE ZMUMPS_BUF MUMPS_5.4.1/src/clr_core.F0000664000175000017500000022337014102210526015414 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE CMUMPS_LR_CORE USE MUMPS_LR_COMMON USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & LRSTATUS, N, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: N INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(N) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok COMPLEX :: ZERO PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER(8) :: KEEP8TMPCOPY, KEEP873COPY LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS) MINSIZE = int(IBCKSZ2 / 2) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE CMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J COMPLEX, POINTER :: LR_BLOCK_PTR(:,:) COMPLEX :: ONE, MONE, ZERO COMPLEX :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL ctrsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL ctrsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'CMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL cscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB, LorU) END SUBROUTINE CMUMPS_LRTRSM SUBROUTINE CMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in CMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT COMPLEX, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER COMPLEX, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS COMPLEX :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE CMUMPS_LRGEMM_SCALING SUBROUTINE CMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT COMPLEX, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL, intent(in) :: TOLEPS COMPLEX :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ COMPLEX, intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 COMPLEX, POINTER, DIMENSION(:,:) :: XY_YZ COMPLEX, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y COMPLEX, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ REAL, EXTERNAL ::scnrm2 COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL cgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for cungqr CALL cungqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL cgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL CMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL cgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL cgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in CMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL cgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL cgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL cgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE CMUMPS_LRGEMM4 SUBROUTINE CMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL cgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE CMUMPS_DECOMPRESS_ACC SUBROUTINE CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT REAL, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO) BUILDQ = (RANK.LE.MAXRANK) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & CMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE CMUMPS_COMPRESS_FR_UPDATES SUBROUTINE CMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) COMPLEX, ALLOCATABLE, DIMENSION(:,:), TARGET :: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL CMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO) BUILDQ2 = (RANK2.LE.MAXRANK) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL CMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & CMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE CMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE CMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in CMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL CMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in CMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'CMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE CMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE CMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL, intent(in) :: TOLEPS REAL, ALLOCATABLE :: RWORK_RRQR(:) COMPLEX, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) COMPLEX, ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL cgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL cgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL CMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL cgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL cungqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL cgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & CMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE CMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE CMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in CMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE CMUMPS_GET_LUA_ORDER SUBROUTINE CMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER COMPLEX :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C COMPLEX, ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST COMPLEX :: ONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL CMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if defined(BLR_MT) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in CMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL cgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if defined(BLR_MT) !$OMP END DO !$OMP END PARALLEL #endif CALL CMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in CMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL CMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, & MTK405=KEEP(405)) ENDIF END SUBROUTINE CMUMPS_BLR_ASM_NIV1 END MODULE CMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE CMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT REAL :: TOLEPS INTEGER :: JPVT(*) REAL :: RWORK(*) COMPLEX :: A(LDA,*), TAU(*) COMPLEX :: WORK(LDW,*) REAL :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK REAL :: TEMP, TEMP2, TOL3Z COMPLEX :: AKK REAL, PARAMETER :: RZERO=0.0E+0, RONE=1.0E+0 COMPLEX :: ZERO COMPLEX :: ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) REAL :: slamch INTEGER :: ilaenv, isamax EXTERNAL :: isamax, slamch EXTERNAL cgeqrf, cunmqr, xerbla EXTERNAL ilaenv EXTERNAL cgemm, cgemv, clarfg, cswap REAL, EXTERNAL :: scnrm2 REAL, EXTERNAL :: snrm2 INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in CMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = scnrm2( M, A( 1, J ), 1 ) RWORK( J ) = scnrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = snrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = snrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(slamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + ISAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + isamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 RETURN END IF IF (RK.GT.MAXRANK) THEN RANK = RK INFO = RK RETURN END IF IF( PVT.NE.RK ) THEN CALL cswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL cswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL cswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN DO J = 1, K-1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J+1 ) = CONJG( WORK( K, J+1 ) ) END DO CALL cgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) DO J = 1, K - 1 C F( K, J ) = CONJG( F( K, J ) ) WORK( K, J + 1 ) = CONJG( WORK( K, J + 1 ) ) END DO END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL clarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL clarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL cgemv( 'Conjugate transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL cgemv( 'Conjugate transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL cgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN CALL cgemm( 'No transpose', 'Conjugate transpose', & 1, N-RK, C & K, -ONE, A( RK, OFFSET+1 ), LDA, F( K+1, 1 ), LDF, & K, -ONE, A( RK, OFFSET+1 ), LDA, WORK( K+1,2 ), LDW, & ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = REAL( LSTICC ) RWORK( N+J ) = REAL( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL cgemm( 'No transpose', 'Conjugate transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = scnrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = scnrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = snrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = snrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK RETURN 999 FORMAT ('On entry to CMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE CMUMPS_TRUNCATED_RRQR MUMPS_5.4.1/src/dfac_root_parallel.F0000664000175000017500000001711314102210522017430 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE DMUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( DMUMPS_ROOT_STRUC ) :: root INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK DOUBLE PRECISION WK( LWK ) INTEGER KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR DOUBLE PRECISION A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT INTEGER IOLDPS INTEGER(8) :: IAPOS DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER LOCAL_M, LOCAL_N, LPIV, IERR, allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE INCLUDE 'mumps_headers.h' EXTERNAL numroc INTEGER numroc IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL DMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL DMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL pdgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pdpotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL DMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in DMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL DMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL DMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & root%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF RETURN END SUBROUTINE DMUMPS_FACTO_ROOT MUMPS_5.4.1/src/cfac_process_contrib_type2.F0000664000175000017500000004756714102210523021132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_LOAD USE CMUMPS_BUF USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_FAC_LR, ONLY: CMUMPS_DECOMPRESS_PANEL USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR, & CMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NB_BLR_COLS, allocok, & NBROWS_PACKET_2PACK, PANEL_BEG_OFFSET INTEGER(8) :: LA_TEMP COMPLEX, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), ALLOCATABLE, TARGET :: BLR_CB(:) INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE COMPLEX, DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL CMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL CMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF ( SLAVE_NODE ) THEN IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL CMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL CMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 3, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ENDIF CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 200 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_COMPLEX, & COMM, IERR ) CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ENDDO 200 CONTINUE CALL CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL CMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 4, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW+I-1 ), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW & ) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 300 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_COMPLEX, & COMM, IERR ) CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH &) ENDDO 300 CONTINUE IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_REAL, & COMM, IERR ) CALL CMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL CMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL CMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) CALL CMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL CMUMPS_DM_FREE_BLOCK( DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.4.1/src/dfac_front_aux.F0000664000175000017500000025104214102210523016600 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE DMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) DOUBLE PRECISION UU, SEUIL DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX DOUBLE PRECISION SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER DMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK, K360 K360 = KEEP(360) NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX)) ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = DMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 IF (KEEP(351).EQ.1) THEN J1_ini = J1 !$ CHUNK = max(K360/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO ENDIF END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE DMUMPS_FAC_H SUBROUTINE DMUMPS_FAC_M(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,XSIZE) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB,IBEG_BLOCK INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER LKJIT, XSIZE DOUBLE PRECISION ONE, ALPHA INTEGER NPIV,JROW2 INTEGER NEL2,NPIVP1,KROW,NEL INCLUDE 'mumps_headers.h' PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IF (NASS.LT.LKJIT) THEN IW(IOLDPS+3+XSIZE) = NASS ELSE IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NEL2 = JROW2 - NPIVP1 IF (NEL2.EQ.0) THEN IF (JROW2.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 IW(IOLDPS+3+XSIZE) = min0(JROW2+LKJIB,NASS) IBEG_BLOCK = NPIVP1+1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 CALL dger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) ENDIF RETURN END SUBROUTINE DMUMPS_FAC_M SUBROUTINE DMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) DOUBLE PRECISION ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) DOUBLE PRECISION, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, K360, CHUNK NOMP = OMP_GET_MAX_THREADS() K360 = KEEP(360) #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.K360) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(K360/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.2) THEN MAXFROMN = 0.0D0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_FAC_N SUBROUTINE DMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K405 .EQ. 1 ) THEN IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 ENDIF IF ( K427_OUT .GT. 99 ) K427_OUT = 0 IF ( K427_OUT .LT. -100 ) K427_OUT = -1 RETURN END SUBROUTINE DMUMPS_FAC_PT_SETLOCK427 SUBROUTINE DMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE DMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & DMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC DOUBLE PRECISION A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL dtrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL dtrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL dgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL dgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_P SUBROUTINE DMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL dtrsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL dgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE DMUMPS_FAC_T SUBROUTINE DMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE DMUMPS_BUF #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL dtrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL dtrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL dgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL dgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL dtrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL dtrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL dgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL dgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL DMUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL dtrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL dgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_SQ SUBROUTINE DMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT DOUBLE PRECISION, intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 DOUBLE PRECISION :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL dger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL dgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ SUBROUTINE DMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE DMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv DOUBLE PRECISION :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL DMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IS_MAXFROMN_AVAIL = .FALSE. 120 CALL DMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL DMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL DMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE DMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST,LPN_LIST, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW DOUBLE PRECISION, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, intent(in) :: LPN_LIST INTEGER, intent(inout) :: PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' DOUBLE PRECISION SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) DOUBLE PRECISION RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION :: RMAX_NORELAX DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER DMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0D0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK,K361 #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() K361 = KEEP(361) #endif PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) IDIAG = APOS CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF (dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = DMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) IF ((J2-J1).GE.K361) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(IDIAG)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(dble(FIXA).GT.RZERO) THEN IF(dble(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_I SUBROUTINE DMUMPS_FAC_I_LDLT & ( NFRONT,NASS,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE DOUBLE PRECISION A(LA) DOUBLE PRECISION UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled DOUBLE PRECISION, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP DOUBLE PRECISION RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV DOUBLE PRECISION RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL DOUBLE PRECISION FIXA, CSEUIL DOUBLE PRECISION PIVOT,DETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max DOUBLE PRECISION ZERO, ONE PARAMETER( ZERO = 0.0D0 ) PARAMETER( ONE = 1.0D0 ) DOUBLE PRECISION RZERO,RONE PARAMETER(RZERO=0.0D0, RONE=1.0D0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 IF (A(APOS).LT.RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN IF (PIVOT .LT. RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (PIVOT .LT. ZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(dble(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 IF (SEUIL.GT.RZERO) THEN IF (sqrt(abs(DETPIV)) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE DMUMPS_FAC_I_LDLT SUBROUTINE DMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT DOUBLE PRECISION, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION VALPIV DOUBLE PRECISION :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL DOUBLE PRECISION ONE, ZERO DOUBLE PRECISION A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, IBEG, IEND INTEGER(8) :: JJ, K1, K2, IROW INTEGER(8) :: ROW_SHIFT, JJ_LOC, IBEG_LOC, IEND_LOC DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX INCLUDE 'mumps_headers.h' PARAMETER(ONE = 1.0D0, & ZERO = 0.0D0) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0D0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 IF (NEL2 > 0) THEN IF (.NOT. IS_MAX_USEFUL) THEN DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ELSE IS_MAXFROMM_AVAIL = .TRUE. DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMM=max( MAXFROMM,abs(A(K1POS+1_8)) ) DO JJ = 2_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ENDIF ENDIF NCB1 = LAST_ROW - IEND_BLOCK IF (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0D0 !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (NCB1-NVSCHUR_K253>300) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL dcopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL dcopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & dble(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ_LDLT SUBROUTINE DMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE DOUBLE PRECISION ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0D0, ALPHA=-1.0D0) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL dtrsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL DMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL dgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IEND_BLOCK,8) CALL dgemm( 'N','N', IROW + Block - IEND_BLOCK - 1, & Block, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL dgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL dgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_SQ_LDLT SUBROUTINE DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP DOUBLE PRECISION A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 DOUBLE PRECISION SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL dswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL dswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL dswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL dswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SWAP_LDLT SUBROUTINE DMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J DOUBLE PRECISION :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY DOUBLE PRECISION :: ONE PARAMETER (ONE = 1.0D0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL dcopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL dcopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE DMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE DMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J DOUBLE PRECISION :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY DOUBLE PRECISION :: ONE PARAMETER (ONE = 1.0D0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE DMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE DMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE DMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2 DOUBLE PRECISION ONE, ALPHA, BETA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO=0.0D0) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL dtrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL DMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL dgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL DMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL dgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL DMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG,LAST_CALL ) IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL dgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL DMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL dgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE DMUMPS_FAC_T_LDLT SUBROUTINE DMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN DMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE DMUMPS_STORE_PERMINFO SUBROUTINE DMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: DIAG DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT END MODULE DMUMPS_FAC_FRONT_AUX_M MUMPS_5.4.1/src/dfac_process_blocfacto_LDLT.F0000664000175000017500000013344214102210522021106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE DMUMPS_LOAD USE DMUMPS_BUF USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_FAC_LR USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR USE DMUMPS_FAC_FRONT_AUX_M, & ONLY : DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 DOUBLE PRECISION MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW, DEST INTEGER ICT11 INTEGER(8) LPOS, LPOS2, DPOS, UPOS INTEGER (8) IPOS, KPOS INTEGER I, IPIV, FPERE, NSLAVES_TOT, & NSLAVES_FOLLOW, NB_BLOC_FAC INTEGER IPOSK, JPOSK, NPIVSENT, Block, IROW, BLSIZE INTEGER allocok, TO_UPDATE_CPT_END DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: UIP21K, BLFCTDYN INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW, PIVDYN LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNPIVBLFCT LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ, SHIFT INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) XSIZE = KEEP(IXSZ) KEEP_BEGS_BLR_LS =.FALSE. KEEP_BEGS_BLR_COL =.FALSE. KEEP_BLR_LS =.FALSE. IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) LD_BLOCFACTO = max(NCOL,1) ENDIF IF (LR_ACTIVATED) THEN DYNPIVBLFCT = .TRUE. ELSE DYNPIVBLFCT = .FALSE. ENDIF IF ( .NOT. DYNPIVBLFCT ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL DMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(PIVDYN(max(1,NPIV)),BLFCTDYN(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR PIVDYN and BLFCTDYN IN ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PIVDYN, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLFCTDYN, int(LA_BLOCFACTO), & MPI_DOUBLE_PRECISION, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL DMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL DMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF ( LASTBL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF ( NPIV1 + NCOL .NE. NASS1 ) THEN WRITE(*,*) 'SymBLFC Error: NPIV1 + NCOL .NE. NASS1 :', & NPIV1,NCOL,NASS1 CALL MUMPS_ABORT() END IF ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNPIVBLFCT) THEN PIVI = abs(PIVDYN(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL dswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (.NOT.LR_ACTIVATED) THEN ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF ELSE ALLOCATE( UIP21K( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * 1 GOTO 700 END IF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNPIVBLFCT) THEN CALL dtrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & BLFCTDYN, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ELSE CALL dtrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ENDIF ENDIF IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A_PTR(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN LPOS = POSELT + int(NPIV1,8) IF (DYNPIVBLFCT) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNPIVBLFCT) THEN PIVI = PIVDYN(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNPIVBLFCT) THEN A11 = ONE/BLFCTDYN(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL dscal( NROW1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNPIVBLFCT) THEN A11 = BLFCTDYN(POSPV1) A22 = BLFCTDYN(POSPV2) A12 = BLFCTDYN(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = BLFCTDYN(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0) THEN CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_LS = NPARTSCB ENDIF call MAX_CLUSTER(BEGS_BLR_LM,NB_BLR_LM+1,MAXI_CLUSTER_LM) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN IF (NPARTSASS_MASTER.GT.NPARTSASS_COL) THEN ENDIF SHIFT = NPARTSASS_COL-NPARTSASS_MASTER ALLOCATE(BEGS_BLR_COL_TMP(size(BEGS_BLR_COL)-SHIFT), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL)-SHIFT GOTO 700 END IF DO II= 1, size(BEGS_BLR_COL)-SHIFT BEGS_BLR_COL_TMP (II) = BEGS_BLR_COL(II+SHIFT) ENDDO BEGS_BLR_COL_TMP(1) = 1 DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL+NELIM) ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT=0 IF (NSLAVES_PREC.GT.0) THEN NB_ACCESSES_INIT=NSLAVES_PREC+1 ENDIF IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNPIVBLFCT) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(BLFCTDYN, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & PIVDYN, OFFSET_IW=1) ELSE CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL DMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & BLFCTDYN, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (DYNPIVBLFCT) THEN CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & BLFCTDYN, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & PIVDYN, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, 0, NPARTSCB, 'V') CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL-NPIV.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN UPOS = int(NPIV+1,8) CALL dgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA, BLFCTDYN(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL dgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL dgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL dgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL dgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL DMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ)) IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN) ) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNPIVBLFCT) THEN CALL DMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFCTDYN, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & PIVDYN, MAXI_CLUSTER, & IERR ) ELSE CALL DMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) ENDIF IF (IERR .EQ. -1 ) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & DMUMPS_PROCESS_SYM_BLOCFACTO" WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1 IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 .AND. NSLAVES_PREC.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8) ENDIF IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN)) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) THEN DEALLOCATE( UIP21K ) ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL DMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF IF (COMPRESS_CB) THEN NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL DMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "DMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL DMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV+NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1+NPIV, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL DMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (NPIV.GT.0) THEN IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN CALL DEALLOC_BLR_PANEL (BLR_LS, NB_BLR_LS, KEEP8) IF (associated(BLR_LS)) DEALLOCATE(BLR_LS) ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.4.1/src/ana_orderings.F0000664000175000017500000151416014102210475016443 0ustar jylexceljylexcelC ========================================================= C C This file includes various modifications of an original C routine MUMPS_ANA_H. The main reference for the approach C used in this routine is C Patrick Amestoy, Timothy A. Davis, and Iain S. Duff, C "An approximate minimum degree ordering algorithm," C SIAM J. Matrix Analysis vol 17, pages=886--905 (1996) C MUMPS_ANA_H is based on the original AMD code: C C AMD, Copyright (c), 1996-2016, Timothy A. Davis, C Patrick R. Amestoy, and Iain S. Duff. All Rights Reserved. C Used in MUMPS under the BSD 3-clause license. C C All other routines are modifications of this original routine C done by MUMPS developers over the years (1996-2020) and are C used in MUMPS under the BSD 3-clause license. C C BSD 3-clause licence: C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C * Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C * Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer in the documentation and/or other materials provided C with the distribution. C * Neither the name of the University of California, Berkeley nor C the names of its contributors may be used to endorse or promote C products derived from this software without specific prior C written permission. C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND C CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, C INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF C MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE C DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR C CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT C NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; C LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) C HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR C OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, C EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C C MUMPS_AMD_ELT is a modification C designed to handle amalgamated and compressed C graphs and was developed in 1999 by Patrick Amestoy C in the context of the PARASOL project (1997-1999). C C MUMPS_HAMD is a modification C designed to take into account a halo in the graph. C The graph is composed is partitioned in two types of nodes C the so called internal nodes and the so called halo nodes. C Halo nodes cannot be selected the both the initial degrees C and updated degrees of internal node should be taken C into account. C This routine also referred to as HALOAMD in MUMPS comments C is used for both Schur functionality and in the coupling with C partitioners such as SCOTCH. C This code was developed for MUMPS platform C by Patrick Amestoy between 1997 and 1999. C C MUMPS_HAMF4 is a major modification of MUMPS_HAMD C since metric used to select pivots in not anymore the C degree but an approximation of the fill-in. C In this approximation C all cliques of elements adjacent to the variable are deducted. C Written by Patrick Amestoy between 1999 and 2000. C It is also used by F. Pellegrini in SCOTCH since 2000. C C MUMPS_QAMD: modified version of reference AMD routine MUMPS_ANA_H C designed to automatically detect and exploit dense or quasi dense C rows in the reduced matrix at any step of the minimum degree. C Written in 1997 by Patrick Amestoy. C References: C P.R. AMESTOY, Recent progress in parallel multifrontal solvers C for unsymmetric sparse matrices, C Proceedings of the 15th World Congress on Scientific Computation, C Modelling and Applied Mathematics, IMACS, Berlin (1997). C P.R. AMESTOY (1999), Methodes directes paralleles de C resolution des systemes creux de grande taille. C Rapport de these d'habilitation de l'INPT. C C MUMPS_CST_AMF: modified version of MUMPS_HAMF4 routine C implementing constraint minimum fill-in based ordering. C Written by Stephane Pralet for MUMPS platform C during his post-doctorate at INPT-IRIT (Oct. 2004- Oct. 2005) C C ---------------------------------------- C To suppress aggressive absorption in ... C MUMPS_ANA_H : Historical AMD C define NOAGG1 C MUMPS_AMD_ELT : (work on compressed graphs) C define NOAGG2 C MUMPS_HAMD : AMD with Halo and used for Schur C define NOAGG3 C MUMPS_HAMF4 : Halo AMF version C define NOAGG4 C MUMPS_QAMD : Quasi dense C define NOAGG5 C MUMPS_SYMQAMD : Symbolic facto based on quasi dense C In the case of MUMPS_SYMQAMD, the aggressive absorption C is controlled by a parameter, AGG6. C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MUMPS_ANA_H: Approximate Minimum Degree AMD approach. C C Description of MUMPS_ANA_H C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C Aggressive absorption might be used to C tighten the bound on the degree. This can result a C significant improvement in the quality of the ordering for C some matrices. C C References and definitions: C [1] Timothy A. Davis and Iain Duff, "An unsymmetric-pattern C multifrontal method for sparse LU factorization", C SIAM J. Matrix Analysis and Applications, C volume=18, pages=140-158 (1997) C [2] Patrick R. Amestoy, Timothy A. Davis, and Iain S. Duff, C "An approximate minimum degree ordering algorithm," C SIAM J. Matrix Analysis vol 17, pages=886--905 (1996) C [3] Alan George and Joseph Liu, "The evolution of the C minimum degree ordering algorithm," SIAM Review, vol. C 31, no. 1, pp. 1-19, March 1989. We list below the C features mentioned in that paper that this code C includes: C mass elimination: C Yes. supervariable detection for mass elimination. C indistinguishable nodes: C Yes (we call these "supervariables"). C We modified the approach used by Duff and Reid to C detect them (the previous hash was the true degree, C which we no longer keep track of). A supervariable is C a set of rows with identical nonzero pattern. All C variables in a supervariable are eliminated together. C Each supervariable has as its numerical name that of C one of its variables (its principal variable). C quotient graph representation: C Yes. We use the term "element" for the cliques formed C during elimination. C The algorithm can operate in place, but it will work C more efficiently if given some "elbow room." C element absorption: C Yes. Similar to Duff,Reid and George,Liu approaches C external degree: C Yes. Similar to Duff, Reid and George, Liu approaches C incomplete degree update and multiple elimination: C No implemented. Our method of C degree update within MUMPS_ANA_H is element-based, not C variable-based. It is thus not well-suited for use C with incomplete degree update or multiple elimination. C C----------------------------------------------------------------------- SUBROUTINE MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT) C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C C Input not modified INTEGER, INTENT(IN) :: TOTEL, N INTEGER(8), INTENT(IN) :: IWLEN LOGICAL, INTENT(IN) :: COMPUTE_PERM C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C NV also meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) C C Internal Workspace only INTEGER :: NEXT(N), DEGREE(N), HEAD(TOTEL), W(N) C --------------------- C Interface Description C --------------------- C INPUT ARGUMENTS (unaltered): C----------------------------- C n : The matrix order. C number of supervariables if compress/blocked format C Restriction: n .ge. 1 C totel : Number of variables to eliminate C In case of blocked format: C each variable i is a supervariable of size nv(i) C totel is computed as the sum(nv(i)) for i \in [1:n] C the algorithm stops when totel variables are C eliminated. C compute_perm : indicates if permutations should be computed C on output in last/elen C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: (PE is copied on output into PARENT array) C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C pfree:On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C nv: On input, encoding of compressed graph: C if nv(1) = -1 then graph is not compressed otherwise C nv(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. C nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. C On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. C Row i is held as follows: C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: C See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: C In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, & PME1, PME2, PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression LOGICAL COMPRESS C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N LAST (I) = 0 HEAD (I) = 0 W (I) = 1 ELEN (I) = 0 ENDDO DO I = 1, TOTEL HEAD(I) = 0 ENDDO IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (COMPRESS) THEN DO I=1,N DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF C C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0 W (I) = 0 ENDIF 20 CONTINUE C ===================================================================== C WHILE (selecting pivots) DO C ===================================================================== 30 IF (NEL .LT. TOTEL) THEN C ===================================================================== C GET PIVOT OF MINIMUM DEGREE C ====================================================================== C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, TOTEL ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN), 8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + ELN - 1 E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme C (which is degme), C plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG1) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG1) IF (DEG.EQ.0.AND.(ELEN(I).GT.1)) THEN C When DEG is zero we need to C absorb in ME all elements adjacent to I P1 = PE (I) C exclude ME --> -2 P2 = P1 + int(ELEN (I),8) - 2_8 DO P =P1,P2 E = IW(P) PE (E) = int(-ME,8) W (E) = 0 ENDDO ENDIF C .... Ready for mass elimination #endif IF (DEG .EQ. 0) THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE (I) = min (DEGREE (I), DEG) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF (NV (I) .LT. 0) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + LN - 1 W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + LN - 1 C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C======================================================================= C COMPUTE THE PERMUTATION VECTORS and update TREE C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C IF (COMPUTE_PERM) THEN C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- IF(COMPRESS) THEN LAST(1:N) = 0 HEAD(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE HEAD(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (HEAD(K-N) .NE. 0) THEN LAST(I)=HEAD(K-N) ELEN(HEAD(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C======================================================================= C END OF COMPUTING PERMUTATIONS C======================================================================= ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_ANA_H C----------------------------------------------------------------------- C MUMPS_AMD_ELT: modified version of reference AMD routine MUMPS_ANA_H C capable of processing already amalgamated or compressed graph. C Used within MUMPS process for the elemental input format of matrices C Input data is in this context modified to be a graph of supervariables. C C Modifications of the interface : C ------------------------------ C INPUT: C ----- C 1/ LEN(I) < 0 <=> i is a secondary variable whose principal C variable is -LEN(I) C 2/ For all secondary variables the adj list MUST not be provided. C THAT is: C ------- C if pe(isecondary) = 0 then C adjacency list of isecondary is not provided C else C pe(isecondary) >0 C len(isecondary) must be equal to len(iprincipal_associated) C then the corresponding space wil not be used and C will be freed by amd if necessary. C endif C REMARK: C ------ C 1/ N must be still set to the order of the matrix C (not of the amalgamated gragh) C 2/ For each supervariable S only supervariables adjacent to S are provided C len(S) is then the number of such supervariables C NV(S) is however updated during the initialisation phase to represent C the size of the supervariable C ( increment nv(s) for each i / len(i) =-s ) C 3/ If (len(i) >=0 for all i ) then we get the classical AMD code C ------------------ SUBROUTINE MUMPS_AMD_ELT(N,IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT) C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C C Input not modified INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: NV(N), ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only INTEGER NEXT(N), DEGREE(N), HEAD(N), W(N) C C Description: C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C --------------------- C Interface Description C --------------------- C INPUT ARGUMENTS (unaltered): C----------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C On output: (PE is copied on output into PARENT array) C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C nv: During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NPRINC INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C nprinc : number of principal variables = number of varialbles C of the compressed graph. C (if the graph is not compressed then nprinc = n) C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM NPRINC = 0 DO I = 1, N LAST (I) = 0 HEAD (I) = 0 NV (I) = 1 W (I) = 1 ELEN (I) = 0 ENDDO DO I=1, N IF (LEN (I).GE.0) THEN DEGREE (I) = LEN (I) NPRINC = NPRINC + 1 ELSE C i is a secondary variable belonging C to supervariable j=-len (i) J = -LEN (I) C used only to skip secondary variables in loop 20 DEGREE (I) = - 1 IF ( PE(I) .NE. 0_8 ) THEN C adjacency list of secondary variable was C provided by the user, C the space will be compressed if necessary LEN (I) = LEN(J) ELSE LEN (I) = 0 ENDIF PE (I) = int(-J,8) NV (J) = NV (J) + NV (I) NV (I) = 0 ELEN (I) = 0 ENDIF ENDDO C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) C degree(i) < 0 corresponds to secondary variables C that need be skipped. IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE IF ( DEG.EQ. 0) THEN C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- C C We have a graph of supervariable and thus need to update C singleton that might already be supervariables with nv(i) C When a supervariable is eliminated its C principal variable must be set to the current step C (NEL+1) which must be stored (negated) in ELEN C ONLY THEN (current step) NEL should be incremented. C This will be exploited when computing the global ordering C of all (secondary and principal) variables at the end of the AMD routine. ELEN (I) = - (NEL + 1) NEL = NEL + NV(I) PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= C C Note that we do want to loop until NEL = N since C we update NEL with the size of the eliminated supervariable C 30 IF (NEL .LT. N) THEN C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1_8 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0_8) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + int(LENJ - 1,8) PSRC = PSRC + int(LENJ - 1,8) ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG2) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG2) IF (DEG.EQ.0.AND.(ELEN(I).GT.1)) THEN C When DEG is zero we need to C absorb in ME all elements adjacent to I P1 = PE (I) C exclude ME --> -2 P2 = P1 + int(ELEN (I),8) - 2_8 DO P =P1,P2 E = IW(P) PE (E) = int(-ME,8) W (E) = 0 ENDDO ENDIF C .... Ready for mass elimination #endif IF (DEG .EQ. 0) THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE (I) = min (DEGREE (I), DEG) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1_8) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF (NV (I) .LT. 0) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_AMD_ELT C ---------------------------------------------------------------------- C Description of MUMPS_HAMD: C MUMPS_HAMD is a modification of AMD reference code (MUMPS_ANA_H) C designed to take into account a halo in the graph. C The graph is composed is partitioned in two types of nodes C the so called internal nodes and the so called halo nodes. C Halo nodes cannot be selected the both the inital degrees C and updated degrees of internal node should be taken C into account. C This routine also referred to as HALOAMD in MUMPS comments C is used for both Schur functionality and in the coupling with C partitioners such as SCOTCH. C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C C SUBROUTINE MUMPS_HAMD(N, IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, HEAD, NEXT, W, PARENT, & LISTVAR_SCHUR, SIZE_SCHUR) C C Parameters C Input not modified INTEGER, intent(in) :: SIZE_SCHUR INTEGER, intent(in) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: NV(N), ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only INTEGER :: NEXT(N), DEGREE(N), HEAD(N), W(N) C C --------------------- C Interface Description C --------------------- C HAMD (short for HALOAMD) C The initial version (so called HALOAMD_V1, developped in September 1997) C is designed to experiment the numerical (fill-in) impact C of taking into account the halo. This code should be able C to experiment no-halo, partial halo, complete halo. C DATE: September 17th 1997 C C HALOAMD is designed to process a gragh composed of two types C of nodes, V0 and V1, extracted from a larger gragh. C V0^V1 = {}, C C We used Min. degree heuristic to order only C nodes in V0, but the adjacency to nodes C in V1 is taken into account during ordering. C Nodes in V1 are odered at last. C Adjacency between nodes of V1 need not be provided, C however |len(i)| must always corresponds to the number of C edges effectively provided in the adjacency list of i. C On input : C ******** C Nodes INODE in V1 are flagged with len(INODE) = -degree C modif version HALO V3 (August 1998): C if len(i) =0 and i \in V1 then C len(i) must be set on input to -N-1 C ERROR return (negative values in ncmpa) C ************ C negative value in ncmpa indicates an error detected C by HALOAMD. C C The graph provided MUST follow the rule: C if (i,j) is an edge in the gragh then C j must be in the adjacency list of i AND C i must be in the adjacency list of j. C REMARKS: C 1/ Providing edges between nodes of V1 should not C affect the final ordering, only the amount of edges C of the halo should effectively affect the solution. C This code should work in the following cases: C 1/ halo not provided C 2/ halo partially provided C 3/ complete halo C 4/ complete halo+interconnection between nodes of V1. C C 1/ should run and provide identical results (w.r.t to current C implementation of AMD in SCOTCH). C 3/ and 4 should provide identical results. C C 2/ All modifications of the AMD initial code are indicated C with begin HALO .. end HALO C C C Ordering of nodes in V0 is based on C Approximate Minimum Degree ordering algorithm, C with aggressive absorption: C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C C ------------------------------ C Modification history: C --------------------- C Date: September, 1997 (V1) C April, 1998 (V2) C August, 1998 (V3) C Octobre, 1998 (V4) C December, 1998 (V5) C January, 1999 (V6) C HALOAMD_V6: C ---------- C 1/ ERROR 2 detection followed by stop statement suppressed C . 2/ pb 1 identified in V5 was not correctly solved C C HALOAMD_V5: C ---------- C 1/ Pb with matrix psmigr 1, because upper bound C degree DEG >N was considered as a node in V1 C C HALOAMD_V4: C ---------- C Only UnsymetrizedMultifrontal interface C (ok for both scotch and UnsymetricMultifrontal) is C included in this file C C HALOAMD_V3: C ---------- C Problem in version 2 : variables of V1 with len(i) =0 C are not well processed. C See modification of the C input to characterize those variables. C C Problem detected by Jacko Koster while experimenting with C version 2 of haloAMD in the context of multiple front method : C "if for an interface variable i, row i in the matrix has only a C nonzero entry on the diagonal, we first remove this entry and len(i) C is set to zero on input to HALOAMD. However, this means that HALOAMD C will treat variable i as an interior variable (in V0) instead as an C interface variable (in V1). (It is indeed a bit strange to have such C interface variables but we encountered some in our debugging C experiments with some random partitionings.) C C Solution : C IF on input i \in V1 and len(i) =0 (that is adjlist(i)={}) THEN C len(i) must be set on input to -N-1. C ENDIF C therefore all variables i / len(i) < 0 an only those are in V1 C variable with len(i) = -N-1 are then processed differently at C the beginning of the code C C HALOAMD_V2: C ---------- C The end of the tree (including links to block of flagged indices C is built) . The list of flagged indices is C considered as a dense amalgamated node. C C Comments on the OUTPUT: C ---------------------- C Let V= V0 U V1 the nodes of the initial graph (|V|=n). C The assembly tree corresponds to the tree C of the supernodes (or supervariables). Each node of the C assembly tree is then composed of one principal variable C and a list of secondary variables. The list of C variable of a node (principal + secondary variables) then C describes the structure of the diagonal bloc of the C supernode. C The elimination tree denotes the tree of all the variables(=node) and C is therefore of order n. C C The arrays NV(N) and PE(N) give a description of the C assembly tree. C 1/ Description of array nv(N) (on OUPUT) C nv(i)=0 i is a secondary variable C N+1> nv(i) >0 i is a principal variable, nv(i) holds the C the number of elements in column i of L (true degree of i) C 2/ Description of array PE(N) (on OUPUT) C pe(i) = -(father of variable/node i) in the elimination tree: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C 3/ Example: C Let If be a root node father of Is in the assembly tree. C If is the principal C variable of the node If and let If1, If2, If3 be the C secondary variables of node If. C Is is the principal C variable of the node Is and let Is1, Is2 be the secondary variables C of node Is. C C THEN: C NV(If1)=NV(If2)=NV(If3) = 0 (secondary variables) C NV(Is1)=NV(Is2) = 0 (secondary variables) C NV(If) > 0 ( principal variable) C NV(Is) > 0 ( principal variable) C PE(If) = 0 (root node) C PE(Is) = -If (If is the father of Is in the assembly tree) C PE(If1)=PE(If2)=PE(If3)= -If ( If is the principal variable) C PE(Is1)=PE(Is2)= -Is ( Is is the principal variable) C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) C positive or null (>=0) : i \in V0 and C len(i) holds the number of entries in row i of the C matrix, excluding the diagonal. C negative (<0) : i \in V1, and C -len(i) hold the number of entries in row i of the C matrix, excluding the diagonal. C len(i) = - | Adj(i) | if i \in V1 C or -N -1 if | Adj(i) | = 0 and i \in V1 C The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C nv: During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C nv(I) = N+1 characterizes nodes in V1. C end HALO C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C begin HALO C on output ncmpa <0 --> error detected during HALO_AMD: C error 1: ncmpa = -N , ordering was stopped. C end HALO C C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C begin HALO C degree(I) = n+1 indicates that i belongs to V1 C end HALO C C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C begin HALO C nbflag: number of flagged entries in the initial gragh. C nreal : number of entries on which ordering must be perfomed C (nreel = N- nbflag) C nelme number of pivots selected when reaching the root C lastd index of the last row in the list of dense rows C end HALO C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM C begin HALO NBFLAG = 0 LASTD = 0 C end HALO DO 10 I = 1, N LAST (I) = 0 HEAD (I) = 0 NV (I) = 1 W (I) = 1 ELEN (I) = 0 DEGREE(I) = LEN(I) 10 CONTINUE C C begin HALO-SCHUR NBFLAG = SIZE_SCHUR C DO K=1,SIZE_SCHUR C I = LISTVAR_SCHUR(K) DEGREE(I) = N+1 IF ((LEN(I) .EQ.0).OR.(LEN(I).EQ.-N-1)) THEN C Both ways of characterizing i \in Schur with Adj(I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 LEN(I) = 0 ENDIF C insert I at the end of degree list of n C (safe: because max external degree is N-1) DEG = N IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF C ENDDO C number of entries to be ordered. NREAL = N - NBFLAG C end HALO-SCHUR C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) C begin HALO-SCHUR IF (DEG.EQ.N+1) GOTO 20 C end HALO-SCHUR C IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= C begin HALO V5 NLEFT = N-NEL C end HALO V5 C begin HALO C AMD test: 30 IF (NEL .LT. N) THEN 30 IF (NEL .LT. NREAL) THEN C end HALO C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C begin HALO IF (ME.LE.0) THEN write (*,*) ' ERROR 1 in HALO_AMD ' C return to calling program with error return NCMPA = -N GOTO 500 ENDIF C end HALO C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I C begin HALO IF (DEGREE(I).LE.N) THEN C end HALO C ---------------------------------------------------- C remove variable i from degree list. (only if i \in V0) C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF C begin HALO ENDIF C end HALO ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C begin HALO IF (DEGREE(I).LE.N) THEN C end HALO C ------------------------------------------------- C remove variable i from degree link list C (only if i in V0) C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF C begin HALO ENDIF C end HALO ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG3) IW (PN) = E PN = PN + 1 HASH = HASH + E #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C begin HALO IF (DEGREE(I).EQ.N+1) DEG = N+1 C end HALO C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG3) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: C begin HALO V6 IF (DEGREE(I).NE.N+1) THEN C I does not belong to halo DEG = min (DEG, NLEFT) DEGREE (I) = min (DEGREE (I), DEG) ENDIF C end HALO V6 C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C begin HALO IF (DEG.LE.N) THEN C end HALO C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH, kind=kind(LAST)) C begin HALO ENDIF C end HALO ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) C begin HALO C old AMD IF (NV (I) .LT. 0) THEN IF ( (NV (I) .LT. 0) .AND. (DEGREE(I) .LE. N) ) THEN C end HALO C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + LN - 1 W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + LN - 1 C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI C begin HALO IF (DEGREE(I).LE.N) THEN C end HALO C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) DEGREE (I) = DEG C begin HALO ENDIF C end HALO C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + LEN (ME) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C begin HALO V2 IF (NEL.LT.N) THEN C C All possible pivots (not flagged have been eliminated). C We amalgamate all flagged variables at the root and C we finish the elimination tree. C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows DO DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG C IF (ME.NE.LISTVAR_SCHUR(1)) THEN write(6,*) ' ERROR 2 in MUMPS_HAMD ' write(6,*) ' wrong principal var for Schur !!' NCMPA = -N - 2 CALL MUMPS_ABORT() ENDIF C NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.N+1) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 C Correct value of NV is (secondary variable) NV(X) = 0 ENDIF ENDDO C ME is the root node ELEN(ME) = NELME C Correct value of NV is (principal variable) NV(ME) = N-NREAL PE(ME) = 0 C end HALO V2 C C begin HALO IF (NEL.NE.N) THEN write(*,*) ' ERROR 2 in MUMPS_HAMD NEL, N=', NEL,N NCMPA = -N - 1 ENDIF ENDIF C end HALO C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. 500 PFREE = MAXMEM C=============================== C Save IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_HAMD C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Description of MUMPS_HAMF4: C MUMPS_HAMF4 is a modified version of halo AMD routine MUMPS_HAMD C implementing an approximate minimum fill-in heuritic. C Version provided to F. Pellegrini on Nov 2000 to be used in SCOTCH. C Approximation of level4 of the minimum fill heuristic C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C SUBROUTINE MUMPS_HAMF4 & (NORIG, N, COMPUTE_PERM, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD & , PARENT & ) IMPLICIT NONE C C Parameters C Input not modified C N : number of nodes in the complete graph including halo C NORIG : C if compressed graph (nv(1).ne-1) then C NORIG is the sum(nv(i)) for i \in [1:N] C else NORIG = N INTEGER, INTENT(IN) :: NORIG, N, NBBUCK LOGICAL, INTENT(IN) :: COMPUTE_PERM INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C NV also meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(N) INTEGER, INTENT(OUT) :: PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only C Min fill approximation one extra array of size NBBUCK+2 C is also needed INTEGER :: NEXT(N), DEGREE(N), W(N) INTEGER :: HEAD(0:NBBUCK+1), WF(N) C C Comments on the OUTPUT: C ---------------------- C Let V= V0 U V1 the nodes of the initial graph (|V|=n). C The assembly tree corresponds to the tree C of the supernodes (or supervariables). Each node of the C assembly tree is then composed of one principal variable C and a list of secondary variables. The list of C variable of a node (principal + secondary variables) then C describes the structure of the diagonal bloc of the C supernode. C The elimination tree denotes the tree of all the variables(=node) and C is therefore of order n. C C The arrays NV(N) and PE(N) give a description of the C assembly tree. C Note that on output C INTEGER(8) PE array is copied on output into C INTEGER PARENT array C C 1/ Description of array nv(N) (on OUTPUT) C nv(i)=0 i is a secondary variable C nv(i) >0 i is a principal variable, nv(i) holds the C the number of elements in column i of L (true degree of i) C With compressed graph (nv(1).ne.-1 on input), C nv(i) can be greater than N since degree can be as large as NORIG C C 2/ Description of array PE(N) (on OUTPUT) C Note that on C pe(i) = -(father of variable/node i) in the elimination tree: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C 3/ Example: C Let If be a root node father of Is in the assembly tree. C If is the principal C variable of the node If and let If1, If2, If3 be the secondary variables C of node If. C Is is the principal C variable of the node Is and let Is1, Is2 be the secondary variables C of node Is. C C THEN: C NV(If1)=NV(If2)=NV(If3) = 0 (secondary variables) C NV(Is1)=NV(Is2) = 0 (secondary variables) C NV(If) > 0 ( principal variable) C NV(Is) > 0 ( principal variable) C PE(If) = 0 (root node) C PE(Is) = -If (If is the father of Is in the assembly tree) C PE(If1)=PE(If2)=PE(If3)= -If ( If is the principal variable) C PE(Is1)=PE(Is2)= -Is ( Is is the principal variable) C C C C HALOAMD_V1: (September 1997) C ********** C Initial version designed to experiment the numerical (fill-in) impact C of taking into account the halo. This code should be able C to experiment no-halo, partial halo, complete halo. C DATE: September 17th 1997 C C HALOAMD is designed to process a gragh composed of two types C of nodes, V0 and V1, extracted from a larger gragh. C V0^V1 = {}, C C We used Min. degree heuristic to order only C nodes in V0, but the adjacency to nodes C in V1 is taken into account during ordering. C Nodes in V1 are odered at last. C Adjacency between nodes of V1 need not be provided, C however |len(i)| must always corresponds to the number of C edges effectively provided in the adjacency list of i. C On input : c ******** C Nodes INODE in V1 are flagged with len(INODE) = -degree C if len(i) =0 and i \in V1 then C len(i) must be set on input to -NORIG-1 C ERROR return (negative values in ncmpa) C ************ C negative value in ncmpa indicates an error detected C by HALOAMD. C C The graph provided MUST follow the rule: C if (i,j) is an edge in the gragh then C j must be in the adjacency list of i AND C i must be in the adjacency list of j. C REMARKS C ------- C C 1/ Providing edges between nodes of V1 should not C affect the final ordering, only the amount of edges C of the halo should effectively affect the solution. C This code should work in the following cases: C 1/ halo not provided C 2/ halo partially provided C 3/ complete halo C 4/ complete halo+interconnection between nodes of V1. C C 1/ should run and provide identical results (w.r.t to current C implementation of AMD in SCOTCH). C 3/ and 4 should provide identical results. C C 2/ All modifications of the AMD initial code are indicated C with begin HALO .. end HALO C C C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C fill-in heuristic. Aggresive absorption is C used to tighten the bound on the degree. This can result an C significant improvement in the quality of the ordering for C some matrices. C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C Restriction: n .ge. 1 C compute_perm : indicates if permutations should be computed C on output in last/elen C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C C nv: On input, encoding of compressed graph: C if NV(1) = -1 then graph is not compressed otherwise C NV(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C Not true anymore : ( nv(I) = N+1 characterizes nodes in V1 C instead nodes in V1 are considered as a dense root node ) C end HALO C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) C positive or null (>=0) : i \in V0 and C len(i) holds the number of entries in row i of the C matrix, excluding the diagonal. C negative (<0) : i \in V1, and C -len(i) hold the number of entries in row i of the C matrix, excluding the diagonal. C The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds C until just before the permutation vectors are computed. C For elements, elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C begin HALO C on output ncmpa <0 --> error detected during HALO_AMD: C error 1: ncmpa = -N , ordering was stopped. C end HALO C C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C begin HALO C while processing variables degree(I) = -NBBUCK-1 (=N2) C indicates that i belongs to V1 C end HALO C C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C C wf : integer array used to store the already filled area of C the variables adajcent to current pivot. C wf is then used to update the score of variable i. C C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, LASTD, NELME, WF3, WF4, N2, PAS INTEGER :: NLEFT_V1 INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD DOUBLE PRECISION RMF, RMF1 DOUBLE PRECISION dummy INTEGER idummy C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C wf3: off diagoanl block area C wf4: diagonal block area C mf : Minimum fill C begin HALO C nbflag: number of flagged entries in the initial gragh. C nreal : number of entries on which ordering must be perfomed C (nreel = N- nbflag) C nelme number of pivots selected when reaching the root C lastd index of the last row in the list of dense rows C end HALO C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod, huge INTEGER TOTEL LOGICAL COMPRESS C======================================================================= C INITIALIZATIONS C======================================================================= C HEAD (0:NBBUCK+1) C C idummy holds the largest integer - 1 C dummy = dble (idummy) idummy = huge(idummy) - 1 dummy = dble(idummy) C variable with degree equal to N2 are in halo C bucket NBBUCK+1 used for HALO variables N2 = -NBBUCK-1 C Distance betweeen elements of the N, ..., NBBUCK entries of HEAD C PAS = max((N/8), 1) WFLG = 2 MAXINT_N=huge(WFLG)-N NCMPA = 0 NEL = 0 HMOD = int(max (1, NBBUCK-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM MINDEG = 0 NLEFT_V1 = 0 C NBFLAG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DO 10 I = 1, N LAST(I) = 0 C NV(I) = 1 W(I) = 1 ELEN (I) = 0 10 CONTINUE IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF(COMPRESS) THEN TOTEL = 0 DO I=1,N IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 NLEFT_V1 = NLEFT_V1 + NV(I) IF (LEN(I).EQ.-NORIG-1) THEN C variable in V1 with empty adj list LEN (I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 ELSE LEN (I) = - LEN(I) ENDIF C end HALO V3 ELSE TOTEL = TOTEL + NV(I) DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO C DEGREE (I) = LEN (I) ENDIF ENDDO ELSE DO I=1,N NV(I) = 1 IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 NLEFT_V1 = NLEFT_V1 + NV(I) IF (LEN(I).EQ.-N-1) THEN LEN (I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 ELSE LEN (I) = - LEN(I) ENDIF C end HALO V3 ELSE DEGREE (I) = LEN (I) ENDIF ENDDO TOTEL = N - NBFLAG ENDIF C C C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N2) THEN C DEG = N2 (flagged variables are stored C in the degree list of NBBUCK + 1 C (safe: because max C max value of degree is NBBUCK) C DEG = NBBUCK + 1 IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF GOTO 20 ENDIF C C IF (DEG .GT. 0) THEN WF(I) = DEG C version 1 IF (DEG.GT.NORIG) THEN DEG = min(((DEG-NORIG)/PAS) + NORIG, NBBUCK) ENDIF C Note that if deg=0 then C No fill-in will occur, C but one variable is adjacent to I C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF C======================================================================= C 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= NLEFT = TOTEL-NEL + NLEFT_V1 C======================================================================= C ===================================================================== 30 IF (NEL .LT. TOTEL) THEN C ===================================================================== C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, NBBUCK ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (ME.LE.0) THEN NCMPA = -N CALL MUMPS_ABORT() ENDIF IF (DEG.GT.NORIG) THEN C ------------------------------- C Linear search to find variable C with best score in the list C ------------------------------- C While end of list list not reached C NEXT(J) = 0 J = NEXT(ME) K = WF(ME) 55 CONTINUE IF (J.GT.0) THEN IF (WF(J).LT.K) THEN ME = J K = WF(ME) ENDIF J= NEXT(J) GOTO 55 ENDIF ILAST = LAST(ME) INEXT = NEXT(ME) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C me is at the head of the degree list HEAD (DEG) = INEXT ENDIF C ELSE C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN C ---------------------------------------------------- C remove variable i from degree list. (only if i \in V0) C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list IF (WF(I).GT.NORIG) THEN DEG = min(((WF(I)-NORIG)/PAS) + NORIG, NBBUCK) ELSE DEG = WF(I) ENDIF HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------- C remove variable i from degree link list C (only if i in V0) C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE IF (WF(I).GT.NORIG) THEN DEG = min(((WF(I)-NORIG)/PAS) + NORIG , NBBUCK) ELSE DEG = WF(I) ENDIF C i is at the head of the degree list HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 WF3 = 0 WF4 = 0 NVI = -NV(I) C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF ( WF(E) .EQ. 0 ) THEN C First time we meet e : compute wf(e) C which holds the surface associated to element e C it will later be deducted from fill-in C area of all variables adjacent to e WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) ENDIF WF4 = WF4 + WF(E) DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E, kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG4) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1_8, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C IF (DEGREE(I).EQ.N2) DEG = N2 C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG4) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: IF (DEGREE(I).NE.N2) THEN C I does not belong to halo IF ( DEGREE (I).LT.DEG ) THEN C Our appox degree is loose. C we keep old value. Note that in C this case we cannot substract WF(I) C for min-fill score. WF4 = 0 WF3 = 0 ELSE DEGREE(I) = DEG ENDIF ENDIF C C compute WF(I) taking into account size of block 3.0 WF(I) = WF4 + 2*NVI*WF3 C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) IF (DEG.NE.N2) THEN C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1_8, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1_8, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) WF(I) = max(WF(I),WF(J)) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL + NLEFT_V1 DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- C-------------------------- C-------------------------- IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN C DEG = DEGREE(I) RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) DEGREE(I) = NLEFT - NVI DEG = DEGREE(I) RMF = dble(DEG)*dble(DEG-1) & - dble(DEGME-NVI)*dble(DEGME-NVI-1) RMF = min(RMF, RMF1) ELSE DEG = DEGREE(I) DEGREE(I) = DEGREE (I) + DEGME - NVI C All previous cliques taken into account (AMF4) RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) ENDIF C RMF = RMF / dble(NVI+1) C IF (RMF.LT.dummy) THEN WF(I) = int ( anint( RMF )) ELSEIF (RMF / dble(N) .LT. dummy) THEN WF(I) = int ( anint( RMF/dble(N) )) ELSE WF(I) = idummy ENDIF WF(I) = max(1,WF(I)) DEG = WF(I) IF (DEG.GT.NORIG) THEN DEG = min(((DEG-NORIG)/PAS) + NORIG, NBBUCK) ENDIF INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) C begin HALO ENDIF C end HALO C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C fill_est = fill_est + nvpiv * (nvpiv + 2 * degme) C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C begin HALO V2 IF (NEL.LT.NORIG) THEN C C All possible pivots (not flagged have been eliminated). C We amalgamate all flagged variables at the root and C we finish the elimination tree. C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows DO DEG = MINDEG, NBBUCK+1 ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.N2) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 C Correct value of NV is (secondary variable) NV(X) = 0 ENDIF ENDDO C ME is the root node ELEN(ME) = NELME C Correct value of NV is (principal variable) NV(ME) = NBFLAG PE(ME) = 0_8 IF (NEL.NE.NORIG) THEN NCMPA = -NORIG - 1 GOTO 500 ENDIF ENDIF C end HALO C======================================================================= C COMPUTE THE PERMUTATION VECTORS and update TREE C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE IF (COMPUTE_PERM) THEN C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the pivot order (last (1..n)). C ---------------------------------------------------------------- C begin COMPRESS IF(COMPRESS) THEN C N is the size of the compressed graph. C If the graph was compressed on input then C indices in ELEN are in [1,TOTEL] C We build the inverse of ELEN in LAST (similar to C the pivot order but has zeros in it) and then compress C it. Since LAST is assumed to be of size N at the C interface level, we need another array to store C the inverse of ELEN for entries greater than N C We use DEGREE. LAST(1:N) = 0 HEAD(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE HEAD(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (HEAD(K-N) .NE. 0) THEN LAST(I)=HEAD(K-N) ELEN(HEAD(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C end COMPRESS ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. 500 PFREE = MAXMEM C=============================== C Save IPE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_HAMF4 C C----------------------------------------------------------------------- C MUMPS_QAMD: modified version of reference AMD routine MUMPS_ANA_H C designed to automatically detect and exploit dense or quasi dense C rows in the reduced matrix at any step of the minimum degree. C C References: C P.R. AMESTOY, Recent progress in parallel multifrontal solvers C for unsymmetric sparse matrices, C Proceedings of the 15th World Congress on Scientific Computation, C Modelling and Applied Mathematics, IMACS, Berlin (1997). C P.R. AMESTOY (1999), Methodes directes paralleles de C resolution des systemes creux de grande taille. C Rapport de these d'habilitation de l'INPT. C C Date 1997 C --------- C SUBROUTINE MUMPS_QAMD & (TOTEL, COMPUTE_PERM, IVersion, THRESH, NDENSE, & N, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PARENT) C Input not modified INTEGER, INTENT(IN) :: TOTEL, N LOGICAL, INTENT(IN) :: COMPUTE_PERM INTEGER, INTENT(IN) :: IVersion, THRESH INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), PARENT(N) INTEGER, INTENT(OUT) :: LAST(N) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C NV also meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) INTEGER, INTENT(OUT) :: NEXT(N), DEGREE(N), HEAD(TOTEL), W(N) INTEGER, INTENT(OUT) :: NDENSE(N) C The input integer parameter THRESH defines the quasi density: C THRESH : input parameter (not modified) C THRESH is used to compute THRESM C <=0 or N Only exactly dense rows in the reduced matrix are selected. C >1 and <=N THRESH correspond to the munimum density requirement. C C IVersion = C 1 : No dense row detection during elimination C Suppressing dense row selection after 1st C and final restrart (Using initial degree of C quasi dense C rows when restarting and suppress C dense row selection) C else : All functionalities enabled C Additionnal parameters/variables due to dense row manipulation: C PARAMETERS: C ---------- C C Local variables: C --------------- INTEGER THRESM, MINDEN, MAXDEN, NDME INTEGER NBD,NBED, NBDM, LASTD, NELME C INTEGER DEG1 LOGICAL IDENSE DOUBLE PRECISION RELDEN C C THRESM : Local Integer holding a C potentially modified value of THRESH. C When quasi dense rows are reintegrated in the C graph to be processed then THRESM is modified. C Note that if one sets THRESM to negative value then C <0 Classical AMD algorithm (no dense row detection) C RELDEN : holds average density to set THRESM automatically C MINDEN: min degree of quasi-dense rows when restarting C MAXDEN: max degree of quasi-dense rows when restarting C NDME : number of dense row adjacent to me C NELME number of pivots selected when reching the root C LASTD index of the last row in the list of dense rows C NBD is the total number of dense rows selected C NBED is the total number of exactly dense rows detected. C NBDM is the maximum number of dense rows selected C IDENSE is used to indicate that the supervariable I is a dense or C quasi-dense row. C----------------------------------------------------------------------- C Given a representation of the nonzero pattern of a symmetric matrix, C A, (excluding the diagonal) perform an approximate minimum C degree ordering to compute a pivot order C such that fill-in in the Cholesky factors A = LL^T is kept low. C Aggressive absorption might be used to C tighten the bound on the degree. This can result a C significant improvement in the quality of the ordering for C some matrices. C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n : The matrix order. C number of supervariables if compress/blocked format C Restriction: n .ge. 1 C totel : Number of variables to eliminate C In case of blocked format: C each variable i is a supervariable of size nv(i) C totel is computed as the sum(nv(i)) for i \in [1:n] C the algorithm stops when totel variables are C eliminated. C compute_perm : indicates if permutations should be computed C on output in last/elen C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C C nv: On input, encoding of compressed graph: C if nv(1) = -1 then graph is not compressed otherwise C nv(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. C nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. C On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C Not true anymore : ( nv(I) = N+1 characterizes nodes in V1. C instead nodes in V1 are considered as a dense root node ) C end HALO C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). Cdense C degree (I) =N+1 if I is an exactly dense row in reduced matrix. C =N+1+LAST_approximate_external_deg of I C if I is a quasi dense row in reduced matrix. C All dense or quasi dense rows are stored in the list pointed C by head(n). Quasi-dense rows (degree(I)=n) are stored first, C and are followed by exactly dense rows in the reduced matrix. C LASTD holds the last row in this list of dense rows or is zero C if the list is empty. Cdense C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8):: HASH, HMOD C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC, PLN, PELN C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression LOGICAL COMPRESS C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod C======================================================================= C INITIALIZATIONS C======================================================================= C ------------------------------------------------------ C Experiments with automatic setting of parameter THRESH. C ------------------------------------------------------ IF (THRESH.GT.0) THEN THRESM = min(N,THRESH) DO I=1,N THRESM = max(THRESM, LEN(I)) ENDDO RELDEN = dble(PFREE-1)/dble(N) C RELDEN holds the average density, THRESM the maximum density THRESM = int(RELDEN)*10 + (THRESM-int(RELDEN))/10 + 1 C ------------------------------------------------------ C end automatic setting of THRESM C ------------------------------------------------------ ELSE C only exactly dense row will be selected THRESM = TOTEL ENDIF IF (THRESM.GE.0) THEN IF ((THRESM.GT.TOTEL).OR.(THRESM.LT.2)) THEN C exactly dense rows only THRESM = TOTEL ENDIF ENDIF LASTD = 0 NBD = 0 NBED = 0 NBDM = 0 WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N NDENSE(I)= 0 W (I) = 1 ELEN (I) = 0 LAST(I) = 0 ENDDO DO I = 1, TOTEL HEAD(I) = 0 ENDDO IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (COMPRESS) THEN DO I=1,N DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- C NEXT = 0 DO 20 I = 1, N DEG = DEGREE (I) IF (DEG .GT. 0) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C or in the dense row list if i is dense or quasi dense. C ---------------------------------------------------------- C test for row density IF ( (THRESM.GE.0) .AND. & (DEG+NV(I).GE.THRESM) ) THEN C I will be inserted in the degree list of N NBD = NBD+NV(I) IF (DEG+NV(I).NE.TOTEL-NEL) THEN DEGREE(I) = DEGREE(I)+TOTEL+1 C insert I at the beginning of degree list of n DEG = TOTEL INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ELSE NBED = NBED+NV(I) DEGREE(I) = TOTEL+1 C insert I at the end of degree list of n DEG = TOTEL IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ENDIF ELSE C place i in the degree list corresponding to its degree INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ENDIF ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) C NEL = NEL + 1 ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C We suppress dense row selection if none of them was found in A C in the 1st pass IF (NBD.EQ.0) THRESM = TOTEL C C======================================================================= C WHILE (selecting pivots) DO C======================================================================= 30 IF (NEL .LT. TOTEL) THEN C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, TOTEL ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (DEG.LT.TOTEL) THEN C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELSE NBDM = max(NBDM,NBD) IF (DEGREE(ME).GT.TOTEL+1) THEN MINDEN = NBD MAXDEN = 0 IF (WFLG .GT. MAXINT_N) THEN DO 52 X = 1, N IF (W (X) .NE. 0) W (X) = 1 52 CONTINUE WFLG = 2 ENDIF WFLG = WFLG + 1 51 CONTINUE C --------------------------------------------------------- C remove chosen variable from link list C --------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) THEN LAST (INEXT) = 0 ELSE LASTD = 0 ENDIF C ---------------------------------------------------------- c build adjacency list of ME in quotient gragh C and calculate its external degree in ndense(me) C ---------------------------------------------------------- NDENSE(ME) = 0 W(ME) = WFLG P1 = PE(ME) P2 = P1 + int(LEN(ME) -1,8) C PLN-1 holds the pointer in IW to the last elet/var in adj list C of ME. LEN(ME) will then be set to PLN-P1 C PELN-1 hold the pointer in IW to the last elet in adj list C of ME. ELEN(ME) will then be set to PELN-P1 C element adjacent to ME PLN = P1 PELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0_8) THEN C E is a nonprincipal variable or absorbed element X = E 53 X = int(-PE(X)) IF (W(X) .EQ.WFLG) GOTO 55 W(X) = WFLG IF ( PE(X) .LT. 0_8 ) GOTO 53 E = X ENDIF C ------------------------------------------- C E is an unabsorbed element or a "dense" row C (NOT already flagged) C ------------------------------------------- IF (ELEN(E).LT.0) then C E is a new element in adj(ME) NDENSE(E) = NDENSE(E) - NV(ME) IW(PLN) = IW(PELN) IW(PELN) = E PLN = PLN+1_8 PELN = PELN + 1_8 C update ndense of ME with all unflagged dense C rows in E PME1 = PE(E) DO 54 PME = PME1, PME1+int(LEN(E)-1,8) X = IW(PME) IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN C X is a dense row NDENSE(ME) = NDENSE(ME) + NV(X) W(X) = WFLG ENDIF 54 CONTINUE ELSE C E is a dense row NDENSE(ME) = NDENSE(ME) + NV(E) IW(PLN)=E PLN = PLN+1_8 ENDIF 55 CONTINUE C ---------------------------------------------- C DEGREE(ME)-(N+1) holds last external degree computed C when Me was detected as dense C NDENSE(ME) is the exact external degree of ME C ---------------------------------------------- WFLG = WFLG + 1 LEN(ME) = int(PLN-P1) ELEN(ME) = int(PELN-P1) NDME = NDENSE(ME)+NV(ME) MINDEN = min (MINDEN, NDME) MAXDEN = max (MAXDEN, NDME) C If we want to select ME as exactly dense (NDME.EQ.NBD) C of quasi dense NDME.GE.THRESMupdated then C ndense(of elements adjacent to ME) sould be updated IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 IF (IVersion.EQ.1) THEN C ------------------------------------------------ C place ME in the degree list of DEGREE(ME)-(N+1) C NDENSE is not used in this case (simulate of C preprocessing ) C ------------------------------------------------ DEG = max (DEGREE(ME)-(TOTEL+1), 1) ELSE C ----------------------------------------- C place ME in the degree list of NDENSE(ME) C ----------------------------------------- DEG = NDENSE(ME) ENDIF DEGREE(ME) = DEG MINDEG = min(DEG,MINDEG) JNEXT = HEAD(DEG) IF (JNEXT.NE. 0) LAST (JNEXT) = ME NEXT(ME) = JNEXT HEAD(DEG) = ME C ------------------------------ C process next quasi dense row C ------------------------------ ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(TOTEL+1) ) GOTO 51 ENDIF HEAD (TOTEL) = ME C --------------------------------------- C update dense row selection strategy C ------------------------------------- C IF (IVersion .EQ.1 ) THEN THRESM = TOTEL ELSE THRESM=max(THRESM*2,MINDEN+(MAXDEN-MINDEN)/2) C THRESM = max(THRESM*2, MINDEN*2) THRESM = min(THRESM,NBD) IF (THRESM.GE.NBD) THRESM=TOTEL ENDIF NBD = NBED C GOTO 30 ENDIF C ------------------------------------------------------------- C ------------------------------------------------------------- IF (DEGREE(ME).EQ.TOTEL+1) THEN C we have only exactly "dense" rows that we C amalgamate at the root node IF (NBD.NE.NBED) THEN write(6,*) ' Internal ERROR quasi dense rows remains' CALL MUMPS_ABORT() ENDIF C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows C RMK: we could compute sum(NVPIV(d)) to check if = NBD NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0_8) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 NV(X) = 0 ENDIF 59 CONTINUE C ME is the root node ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0_8 IF (NEL.NE.TOTEL) THEN write(6,*) 'Internal ERROR 2 detected in QAMD' write(6,*) ' NEL not equal to N: N, NEL =',N,NEL CALL MUMPS_ABORT() ENDIF GOTO 265 ENDIF ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NDENSE(ME) = 0 C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1_8 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (DEGREE (I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1_8 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI - NDENSE(E) ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 180 P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #if defined (NOAGG5) C ------------------------------ C suppress aggressive absorption C ------------------------------ ELSE IF (DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C C ------------------------------ C try aggressive absorption C when possible C ELSE IF ((DEXT .EQ. 0) .AND. & (NDENSE(ME).EQ.NBD)) THEN C aggressive absorption: e is not adjacent to me, but C |Le(G') \ Lme(G')| is 0 and all dense rows C are in me, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 ELSE IF (DEXT.EQ.0) THEN IW(PN) = E PN = PN+1 HASH = HASH + int(E,kind=8) #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list C add degree only of non-dense rows. IF (DEGREE(J).LE.TOTEL) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG5) IF (DEG.EQ.0.AND.(NDENSE(ME).EQ.NBD).AND.(ELEN(I).GT.1)) THEN C When mass elimination will be performed then C absorb in ME all element adjacent to I P1 = PE (I) C exclude ME --> -2 P2 = P1 + int(ELEN (I),8) - 2_8 DO P =P1,P2 E = IW(P) PE (E) = int(-ME,8) W (E) = 0 ENDDO ENDIF C .... Ready for mass elimination #endif IF ((DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE(I) = min (DEG+NBD-NDENSE(ME), & DEGREE(I)) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.TOTEL) ) THEN C only done for nondense rows C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- PE (J) = int(-I,8) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).LE.TOTEL) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) DEGREE (I) = DEG IDENSE = .FALSE. C IF ( (IVersion .NE. 1).AND. (THRESM.GE.0)) THEN C ------------------- C Dense row detection C ------------------- C DEGME is exact external degree of pivot ME |Le\Ve|, C DEG is is approx external degree of I C Relaxed dense row selection based on: C 1/ We want to avoid selecting dense rows that are C almost completely represented by adj(ME) C 1/ its density in reduced matrix and IF (DEG+NVI .GE. THRESM) THEN IF (THRESM.EQ.TOTEL) THEN C We must be sure that I is exactly dense in reduced matrix IF ((ELEN(I).LE.2) .AND. ((DEG+NVI).EQ.NLEFT) ) THEN C DEG approximation is exact and I is dense DEGREE(I) = TOTEL+1 IDENSE = .TRUE. ENDIF ELSE C relaxed dense row detection IDENSE = .TRUE. IF ((ELEN(I).LE.2).AND.((DEG+NVI).EQ.NLEFT) ) THEN DEGREE(I) = TOTEL+1 ELSE DEGREE(I) = TOTEL+1+DEGREE(I) ENDIF ENDIF ENDIF IF (IDENSE) THEN C update NDENSE of all elements in the list of element C adjacent to I (including ME). P1 = PE(I) P2 = P1 + int(ELEN(I) - 1,8) IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF C insert I in the list of dense rows NBD = NBD+NVI DEG = TOTEL IF (DEGREE(I).EQ.TOTEL+1) THEN c insert I at the end of the list NBED = NBED +NVI IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ELSE C insert I at the beginning of the list INEXT = HEAD(DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ENDIF C end of IDENSE=true ENDIF C end of THRESM>0 ENDIF C IF (.NOT.IDENSE) THEN C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I ENDIF C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) ENDIF C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= 265 CONTINUE C======================================================================= C COMPUTE THE PERMUTATION VECTORS and update TREE C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE IF (COMPUTE_PERM) THEN C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- IF(COMPRESS) THEN LAST(1:N) = 0 HEAD(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE HEAD(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (HEAD(K-N) .NE. 0) THEN LAST(I)=HEAD(K-N) ELEN(HEAD(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C======================================================================= C END OF COMPUTING PERMUTATIONS C======================================================================= ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_QAMD C----------------------------------------------------------------------- C MUMPS_CST_AMF: modified version of MUMPS_HAMF4 routine C implementing constraint minimum fill-in based C ordering. C Written by Stephane Pralet iduring his post-doctorate at INPT-IRIT C (Oct. 2004- Oct. 2005) C C Restrictive integer 64 bit variant : C it is assumed that IW array size can exceed 32-bit integer C SUBROUTINE MUMPS_CST_AMF (N, NBBUCK, & IWLEN, PE, PFREE, LEN, IW, NV, ELEN, & LAST, NCMPA, DEGREE, WF, NEXT, W, HEAD, & CONSTRAINT,THESON, PARENT) IMPLICIT NONE C C Parameters C Input not modified INTEGER, INTENT(IN) :: N, NBBUCK INTEGER(8), INTENT(IN) :: IWLEN C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C NV meaningful as input to encode compressed graphs INTEGER, INTENT(INOUT) :: NV(N) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(N), PARENT(N) C C Input/output INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) C C Internal Workspace only C Min fill approximation one extra array of size NBBUCK+2 C is also needed INTEGER :: NEXT(N), DEGREE(N), W(N) INTEGER :: HEAD(0:NBBUCK+1), WF(N) C C Comments on the OUTPUT: C ---------------------- C Let V= V0 U V1 the nodes of the initial graph (|V|=n). C The assembly tree corresponds to the tree C of the supernodes (or supervariables). Each node of the C assembly tree is then composed of one principal variable C and a list of secondary variables. The list of C variable of a node (principal + secondary variables) then C describes the structure of the diagonal bloc of the C supernode. C The elimination tree denotes the tree of all the variables(=node) and C is therefore of order n. C C The arrays NV(N) and PE(N) give a description of the C assembly tree. C C 1/ Description of array nv(N) (on OUPUT) C nv(i)=0 i is a secondary variable C N+1> nv(i) >0 i is a principal variable, nv(i) holds the C the number of elements in column i of L (true degree of i) C C 2/ Description of array PE(N) (on OUPUT) C pe(i) = -(father of variable/node i) in the elimination tree: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C C 3/ Example: C Let If be a root node father of Is in the assembly tree. C If is the principal C variable of the node If and let If1, If2, If3 be the secondary variables C of node If. C Is is the principal C variable of the node Is and let Is1, Is2 be the secondary variables C of node Is. C C THEN: C NV(If1)=NV(If2)=NV(If3) = 0 (secondary variables) C NV(Is1)=NV(Is2) = 0 (secondary variables) C NV(If) > 0 ( principal variable) C NV(Is) > 0 ( principal variable) C PE(If) = 0 (root node) C PE(Is) = -If (If is the father of Is in the assembly tree) C PE(If1)=PE(If2)=PE(If3)= -If ( If is the principal variable) C PE(Is1)=PE(Is2)= -Is ( Is is the principal variable) C C C C HALOAMD_V1: (September 1997) C ********** C Initial version designed to experiment the numerical (fill-in) impact C of taking into account the halo. This code should be able C to experiment no-halo, partial halo, complete halo. C DATE: September 17th 1997 C C HALOAMD is designed to process a gragh composed of two types C of nodes, V0 and V1, extracted from a larger gragh. C V0^V1 = {}, C C We used Min. degree heuristic to order only C nodes in V0, but the adjacency to nodes C in V1 is taken into account during ordering. C Nodes in V1 are odered at last. C Adjacency between nodes of V1 need not be provided, C however |len(i)| must always corresponds to the number of C edges effectively provided in the adjacency list of i. C On input : c ******** C Nodes INODE in V1 are flagged with len(INODE) = -degree C modif version HALO V3 (August 1998): C if len(i) =0 and i \in V1 then C len(i) must be set on input to -N-1 C ERROR return (negative values in ncmpa) C ************ C negative value in ncmpa indicates an error detected C by HALOAMD. C C The graph provided MUST follow the rule: C if (i,j) is an edge in the gragh then C j must be in the adjacency list of i AND C i must be in the adjacency list of j. C REMARKS C ------- C C 1/ Providing edges between nodes of V1 should not C affect the final ordering, only the amount of edges C of the halo should effectively affect the solution. C This code should work in the following cases: C 1/ halo not provided C 2/ halo partially provided C 3/ complete halo C 4/ complete halo+interconnection between nodes of V1. C C 1/ should run and provide identical results (w.r.t to current C implementation of AMD in SCOTCH). C 3/ and 4 should provide identical results. C C 2/ All modifications of the AMD initial code are indicated C with begin HALO .. end HALO C C C Ordering of nodes in V0 is based on approximate minimum C fill-in heuristic. C C----------------------------------------------------------------------- C begin CONSTRAINT C CONSTRAINT(I) >= 0 : I can be selected C < 0 : I cannot be selected C > 0 : I release CONSTRAINT(I) C THESON(I) = 0 : I is a leaf in the supervariable representation C THESON(I) > I : THESON(I) belongs to the same supervariable as I C Parameters: INTEGER, INTENT(INOUT) :: CONSTRAINT(N) INTEGER, INTENT(out) :: THESON(N) INTEGER PREV,TOTO C end CONSTRAINT C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C On output: (PE is copied on output into PARENT array) C C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C C nv: On input, encoding of compressed graph: C if NV(1) = -1 then graph is not compressed otherwise C NV(I) holds the weight of node I. C During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C begin HALO C On output, nv(I) can be used to find node in set V1. C Not true anymore : ( nv(I) = N+1 characterizes nodes in V1. C instead nodes in V1 are considered as a dense root node ) C end HALO C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) C positive or null (>=0) : i \in V0 and C len(i) holds the number of entries in row i of the C matrix, excluding the diagonal. C negative (<0) : i \in V1, and C -len(i) hold the number of entries in row i of the C matrix, excluding the diagonal. C len(i) = - | Adj(i) | if i \in V1 C or -N -1 if | Adj(i) | = 0 and i \in V1 C The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C begin HALO C on output ncmpa <0 --> error detected during HALO_AMD: C error 1: ncmpa = -N , ordering was stopped. C end HALO C C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C begin HALO C degree(I) = n+1 indicates that i belongs to V1 C end HALO C C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C C wf : integer array used to store the already filled area of C the variables adajcent to current pivot. C wf is then used to update the score of variable i. C C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X, & NBFLAG, NREAL, LASTD, NELME, WF3, WF4, N2, PAS INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) :: MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8):: HASH, HMOD DOUBLE PRECISION :: RMF, RMF1 DOUBLE PRECISION :: dummy INTEGER :: idummy C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C wf3: off diagonal block area C wf4: diagonal block area C mf : Minimum fill C begin HALO C nbflag: number of flagged entries in the initial gragh. C nreal : number of entries on which ordering must be perfomed C (nreel = N- nbflag) C nelme number of pivots selected when reaching the root C lastd index of the last row in the list of dense rows C end HALO C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod, huge INTEGER TOTEL C======================================================================= C INITIALIZATIONS C======================================================================= C HEAD (0:NBBUCK+1) C begin HALO C C idummy holds the largest integer - 1 C dummy = dble (idummy) idummy = huge(idummy) - 1 dummy = dble(idummy) C variable with degree equal to N2 are in halo C bucket NBBUCK+1 used for HALO variables N2 = -NBBUCK-1 C end HALO C Distance betweeen elements of the N, ..., NBBUCK entries of HEAD C C update done on 20 Feb 2002 (PAS>= 1) PAS = max((N/8), 1) WFLG = 2 MAXINT_N=huge(WFLG)-N NCMPA = 0 NEL = 0 HMOD = int(max (1, NBBUCK-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM MINDEG = 0 C NBFLAG = 0 LASTD = 0 HEAD(0:NBBUCK+1) = 0 DO 10 I = 1, N THESON(I) = 0 LAST (I) = 0 C NV (I) = 1 W (I) = 1 ELEN (I) = 0 10 CONTINUE TOTEL = 0 DO I=1,N IF (LEN(I).LT.0) THEN DEGREE (I) = N2 NBFLAG = NBFLAG +1 IF (LEN(I).EQ.-N-1) THEN C variable in V1 with empty adj list LEN (I) = 0 C Because of compress, we force skipping this C entry which is anyway empty PE (I) = 0_8 ELSE LEN (I) = - LEN(I) ENDIF C end HALO V3 ELSE TOTEL = TOTEL + NV(I) DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDIF ENDDO C C C number of entries to be ordered. NREAL = N - NBFLAG C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (DEG.EQ.N2) THEN C DEG = N2 (flagged variables are stored C in the degree list of NBBUCK + 1 C (safe: because max C max value of degree is NBBUCK) C DEG = NBBUCK + 1 IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF GOTO 20 ENDIF C C IF (DEG .GT. 0) THEN WF(I) = DEG IF (DEG.GT.N) THEN DEG = min(((DEG-N)/PAS) + N , NBBUCK) ENDIF C Note that if deg=0 then C No fill-in will occur, C but one variable is adjacent to I C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C ---------------------------------------------------------- INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF C======================================================================= C 20 CONTINUE C======================================================================= C WHILE (selecting pivots) DO C======================================================================= NLEFT = TOTEL-NEL C======================================================================= C ===================================================================== 30 IF (NEL .LT. TOTEL) THEN C ===================================================================== C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, NBBUCK ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF (ME.LE.0) THEN NCMPA = -N CALL MUMPS_ABORT() ENDIF IF (DEG.GT.N) THEN C ------------------------------- C Linear search to find variable C with best score in the list C ------------------------------- C While end of list list not reached C NEXT(J) = 0 J = NEXT(ME) K = WF(ME) C if ME is not available IF(CONSTRAINT(ME) .LT. 0) THEN K = -1 ENDIF 55 CONTINUE IF (J.GT.0) THEN C j is available IF(CONSTRAINT(J) .GE. 0) THEN IF (WF(J).LT.K .OR. K .LT. 0) THEN ME = J K = WF(ME) ENDIF ENDIF J= NEXT(J) GOTO 55 ENDIF ILAST = LAST(ME) INEXT = NEXT(ME) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C me is at the head of the degree list HEAD (DEG) = INEXT ENDIF C ELSE C select ME which verify the constraint C if it is directly ok IF(CONSTRAINT(ME) .GE. 0) GOTO 59 56 CONTINUE C if ME has a successor exaine it IF(NEXT(ME) .NE. 0) THEN ME = NEXT(ME) IF(CONSTRAINT(ME) .GE. 0) THEN GOTO 59 ELSE GOTO 56 ENDIF ELSE C ME has no successor -> increase deg till finding a valid ME C 57: increase deg till a non empty list is found 57 DEG = DEG+1 ME = HEAD(DEG) C no empty found IF(ME .GT. 0) THEN C good piv found IF(CONSTRAINT(ME) .GE. 0) THEN GOTO 59 ELSE C else loop on next GOTO 56 ENDIF ELSE C increase degree GOTO 57 ENDIF ENDIF 59 PREV = LAST (ME) INEXT = NEXT (ME) IF(PREV .NE. 0) THEN NEXT(PREV) = INEXT ELSE HEAD (DEG) = INEXT ENDIF C remove ME from the x2 linked lists IF (INEXT .NE. 0) LAST (INEXT) = PREV ENDIF C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- TOTO = ME 5910 IF(TOTO .NE. 0) THEN J = CONSTRAINT(TOTO) IF(J .GT. 0) THEN CONSTRAINT(J) = 0 ENDIF TOTO = THESON(TOTO) GOTO 5910 ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + LEN (ME) - 1 I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).NE.N2) THEN C ---------------------------------------------------- C remove variable i from degree list. (only if i \in V0) C ---------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list IF (WF(I).GT.N) THEN DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) ELSE DEG = WF(I) ENDIF HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + int(LENJ - 1,8) PSRC = PSRC + int(LENJ - 1,8) ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------- C remove variable i from degree link list C (only if i in V0) C ------------------------------------------------- ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE IF (WF(I).GT.N) THEN DEG = min(((WF(I)-N)/PAS) + N , NBBUCK) ELSE DEG = WF(I) ENDIF C i is at the head of the degree list HEAD (DEG) = INEXT ENDIF ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI WF(E) = 0 ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- DO 180 PME = PME1, PME2 I = IW (PME) P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 WF3 = 0 WF4 = 0 NVI = -NV(I) C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN IF ( WF(E) .EQ. 0 ) THEN C First time we meet e : compute wf(e) C which holds the surface associated to element e C it will later be deducted from fill-in C area of all variables adjacent to e WF(E) = DEXT * ( (2 * DEGREE(E)) - DEXT - 1) ENDIF WF4 = WF4 + WF(E) DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (DEXT .EQ. 0) THEN #if defined (NOAGG4) IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) #else C aggressive absorption: e is not adjacent to me, but C the |Le \ Lme| is 0, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 #endif ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1_8) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list DEG = DEG + NVJ WF3 = WF3 + NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C IF (DEGREE(I).EQ.N2) DEG = N2 C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- #if defined (NOAGG4) IF (ELEN(I).EQ.1 .AND. P3.EQ.PN) THEN #else IF (DEG .EQ. 0) THEN #endif C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. TOTO = I 5911 IF(TOTO .NE. 0) THEN J = CONSTRAINT(TOTO) IF(J .GT. 0) THEN CONSTRAINT(J) = 0 ENDIF TOTO = THESON(TOTO) GOTO 5911 ENDIF PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: C AMD DEGREE (I) = min (DEGREE (I), DEG) IF (DEGREE(I).NE.N2) THEN C I does not belong to halo C dk = min (d(k-1)+degme, deg+degme) IF ( DEGREE (I).LT.DEG ) THEN C Our appox degree is loose. C we keep old value. Note that in C this case we cannot substract WF(I) C for min-fill score. WF4 = 0 WF3 = 0 ELSE DEGREE(I) = DEG ENDIF ENDIF C C compute WF(I) taking into account size of block 3.0 WF(I) = WF4 + 2*NVI*WF3 C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1_8) IF (DEG.NE.N2) THEN C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV (I) .LT. 0) .AND. (DEGREE(I).NE.N2) ) THEN C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN IF(CONSTRAINT(J) .LT. 0 & .AND. CONSTRAINT(I) .LT. 0) THEN GOTO 240 ENDIF IF(CONSTRAINT(I) .GE. 0) THEN IF(CONSTRAINT(J) .LT. 0) THEN TOTO = I 221 IF(TOTO .NE. 0) THEN IF(CONSTRAINT(TOTO) .EQ. J) THEN GOTO 225 ENDIF TOTO =THESON(TOTO) GOTO 221 ENDIF ELSE GOTO 225 ENDIF ELSE C if I is locked see if it is freed thanks to J IF(CONSTRAINT(J) .GE. 0) THEN TOTO = J 222 IF(TOTO .NE. 0) THEN IF(CONSTRAINT(TOTO) .EQ. I) THEN GOTO 225 ENDIF TOTO =THESON(TOTO) GOTO 222 ENDIF ENDIF ENDIF GOTO 240 225 CONTINUE C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1_8, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- C update the supervariable composition TOTO = I 231 IF(THESON(TOTO) .NE. 0) THEN TOTO = THESON(TOTO) GOTO 231 ENDIF THESON(TOTO) = J IF(CONSTRAINT(I) .LT. 0) THEN CONSTRAINT(I) = 0 ENDIF PE (J) = int(-I,8) WF(I) = max(WF(I),WF(J)) C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: NV (I) = NV (I) + NV (J) NV (J) = 0 ELEN (J) = 0 C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).NE.N2) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I) + DEGME - NVI, NLEFT - NVI) IF (DEGREE (I) + DEGME .GT. NLEFT ) THEN C DEG = DEGREE(I) RMF1 = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) DEGREE(I) = NLEFT - NVI DEG = DEGREE(I) RMF = dble(DEG)*dble(DEG-1) & - dble(DEGME-NVI)*dble(DEGME-NVI-1) RMF = min(RMF, RMF1) ELSE DEG = DEGREE(I) DEGREE(I) = DEGREE (I) + DEGME - NVI RMF = dble(DEG)*dble( (DEG-1) + 2*DEGME ) & - dble(WF(I)) ENDIF RMF = RMF / dble(NVI+1) C IF (RMF.LT.dummy) THEN WF(I) = int ( anint( RMF )) ELSEIF (RMF / dble(N) .LT. dummy) THEN WF(I) = int ( anint( RMF/dble(N) )) ELSE WF(I) = idummy ENDIF WF(I) = max(1,WF(I)) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- DEG = WF(I) IF (DEG.GT.N) THEN DEG = min(((DEG-N)/PAS) + N , NBBUCK) ENDIF INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (DEG) = I C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, DEG) ENDIF C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C fill_est = fill_est + nvpiv * (nvpiv + 2 * degme) C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= C begin HALO V2 IF (NBFLAG.GT.0) THEN C C All possible pivots (not flagged have been eliminated). C We amalgamate all flagged variables at the root and C we finish the elimination tree. C 1/ Go through all C non absorbed elements (root of the subgraph) C and absorb in ME C 2/ perform mass elimination of all dense rows DO DEG = MINDEG, NBBUCK+1 ME = HEAD (DEG) IF (ME .GT. 0) GO TO 51 ENDDO 51 MINDEG = DEG NELME = -(NEL+1) DO X=1,N IF ((PE(X).GT.0_8) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element PE(X) = int(-ME,8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.N2) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 C Correct value of NV is (secondary variable) NV(X) = 0 ENDIF ENDDO C ME is the root node ELEN(ME) = NELME C Correct value of NV is (principal variable) NV(ME) = N-NREAL PE(ME) = 0_8 C ENDIF C end HALO C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- IF(.TRUE.) THEN C N is the size of the compressed graph. C If the graph was compressed on input then C indices in ELEN are in [1,TOTEL] C We build the inverse of ELEN in LAST (similar to C the pivot order but has zeros in it) and then compress C it. Since LAST is assumed to be of size N at the C interface level, we need another array to store C the inverse of ELEN for entries greater than N C We use DEGREE. LAST(1:N) = 0 DEGREE(1:TOTEL-N)=0 DO I = 1, N K = abs (ELEN (I)) IF ( K <= N ) THEN LAST (K) = I ELSE DEGREE(K-N)=I ENDIF ENDDO I = 1 DO K = 1, N IF(LAST (K) .NE. 0) THEN LAST(I) = LAST(K) ELEN(LAST(K)) = I I = I + 1 ENDIF ENDDO DO K = N+1, TOTEL IF (DEGREE(K-N) .NE. 0) THEN LAST(I)=DEGREE(K-N) ELEN(DEGREE(K-N)) = I I = I + 1 ENDIF END DO ELSE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_CST_AMF C----------------------------------------------------------------------- C MUMPS_SYMQAMD: modified version of MUMPS_QAMD code to C designed to compute a symbolic factorization given C an input ordering (provided in PERM array) and possibly C a schur area. C --------- SUBROUTINE MUMPS_SYMQAMD & ( THRESH, NDENSE, & N, TOTEL, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PERM, LISTVAR_SCHUR, SIZE_SCHUR, & AGG6, PARENT ) IMPLICIT NONE C Input not modified INTEGER, INTENT(IN) :: N, TOTEL, SIZE_SCHUR LOGICAL, INTENT(IN) :: AGG6 INTEGER, INTENT(IN) :: THRESH INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(IN) :: LISTVAR_SCHUR(max(1,SIZE_SCHUR)) C Input undefined on output INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) C C Output only INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: ELEN(N), LAST(TOTEL), PARENT(N) C C Input/output INTEGER, INTENT(INOUT) :: NV(N) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) INTEGER, INTENT(INOUT) :: PERM(N) C C Internal Workspace only INTEGER, INTENT(OUT) :: NDENSE(N), DEGREE(N), & HEAD(TOTEL), NEXT(N), W(N) C C ======================= C INTERFACE DOCUMENTATION C SPECIFIC TO SYMQAMD. C ======================= C (more details are sometimes C available in the C PREVIOUS DOCUMENTATION C section) C C N (in): the size of the matrix C number of supervariables if blocked format C TOTEL (in) : Number of variables to eliminate C C IWLEN (in): the length of the workspace IW C C PFREE (inout): says that IW(1:PFREE-1) contains the graph on input, see C below. (on output see meaning bellow) C IW (inout): C On input, IW(1:PFREE-1) contains the orginal graph C On output it has been corrupted because IW(1:IWLEN) has been C used as workspace. C C LEN(inout): On input, C LEN (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of LEN(1..N) C are undefined on output. C C PE(inout): On input PE(i) contains the pointers in IW to (the column C indices of) row i of the matrix. C On output it contains the tree: C - if I is a principal variable (NV(I) >0) then -pe(I) is the principal C variable of the father, or 0 if I is a root node. C - if I is a secondary variable (NV(I)=0) then -pe(I) is the principal C variable of the node it belongs to. C C On output: (PE is copied on output into PARENT array) C C C NV(inout): C On input: encoding of a blocked matrix C if NV(1).NE.-1 the NV(I) holds the weight of node I. C During execution, C abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. C If i is a nonprincipal variable, then nv (i) = 0. C nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. C On output: C - if i is a principal variable, NV(i) is the size of the front C in the multifrontal terminology. C - if i is a secondary variable, NV(i)=0 C C PERM (inout) : MUST BE SET TO HOLD THE POSITION OF VARIABLE I IN THE C PERMUTED ORDER. C PERM(I) = J means that I is the Jth pivot. C PERM IS NOT ALTERED IF SIZE_SCHUR = 0. C IF SIZE_SCHUR > 0 and variable I is part of the Schur, C then PERM(I) must be greater than N - SIZE_SCHUR. C In that case, PERM(I) is altered: it is set to N+1 internally ! C C SIZE_SCHUR (in) : > 0 means that the last SIZE_SCHUR variable C in the order (such that PERM(I) > N-SIZE_SCHUR) C are part of the schur decompositon C and should remain ordered last and amalgamated C at the root of the elimination tree. C C LISTVAR_SCHUR(1:SIZE_SCHUR) (in): should be set on entry to the list of C variables (original indices) in the Schur complement C C THRESH (in): is used to set the local variable THRESM, corresponding C to the internal restarting feature. C <= 0 Recommended value. Automatic setting will be done. C Note that this does not correspond to the historical C documentation further below. C = N Only exactly dense rows in the reduced matrix are selected. C > 1 and <= N THRESH correspond to the minimum density requirement. C C At the moment if SIZE_SCHUR > 0 restarting functionality is disabled, C which means that performance is not optimal. It should work again with C a small modification but this has to be tested when it is re-enabled. C C ELEN (out) needs not be set on entry. C It contains the inverse C permutation on output. Not sure what it contains for the Schur C variables. C (it should be ok for the Schur too). C C LAST used internally as working space; C On output, last (1..n) holds the permutation, i = last (k), then C row i is the kth pivot row. C Not used on output and C Computation has been suppressed C since in the context of blocked matrix format C one cannot so easily compute last out of elen C (see end of MUMPS_QAMD in case of COMRPESS, C because elen(i) \in [1:TOTEL] and not \in [1:N]) C C AGG6 (in): controls if aggressive absorption should be authorized. C C ------------------------------------------- C ARGUMENTS USED INTERNALLY AS WORKARRAYS C Maybe some things are significant on output C but not in the normal cases of usage. C ------------------------------------------- C C NDENSE, LAST, NEXT, HEAD, DEGREE, W C C ------ C OUTPUT C ------ C C NCMPA (out): number of compressions. C C C ====================== C PREVIOUS DOCUMENTATION C ====================== C C NDENSE of an element is the number of dense rows in the element. C----------------------------------------------------------------------- C It is a modified version of MUMPS_QAMD C designed to automatically detect and exploit dense or quasi dense C rows in the reduced matrix at any step of the minimum degree. C The input integer parameter THRESH defines the quasi density: C THRESH : input parameter (not modified) C THRESH is used to compute THRESM C <=0 or N Only exactly dense rows in the reduced matrix are selected. C >1 and <=N THRESH correspond to the munimum density requirement. C Version 0: All dense and quasi dense rows are amalgamated at the C root node. C Version 1: Restart AMD with all quasi dense rows, and C increase density requirement. C----------------------------------------------------------------------- C Additionnal parameters/variables due to dense row manipulation: C C Local variables: C --------------- INTEGER THRESM, NDME, PERMeqN INTEGER NBD,NBED, NBDM, LASTD, NELME LOGICAL IDENSE C THRESM : Local Integer holding a C potentially modified value of THRESH. C When quasi dense rows are reintegrated in the C graph to be processed then THRESM is modified. C Note that if one sets THRESM to negative value then C <0 Classical AMD algorithm (no dense row detection) C NDME : number of dense row adjacent to me C NELME number of pivots selected when reching the root C LASTD index of the last row in the list of dense rows C NBD is the total number of dense rows selected C NBED is the total number of exactly dense rows detected. C NBDM is the maximum number of dense rows selected C IDENSE is used to indicate that the supervariable I is a dense or C quasi-dense row. C----------------------------------------------------------------------- C INPUT ARGUMENTS (unaltered): C----------------------------------------------------------------------- C n: The matrix order. C C Restriction: n .ge. 1 C iwlen: The length of iw (1..iwlen). On input, the matrix is C stored in iw (1..pfree-1). However, iw (1..iwlen) should be C slightly larger than what is required to hold the matrix, at C least iwlen .ge. pfree + n is recommended. Otherwise, C excessive compressions will take place. C *** We do not recommend running this algorithm with *** C *** iwlen .lt. pfree + n. *** C *** Better performance will be obtained if *** C *** iwlen .ge. pfree + n *** C *** or better yet *** C *** iwlen .gt. 1.2 * pfree *** C *** (where pfree is its value on input). *** C The algorithm will not run at all if iwlen .lt. pfree-1. C C Restriction: iwlen .ge. pfree-1 C----------------------------------------------------------------------- C INPUT/OUPUT ARGUMENTS: C----------------------------------------------------------------------- C pe: On input, pe (i) is the index in iw of the start of row i, or C zero if row i has no off-diagonal non-zeros. C C During execution, it is used for both supervariables and C elements: C C * Principal supervariable i: index into iw of the C description of supervariable i. A supervariable C represents one or more rows of the matrix C with identical nonzero pattern. C * Non-principal supervariable i: if i has been absorbed C into another supervariable j, then pe (i) = -j. C That is, j has the same pattern as i. C Note that j might later be absorbed into another C supervariable j2, in which case pe (i) is still -j, C and pe (j) = -j2. C * Unabsorbed element e: the index into iw of the description C of element e, if e has not yet been absorbed by a C subsequent element. Element e is created when C the supervariable of the same name is selected as C the pivot. C * Absorbed element e: if element e is absorbed into element C e2, then pe (e) = -e2. This occurs when the pattern of C e (that is, Le) is found to be a subset of the pattern C of e2 (that is, Le2). If element e is "null" (it has C no nonzeros outside its pivot block), then pe (e) = 0. C C On output, pe holds the assembly tree/forest, which implicitly C represents a pivot order with identical fill-in as the actual C order (via a depth-first search of the tree). C C On output: C If nv (i) .gt. 0, then i represents a node in the assembly tree, C and the parent of i is -pe (i), or zero if i is a root. C If nv (i) = 0, then (i,-pe (i)) represents an edge in a C subtree, the root of which is a node in the assembly tree. C pfree: On input, the matrix is stored in iw (1..pfree-1) and C the rest of the array iw is free. C During execution, additional data is placed in iw, and pfree C is modified so that components of iw from pfree are free. C On output, pfree is set equal to the size of iw that C would have been needed for no compressions to occur. If C ncmpa is zero, then pfree (on output) is less than or equal to C iwlen, and the space iw (pfree+1 ... iwlen) was not used. C Otherwise, pfree (on output) is greater than iwlen, and all the C memory in iw was used. C----------------------------------------------------------------------- C INPUT/MODIFIED (undefined on output): C----------------------------------------------------------------------- C len: On input, len (i) holds the number of entries in row i of the C matrix, excluding the diagonal. The contents of len (1..n) C are undefined on output. C iw: On input, iw (1..pfree-1) holds the description of each row i C in the matrix. The matrix must be symmetric, and both upper C and lower triangular parts must be present. The diagonal must C not be present. Row i is held as follows: C C len (i): the length of the row i data structure C iw (pe (i) ... pe (i) + len (i) - 1): C the list of column indices for nonzeros C in row i (simple supervariables), excluding C the diagonal. All supervariables start with C one row/column each (supervariable i is just C row i). C if len (i) is zero on input, then pe (i) is ignored C on input. C C Note that the rows need not be in any particular order, C and there may be empty space between the rows. C C During execution, the supervariable i experiences fill-in. C This is represented by placing in i a list of the elements C that cause fill-in in supervariable i: C C len (i): the length of supervariable i C iw (pe (i) ... pe (i) + elen (i) - 1): C the list of elements that contain i. This list C is kept short by removing absorbed elements. C iw (pe (i) + elen (i) ... pe (i) + len (i) - 1): C the list of supervariables in i. This list C is kept short by removing nonprincipal C variables, and any entry j that is also C contained in at least one of the elements C (j in Le) in the list for i (e in row i). C C When supervariable i is selected as pivot, we create an C element e of the same name (e=i): C C len (e): the length of element e C iw (pe (e) ... pe (e) + len (e) - 1): C the list of supervariables in element e. C C An element represents the fill-in that occurs when supervariable C i is selected as pivot (which represents the selection of row i C and all non-principal variables whose principal variable is i). C We use the term Le to denote the set of all supervariables C in element e. Absorbed supervariables and elements are pruned C from these lists when computationally convenient. C C CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION. C The contents of iw are undefined on output. C----------------------------------------------------------------------- C OUTPUT (need not be set on input): C----------------------------------------------------------------------- C nv: During execution, abs (nv (i)) is equal to the number of rows C that are represented by the principal supervariable i. If i is C a nonprincipal variable, then nv (i) = 0. Initially, C nv (i) = 1 for all i. nv (i) .lt. 0 signifies that i is a C principal variable in the pattern Lme of the current pivot C element me. On output, nv (e) holds the true degree of element C e at the time it was created (including the diagonal part). C elen: See the description of iw above. At the start of execution, C elen (i) is set to zero. During execution, elen (i) is the C number of elements in the list for supervariable i. When e C becomes an element, elen (e) = -nel is set, where nel is the C current step of factorization. elen (i) = 0 is done when i C becomes nonprincipal. C C For variables, elen (i) .ge. 0 holds until just before the C permutation vectors are computed. For elements, C elen (e) .lt. 0 holds. C C On output elen (1..n) holds the inverse permutation (the same C as the 'INVP' argument in Sparspak). That is, if k = elen (i), C then row i is the kth pivot row. Row i of A appears as the C (elen(i))-th row in the permuted matrix, PAP^T. C last: In a degree list, last (i) is the supervariable preceding i, C or zero if i is the head of the list. In a hash bucket, C last (i) is the hash key for i. last (head (hash)) is also C used as the head of a hash bucket if head (hash) contains a C degree list (see head, below). C C On output, last (1..n) holds the permutation (the same as the C 'PERM' argument in Sparspak). That is, if i = last (k), then C row i is the kth pivot row. Row last (k) of A is the k-th row C in the permuted matrix, PAP^T. C ncmpa: The number of times iw was compressed. If this is C excessive, then the execution took longer than what could have C been. To reduce ncmpa, try increasing iwlen to be 10% or 20% C larger than the value of pfree on input (or at least C iwlen .ge. pfree + n). The fastest performance will be C obtained when ncmpa is returned as zero. If iwlen is set to C the value returned by pfree on *output*, then no compressions C will occur. C----------------------------------------------------------------------- C LOCAL (not input or output - used only during execution): C----------------------------------------------------------------------- C degree: If i is a supervariable, then degree (i) holds the C current approximation of the external degree of row i (an upper C bound). The external degree is the number of nonzeros in row i, C minus abs (nv (i)) (the diagonal part). The bound is equal to C the external degree if elen (i) is less than or equal to two. C C We also use the term "external degree" for elements e to refer C to |Le \ Lme|. If e is an element, then degree (e) holds |Le|, C which is the degree of the off-diagonal part of the element e C (not including the diagonal part). C degree (I) =N+1 if I is an exactly dense row in reduced matrix. C =N+1+LAST_approximate_external_deg of I C if I is a quasi dense row in reduced matrix. C All dense or quasi dense rows are stored in the list pointed C by head(n). Quasi-dense rows (degree(I)=n) are stored first, C and are followed by exactly dense rows in the reduced matrix. C LASTD holds the last row in this list of dense rows or is zero C if the list is empty. C head: head is used for degree lists. head (deg) is the first C supervariable in a degree list (all supervariables i in a C degree list deg have the same approximate degree, namely, C deg = degree (i)). If the list deg is empty then C head (deg) = 0. C C During supervariable detection head (hash) also serves as a C pointer to a hash bucket. C If head (hash) .gt. 0, there is a degree list of degree hash. C The hash bucket head pointer is last (head (hash)). C If head (hash) = 0, then the degree list and hash bucket are C both empty. C If head (hash) .lt. 0, then the degree list is empty, and C -head (hash) is the head of the hash bucket. C After supervariable detection is complete, all hash buckets C are empty, and the (last (head (hash)) = 0) condition is C restored for the non-empty degree lists. C next: next (i) is the supervariable following i in a link list, or C zero if i is the last in the list. Used for two kinds of C lists: degree lists and hash buckets (a supervariable can be C in only one kind of list at a time). C w: The flag array w determines the status of elements and C variables, and the external degree of elements. C C for elements: C if w (e) = 0, then the element e is absorbed C if w (e) .ge. wflg, then w (e) - wflg is the size of C the set |Le \ Lme|, in terms of nonzeros (the C sum of abs (nv (i)) for each principal variable i that C is both in the pattern of element e and NOT in the C pattern of the current pivot element, me). C if wflg .gt. w (e) .gt. 0, then e is not absorbed and has C not yet been seen in the scan of the element lists in C the computation of |Le\Lme| in loop 150 below. C C for variables: C during supervariable detection, if w (j) .ne. wflg then j is C not in the pattern of variable i C C The w array is initialized by setting w (i) = 1 for all i, C and by setting wflg = 2. It is reinitialized if wflg becomes C too large (to ensure that wflg+n does not cause integer C overflow). C----------------------------------------------------------------------- C LOCAL INTEGERS: C----------------------------------------------------------------------- C THRESM is used to C accelerate symolic factorization C THRESM is dynamically updated to C allow more quasi-dense row selection C ThresPrev holds last starting value C at the beginning of one iteration C ThresMin holds minimum value of THRESH INTEGER :: FDEG, ThresMin, ThresPrev, IBEGSchur, NbSchur, & ThresMinINIT INTEGER :: DEGMAX,THD, THDperm, THD_AGG DOUBLE PRECISION :: RELDEN LOGICAL :: AGG6_loc, DenseRows LOGICAL :: SchurON INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER :: SIZE_SCHUR_LOC INTEGER(8) MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD LOGICAL :: COMPRESS C deg: the degree of a variable or element C degme: size, |Lme|, of the current element, me (= degree (me)) C dext: external degree, |Le \ Lme|, of some element e C dmax: largest |Le| seen so far C e: an element C elenme: the length, elen (me), of element list of pivotal var. C eln: the length, elen (...), of an element list C hash: the computed value of the hash function C hmod: the hash function is computed modulo hmod = max (1,n-1) C i: a supervariable C ilast: the entry in a link list preceding i C inext: the entry in a link list following i C j: a supervariable C jlast: the entry in a link list preceding j C jnext: the entry in a link list, or path, following j C k: the pivot order of an element or variable C knt1: loop counter used during element construction C knt2: loop counter used during element construction C knt3: loop counter used during compression C lenj: len (j) C ln: length of a supervariable list C maxint_n: large integer to test risk of overflow on wflg C maxmem: amount of memory needed for no compressions C me: current supervariable being eliminated, and the C current element created by eliminating that C supervariable C mem: memory in use assuming no compressions have occurred C mindeg: current minimum degree C nel: number of pivots selected so far C newmem: amount of new memory needed for current pivot element C nleft: n - nel, the number of nonpivotal rows/columns remaining C nvi: the number of variables in a supervariable i (= nv (i)) C nvj: the number of variables in a supervariable j (= nv (j)) C nvpiv: number of pivots in current element C slenme: number of variables in variable list of pivotal variable C we: w (e) C wflg: used for flagging the w array. See description of iw. C wnvi: wflg - nv (i) C x: either a supervariable or an element C----------------------------------------------------------------------- C LOCAL POINTERS: C----------------------------------------------------------------------- INTEGER(8) P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC, PLN, PELN C Any parameter (pe (...) or pfree) or local variable C starting with "p" (for Pointer) is an index into iw, C and all indices into iw use variables starting with C "p." The only exception to this rule is the iwlen C input argument. C p: pointer into lots of things C p1: pe (i) for some variable i (start of element list) C p2: pe (i) + elen (i) - 1 for some var. i (end of el. list) C p3: index of first supervariable in clean list C pdst: destination pointer, for compression C pend: end of memory to compress C pj: pointer into an element or variable C pme: pointer into the current element (pme1...pme2) C pme1: the current element, me, is stored in iw (pme1...pme2) C pme2: the end of the current element C pn: pointer into a "clean" variable, also used to compress C psrc: source pointer, for compression C----------------------------------------------------------------------- C FUNCTIONS CALLED: C----------------------------------------------------------------------- INTRINSIC max, min, mod, maxval C======================================================================= C INITIALIZATIONS C======================================================================= IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0_8 IF (NV(1).LT.0) NV(1) = 1 NCMPA = 0 PARENT(1) = 0 RETURN ENDIF AGG6_loc = AGG6 DenseRows = .FALSE. C C We can now assume that N>1 C CSymbolic Intialize degrees with the order given by PERM C SIZE_SCHUR_LOC = SIZE_SCHUR SIZE_SCHUR_LOC = min(N,SIZE_SCHUR_LOC) SIZE_SCHUR_LOC = max(0,SIZE_SCHUR_LOC) SchurON = (SIZE_SCHUR_LOC > 0) IBEGSchur = N-SIZE_SCHUR_LOC+1 THRESM = THRESH ! local value of THRESH IF (THRESM.GT.N) THRESM = N IF (THRESM.LT.0) THRESM = 0 C Variables in the schur are considered as exactly dense C (Schur variables are ordered last, we check it here) IF ( SchurON ) THEN DO I= 1, N IF ( PERM(I) .GE. IBEGSchur) THEN PERM(I) = N + 1 C Because of compress, we force skipping this C entry which is anyway empty IF (LEN(I) .EQ.0) THEN PE(I) = 0_8 ENDIF ENDIF ENDDO ENDIF C IF (SchurON) THEN C C Only restriction is n>= THRESM > 0 C C only exactly dense row will be selected C It should also work ok combined to C quasi dense row selection. C (To be Tested it seperately) THRESM = N ThresMin = N ThresPrev = N ELSE THRESM = max(int(31*N/32),THRESM) THRESM = max(THRESM,1) C DEGMAX= maxval(LEN) RELDEN=dble(PFREE-1)/dble(N) THD = int(RELDEN)*10 + (DEGMAX-int(RELDEN))/10 + 1 IF (THD.LT.DEGMAX) THEN DenseRows = .TRUE. THDperm = N DO I = 1,N IF (LEN(I) .GT. THD) THEN THDperm = min(THDperm,PERM(I)) ENDIF ENDDO THRESM = min(THRESM, THDperm) ENDIF C Compute ThresMin and initialise ThresPrev ThresMin = max( 3*THRESM / 4, 1) ThresPrev = THRESM C ENDIF ! test on SchurON C ThresMinINIT = ThresMin/4 THD_AGG = max(128, min(TOTEL/2048, 1024)) IF (THRESM.GT.0) THEN IF ((THRESM.GT.N).OR.(THRESM.LT.2)) THEN C exactly dense rows only THRESM = N ENDIF ENDIF LASTD = 0 NBD = 0 NBED = 0 NBDM = 0 WFLG = 2 MAXINT_N=huge(WFLG)-TOTEL MINDEG = 1 NCMPA = 0 NEL = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO I = 1, N NDENSE(I)= 0 W (I) = 1 ELEN (I) = 0 C NV (I) = 1 C DEGREE (I) = LEN (I) ENDDO DO I=1, N LAST (I) = 0 HEAD (I) = 0 ENDDO C initialize degree IF(NV(1) .LT. 0) THEN COMPRESS = .FALSE. ELSE COMPRESS = .TRUE. ENDIF IF (COMPRESS) THEN DO I=1,N DEGREE(I) = 0 DO P= PE(I) , PE(I)+int(LEN(I)-1,8) DEGREE(I) = DEGREE(I) + NV(IW(P)) ENDDO ENDDO ELSE DO I=1,N NV(I) = 1 DEGREE (I) = LEN (I) ENDDO ENDIF C ---------------------------------------------------------------- C initialize degree lists and eliminate rows with no off-diag. nz. C ---------------------------------------------------------------- DO 20 I = 1, N DEG = DEGREE (I) IF (PERM(I).EQ.N) THEN C save that I is last in the order PERMeqN = I PERM(I) = N-1 ENDIF FDEG = PERM(I) IF ( (DEG .GT. 0).OR.(PERM(I).EQ.N+1) ) THEN C ---------------------------------------------------------- C place i in the degree list corresponding to its degree C or in the dense row list if i is dense or quasi dense. C ---------------------------------------------------------- C test for row density IF ( (THRESM.GT.0) .AND. & (FDEG .GT.THRESM) ) THEN C I will be inserted in the degree list of N NBD = NBD+NV(I) IF (FDEG.NE.N+1) THEN C DEGREE(I) = DEGREE(I)+TOTEL+2 C insert I at the beginning of degree list of n DEG = N INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ELSE C Only Schur variables are concerned here C Property: LISTVAR_SCHUR (1) will C be first in the list of schur variables NBED = NBED+NV(I) DEGREE(I) = TOTEL+1 C insert I at the end of degree list of n DEG = N IF (LASTD.EQ.0) THEN C degree list is empty LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ENDIF ELSE C place i in the degree list corresponding to its degree INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (FDEG) = I ENDIF ELSE C ---------------------------------------------------------- C we have a variable that can be eliminated at once because C there is no off-diagonal non-zero in its row. C ---------------------------------------------------------- NEL = NEL + NV(I) ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE C We suppress dense row selection if none of them was found in A C in the 1st pass IF ((NBD.EQ.0).AND.(THRESM.GT.0)) THRESM = N C C======================================================================= C WHILE (selecting pivots) DO C======================================================================= 30 IF (NEL .LT. TOTEL) THEN C======================================================================= C GET PIVOT OF MINIMUM DEGREE C======================================================================= C ------------------------------------------------------------- C find next supervariable for elimination C ------------------------------------------------------------- DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG C ------------------------------------------------------------- C We want to respect the ordering provided by the user C Therefefore if (DEG > THRESM .and. NBD.ge.0) then C A quasi-dense variable might have a perm value C smaller than ME. C We thus in this case force restarting. C ------------------------------------------------------------- IF ( (DEG.NE.N) .AND. & (DEG.GT.THRESM+1) .AND. (NBD.GT.0) ) THEN MINDEG = N GOTO 30 ENDIF IF (DEGREE(ME).LE.TOTEL) THEN C ------------------------------------------------------------- C remove chosen variable from link list C ------------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELSE C C Because of restarting forced even if C variable (not yest quasi dense) but of C value of perm larger thatn thresm still C to be eliminated we have to reset MINDEB to 1 MINDEG = 1 NBDM = max(NBDM,NBD) IF (DEGREE(ME).GT.TOTEL+1) THEN IF (WFLG .GT. MAXINT_N) THEN DO 52 X = 1, N IF (W (X) .NE. 0) W (X) = 1 52 CONTINUE WFLG = 2 ENDIF WFLG = WFLG + 1 51 CONTINUE C --------------------------------------------------------- C remove chosen variable from link list C --------------------------------------------------------- INEXT = NEXT (ME) IF (INEXT .NE. 0) THEN LAST (INEXT) = 0 ELSE LASTD = 0 ENDIF C ---------------------------------------------------------- c build adjacency list of ME in quotient gragh C and calculate its external degree in ndense(me) C ---------------------------------------------------------- NDENSE(ME) = 0 W(ME) = WFLG P1 = PE(ME) P2 = P1 + int(LEN(ME) -1,8) C PLN-1 holds the pointer in IW to the last elet/var in adj list C of ME. LEN(ME) will then be set to PLN-P1 C PELN-1 hold the pointer in IW to the last elet in in adj list C of ME. ELEN(ME) will then be set to PELN-P1 C element adjacent to ME PLN = P1 PELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0_8) THEN C E is a nonprincipal variable or absorbed element X = E 53 X = int(-PE(X)) IF (W(X) .EQ.WFLG) GOTO 55 W(X) = WFLG IF ( PE(X) .LT. 0_8 ) GOTO 53 E = X ENDIF C ------------------------------------------- C E is an unabsorbed element or a "dense" row C (NOT already flagged) C ------------------------------------------- IF (ELEN(E).LT.0) THEN C E is a new element in adj(ME) NDENSE(E) = NDENSE(E) - NV(ME) IW(PLN) = IW(PELN) IW(PELN) = E PLN = PLN+1_8 PELN = PELN + 1_8 C update ndense of ME with all unflagged dense C rows in E PME1 = PE(E) DO 54 PME = PME1, PME1+int(LEN(E)-1,8) X = IW(PME) IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN C X is a dense row NDENSE(ME) = NDENSE(ME) + NV(X) W(X) = WFLG ENDIF 54 CONTINUE ELSE C E is a dense row NDENSE(ME) = NDENSE(ME) + NV(E) IW(PLN)=E PLN = PLN+1_8 ENDIF 55 CONTINUE C ---------------------------------------------- C DEGREE(ME)-(TOTEL+2) holds last external degree computed C when Me was detected as dense C NDENSE(ME) is the exact external degree of ME C ---------------------------------------------- WFLG = WFLG + 1 LEN(ME) = int(PLN-P1) ELEN(ME) = int(PELN-P1) NDME = NDENSE(ME)+NV(ME) IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 C --------------------------------------------------------- C place ME in the degree list of NDENSE(ME), update DEGREE C --------------------------------------------------------- DEGREE(ME) = NDENSE(ME) DEG = PERM(ME) MINDEG = min(DEG,MINDEG) JNEXT = HEAD(DEG) IF (JNEXT.NE. 0) LAST (JNEXT) = ME NEXT(ME) = JNEXT HEAD(DEG) = ME C ------------------------------ C process next quasi dense row C ------------------------------ ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(TOTEL+1) ) GOTO 51 ENDIF HEAD (N) = ME C --------------------------------------- C update dense row selection strategy C ------------------------------------- IF (THRESM.LT.N) THEN ThresMin = max(THRESM+ThresMin,ThresPrev+ThresMin/2+1) ThresMin = min(ThresMin, N) ThresPrev = ThresPrev+(N-ThresPrev)/2+ThresMinINIT THRESM = max( & THRESM + int(sqrt(dble(ThresMin)))+ ThresMinINIT , & ThresPrev) THRESM = min(THRESM,N) ThresMin = min(THRESM, ThresMin) ThresPrev = THRESM ENDIF NBD = NBED C get back to Min degree elimination loop C GOTO 30 ENDIF C ------------------------------------------------------------- C ------------------------------------------------------------- IF (DEGREE(ME).EQ.TOTEL+1) THEN C we have only exactly "dense" rows that we C amalgamate at the root node IF (NBD.NE.NBED) THEN write(6,*) ' ERROR in MUMPS_SYMQAMD quasi dense rows remains' CALL MUMPS_ABORT() ENDIF NbSchur = 0 ! Only for checking NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN PE(X) = int(-LISTVAR_SCHUR(1),8) ELSE IF ((PE(X).GT.0) .AND. (ELEN(X).LT.0)) THEN C X is an unabsorbed element C -- Force sons to be linked to first node in Schur PE(X) = int(-LISTVAR_SCHUR(1),8) C W(X) = 0 could be suppressed ?? check it ELSEIF (DEGREE(X).EQ.TOTEL+1) THEN C X is a dense row, absorb it in ME (mass elimination) NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 NV(X) = 0 NbSchur = NbSchur+ 1 ENDIF 59 CONTINUE IF (NbSchur.NE.SIZE_SCHUR_LOC) then write(6,*) ' Internal error 2 in QAMD :', & ' Schur size expected:',SIZE_SCHUR_LOC, 'Real:', NbSchur CALL MUMPS_ABORT() ENDIF C ME is the root node ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0_8 IF (NEL.NE.N) THEN write(6,*) 'Internal ERROR 2 detected in QAMD' write(6,*) ' NEL not equal to N: N, NEL =',N,NEL CALL MUMPS_ABORT() ENDIF IF (ME.NE. LISTVAR_SCHUR(1)) THEN C -- Set all node in Schur list to point to LISTVAR_SCHUR(1) DO I=1, SIZE_SCHUR_LOC PE(LISTVAR_SCHUR(I)) = int(-LISTVAR_SCHUR(1),8) ENDDO PE(LISTVAR_SCHUR(1)) = 0_8 NV( LISTVAR_SCHUR(1))= NV(ME) NV(ME) = 0 ELEN( LISTVAR_SCHUR(1)) = ELEN(ME) ELEN(ME) = 0 ENDIF GOTO 265 ENDIF ENDIF C ------------------------------------------------------------- C me represents the elimination of pivots nel+1 to nel+nv(me). C place me itself as the first in this set. It will be moved C to the nel+nv(me) position when the permutation vectors are C computed. C ------------------------------------------------------------- ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NDENSE(ME) = 0 C======================================================================= C CONSTRUCT NEW ELEMENT C======================================================================= C ------------------------------------------------------------- C At this point, me is the pivotal supervariable. It will be C converted into the current element. Scan list of the C pivotal supervariable, me, setting tree pointers and C constructing new list of supervariables for the new element, C me. p is a pointer to the current position in the old list. C ------------------------------------------------------------- C flag the variable "me" as being in Lme by negating nv (me) NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN C ---------------------------------------------------------- C construct the new element in place C ---------------------------------------------------------- PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN C ---------------------------------------------------- C i is a principal variable not yet placed in Lme. C store i in new list C ---------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I C ---------------------------------------------------- C remove variable i from degree list. C ---------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 60 CONTINUE C this element takes no new memory in iw: NEWMEM = 0 ELSE C ---------------------------------------------------------- C construct the new element in empty space, iw (pfree ...) C ---------------------------------------------------------- P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN C search the supervariables in me. E = ME PJ = P LN = SLENME ELSE C search the elements in me. E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF C ------------------------------------------------------- C search for different supervariables and add them to the C new list, compressing when necessary. this loop is C executed once for each element in the list and once for C all the supervariables in the list. C ------------------------------------------------------- KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN C ------------------------------------------------- C compress iw, if necessary C ------------------------------------------------- IF (PFREE .GT. IWLEN) THEN C prepare for compressing iw by adjusting C pointers and lengths so that the lists being C searched in the inner and outer loops contain C only the remaining entries. PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED C Reset KNT1_UPDATED in case of recompress C at same iteration of the loop 120 KNT1_UPDATED = 0 C Check if anything left in supervariable ME IF (LEN (ME) .EQ. 0) PE (ME) = 0 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED C Reset KNT2_UPDATED in case of recompress C at same iteration of the loop 110 KNT2_UPDATED = 0 C Check if anything left in element E IF (LEN (E) .EQ. 0) PE (E) = 0 NCMPA = NCMPA + 1 C store first item in pe C set first entry to -item DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE C psrc/pdst point to source/destination PDST = 1 PSRC = 1 PEND = PME1 - 1 C while loop: 80 CONTINUE IF (PSRC .LE. PEND) THEN C search for next negative entry J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1 C copy from source to destination LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + LENJ - 1 PSRC = PSRC + LENJ - 1 ENDIF GO TO 80 ENDIF C move the new partially-constructed element P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF C ------------------------------------------------- C i is a principal variable not yet placed in Lme C store i in new list C ------------------------------------------------- DEGME = DEGME + NVI C flag i as being in Lme by negating nv (i) NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 C ------------------------------------------------- C remove variable i from degree link list C ------------------------------------------------- C only done for non "dense" rows IF (DEGREE(I).LE.TOTEL) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE C i is at the head of the degree list HEAD (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN C set tree pointer and flag to indicate element e is C absorbed into new element me (the parent of e is me) PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 C this element takes newmem new memory in iw (possibly zero) NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF C ------------------------------------------------------------- C me has now been converted into an element in iw (pme1..pme2) C ------------------------------------------------------------- C degme holds the external degree of new element DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) C ------------------------------------------------------------- C make sure that wflg is not too large. With the current C value of wflg, wflg+n must not cause integer overflow C ------------------------------------------------------------- IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF C======================================================================= C COMPUTE (w (e) - wflg) = |Le\Lme| FOR ALL ELEMENTS Cdense C COMPUTE (w(e) - wflg) = |Le(G')\Lme(G')| FOR ALL ELEMENTS C where G' is the subgraph of G excluding ''dense" rows) Cdense C======================================================================= C ------------------------------------------------------------- C Scan 1: compute the external degrees of previous elements C with respect to the current element. That is: C (w (e) - wflg) = |Le \ Lme| C for each element e that appears in any supervariable in Lme. C The notation Le refers to the pattern (list of C supervariables) of a previous element e, where e is not yet C absorbed, stored in iw (pe (e) + 1 ... pe (e) + iw (pe (e))). C The notation Lme refers to the pattern of the current element C (stored in iw (pme1..pme2)). If (w (e) - wflg) becomes C zero, then the element e will be absorbed in scan 2. C aggressive absorption is possible only if NDENSE(ME) = NBD C which is true when only exactly dense rows have been selected. C ------------------------------------------------------------- DO 150 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN C note that nv (i) has been negated to denote i in Lme: NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN C unabsorbed element e has been seen in this loop WE = WE - NVI ELSE IF (WE .NE. 0) THEN C e is an unabsorbed element C this is the first we have seen e in all of Scan 1 WE = DEGREE (E) + WNVI - NDENSE(E) Cn dense ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE C======================================================================= C DEGREE UPDATE AND ELEMENT ABSORPTION C======================================================================= C ------------------------------------------------------------- C Scan 2: for each i in Lme, sum up the degree of Lme (which C is degme), plus the sum of the external degrees of each Le C for the elements e appearing within i, plus the C supervariables in i. Place i in hash list. C ------------------------------------------------------------- AGG6_loc = (AGG6 .OR. (DEGREE(ME) .LT. THD_AGG)) DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.TOTEL) GOTO 180 P1 = PE (I) P2 = P1 + int(ELEN (I) - 1,8) PN = P1 HASH = 0_8 DEG = 0 C ---------------------------------------------------------- C scan the element list associated with supervariable i C ---------------------------------------------------------- DO 160 P = P1, P2 E = IW (P) C dext = | Le \ Lme | DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1_8 HASH = HASH + int(E,kind=8) C ------------------------------ C suppress aggressive absorption C ------------------------------ ELSE IF (.NOT. AGG6_loc .AND. DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1_8 HASH = HASH + int(E,kind=8) C C ------------------------------ C try aggressive absorption C when possible ELSE IF (AGG6_loc .AND. (DEXT .EQ. 0) .AND. & ((NDENSE(ME).EQ.NBD).OR.(NDENSE(E).EQ.0))) THEN C aggressive absorption: e is not adjacent to me, but C |Le(G') \ Lme(G')| is 0 and all dense rows C are in me, so absorb it into me PE (E) = int(-ME,8) W (E) = 0 ELSE IF (AGG6_loc .AND. DEXT.EQ.0) THEN IW(PN) = E PN = PN+1 HASH = HASH + int(E,kind=8) ENDIF 160 CONTINUE C count the number of elements in i (including me): ELEN (I) = int(PN - P1 + 1) C ---------------------------------------------------------- C scan the supervariables in the list associated with i C ---------------------------------------------------------- P3 = PN DO 170 P = P2 + 1, P1 + int(LEN (I) - 1,8) J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN C j is unabsorbed, and not in Lme. C add to degree and add to new list C add degree only of non-dense rows. IF (DEGREE(J).LE.TOTEL) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE C ---------------------------------------------------------- C update the degree and check for mass elimination C ---------------------------------------------------------- IF (((ELEN(I).EQ.1).AND.(P3.EQ.PN)) & .OR. & (AGG6_loc.AND.(DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) & ) & THEN C ------------------------------------------------------- C mass elimination C ------------------------------------------------------- C There is nothing left of this node except for an C edge to the current pivot element. elen (i) is 1, C and there are no variables adjacent to node i. C Absorb i into the current pivot element, me. PE (I) = int(-ME,8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE C ------------------------------------------------------- C update the upper-bound degree of i C ------------------------------------------------------- C the following degree does not yet include the size C of the current element, which is added later: DEGREE(I) = min (DEG+NBD-NDENSE(ME), & DEGREE(I)) C ------------------------------------------------------- C add me to the list for i C ------------------------------------------------------- C move first supervariable to end of list IW (PN) = IW (P3) C move first element to end of element part of list IW (P3) = IW (P1) C add new element to front of list. IW (P1) = ME C store the new length of the list in len (i) LEN (I) = int(PN - P1 + 1) C ------------------------------------------------------- C place in hash bucket. Save hash key of i in last (i). C ------------------------------------------------------- HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN C the degree list is empty, hash head is -j NEXT (I) = -J HEAD (HASH) = -I ELSE C degree list is not empty C use last (head (hash)) as hash head NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME C ------------------------------------------------------------- C Clear the counter array, w (...), by incrementing wflg. C ------------------------------------------------------------- DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX C make sure that wflg+n does not cause integer overflow IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF C at this point, w (1..n) .lt. wflg holds C======================================================================= C SUPERVARIABLE DETECTION C======================================================================= DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.TOTEL) ) THEN C only done for nondense rows C i is a principal variable in Lme C ------------------------------------------------------- C examine all hash buckets with 2 or more variables. We C do this by examing all unique hash keys for super- C variables in the pattern Lme of the current element, me C ------------------------------------------------------- HASH = int(LAST (I),kind=8) C let i = head of hash bucket, and empty the hash bucket J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN C degree list is empty I = -J HEAD (HASH) = 0 ELSE C degree list is not empty, restore last () of head I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 C while loop: 200 CONTINUE IF (NEXT (I) .NE. 0) THEN X = I C ---------------------------------------------------- C this bucket has one or more variables following i. C scan all of them to see if i can absorb any entries C that follow i in hash bucket. Scatter i into w. C ---------------------------------------------------- LN = LEN (I) ELN = ELEN (I) C do not flag the first element in the list (me) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE C ---------------------------------------------------- C scan every other entry j following i in bucket C ---------------------------------------------------- JLAST = I J = NEXT (I) C while loop: 220 CONTINUE IF (J .NE. 0) THEN C ------------------------------------------------- C check if j and i have identical nonzero pattern C ------------------------------------------------- C jump if i and j do not have same size data structure IF (LEN (J) .NE. LN) GO TO 240 C jump if i and j do not have same number adj elts IF (ELEN (J) .NE. ELN) GO TO 240 C do not flag the first element in the list (me) DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) C jump if an entry (iw(p)) is in j but not in i IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE C ------------------------------------------------- C found it! j can be absorbed into i C ------------------------------------------------- IF (PERM(J).GT.PERM(X)) THEN ! J is absorbed by X PE (J) = int(-X,8) NV (X) = NV (X) + NV (J) NV (J) = 0 ELEN (J) = 0 ELSE ! X is absorbed by J PE (X) = int(-J,8) NV (J) = NV (X) + NV (J) NV (X) = 0 ELEN (X) = 0 X = J ENDIF C both nv (i) and nv (j) are negated since they C are in Lme, and the absolute values of each C are the number of variables in i and j: C delete j from hash bucket J = NEXT (J) NEXT (JLAST) = J GO TO 220 C ------------------------------------------------- 240 CONTINUE C j cannot be absorbed into i C ------------------------------------------------- JLAST = J J = NEXT (J) GO TO 220 ENDIF C ---------------------------------------------------- C no more variables can be absorbed into i C go to next i in bucket and clear flag array C ---------------------------------------------------- WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE C======================================================================= C RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVAR. FROM ELEMENT C======================================================================= C ------------------------------ C Update thresm for having more C quasi dense rows to select C ------------------------------ IF ( .NOT.DenseRows.AND.(THRESM .GT. 0).AND.(THRESM.LT.N) ) & THEN THRESM = max(ThresMin, THRESM-NVPIV) ENDIF P = PME1 NLEFT = TOTEL - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN C i is a principal variable in Lme C restore nv (i) to signify that i is principal NV (I) = NVI IF (DEGREE(I).LE.TOTEL) THEN C ------------------------------------------------------- C compute the external degree (add size of current elem) C ------------------------------------------------------- DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) DEGREE (I) = DEG IDENSE = .FALSE. C C ------------------- C Dense row detection C ------------------- IF (THRESM.GT.0) THEN IF (PERM(I) .GT. THRESM) THEN C relaxed dense row detection IDENSE = .TRUE. C DEGREE(I) = DEGREE(I)+TOTEL+2 ENDIF IF (IDENSE) THEN C update NDENSE of all elements in the list of element C adjacent to I (including ME). P1 = PE(I) P2 = P1 + int(ELEN(I) - 1,8) IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF C insert I in the list of dense rows NBD = NBD+NVI FDEG = N DEG = N C insert I at the beginning of the list INEXT = HEAD(DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I C end of IDENSE=true ENDIF C end of THRESM>0 ENDIF C IF (.NOT.IDENSE) THEN FDEG = PERM(I) C ------------------------------------------------------- C place the supervariable at the head of the degree list C ------------------------------------------------------- INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (FDEG) = I ENDIF C ------------------------------------------------------- C save the new degree, and find the minimum degree C ------------------------------------------------------- MINDEG = min (MINDEG, FDEG) ENDIF C ------------------------------------------------------- C place the supervariable in the element pattern C ------------------------------------------------------- IW (P) = I P = P + 1 ENDIF 260 CONTINUE C======================================================================= C FINALIZE THE NEW ELEMENT C======================================================================= NV (ME) = NVPIV + DEGME C nv (me) is now the degree of pivot (including diagonal part) C save the length of the list for the new element me LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN C there is nothing left of the current pivot element PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN C element was not constructed in place: deallocate part C of it (final size is less than or equal to newmem, C since newly nonprincipal variables have been removed). PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF C======================================================================= C END WHILE (selecting pivots) GO TO 30 ENDIF C======================================================================= 265 CONTINUE C======================================================================= C COMPUTE THE PERMUTATION VECTORS C======================================================================= C ---------------------------------------------------------------- C The time taken by the following code is O(n). At this C point, elen (e) = -k has been done for all elements e, C and elen (i) = 0 has been done for all nonprincipal C variables i. At this point, there are no principal C supervariables left, and all elements are absorbed. C ---------------------------------------------------------------- C ---------------------------------------------------------------- C compute the ordering of unordered nonprincipal variables C ---------------------------------------------------------------- DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN C ---------------------------------------------------------- C i is an un-ordered row. Traverse the tree from i until C reaching an element, e. The element, e, was the C principal supervariable of i and all nodes in the path C from i to when e was selected as pivot. C ---------------------------------------------------------- J = int(-PE (I)) C while (j is a variable) do: 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J C ---------------------------------------------------------- C get the current pivot ordering of e C ---------------------------------------------------------- K = -ELEN (E) C ---------------------------------------------------------- C traverse the path again from i to e, and compress the C path (all nodes point to e). Path compression allows C this code to compute in O(n) time. Order the unordered C nodes in the path, and place the element e at the end. C ---------------------------------------------------------- J = I C while (j is a variable) do: 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J) = int(-E,8) IF (ELEN (J) .EQ. 0) THEN C j is an unordered row ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF C leave elen (e) negative, so we know it is an element ELEN (E) = -K ENDIF 290 CONTINUE C ---------------------------------------------------------------- C reset the inverse permutation (elen (1..n)) to be positive, C and compute the permutation (last (1..n)). C ---------------------------------------------------------------- DO 300 I = 1, N K = abs (ELEN (I)) C LAST (K) = I C LAST (K) = I ELEN (I) = K 300 CONTINUE IF (.NOT.SchurON) THEN C ----------------------------- C restore PERM(I)=N for PERMeqN C ----------------------------- PERM(PERMeqN) = N ENDIF C======================================================================= C RETURN THE MEMORY USAGE IN IW C======================================================================= C If maxmem is less than or equal to iwlen, then no compressions C occurred, and iw (maxmem+1 ... iwlen) was unused. Otherwise C compressions did occur, and iwlen would have had to have been C greater than or equal to maxmem for no compressions to occur. C Return the value of maxmem in the pfree argument. PFREE = MAXMEM C=============================== C Save PE in PARENT array DO I=1,N PARENT(I) = int(PE(I)) ENDDO C=============================== RETURN END SUBROUTINE MUMPS_SYMQAMD MUMPS_5.4.1/src/mumps_static_mapping.F0000664000175000017500000054760014102210475020057 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_STATIC_MAPPING USE MUMPS_LR_COMMON IMPLICIT NONE PRIVATE PUBLIC :: MUMPS_DISTRIBUTE, MUMPS_RETURN_CANDIDATES, & MUMPS_INIT_ARCH_PARAMETERS,MUMPS_END_ARCH_CV integer,pointer,dimension(:,:),SAVE::cv_cand integer,pointer,dimension(:),SAVE::cv_par2_nodes integer,SAVE::cv_slavef,cv_nb_niv2,cv_lp,cv_mp integer, parameter:: tsplit_beg=4 integer, parameter:: tsplit_mid=5 integer, parameter:: tsplit_last=6 integer,parameter::cv_invalid=-9999 DOUBLE PRECISION,parameter::cv_d_invalid=-9999.D0 integer,parameter::cv_equilib_flops=1 integer,parameter::cv_equilib_mem=2 integer,parameter::cv_error_memalloc = -13 integer,parameter::cv_error_memdeloc = -96 integer,dimension(:),allocatable,save :: mem_distribtmp integer, dimension(:),allocatable, save :: table_of_process integer,dimension(:),allocatable,save :: mem_distribmpi integer, save ::ke69,nb_arch_nodes logical,dimension(:),allocatable,save :: allowed_nodes integer,dimension(:),allocatable,save :: score type nodelist integer::nodenumber type(nodelist),pointer::next end type nodelist type alloc_arraytype integer, pointer, dimension(:)::t2_nodenumbers integer, pointer, dimension(:,:)::t2_cand DOUBLE PRECISION, pointer, dimension(:)::t2_candcostw(:), & t2_candcostm(:) integer:: nmb_t2s end type alloc_arraytype type splitting_data integer:: new_ison,new_ifather,old_keep2 DOUBLE PRECISION:: ncostw_oldinode,ncostm_oldinode, & tcostw_oldinode,tcostm_oldinode end type splitting_data type procs4node_t integer, dimension(:), pointer :: ind_proc end type procs4node_t DOUBLE PRECISION, pointer, dimension(:) :: & cv_proc_workload, & cv_proc_maxwork, & cv_proc_memused, & cv_proc_maxmem type(splitting_data)::cv_last_splitting integer::cv_n,cv_nsteps,cv_maxlayer, & cv_nbsa,cv_maxnsteps,cv_maxdepth, & cv_maxnodenmb,cv_total_amalg,cv_total_split, & cv_bitsize_of_int,cv_size_ind_proc & ,cv_mixed_strat_bound,cv_dist_L0_mixed_strat_bound & ,cv_layerl0_end,cv_layerl0_start integer :: layerL0_endforarrangeL0 DOUBLE PRECISION :: mincostw DOUBLE PRECISION:: cv_costw_upper,cv_costm_upper, & cv_costw_layer0,cv_costm_layer0,cv_relax, & cv_costw_total,cv_costm_total,cv_l0wthresh,cv_splitthresh logical::cv_constr_work,cv_constr_mem integer,pointer,dimension(:):: cv_nodetype,cv_nodelayer, & cv_layerl0_array,cv_proc_sorted,cv_depth integer,dimension(:),pointer:: & cv_ne,cv_nfsiz,cv_frere,cv_fils,cv_keep,cv_info, & cv_procnode,cv_ssarbr,cv_icntl integer(8),dimension(:),pointer::cv_keep8 type(alloc_arraytype),pointer,dimension(:)::cv_layer_p2node DOUBLE PRECISION,dimension(:),pointer:: cv_ncostw, & cv_tcostw,cv_ncostm,cv_tcostm,cv_layerworkload,cv_layermemused & ,cv_layerl0_sorted_costw type(procs4node_t),dimension(:),pointer :: cv_prop_map integer, dimension(:), pointer :: cv_SIZEOFBLOCKS logical :: cv_BLKON contains subroutine MUMPS_DISTRIBUTE(n,slavef,icntl,info, & ne,nfsiz,frere,fils,keep,KEEP8, & procnode,ssarbr,nbsa,peak,istat & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) implicit none integer,intent(in)::n,slavef integer, intent(inout),TARGET:: ne(n),nfsiz(n), & procnode(n),ssarbr(n),frere(n),fils(n),keep(500), & icntl(60),info(80) integer, intent(in) :: LSIZEOFBLOCKS integer, intent(in) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER(8) KEEP8(150) integer,intent(out)::nbsa,istat integer ierr,nmb_thislayer,layernmb,mapalgo,allocok,i integer,pointer,dimension(:)::thislayer integer,parameter::memonly=1,floponly=2,hybrid=3 DOUBLE PRECISION:: & maxwork,minwork,maxmem,minmem,workbalance,membalance DOUBLE PRECISION:: cost_root_node DOUBLE PRECISION,dimension(:),allocatable:: work_per_proc integer,dimension(:),allocatable::id_son logical :: cont character (len=48):: err_rep,subname DOUBLE PRECISION peak logical :: BLKON BLKON = (SIZEOFBLOCKS(1).GT.0) cv_BLKON = BLKON istat=-1 subname='DISTRIBUTE' cv_lp=icntl(1) cv_mp=icntl(3) IF (icntl(4).LT.2) cv_mp=0 nullify(thislayer) err_rep='INITPART1' call MUMPS_INITPART1(n,slavef, & frere,fils,nfsiz,ne,keep,KEEP8,icntl,info, & procnode,ssarbr,peak,ierr & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) if (ierr.ne.0) goto 99999 err_rep='PROCINIT' call MUMPS_PROCINIT(istat=ierr) if (ierr.ne.0) goto 99999 err_rep='CALCCOST' call MUMPS_CALCCOSTS(ierr) if (ierr.ne.0) goto 99999 err_rep='ROOTLIST' call MUMPS_ROOTLIST(ierr) if (ierr.ne.0) goto 99999 err_rep='LAYERL0' call MUMPS_LAYERL0(ierr) if (ierr.ne.0) goto 99999 if (ierr.ne.0) goto 99999 err_rep='INITPART2' call MUMPS_INITPART2(ierr) if (ierr.ne.0) goto 99999 err_rep='WORKMEM_' call MUMPS_WORKMEM_IMBALANCE( & cv_proc_workload,cv_proc_memused, & maxwork,minwork,maxmem,minmem) if(maxwork.gt.0.0D0) then workbalance=minwork/maxwork else workbalance=0.0D0 endif if(maxmem.gt.0.0D0) then membalance=minmem/maxmem else membalance=0.0D0 endif err_rep='mem_alloc' allocate(thislayer(cv_maxnodenmb),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 2*cv_maxnsteps+cv_maxnodenmb if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname ierr = cv_error_memalloc goto 99999 end if cont=.TRUE. layernmb=0 mapalgo=floponly err_rep='SELECT_TYPE3' call MUMPS_SELECT_TYPE3(ierr) if (ierr.ne.0) goto 99999 IF (cv_keep(38) .ne. 0 .and. cv_keep(60) .eq. 0 ) THEN call MUMPS_GET_FLOPS_COST(cv_nfsiz(keep(38)), & cv_nfsiz(keep(38)), cv_nfsiz(keep(38)), & cv_keep(50), 3, cost_root_node) cost_root_node = cost_root_node / dble(cv_slavef) do i=1, cv_slavef cv_proc_memused(i)=cv_proc_memused(i)+ & dble(cv_nfsiz(keep(38)))*dble(cv_nfsiz(keep(38)))/ & dble(cv_slavef) cv_proc_workload(i)=cv_proc_workload(i)+dble(cost_root_node) enddo ENDIF do while((cont).OR.(layernmb.le.cv_maxlayer)) err_rep='FIND_THIS' call MUMPS_FIND_THISLAYER(layernmb,thislayer,nmb_thislayer, & ierr) if (ierr.ne.0) goto 99999 err_rep='DO_SPLITTING' if(cv_keep(82) .gt. 0) then if(layernmb.gt.0) call MUMPS_SPLIT_DURING_MAPPING & (layernmb,thislayer,nmb_thislayer,ierr) endif if (ierr.ne.0) goto 99999 err_rep='ASSIGN_TYPES' call MUMPS_ASSIGN_TYPES(layernmb,thislayer,nmb_thislayer, & ierr) if (ierr.ne.0) goto 99999 if(layernmb.gt.0) then if ((cv_keep(24).eq.1).OR.(cv_keep(24).eq.2).OR. & (cv_keep(24).eq.4).OR.(cv_keep(24).eq.6)) then err_rep='COSTS_LAYER_T2' call MUMPS_COSTS_LAYER_T2(layernmb,nmb_thislayer,ierr) elseif((cv_keep(24).eq.8).OR.(cv_keep(24).eq.10) & .OR.(cv_keep(24).eq.12).OR.(cv_keep(24).eq.14) & .OR.(cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then err_rep='COSTS_LAYER_T2PM' call MUMPS_COSTS_LAYER_T2PM(layernmb,nmb_thislayer,ierr) else err_rep='wrong strategy for COSTS_LAYER_T2' ierr = -9999 endif if (ierr.ne.0) goto 99999 err_rep='WORKMEM_' call MUMPS_WORKMEM_IMBALANCE( & cv_proc_workload,cv_proc_memused, & maxwork,minwork,maxmem,minmem) if(maxwork.gt.0.0D0) then workbalance=minwork/maxwork else workbalance=0.0D0 endif if(maxmem.gt.0.0D0) then membalance=minmem/maxmem else membalance=0.0D0 endif if(mapalgo.eq.memonly) then err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_mem,ierr) if (ierr.ne.0) goto 99999 elseif(mapalgo.eq.floponly) then err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_flops,ierr) if (ierr.ne.0) goto 99999 elseif(mapalgo.eq.hybrid) then if (workbalance <= membalance) then err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_flops,ierr) if (ierr.ne.0) goto 99999 else err_rep='MAP_LAYER' call MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,cv_equilib_mem,ierr) if (ierr.ne.0) goto 99999 endif else if(cv_lp.gt.0) & write(cv_lp,*)'Unknown mapalgo in ',subname return endif endif layernmb=layernmb+1 err_rep='HIGHER_LAYER' call MUMPS_HIGHER_LAYER(layernmb,thislayer, & nmb_thislayer,cont,ierr) if (ierr.ne.0) goto 99999 end do IF ( (cv_keep(79).EQ.0).OR.(cv_keep(79).EQ.3).OR. & (cv_keep(79).EQ.5).OR.(cv_keep(79).EQ.7) & ) THEN if(cv_slavef.gt.4) then err_rep='POSTPROCESS' call MUMPS_POSTPROCESS_MEM() endif ENDIF err_rep='SETUP_CAND' call MUMPS_SETUP_CAND(ierr) if (ierr.ne.0) goto 99999 err_rep='ENCODE_PROC' call MUMPS_ENCODE_PROCNODE(ierr) if (ierr.ne.0) goto 99999 err_rep='STORE_GLOB' call MUMPS_STORE_GLOBALS(ne,nfsiz,frere,fils,keep,KEEP8, & info,procnode,ssarbr,nbsa) err_rep='mem_dealloc' deallocate(thislayer,STAT=ierr) if (ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname ierr = cv_error_memdeloc goto 99999 endif err_rep='TERMGLOB' call MUMPS_TERMGLOB(ierr) if (ierr.ne.0) goto 99999 istat=0 return 99999 continue if(cv_lp.gt.0) then write(cv_lp,*)'Error in ',subname,', layernmb=',layernmb write(cv_lp,*)'procedure reporting the error: ',err_rep endif if(ierr.eq.cv_error_memalloc) then info(1) = cv_info(1) info(2) = cv_info(2) endif istat=ierr return CONTAINS subroutine MUMPS_ACCEPT_L0( & map_strat,workload,memused,accepted, & istat) implicit none integer,intent(in)::map_strat DOUBLE PRECISION,dimension(:),intent(in)::workload, memused logical,intent(out)::accepted integer,intent(out)::istat DOUBLE PRECISION maxi,mini,mean,stddev, dpkeep102 integer i,nmb intrinsic maxval,minval,count,sum character (len=48):: subname logical alternative_criterion DOUBLE PRECISION:: & MINFLOPS , MINMEM, & CL_RATE, DV_RATE istat=-1 if ( cv_keep(72) .EQ. 1) then MINFLOPS = 2.0D0 MINMEM=50.0D0 CL_RATE =0.8D0 DV_RATE=0.2D0 else IF (cv_keep(66).NE.0) THEN MINFLOPS = 5.0D8 MINMEM=5.0D7 CL_RATE =0.8D0 DV_RATE=0.2D0 ELSE MINFLOPS = 5.0D7 MINMEM=5.0D6 CL_RATE =0.8D0 DV_RATE=0.2D0 ENDIF endif dpkeep102 = dble(cv_keep(102)) IF (cv_keep(66).NE.0) THEN IF (cv_slavef.LT.3)THEN dpkeep102 = dble(150) ELSEIF (cv_slavef.LT.5)THEN dpkeep102 = dble(200) ELSEIF (cv_slavef.LT.8)THEN dpkeep102 = dble(250) ELSEIF (cv_slavef.LT.32)THEN dpkeep102 = dble(275) ELSEIF (cv_slavef.LT.512)THEN dpkeep102 = dble(300) ELSEIF (cv_slavef.GE.512)THEN dpkeep102 = dble(400) ENDIF ENDIF subname='ACCEPT_L0' accepted=.FALSE. alternative_criterion=.FALSE. if(map_strat.eq.cv_equilib_flops) then maxi=maxval(workload) mini=minval(workload) if (maxi.lt.MINFLOPS) then accepted=.TRUE. elseif(maxi.le.(dpkeep102/dble(100))*mini)then accepted=.TRUE. endif if ((.NOT.accepted).AND.(alternative_criterion)) then mean=sum(workload)/max(dble(cv_slavef),dble(1)) stddev=dble(0) do i=1,cv_slavef stddev=stddev+ & (abs(workload(i)-mean)*abs(workload(i)-mean)) enddo stddev=sqrt(stddev/max(dble(cv_slavef),dble(1))) nmb=count(mask=abs(workload-mean)0) in=cv_fils(in) end do in=-in do while(in.gt.0) call MUMPS_TYPEINSSARBR(in) in=cv_frere(in) enddo enddo do i=1,cv_n if (cv_frere(i).lt.cv_n+1) then if(cv_nodetype(i).eq.cv_invalid) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname return endif if (i.eq.cv_keep(38)) then if (cv_nodetype(i).ne.3) then cv_nodetype(i)=3 endif endif cv_procnode(i)=MUMPS_ENCODE_TPN_IPROC( cv_nodetype(i), & cv_procnode(i)-1, cv_keep(199)) in=cv_fils(i) do while (in>0) cv_procnode(in)=cv_procnode(i) in=cv_fils(in) end do end if end do istat = 0 return end subroutine MUMPS_ENCODE_PROCNODE subroutine MUMPS_FATHSON_REPLACE(ifather,istat) implicit none integer,intent(in)::ifather integer,intent(out)::istat integer in,son,oldl0end logical father_has_sons character (len=48):: subname istat=-1 subname='FATHSON_REPLACE' father_has_sons=.TRUE. in=ifather do while (in.gt.0) in=cv_fils(in) end do if(in.eq.0) then cv_nodelayer(ifather)=1 cv_keep(262)=cv_keep(262)+1 father_has_sons=.FALSE. end if if(cv_layerl0_end-cv_layerl0_start.gt.0) then cv_layerl0_start= cv_layerl0_start+1 elseif(father_has_sons) then cv_layerl0_start= cv_layerl0_start+1 else istat=1 cv_nodelayer(ifather)=0 return endif cv_nbsa=cv_nbsa-1 oldl0end = cv_layerl0_end if (father_has_sons) then son=-in son=-in 10 continue cv_layerl0_end=cv_layerl0_end+1 if (cv_tcostw(son).GT.mincostw) & layerL0_endforarrangeL0 = layerL0_endforarrangeL0+1 cv_layerl0_array(cv_layerl0_end)=son cv_layerl0_sorted_costw(cv_layerl0_end)=cv_tcostw(son) cv_nbsa=cv_nbsa+1 if((cv_frere(son).gt.0).and.(cv_frere(son).lt.cv_n+1)) then son=cv_frere(son) goto 10 end if endif cv_costw_layer0=cv_costw_layer0 - cv_ncostw(ifather) cv_costm_layer0=cv_costm_layer0 - cv_ncostm(ifather) cv_costw_upper=cv_costw_upper + cv_ncostw(ifather) cv_costm_upper=cv_costm_upper + cv_ncostm(ifather) if(cv_layerl0_end.gt.oldl0end) then call MUMPS_SORT_MSORT(ierr,cv_layerl0_end-oldl0end, & cv_layerl0_array(oldl0end+1:cv_layerl0_end), & cv_layerl0_sorted_costw(oldl0end+1:cv_layerl0_end)) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) 'Error reported by MUMPS_SORT_MSORT in', & subname istat = ierr return endif call MUMPS_SORT_MMERGE( & cv_layerl0_start,oldl0end,oldl0end-cv_layerl0_start+1, & oldl0end+1,cv_layerl0_end,cv_layerl0_end-oldl0end, & cv_layerl0_array(1:cv_layerl0_end), & cv_layerl0_sorted_costw(1:cv_layerl0_end),ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MMERGE in', & subname istat = ierr return endif endif istat=0 return end subroutine MUMPS_FATHSON_REPLACE subroutine MUMPS_FIND_BEST_PROC(inode,map_strat,work,mem, & workload,memused,proc,istat,respect_prop) !DEC$ NOOPTIMIZE implicit none integer, intent(in)::inode,map_strat DOUBLE PRECISION,intent(in)::work,mem DOUBLE PRECISION,dimension(:),intent(inout)::workload, memused integer,intent(out):: proc,istat logical,intent(in),OPTIONAL::respect_prop integer i logical respect_proportional intrinsic huge DOUBLE PRECISION dummy character (len=48):: subname istat=-1 respect_proportional=.FALSE. if(present(respect_prop)) respect_proportional=respect_prop subname='FIND_BEST_PROC' proc=-1 if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) return dummy=huge(dummy) do i=cv_slavef,1,-1 if ( & ((.NOT.respect_proportional) & .OR. & (MUMPS_BIT_GET4PROC(inode,i).AND.respect_proportional)) & .AND. & (((workload(i).lt.dummy).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(i).lt.dummy).AND. & (map_strat.eq.cv_equilib_mem))))then if((.not.cv_constr_work).or. & (workload(i)+work.lt.cv_proc_maxwork(i))) then if((.not.cv_constr_mem).or. & (memused(i)+mem.lt.cv_proc_maxmem(i))) then proc=i if(map_strat.eq.cv_equilib_flops) then dummy=workload(i) elseif(map_strat.eq.cv_equilib_mem) then dummy=memused(i) endif end if end if end if end do if (proc.ne.-1) then workload(proc)=workload(proc)+work memused(proc)=memused(proc)+mem istat=0 end if return end subroutine MUMPS_FIND_BEST_PROC subroutine MUMPS_FIND_THISLAYER(nmb, & thislayer,nmb_thislayer,istat) implicit none integer, intent(in)::nmb integer,intent(out) :: thislayer(:) integer,intent(out) :: nmb_thislayer,istat integer i character (len=48):: subname istat=-1 subname='FIND_THISLAYER' thislayer=0 nmb_thislayer=0 if((nmb.lt.0).or.(nmb.gt.cv_maxlayer)) return do i=1,cv_n if(cv_nodelayer(i).eq.nmb) then nmb_thislayer=nmb_thislayer+1 if(nmb_thislayer.gt.cv_maxnodenmb) then if(cv_lp.gt.0) & write(cv_lp,*)'Problem with nmb_thislayer in ',subname return endif thislayer(nmb_thislayer)=i end if end do istat=0 return end subroutine MUMPS_FIND_THISLAYER subroutine MUMPS_HIGHER_LAYER(startlayer,thislayer, & nmb_thislayer,cont,istat) implicit none integer,intent(in)::startlayer,nmb_thislayer integer,intent(in)::thislayer(:) logical,intent(inout)::cont integer,intent(out)::istat integer :: visited integer il,i,current,in,ifather logical father_valid,upper_layer_exists character (len=48):: subname istat=-1 subname='HIGHER_LAYER' if(.NOT.cont) return if(startlayer.lt.1) return current=startlayer-1 visited = -current-1 upper_layer_exists=.FALSE. if (current.eq.0) then do i=1,cv_n if (cv_nodelayer(i).ne.current) then if(cv_nodelayer(i).eq.1) then upper_layer_exists=.TRUE. exit endif endif enddo endif do il=1,nmb_thislayer i = thislayer(il) in=i if (cv_nodetype(in).eq.tsplit_beg) then do while (cv_frere(in).lt.0) ifather = -cv_frere(in) if (abs(cv_nodetype(ifather)).eq.tsplit_mid) then in = ifather cv_nodelayer (in) = -visited-1 cycle else if (abs(cv_nodetype(ifather)).eq.tsplit_last) then in = ifather cv_nodelayer (in) = current exit else write(6,*) ' Internal error 1 in MUMPS_HIGHER_LAYER' call MUMPS_ABORT() endif end do endif enddo do il=1,nmb_thislayer i = thislayer(il) if (cv_nodelayer(i).lt.current) cycle in=i if (cv_nodetype(in).eq.tsplit_beg) then cv_nodelayer (in) = visited do while (cv_frere(in).lt.0) ifather = -cv_frere(in) if (abs(cv_nodetype(ifather)).eq.tsplit_mid) then in = ifather cv_nodelayer (in) = -visited-1 cycle else if (abs(cv_nodetype(ifather)).eq.tsplit_last) then in = ifather exit else write(6,*) ' Internal error 1 in MUMPS_HIGHER_LAYER', & cv_nodetype(ifather) call MUMPS_ABORT() endif end do endif if(cv_frere(in).eq.0) cycle cv_nodelayer (in) = visited father_valid=.TRUE. do while(cv_frere(in).gt.0) if (cv_nodelayer(cv_frere(in)).gt.current) then father_valid=.FALSE. in = cv_frere(in) cycle endif if (cv_nodelayer(cv_frere(in)).eq.visited) exit in=cv_frere(in) if (cv_nodelayer(in).eq.current) then cv_nodelayer(in) = visited endif end do if (.not.father_valid .or. cv_frere(in).gt.0) then cycle endif ifather=-cv_frere(in) if(cv_nodelayer(ifather).eq.current+1) then cycle endif in=ifather do while (cv_fils(in).gt.0) in=cv_fils(in) end do in=-cv_fils(in) if(cv_nodelayer(in).gt.current) then father_valid=.FALSE. else father_valid=.TRUE. do while(cv_frere(in).gt.0) in=cv_frere(in) if(cv_nodelayer(in).gt.current) then father_valid=.FALSE. exit endif if(cv_nodelayer(in).eq.visited) then exit endif end do endif if(father_valid) then cv_nodelayer(ifather)=current+1 upper_layer_exists=.TRUE. end if end do if (upper_layer_exists) then current=current+1 cv_maxlayer=current cont=.TRUE. else cv_maxlayer=current cont=.FALSE. endif do il=1,nmb_thislayer i = thislayer(il) if (cv_nodelayer(i).eq.visited) cv_nodelayer(i) = -visited-1 enddo istat=0 return end subroutine MUMPS_HIGHER_LAYER subroutine MUMPS_INITPART1(n,slavef, & frere,fils,nfsiz,ne,keep,KEEP8,icntl,info, & procnode,ssarbr,peak,istat & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) implicit none integer, intent(in)::n,slavef integer, intent(in), TARGET:: frere(n),fils(n),nfsiz(n),ne(n), & keep(500),icntl(60),info(80), & procnode(n),ssarbr(n) INTEGER(8), intent(in), TARGET:: KEEP8(150) integer,intent(out)::istat integer, intent(in) :: LSIZEOFBLOCKS integer, intent(in), TARGET :: SIZEOFBLOCKS(LSIZEOFBLOCKS) integer i,allocok,rest DOUBLE PRECISION peak character (len=48):: subname intrinsic bit_size,min,max istat=-1 nullify(cv_frere,cv_fils,cv_nfsiz,cv_ne,cv_keep,cv_keep8, & cv_icntl,cv_info,cv_procnode,cv_ssarbr) nullify(cv_ncostw,cv_tcostw,cv_ncostm,cv_tcostm, & cv_nodelayer,cv_nodetype,cv_depth, & cv_layerworkload,cv_layermemused,cv_prop_map) nullify(cv_SIZEOFBLOCKS) cv_SIZEOFBLOCKS => SIZEOFBLOCKS subname='INITPART1' cv_n=n cv_slavef=slavef cv_keep=>keep cv_keep8=>KEEP8 if(cv_keep(82) .lt. 0) then write(cv_lp,*) & 'Warning in mumps_static_mapping : splitting is set off' cv_keep(82) = 0 endif if(cv_keep(83) .lt. 0) then write(cv_lp,*) & 'warning in mumps_static_mapping : keep(83) reset to 0' cv_keep(83) = 0 endif if(slavef.gt.1) then cv_mixed_strat_bound = max(cv_keep(78),1) cv_maxdepth = slavef else cv_maxdepth = 0 cv_mixed_strat_bound=0 endif cv_bitsize_of_int = bit_size(n) if(cv_bitsize_of_int.le.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Problem with bit size in ',subname return endif rest = mod(cv_slavef,cv_bitsize_of_int) if (rest.eq.0) then cv_size_ind_proc = cv_slavef / cv_bitsize_of_int else cv_size_ind_proc = cv_slavef / cv_bitsize_of_int + 1 endif allocate(cv_ncostw(n),cv_tcostw(n),cv_ncostm(n),cv_tcostm(n), & cv_nodelayer(n),cv_nodetype(n),cv_depth(n), & cv_layerworkload(slavef),cv_layermemused(slavef), & cv_prop_map(n),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 8*n+2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if if(cv_keep(82) .eq. 0) then if(cv_lp.gt.0) & write(cv_lp,*)' No splitting during static mapping ' endif cv_frere=>frere cv_fils=>fils cv_nfsiz=>nfsiz cv_ne=>ne cv_icntl=>icntl cv_info=>info cv_procnode=>procnode cv_ssarbr=>ssarbr cv_ssarbr=0 cv_nodetype=cv_invalid cv_nsteps=keep(28) if((keep(28).gt.n).OR.(keep(28).lt.0)) then if(cv_lp.gt.0) & write(cv_lp,*)'problem with nsteps in ',subname return end if cv_costw_upper=0.0D0 cv_costm_upper=0.0D0 cv_costw_layer0=0.0D0 cv_costm_layer0=0.0D0 cv_costw_total=0.0D0 cv_costm_total=0.0D0 cv_nodelayer=n+2 cv_depth=cv_invalid cv_l0wthresh=0.0D0 cv_splitthresh=0.45D0 cv_relax=dble(1) + dble(max(0,keep(68)))/dble(100) cv_maxlayer=0 cv_maxnsteps= cv_nsteps+1 cv_layerworkload=dble(0) cv_layermemused=dble(0) cv_total_amalg=0 cv_total_split=0 cv_last_splitting%new_ison=cv_invalid cv_last_splitting%new_ifather=cv_invalid cv_last_splitting%old_keep2=cv_invalid cv_last_splitting%ncostw_oldinode=cv_d_invalid cv_last_splitting%ncostm_oldinode=cv_d_invalid cv_last_splitting%tcostw_oldinode=cv_d_invalid cv_last_splitting%tcostm_oldinode=cv_d_invalid do i=1,cv_n nullify(cv_prop_map(i)%ind_proc) end do istat=0 return end subroutine MUMPS_INITPART1 subroutine MUMPS_INITPART2(istat) implicit none integer,intent(out)::istat integer i,allocok,inode,in,inoderoot,ierr,maxcut character (len=48):: subname istat=-1 subname='INITPART2' if(associated(cv_layerl0_array))deallocate(cv_layerl0_array) if(associated(cv_layerl0_sorted_costw)) & deallocate(cv_layerl0_sorted_costw) deallocate(cv_depth,cv_tcostw,cv_tcostm,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if if(cv_maxnsteps.lt.1) then if(cv_lp.gt.0) & write(cv_lp,*)'problem with maxnsteps in ',subname return end if cv_maxnodenmb=cv_maxnsteps do i=1,cv_nbsa inode=cv_ssarbr(i) inoderoot=inode 300 continue in = inode do while (in.ne.0) inode = in do while (in.gt.0) in = cv_fils(in) end do if (in.lt.0) in=-in end do 100 continue if (inode.ne.inoderoot) then cv_maxnodenmb=cv_maxnodenmb-1 in = cv_frere(inode) inode = abs(in) if (in.lt.0) then go to 100 else go to 300 end if end if end do if(cv_keep(82) .gt. 0) then maxcut = min((cv_keep(82)-1)*cv_maxnodenmb,cv_n) cv_maxnsteps = min(cv_maxnsteps+maxcut,cv_n) cv_maxnodenmb = min(cv_maxnodenmb+maxcut,cv_n) endif nullify(cv_layer_p2node) if(cv_maxnodenmb.lt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'problem with maxnodenmb in ',subname return elseif(cv_maxnodenmb.lt.1) then cv_maxnodenmb = 1 end if allocate(cv_layer_p2node(cv_maxnodenmb),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_maxnodenmb istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if do i=1,cv_maxnodenmb nullify(cv_layer_p2node(i)%t2_nodenumbers, & cv_layer_p2node(i)%t2_cand, & cv_layer_p2node(i)%t2_candcostw, & cv_layer_p2node(i)%t2_candcostm) cv_layer_p2node(i)%nmb_t2s=0 enddo istat = 0 end subroutine MUMPS_INITPART2 function MUMPS_ISTYPE2BYSIZE(nfront,npiv) implicit none logical::MUMPS_ISTYPE2BYSIZE integer,intent(in)::nfront,npiv MUMPS_ISTYPE2BYSIZE=.FALSE. if( (nfront - npiv > cv_keep(9)) & .and. ((npiv > cv_keep(4)).or.(.TRUE.)) & .and. (cv_icntl(59).eq.0) ) MUMPS_ISTYPE2BYSIZE=.TRUE. return end function MUMPS_ISTYPE2BYSIZE subroutine MUMPS_LAYERL0(istat) implicit none integer,intent(out)::istat integer i,ierr,inode logical accepted integer,parameter::map_strat=cv_equilib_flops character (len=48):: err_rep,subname logical use_geist_ng_replace, skiparrangeL0 INTEGER MINSIZE_L0 INTEGER CURRENT_SIZE_L0 istat=-1 subname='LAYERL0' accepted=.FALSE. IF (cv_keep(72).EQ.2) THEN MINSIZE_L0 = 6*cv_slavef ELSE IF (cv_keep(66).NE.0) THEN IF (cv_keep(66).EQ.1) THEN MINSIZE_L0 = 3*cv_slavef ELSE MINSIZE_L0 = 2*cv_slavef ENDIF ELSE MINSIZE_L0 = 3*cv_slavef ENDIF ENDIF 55 continue skiparrangeL0 = .false. do while(.not.accepted) IF (cv_keep(66).EQ.2) THEN CURRENT_SIZE_L0 = layerL0_endforarrangeL0 ELSE CURRENT_SIZE_L0 = layerL0_endforarrangeL0 ENDIF IF ( ( (CURRENT_SIZE_L0.LT.MINSIZE_L0) & .OR. skiparrangeL0 & ) & .AND. & (cv_layerl0_end.LT.cv_maxnsteps/2) ) THEN accepted = .false. ELSE err_rep='ARRANGEL0' call MUMPS_ARRANGEL0(map_strat, layerL0_endforarrangeL0, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if err_rep='ACCEPT_L0' call MUMPS_ACCEPT_L0(map_strat, & cv_layerworkload,cv_layermemused, & accepted,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if ENDIF IF (cv_keep(66).EQ.0) THEN IF (cv_slavef.GT.16) & skiparrangeL0 = .NOT.skiparrangeL0 ENDIF if (accepted.OR.(cv_costw_total.le.0.0D0)) then exit elseif(((cv_costw_layer0/cv_costw_total).gt.cv_l0wthresh) .AND. & (.TRUE.))then err_rep='MAX_TCOST_L0' inode = cv_layerl0_array(cv_layerl0_start) use_geist_ng_replace = .TRUE. if(use_geist_ng_replace) then err_rep='FATHSON_REPLACE' call MUMPS_FATHSON_REPLACE(inode,ierr) if(ierr.eq.1) then accepted=.TRUE. elseif(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error rep. by ',err_rep,' in ',subname istat = ierr return endif endif else accepted=.TRUE. end if end do accepted=.TRUE. if (accepted) then else goto 55 endif err_rep='LIST2LAYER' call MUMPS_LIST2LAYER(ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if err_rep='MAKE_PROPMAP' call MUMPS_MAKE_PROPMAP(ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if if ( cv_keep(75).EQ.1 ) then call MUMPS_ARRANGEL0(map_strat, cv_layerl0_end, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr, respect_prop=.TRUE.) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error reported by ',err_rep,' in ',subname istat = ierr return end if else if (layerL0_endforarrangeL0.LT.cv_layerl0_end) THEN call MUMPS_ARRANGEL0(map_strat, cv_layerl0_end, & cv_layerworkload,cv_layermemused, & cv_procnode,ierr) endif call MUMPS_MAPSUBTREE(cv_procnode) do i=1,cv_slavef cv_proc_workload(i)=cv_layerworkload(i) cv_proc_memused(i)=cv_layermemused(i) end do istat=0 return end subroutine MUMPS_LAYERL0 subroutine MUMPS_LIST2LAYER(istat) implicit none integer, intent(out)::istat character (len=48):: subname integer i,inode istat=-1 subname='LIST2LAYER' cv_dist_L0_mixed_strat_bound=0 cv_nbsa=0 do i=cv_layerl0_start,cv_layerl0_end inode=cv_layerl0_array(i) if(inode.gt.0) then cv_dist_L0_mixed_strat_bound=max(cv_dist_L0_mixed_strat_bound & ,max(cv_depth(inode)-cv_mixed_strat_bound,0)) cv_nodelayer(inode)=0 cv_nbsa=cv_nbsa+1 cv_ssarbr(cv_nbsa)=inode endif enddo istat=0 return end subroutine MUMPS_LIST2LAYER subroutine MUMPS_MAKE_PROPMAP(istat) implicit none integer,intent(out)::istat integer i,pctr,pctr2,ierr character (len=48):: subname INTEGER, ALLOCATABLE, DIMENSION(:) :: procindex INTEGER :: allocok subname = "MUMPS_MAKE_PROPMAP" istat = -1 ALLOCATE(procindex(cv_size_ind_proc),stat=allocok) IF (allocok > 0) THEN cv_info(1) = cv_error_memalloc cv_info(2) = cv_maxnodenmb istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) 'Memory allocation error in ',subname return ENDIF pctr=cv_n pctr2=cv_mixed_strat_bound do i=1,cv_slavef call MUMPS_BIT_SET(procindex,i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'MUMPS_BIT_SET signalled error to',subname istat = ierr GOTO 999 end if end do do i=1,cv_n if(cv_frere(i).eq.0) then if(.NOT.associated(cv_prop_map(i)%ind_proc)) then call MUMPS_PROPMAP_INIT(i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr GOTO 999 end if endif cv_prop_map(i)%ind_proc = procindex call MUMPS_PROPMAP(i,pctr,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'PROPMAP signalled error to',subname istat = ierr GOTO 999 endif if((cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then call MUMPS_MOD_PROPMAP(i,pctr2,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'MOD_PROPMAP signalled error to',subname istat = ierr GOTO 999 endif endif endif end do istat = 0 999 CONTINUE DEALLOCATE(procindex) return end subroutine MUMPS_MAKE_PROPMAP subroutine MUMPS_MAP_LAYER(layernmb,thislayer, & nmb_thislayer,map_strat,istat) implicit none integer, intent(in)::layernmb,thislayer(:), & nmb_thislayer,map_strat integer,intent(out)::istat integer i,inode,j,k,ierr,nmb,aux_int,nmb_cand_needed DOUBLE PRECISION aux_flop,aux_mem INTEGER, ALLOCATABLE, DIMENSION(:) :: candid, sorted_nmb DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: & sorted_costw, sorted_costm, old_workload, old_memused character (len=48):: err_rep,subname logical use_propmap istat=-1 subname='MAP_LAYER' if((cv_keep(24).eq.8).OR.(cv_keep(24).eq.10) & .OR.(cv_keep(24).eq.12).OR.(cv_keep(24).eq.14) & .OR.(cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then use_propmap=.TRUE. else use_propmap=.FALSE. endif if((layernmb.lt.0).or.(layernmb.gt.cv_maxlayer)) return if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) return ALLOCATE(candid(cv_slavef), sorted_nmb(2*nmb_thislayer), & sorted_costw(2*nmb_thislayer), sorted_costm(2*nmb_thislayer), & old_workload(cv_slavef), old_memused(cv_slavef), stat=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 7*nmb_thislayer+2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname goto 999 end if do i=1,nmb_thislayer inode=thislayer(i) if (cv_nodetype(inode).eq.3) then cv_procnode(inode)=1 exit end if end do do i=1,cv_slavef old_workload(i)=cv_layerworkload(i) old_memused(i)=cv_layermemused(i) enddo nmb=0 do i=1,nmb_thislayer inode=thislayer(i) if(cv_nodetype(inode).eq.1) then nmb=nmb+1 sorted_nmb(nmb)=inode sorted_costw(nmb)=cv_ncostw(inode) sorted_costm(nmb)=cv_ncostm(inode) else if(MUMPS_IS_NODE_OF_TYPE2(inode)) then nmb=nmb+1 do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j).ne.inode) & then cycle else sorted_costw(nmb)= & cv_layer_p2node(layernmb)%t2_candcostw(j) sorted_costm(nmb)= & cv_layer_p2node(layernmb)%t2_candcostm(j) endif enddo if((sorted_costw(nmb).eq.cv_d_invalid).OR. & (sorted_costm(nmb).eq.cv_d_invalid)) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 end if if(sorted_costw(nmb).lt.cv_ncostw(inode))then sorted_costw(nmb)=cv_ncostw(inode) sorted_costm(nmb)=cv_ncostm(inode) sorted_nmb(nmb)=inode else sorted_nmb(nmb)=-inode endif else if(cv_nodetype(inode).eq.3) then cycle else if(cv_lp.gt.0) & write(cv_lp,*)'Unknown node type. Error in ',subname goto 999 end if end do if (map_strat.eq.cv_equilib_flops) then call MUMPS_SORT_MSORT(ierr,nmb,sorted_nmb(1:nmb), & sorted_costw(1:nmb),sorted_costm(1:nmb)) elseif(map_strat.eq.cv_equilib_mem) then call MUMPS_SORT_MSORT(ierr,nmb,sorted_nmb(1:nmb), & sorted_costm(1:nmb),sorted_costw(1:nmb)) endif if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MSORT in ',subname istat = ierr goto 999 endif do i=1,nmb aux_int=sorted_nmb(i) aux_flop=sorted_costw(i) aux_mem=sorted_costm(i) k=1 if (aux_int.lt.0) then inode=-aux_int err_rep='SORTPROCS' if(use_propmap) then call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & inode=inode,istat=ierr) else call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & istat=ierr) end if if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by ',err_rep,' in ',subname istat = ierr goto 999 endif nmb_cand_needed=cv_invalid do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j).ne.inode) & then cycle else nmb_cand_needed= & cv_layer_p2node(layernmb)%t2_cand(j,cv_slavef+1) exit endif enddo if(nmb_cand_needed.eq.cv_invalid) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif do while((k.le.cv_slavef).and.(nmb_cand_needed.gt.0)) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)) & =inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem nmb_cand_needed=nmb_cand_needed-1 k=k+1 else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do if(nmb_cand_needed.gt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif aux_flop=cv_ncostw(inode) aux_mem=cv_ncostm(inode) do while(k.le.cv_slavef) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_procnode(inode)=cv_proc_sorted(k) cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)) & =-inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem exit else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do else inode=aux_int err_rep='SORTPROCS' if(use_propmap) then call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & inode=inode,istat=ierr) else call MUMPS_SORTPROCS(map_strat, & cv_proc_workload,cv_proc_memused, & inode,istat=ierr) endif if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by ',err_rep,' in ',subname istat = ierr goto 999 endif if (cv_nodetype(inode).eq.1) then do while(k.le.cv_slavef) if((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k))))) then cv_procnode(inode)=cv_proc_sorted(k) cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem exit else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Inconsist data in ',subname goto 999 endif end if end do elseif (MUMPS_IS_NODE_OF_TYPE2(inode)) then do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j).ne. & inode) then cycle else exit endif enddo do while(k.le.cv_slavef) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_procnode(inode)=cv_proc_sorted(k) cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)%t2_cand(j,cv_proc_sorted(k)) & =-inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem exit else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do nmb_cand_needed=cv_invalid do j=1,cv_layer_p2node(layernmb)%nmb_t2s if(cv_layer_p2node(layernmb)%t2_nodenumbers(j) & .ne.inode) & then cycle else nmb_cand_needed= & cv_layer_p2node(layernmb)% & t2_cand(j,cv_slavef+1) exit endif enddo if(nmb_cand_needed.eq.cv_invalid) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif aux_flop= & cv_layer_p2node(layernmb)%t2_candcostw(j) aux_mem= & cv_layer_p2node(layernmb)%t2_candcostm(j) do while((k.le.cv_slavef).and.(nmb_cand_needed.gt.0)) if(((.not.cv_constr_work).or. & (cv_proc_workload(cv_proc_sorted(k))+aux_flop.lt. & cv_proc_maxwork(cv_proc_sorted(k)))) & .AND.((.not.cv_constr_mem).or. & (cv_proc_memused(cv_proc_sorted(k))+aux_mem.lt. & cv_proc_maxmem(cv_proc_sorted(k)))) & .AND. & (cv_layer_p2node(layernmb)% & t2_cand(j,cv_proc_sorted(k)).eq.0)) & then cv_proc_workload(cv_proc_sorted(k))= & cv_proc_workload(cv_proc_sorted(k))+aux_flop cv_proc_memused(cv_proc_sorted(k))= & cv_proc_memused(cv_proc_sorted(k))+aux_mem cv_layer_p2node(layernmb)% & t2_cand(j,cv_proc_sorted(k)) & =inode cv_layerworkload(cv_proc_sorted(k))= & cv_layerworkload(cv_proc_sorted(k))+aux_flop cv_layermemused(cv_proc_sorted(k))= & cv_layermemused(cv_proc_sorted(k))+aux_mem nmb_cand_needed=nmb_cand_needed-1 k=k+1 else k=k+1 if(k.gt.cv_slavef) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end do if(nmb_cand_needed.gt.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif end if end if end do do i=1,cv_layer_p2node(layernmb)%nmb_t2s nmb_cand_needed= & cv_layer_p2node(layernmb)%t2_cand(i,cv_slavef+1) candid= cv_layer_p2node(layernmb)%t2_cand(i,1:cv_slavef) cv_layer_p2node(layernmb)%t2_cand(i,1:cv_slavef)=-1 k=0 do j=1,cv_slavef if(candid(j).gt.0) then k=k+1 cv_layer_p2node(layernmb)%t2_cand(i,k)=j-1 end if end do if (k.ne.nmb_cand_needed) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname goto 999 endif enddo do i=1,cv_slavef cv_layerworkload(i)=cv_layerworkload(i)-old_workload(i) cv_layermemused(i)=cv_layermemused(i)-old_memused(i) enddo istat=0 999 continue DEALLOCATE(candid, sorted_nmb, sorted_costw, sorted_costm, & old_workload, old_memused) return end subroutine MUMPS_MAP_LAYER recursive subroutine MUMPS_MAPBELOW(inode,procnmb, & procnode) integer,intent(in)::inode,procnmb integer,intent(inout)::procnode(:) integer in procnode(inode)=procnmb if (cv_fils(inode).eq.0) return in=cv_fils(inode) do while(in>0) procnode(in)=procnmb in=cv_fils(in) end do in=-in do while(in>0) call MUMPS_MAPBELOW(in,procnmb,procnode) in=cv_frere(in) end do return end subroutine MUMPS_MAPBELOW subroutine MUMPS_MAPSUBTREE(procnode) implicit none integer,intent(inout)::procnode(:) integer i,inode,procnmb do i=cv_layerl0_start,cv_layerl0_end inode=cv_layerl0_array(i) if(inode.gt.0) then procnmb=procnode(inode) call MUMPS_MAPBELOW(inode,procnmb,procnode) endif enddo return end subroutine MUMPS_MAPSUBTREE subroutine MUMPS_POSTPROCESS_MEM() implicit none integer candid,inode,index,i,j,layernmb,master,nmbcand,swapper, & totalnmb,node_of_master,node_of_candid,node_of_swapper DOUBLE PRECISION::mastermem,slavemem,maxmem logical swapthem,cand_better_master_arch,cand_better_swapper_arch intrinsic maxval,minval maxmem=maxval(cv_proc_memused(:)) totalnmb=0 do layernmb=cv_maxlayer,1,-1 do i=1,cv_layer_p2node(layernmb)%nmb_t2s inode=cv_layer_p2node(layernmb)%t2_nodenumbers(i) master=cv_procnode(inode) if(ke69 .gt. 1) then allowed_nodes = .FALSE. call MUMPS_FIX_ACCEPTED_MASTER(layernmb,i) node_of_master = mem_distribmpi(master-1) if (node_of_master .lt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*)'node_of_master_not found' endif node_of_swapper = node_of_master endif mastermem=cv_proc_memused(master) nmbcand=cv_layer_p2node(layernmb)%t2_cand(i,cv_slavef+1) swapper=master index=0 do j=1,nmbcand candid=cv_layer_p2node(layernmb)%t2_cand(i,j)+1 slavemem=cv_proc_memused(candid) if(ke69 .gt. 1) then node_of_candid = mem_distribmpi(candid-1) if (node_of_candid .lt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'node_of_candid_not found' endif endif if(ke69 .le. 1) then if((slavemem.lt.mastermem) .and. & (slavemem.lt.cv_proc_memused(swapper))) then swapper=candid index=j endif else cand_better_master_arch = ( & ( & (slavemem.lt.mastermem) .or. & (.not. allowed_nodes(node_of_master)) & ) & .and. allowed_nodes(node_of_candid) & ) cand_better_swapper_arch = ( & ( & (slavemem.lt.cv_proc_memused(swapper)) .or. & (.not. allowed_nodes(node_of_swapper)) & ) & .and. allowed_nodes(node_of_candid) & ) if(cand_better_master_arch .and. & cand_better_swapper_arch ) then swapper=candid node_of_swapper = node_of_candid index=j endif endif enddo if(swapper.ne.master) then swapthem = .FALSE. if(0.75D0*mastermem.ge.cv_proc_memused(swapper)) & swapthem=.TRUE. if(mastermem.le.mastermem-cv_ncostm(inode) & +cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(mastermem.le.cv_proc_memused(swapper) & +cv_ncostm(inode) & -cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(maxmem.le.mastermem-cv_ncostm(inode) & +cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(maxmem.le.cv_proc_memused(swapper)+cv_ncostm(inode) & -cv_layer_p2node(layernmb)%t2_candcostm(i)) & swapthem=.FALSE. if(ke69 .gt. 1) then if (.not. allowed_nodes(node_of_master)) then swapthem=.TRUE. endif endif if(.NOT.swapthem) cycle cv_proc_workload(master)=cv_proc_workload(master) & -cv_ncostw(inode) & +cv_layer_p2node(layernmb)%t2_candcostw(i) cv_proc_memused(master)=cv_proc_memused(master) & -cv_ncostm(inode) & +cv_layer_p2node(layernmb)%t2_candcostm(i) cv_proc_workload(swapper)=cv_proc_workload(swapper) & +cv_ncostw(inode) & -cv_layer_p2node(layernmb)%t2_candcostw(i) cv_proc_memused(swapper)=cv_proc_memused(swapper) & +cv_ncostm(inode) & -cv_layer_p2node(layernmb)%t2_candcostm(i) cv_layer_p2node(layernmb)%t2_cand(i,index)=master-1 cv_procnode(inode)=swapper maxmem=maxval(cv_proc_memused(:)) totalnmb = totalnmb+1 endif enddo enddo end subroutine MUMPS_POSTPROCESS_MEM subroutine MUMPS_PROCINIT(maxwork,maxmem,istat) implicit none DOUBLE PRECISION,intent(in),OPTIONAL::maxwork(cv_slavef), & maxmem(cv_slavef) integer,intent(out)::istat integer i,allocok intrinsic huge DOUBLE PRECISION dummy character (len=48):: subname istat=-1 subname='PROCINIT' if(present(maxwork)) then cv_constr_work=.TRUE. else cv_constr_work=.FALSE. end if if(present(maxmem)) then cv_constr_mem=.TRUE. else cv_constr_mem=.FALSE. end if allocate(cv_proc_workload(cv_slavef), & cv_proc_maxwork(cv_slavef), & cv_proc_memused(cv_slavef), & cv_proc_maxmem(cv_slavef), & cv_proc_sorted(cv_slavef), & STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if allocate(work_per_proc(cv_slavef),id_son(cv_slavef),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 2*cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if do i=1,cv_slavef cv_proc_workload(i)=dble(0) if(cv_constr_work) then cv_proc_maxwork(i)=maxwork(i) else cv_proc_maxwork(i)=(huge(dummy)) endif cv_proc_memused(i)=dble(0) if(cv_constr_mem) then cv_proc_maxmem(i)=maxmem(i) else cv_proc_maxmem(i)=(huge(dummy)) endif end do do i=1, cv_slavef cv_proc_sorted(i)=i enddo istat=0 return end subroutine MUMPS_PROCINIT recursive subroutine MUMPS_MOD_PROPMAP & (inode,ctr,istat) implicit none integer, intent(in)::inode,ctr integer, intent(inout)::istat integer::j,k,in,in1,ierr,son,nmb_procs_inode,nmb_sons_inode, & current,i INTEGER, ALLOCATABLE, DIMENSION(:) :: procs4son INTEGER :: allocok character (len=48):: subname DOUBLE PRECISION :: relative_weight,costs_sons DOUBLE PRECISION :: loc_relax INTEGER :: depth logical force_cand DOUBLE PRECISION Y intrinsic random_number integer nmb_propmap_strict,share2,procsrest,current2 integer k69onid INTEGER, ALLOCATABLE, DIMENSION(:) :: procs_inode LOGICAL UPDATE_CTR if (ctr.le.0) then istat = 0 return endif istat= -1 if(cv_frere(inode).eq.cv_n+1) return subname='MOD_PROPMAP' if(.NOT.associated(cv_prop_map(inode)%ind_proc)) return ALLOCATE(procs_inode(cv_slavef), & procs4son(cv_size_ind_proc),stat=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_size_ind_proc + cv_slavef istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if procs_inode=-1 nmb_procs_inode = 0 do j=1,cv_slavef if( MUMPS_BIT_GET4PROC(inode,j))then nmb_procs_inode = nmb_procs_inode + 1 endif end do i=0 do j=1,cv_slavef if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1, & k69onid,ierr) else k69onid = j endif if(MUMPS_BIT_GET4PROC(inode,k69onid))then i = i + 1 procs_inode(i)=k69onid endif end do if(i.ne.nmb_procs_inode)then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname goto 999 endif if(nmb_procs_inode.eq.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname goto 999 end if if ((cv_nodelayer(inode).eq.0).AND. & (cv_frere(inode).ne.cv_n+1)) then istat = 0 goto 999 endif nmb_sons_inode = 0 costs_sons = dble(0) force_cand=(mod(cv_keep(24),2).eq.0) in = inode do while (cv_fils(in).gt.0) in=cv_fils(in) end do if (cv_fils(in).eq.0) then istat = 0 goto 999 endif in = -cv_fils(in) son=in do while(in.gt.0) nmb_sons_inode = nmb_sons_inode + 1 if(cv_tcostw(in).le.0.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Subtree costs for ',in, & ' should be positive in ',subname goto 999 endif costs_sons = costs_sons + cv_tcostw(in) in=cv_frere(in) enddo if(costs_sons.le.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname goto 999 endif depth= max(cv_mixed_strat_bound - ctr,0) if ((cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then if(depth.ge.cv_mixed_strat_bound) then loc_relax = dble(1) else loc_relax = dble(1) + & max(dble(cv_keep(77))/dble(100), dble(0)) endif else loc_relax = dble(1) endif in=son current = 1 do while(in.gt.0) UPDATE_CTR = .TRUE. if( ( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) & .OR. ( nmb_sons_inode.EQ.1 ) & ) then procs4son = cv_prop_map(inode)%ind_proc IF (nmb_sons_inode.EQ.1) UPDATE_CTR=.FALSE. else do k=1,cv_size_ind_proc do j=0,cv_bitsize_of_int-1 procs4son(k)=ibclr(procs4son(k),j) end do end do nmb_propmap_strict=0 do k=1,cv_slavef if( MUMPS_BIT_GET4PROC(in,k)) then nmb_propmap_strict=nmb_propmap_strict+1 call MUMPS_BIT_SET(procs4son,k,ierr) end if end do if(costs_sons.gt.0.0D0) then relative_weight=cv_tcostw(in)/costs_sons else relative_weight=0.0D0 endif current = nmb_propmap_strict share2= & max(0,nint(relative_weight*(loc_relax-dble(1))* & dble(nmb_procs_inode))) procsrest=nmb_procs_inode - nmb_propmap_strict share2=min(share2,procsrest) CALL random_number(Y) current2=int(dble(Y)*dble(procsrest)) k=1 i=1 do while((share2.gt.0).and.(i.le.2)) do j=1,nmb_procs_inode if(share2.le.0) exit k69onid = procs_inode(j) if(( MUMPS_BIT_GET4PROC(inode,k69onid)).AND. & (.NOT.MUMPS_BIT_GET(procs4son,k69onid))) then if(k.ge.current2)then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share2 = share2 - 1 endif k=k+1 end if enddo i=i+1 enddo if(share2.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if end if ierr=0 in1=in cv_prop_map(in1)%ind_proc=procs4son IF (UPDATE_CTR) THEN call MUMPS_MOD_PROPMAP(in1,ctr-1,ierr) ELSE call MUMPS_MOD_PROPMAP(in1,ctr,ierr) ENDIF if(ierr.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname istat=ierr goto 999 endif in=cv_frere(in) end do istat = 0 999 continue DEALLOCATE(procs_inode,procs4son) return end subroutine MUMPS_MOD_PROPMAP recursive subroutine MUMPS_PROPMAP(inode,ctr,istat) implicit none integer, intent(in)::inode,ctr integer, intent(inout)::istat integer::j,k,in,in1,ierr,son,nmb_procs_inode,nmb_sons_inode, & share,current,offset, & in_tmp,nfront,npiv,ncb, & keep48_loc,min_cand_needed integer, dimension(:), allocatable :: procs4son character (len=48):: subname DOUBLE PRECISION :: relative_weight,costs_sons, shtemp DOUBLE PRECISION :: costs_sons_real DOUBLE PRECISION :: PartofaProc LOGICAL :: SkipSmallNodes PARAMETER (PartofaProc=0.01D0) DOUBLE PRECISION :: loc_relax INTEGER :: depth logical force_cand integer MUMPS_REG_GETKMAX, MUMPS_BLOC2_GET_NSLAVESMIN external MUMPS_REG_GETKMAX, MUMPS_BLOC2_GET_NSLAVESMIN DOUBLE PRECISION Y intrinsic random_number integer nmb_propmap_strict,share2,procsrest,current2 integer k69onid,nb_free_procs,local_son_indice,nb_procs_for_sons, & ptr_upper_ro_procs INTEGER :: allocok logical upper_round_off,are_sons_treated DOUBLE PRECISION tmp_cost if (ctr.le.0) then istat = 0 return endif istat= -1 if(cv_frere(inode).eq.cv_n+1) return subname='PROPMAP' nmb_procs_inode = 0 do j=1,cv_slavef if( MUMPS_BIT_GET4PROC(inode,j)) & nmb_procs_inode = nmb_procs_inode + 1 end do if(nmb_procs_inode.eq.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname return end if if ((cv_nodelayer(inode).eq.0).AND. & (cv_frere(inode).ne.cv_n+1)) then istat = 0 return endif ptr_upper_ro_procs=1 work_per_proc(1:cv_slavef)=0.0D0 id_son(1:cv_slavef)=0 nmb_sons_inode = 0 costs_sons = dble(0) force_cand=(mod(cv_keep(24),2).eq.0) min_cand_needed=0 in = inode do while (cv_fils(in).gt.0) in=cv_fils(in) end do if (cv_fils(in).eq.0) then istat = 0 return endif in = -cv_fils(in) son=in do while(in.gt.0) nmb_sons_inode = nmb_sons_inode + 1 if(cv_tcostw(in).le.0.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Subtree costs for ',in, & ' should be positive in ',subname return endif costs_sons = costs_sons + cv_tcostw(in) in=cv_frere(in) enddo costs_sons_real = costs_sons SkipSmallNodes = .true. IF (costs_sons_real.gt.0.0D0) then in = son do while (in.gt.0) relative_weight=cv_tcostw(in)/costs_sons_real shtemp = relative_weight*dble(nmb_procs_inode) IF (shtemp.lt.PartofaProc) THEN costs_sons = costs_sons - cv_tcostw(in) ENDIF in=cv_frere(in) enddo IF (costs_sons.LT. PartofaProc*costs_sons_real) THEN costs_sons = costs_sons_real SkipSmallNodes = .false. ENDIF ENDIF if(costs_sons.le.0.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname & ,subname return endif if(cv_relax.le.0.0D0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname,'. Wrong cv_relax' return endif ALLOCATE(procs4son(cv_size_ind_proc),stat=allocok) IF (allocok .GT. 0) THEN cv_info(1) = cv_error_memalloc cv_info(2) = cv_size_ind_proc istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'Memory allocation error in ',subname return ENDIF depth= max(cv_n - ctr,0) if(cv_keep(24).eq.8) then loc_relax = cv_relax elseif ((cv_keep(24).eq.16).OR.(cv_keep(24).eq.18)) then loc_relax = cv_relax elseif (cv_keep(24).eq.10) then loc_relax = cv_relax elseif ((cv_keep(24).eq.12).OR.(cv_keep(24).eq.14)) then if(depth.ge.cv_mixed_strat_bound) then loc_relax = cv_relax else loc_relax = cv_relax + & max(dble(cv_keep(77))/dble(100), dble(0)) endif endif in=son current = 1 local_son_indice=1 nb_procs_for_sons=0 upper_round_off=.FALSE. are_sons_treated=.TRUE. do while(in.gt.0) if( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) then procs4son = cv_prop_map(inode)%ind_proc are_sons_treated=.FALSE. nb_procs_for_sons=nmb_procs_inode nmb_propmap_strict=nmb_procs_inode elseif(nmb_procs_inode .LE. cv_keep(83)) then procs4son = cv_prop_map(inode)%ind_proc are_sons_treated=.FALSE. nb_procs_for_sons=nmb_procs_inode nmb_propmap_strict=nmb_procs_inode else do k=1,cv_size_ind_proc do j=0,cv_bitsize_of_int-1 procs4son(k)=ibclr(procs4son(k),j) end do end do if(costs_sons.gt.0.0D0) then relative_weight=cv_tcostw(in)/costs_sons else relative_weight=dble(0) endif shtemp = relative_weight*dble(nmb_procs_inode) IF ( (shtemp.LT.PartofaProc) & .AND. ( SkipSmallNodes ) ) THEN share = 1 do j=current,cv_slavef if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share -1 exit endif enddo if (share.gt.0) then do j=1,current-1 if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share -1 exit endif enddo endif if(share.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if if(.NOT.associated(cv_prop_map(in)%ind_proc)) then call MUMPS_PROPMAP_INIT(in,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr goto 999 end if endif current = j cv_prop_map(in)%ind_proc = procs4son in = cv_frere(in) cycle ENDIF share = max(1,nint(shtemp)) if (dble(share).ge.shtemp) then upper_round_off=.TRUE. else upper_round_off = .FALSE. endif share=min(share,nmb_procs_inode) nmb_propmap_strict=share nb_procs_for_sons=nb_procs_for_sons+nmb_propmap_strict offset=1 do j=current,cv_slavef if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share-1 if(share.le.0) then current = j + offset if(current.gt.cv_slavef) current = 1 exit end if end if end do if(share.gt.0) then do j=1,current-1 if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if( MUMPS_BIT_GET4PROC(inode,k69onid)) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share = share-1 if(share.le.0) then current = j + offset if(current.gt.cv_slavef) current = 1 exit end if end if end do endif if(share.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if if(.not.upper_round_off)then if(local_son_indice.lt.cv_slavef)then id_son(local_son_indice)=in work_per_proc(local_son_indice)=cv_tcostw(in)/ & dble(nmb_propmap_strict) local_son_indice=local_son_indice+1 if(local_son_indice.eq.cv_slavef)then CALL MUMPS_SORT_MSORT(ierr,cv_slavef,id_son, & work_per_proc) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MSORT in ',subname istat = ierr goto 999 endif endif else current2=cv_slavef tmp_cost=cv_tcostw(in)/dble(nmb_propmap_strict) do while(current2.ge.1) if(tmp_cost.lt.work_per_proc(current2))exit current2=current2-1 enddo if(current2.ne.cv_slavef)then if(current2.eq.0)then current2=1 endif do j=cv_slavef-1,current2,-1 id_son(j+1)=id_son(j) work_per_proc(j+1)=work_per_proc(j) enddo id_son(current2)=in work_per_proc(current2)=tmp_cost endif endif endif upper_round_off=.FALSE. endif if(.NOT.associated(cv_prop_map(in)%ind_proc)) then call MUMPS_PROPMAP_INIT(in,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to' & ,subname istat = ierr goto 999 end if endif cv_prop_map(in)%ind_proc = procs4son in=cv_frere(in) end do if(are_sons_treated)then if(nb_procs_for_sons.ne.nmb_procs_inode)then do j=1,nmb_procs_inode-nb_procs_for_sons procs4son=cv_prop_map(id_son(j))%ind_proc do while(current.le.cv_slavef) if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(current-1,k69onid,ierr) else k69onid = current endif if(.NOT.MUMPS_BIT_GET4PROC(inode,k69onid)) then current=current+1 else exit endif enddo call MUMPS_BIT_SET(procs4son,k69onid,ierr) cv_prop_map(id_son(j))%ind_proc=procs4son enddo ptr_upper_ro_procs=min(j,nmb_procs_inode-nb_procs_for_sons) endif endif in=son current = 1 do while(in.gt.0) if( (nmb_sons_inode.ge.nmb_procs_inode).AND. & (nmb_procs_inode.LT.4) ) then procs4son = cv_prop_map(inode)%ind_proc elseif(nmb_procs_inode .LE. cv_keep(83)) then procs4son = cv_prop_map(inode)%ind_proc else procs4son = cv_prop_map(in)%ind_proc in_tmp=in nfront=cv_nfsiz(in_tmp) npiv=0 in_tmp=in_tmp do while(in_tmp.gt.0) if (cv_BLKON) then npiv = npiv + cv_SIZEOFBLOCKS(in_tmp) else npiv=npiv+1 endif in_tmp=cv_fils(in_tmp) end do ncb=nfront-npiv if (force_cand) then if (cv_keep(50) == 0) then keep48_loc=0 else keep48_loc=3 endif if (cv_keep(48).EQ.5) keep48_loc = 5 min_cand_needed= & MUMPS_BLOC2_GET_NSLAVESMIN & (cv_slavef, keep48_loc,cv_keep8(21), & cv_keep(50), & nfront,ncb, & cv_keep(375), cv_keep(119)) min_cand_needed=min(cv_slavef,min_cand_needed+1) else min_cand_needed = 0 endif min_cand_needed = max(min_cand_needed, cv_keep(91)) if(costs_sons.gt.0.0D0) then relative_weight=cv_tcostw(in)/costs_sons else relative_weight=dble(0) endif nmb_propmap_strict=0 do k=1,cv_slavef if( MUMPS_BIT_GET(procs4son,k)) then nmb_propmap_strict=nmb_propmap_strict+1 end if end do offset=1 share2= & max(0,nint(relative_weight*(loc_relax-dble(1))* & dble(nmb_procs_inode))) share2 = max(share2, min_cand_needed -nmb_propmap_strict, & (cv_keep(83)/2) - nmb_propmap_strict) procsrest=nmb_procs_inode - nmb_propmap_strict share2=min(share2,procsrest) share2 = 0 CALL random_number(Y) current2 =int(dble(Y)*dble(procsrest)) nb_free_procs=1 do j=1,cv_slavef if(share2.le.0) exit if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if(( MUMPS_BIT_GET4PROC(inode,k69onid)).AND. & (.NOT.MUMPS_BIT_GET(procs4son,k69onid))) then if(nb_free_procs.ge.current2)then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share2 = share2 - 1 endif nb_free_procs=nb_free_procs+1 end if end do if(share2.gt.0) then do j=1,cv_slavef if(share2.le.0) exit if(ke69 .gt.1) then call MUMPS_GET_IDP1_PROC(j-1,k69onid,ierr) else k69onid = j endif if(( MUMPS_BIT_GET4PROC(inode,k69onid)).AND. & (.NOT.MUMPS_BIT_GET(procs4son,k69onid))) then call MUMPS_BIT_SET(procs4son,k69onid,ierr) if(ierr.ne.0) then if(cv_lp.gt.0)write(cv_lp,*) & 'BIT_SET signalled error to',subname istat = ierr goto 999 end if share2 = share2 - 1 end if end do endif if(share2.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname goto 999 end if endif ierr=0 in1=in cv_prop_map(in1)%ind_proc = procs4son call MUMPS_PROPMAP(in1,ctr-1,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) write(cv_lp,*) & 'Error reported in ',subname istat=ierr goto 999 endif in=cv_frere(in) end do istat = 0 999 CONTINUE DEALLOCATE(procs4son) return end subroutine MUMPS_PROPMAP subroutine MUMPS_PROPMAP_INIT(inode,istat) implicit none integer, intent(in)::inode integer, intent(out)::istat integer j,k,allocok character (len=48):: subname istat = -1 if(cv_frere(inode).eq.cv_n+1) return subname='PROPMAP_INIT' if(.not.associated( & cv_prop_map(inode)%ind_proc)) then allocate(cv_prop_map(inode)%ind_proc & (cv_size_ind_proc),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_size_ind_proc istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if end if do k=1,cv_size_ind_proc do j=0,cv_bitsize_of_int-1 cv_prop_map(inode)%ind_proc(k)= & ibclr(cv_prop_map(inode)%ind_proc(k),j) end do end do istat = 0 return end subroutine MUMPS_PROPMAP_INIT subroutine MUMPS_PROPMAP_TERM(inode,istat) integer,intent(in)::inode integer,intent(out)::istat integer ierr character (len=48):: subname subname='PROPMAP_TERM' istat =-1 if(associated(cv_prop_map(inode)%ind_proc)) then deallocate(cv_prop_map(inode)%ind_proc, STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ', subname istat = cv_error_memdeloc return endif nullify(cv_prop_map(inode)%ind_proc) end if istat =0 return end subroutine MUMPS_PROPMAP_TERM subroutine MUMPS_PROPMAP4SPLIT(inode,ifather,istat) implicit none integer,intent(in)::inode,ifather integer,intent(out)::istat character (len=48):: subname istat= -1 subname='PROPMAP4SPLIT' if((cv_frere(inode).eq.cv_n+1).OR.(cv_frere(ifather).eq.cv_n+1) & .OR.(.NOT.associated(cv_prop_map(inode)%ind_proc))) then if(cv_lp.gt.0) & write(cv_lp,*)'tototo signalled error to' & ,subname return endif if(.NOT.associated(cv_prop_map(ifather)%ind_proc)) then call MUMPS_PROPMAP_INIT(ifather,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_INIT signalled error to ' & ,subname istat = ierr return end if endif cv_prop_map(ifather)%ind_proc = & cv_prop_map(inode)%ind_proc istat=0 return end subroutine MUMPS_PROPMAP4SPLIT subroutine MUMPS_ROOTLIST(istat) implicit none integer,intent(out)::istat integer i,allocok character (len=48):: subname istat=-1 subname='ROOTLIST' allocate(cv_layerl0_array(cv_maxnsteps), & cv_layerl0_sorted_costw(cv_maxnsteps),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 12*cv_maxnsteps istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if do i=1,cv_maxnsteps cv_layerl0_sorted_costw(i)=dble(0) cv_layerl0_array(i)=0 end do cv_layerl0_start = 0 cv_layerl0_end = 0 layerL0_endforarrangeL0 = 0 if ((.NOT.associated(cv_tcostw)).OR.(.NOT.associated(cv_tcostm))) & then if(cv_lp.gt.0) & write(cv_lp,*)'Error:tcost must be allocated in ',subname return end if cv_nbsa=0 do i=1,cv_n if (cv_frere(i).eq.0) then cv_layerl0_start=1 cv_layerl0_end=cv_layerl0_end+1 IF (cv_tcostw(i).GT.mincostw) & layerL0_endforarrangeL0 = layerL0_endforarrangeL0+1 cv_layerl0_array(cv_layerl0_end)=i cv_layerl0_sorted_costw(cv_layerl0_end)=cv_tcostw(i) cv_costw_layer0=cv_costw_layer0 + cv_tcostw(i) cv_costm_layer0=cv_costm_layer0 + cv_tcostm(i) cv_nbsa=cv_nbsa+1 end if end do if(cv_nbsa.eq.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Error:no root nodes in ',subname return end if call MUMPS_SORT_MSORT(ierr,cv_layerl0_end-cv_layerl0_start+1, & cv_layerl0_array(cv_layerl0_start:cv_layerl0_end), & cv_layerl0_sorted_costw(cv_layerl0_start:cv_layerl0_end)) IF (ierr .ne.0) then if(cv_lp.gt.0) & write(cv_lp,*) & 'Error reported by MUMPS_SORT_MSORT in ',subname istat = ierr return ENDIF cv_costw_total=cv_costw_layer0 cv_costm_total=cv_costm_layer0 istat=0 return end subroutine MUMPS_ROOTLIST subroutine MUMPS_SELECT_TYPE3(istat) implicit none integer,intent(out)::istat character (len=48):: subname subname='SELECT_TYPE3' CALL MUMPS_SELECT_K38K20(cv_n, slavef, cv_mp, cv_icntl(13), & cv_keep(1), cv_frere(1), cv_nfsiz(1), istat) IF (istat .NE. 0) THEN if(cv_lp.gt.0) & write(cv_lp,*) & 'Error: Can''t select type 3 node in ',subname ELSE IF (cv_keep(38) .ne. 0) then IF(cv_nodelayer(cv_keep(38)).eq.0.and. & (cv_keep(60).EQ.0)) then cv_keep(38)=0 ELSE cv_nodetype(cv_keep(38))=3 ENDIF ENDIF RETURN end subroutine MUMPS_SELECT_TYPE3 subroutine MUMPS_SETUP_CAND(istat) integer,intent(out):: istat integer :: i,dummy,layernmb,allocok integer :: montype, nbcand, inode character (len=48) :: subname istat=-1 subname='SETUP_CAND' cv_nb_niv2=0 do i=1,cv_n if(MUMPS_IS_NODE_OF_TYPE2(i)) cv_nb_niv2=cv_nb_niv2+1 end do cv_keep(56)=cv_nb_niv2 nullify(cv_par2_nodes,cv_cand) if(cv_nb_niv2.GT.0) then allocate(cv_par2_nodes(cv_nb_niv2), & cv_cand(cv_nb_niv2,cv_slavef+1),STAT=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = cv_nb_niv2*(cv_slavef+2) istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if cv_par2_nodes=0 cv_cand(:,:)=0 dummy=1 do layernmb=1,cv_maxlayer do i=1,cv_layer_p2node(layernmb)%nmb_t2s inode = cv_layer_p2node(layernmb)%t2_nodenumbers(i) cv_par2_nodes(dummy)= inode nbcand = cv_layer_p2node(layernmb)%t2_cand(i,cv_slavef+1) cv_cand(dummy,:)=cv_layer_p2node(layernmb)%t2_cand(i,:) montype= cv_nodetype(inode) if (montype.eq.tsplit_beg) then CALL MUMPS_SETUP_CAND_CHAIN(cv_n, cv_nb_niv2, & cv_frere(1), cv_nodetype(1), & cv_par2_nodes(1), cv_procnode(1), cv_cand(1,1), & inode, & slavef, dummy, nbcand, istat) endif dummy=dummy+1 enddo enddo if(dummy.ne.cv_nb_niv2+1) then if(cv_lp.gt.0) & write(cv_lp,*)'Error in ',subname, & ' : dummy =',dummy,'nbniv2 =',cv_nb_niv2 return endif endif istat=0 return end subroutine MUMPS_SETUP_CAND subroutine MUMPS_SORTPROCS(map_strat,workload,memused, & inode,istat) implicit none integer,intent(in)::map_strat DOUBLE PRECISION,dimension(:),intent(in)::workload, memused integer, optional::inode,istat integer i,j,aux_int,nmb_procs,pos character (len=48):: subname logical enforce_prefsort logical use_propmap logical,SAVE::init1 = .FALSE. logical,SAVE::init2 = .FALSE. subname='SORTPROCS' enforce_prefsort=.TRUE. use_propmap=present(inode) if(present(istat))istat=-1 if((map_strat.ne.cv_equilib_flops).and. & (map_strat.ne.cv_equilib_mem)) then if(cv_lp.gt.0) & write(cv_lp,*)'error in ',subname return endif i=0 do i = 1, cv_slavef cv_proc_sorted(i)=i enddo if (.not.present(inode)) then if(.NOT.init1) then init1=.TRUE. end if do i=1,cv_slavef-1 do j=i+1,cv_slavef if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do else if(present(inode)) then if (use_propmap) then if(.NOT.init2) then init2=.TRUE. end if nmb_procs=0 do pos=1,cv_slavef if( MUMPS_BIT_GET4PROC(inode,pos)) then if (pos.le.nmb_procs) then exit else nmb_procs=nmb_procs+1 aux_int=cv_proc_sorted(pos) cv_proc_sorted(pos)= & cv_proc_sorted(nmb_procs) cv_proc_sorted(nmb_procs)=aux_int cycle end if end if end do end if do i=1,nmb_procs-1 do j=i+1,nmb_procs if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do do i=nmb_procs+1,cv_slavef-1 do j=i+1,cv_slavef if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do if(.NOT.enforce_prefsort) then if(((2.0D0*workload(cv_proc_sorted(nmb_procs+1)).lt. & workload(cv_proc_sorted(1))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((2.0D0*memused(cv_proc_sorted(nmb_procs+1)).lt. & memused(cv_proc_sorted(1))).AND. & (map_strat.eq.cv_equilib_mem)))then do i=1,cv_slavef-1 do j=i+1,cv_slavef if(((workload(cv_proc_sorted(j)).lt. & workload(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_flops)) & .OR. & ((memused(cv_proc_sorted(j)).lt. & memused(cv_proc_sorted(i))).AND. & (map_strat.eq.cv_equilib_mem)))then aux_int=cv_proc_sorted(j) cv_proc_sorted(j)=cv_proc_sorted(i) cv_proc_sorted(i)=aux_int end if end do end do endif end if endif if(present(istat))istat=0 return end subroutine MUMPS_SORTPROCS subroutine MUMPS_STORE_GLOBALS(ne,nfsiz,frere,fils,keep,KEEP8, & info,procnode,ssarbr,nbsa) implicit none integer,dimension(cv_n),intent(inout)::ne,nfsiz,frere,fils, & procnode,ssarbr integer, intent(inout):: keep(500),info(80),nbsa INTEGER(8) KEEP8(150) ne=cv_ne nfsiz=cv_nfsiz frere=cv_frere fils=cv_fils keep(2) =cv_keep(2) keep(20)=cv_keep(20) keep(28)=cv_nsteps keep(38)=cv_keep(38) keep(56)=cv_keep(56) keep(61)=cv_keep(61) info(5)=cv_info(5) info(6)=cv_nsteps procnode=cv_procnode ssarbr=cv_ssarbr nbsa=cv_nbsa end subroutine MUMPS_STORE_GLOBALS subroutine MUMPS_TERMGLOB(istat) implicit none integer,intent(out)::istat integer i,ierr,layernmb character (len=48):: subname istat=-1 subname='TERMGLOB' nullify(cv_frere,cv_fils,cv_nfsiz,cv_ne,cv_keep,cv_keep8, & cv_icntl,cv_info,cv_procnode,cv_ssarbr) deallocate(cv_proc_workload,cv_proc_maxwork,cv_proc_memused, & cv_proc_maxmem,cv_nodetype, & cv_nodelayer,cv_proc_sorted, & cv_ncostw,cv_ncostm, & cv_layerworkload,cv_layermemused, & STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if deallocate(work_per_proc,id_son,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if do layernmb=1,cv_maxlayer if(cv_layer_p2node(layernmb)%nmb_t2s.gt.0) then deallocate(cv_layer_p2node(layernmb)%t2_nodenumbers, & cv_layer_p2node(layernmb)%t2_cand, & cv_layer_p2node(layernmb)%t2_candcostw, & cv_layer_p2node(layernmb)%t2_candcostm, & STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ', & subname istat = cv_error_memdeloc return end if endif enddo if(associated(cv_layer_p2node)) then deallocate(cv_layer_p2node,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if end if do i=1,cv_n call MUMPS_PROPMAP_TERM(i,ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'PROPMAP_TERM signalled error in ', & subname istat = ierr return end if end do if(associated(cv_prop_map))deallocate(cv_prop_map,STAT=ierr) if(ierr.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if istat=0 return end subroutine MUMPS_TERMGLOB recursive subroutine MUMPS_TREECOSTS(pos) implicit none integer,intent(in)::pos integer i,nfront,npiv,nextpos if ((.NOT.associated(cv_tcostw)).OR.(.NOT.associated(cv_tcostm))) & then call MUMPS_ABORT() end if nfront=cv_nfsiz(pos) npiv=1 nextpos=cv_fils(pos) do while (nextpos.gt.0) if (cv_BLKON) then npiv = npiv + cv_SIZEOFBLOCKS(nextpos) else npiv=npiv+1 endif nextpos=cv_fils(nextpos) end do call MUMPS_CALCNODECOSTS(npiv,nfront, & cv_ncostw(pos), cv_ncostm(pos)) cv_tcostw(pos)=cv_ncostw(pos) cv_tcostm(pos)=cv_ncostm(pos) if (cv_ne(pos).ne.0) then nextpos=cv_fils(pos) do while(nextpos.gt.0) nextpos=cv_fils(nextpos) end do nextpos=-nextpos do i=1,cv_ne(pos) cv_depth(nextpos)=cv_depth(pos)+1 call MUMPS_TREECOSTS(nextpos) cv_tcostw(pos)=cv_tcostw(pos)+cv_tcostw(nextpos) cv_tcostm(pos)=cv_tcostm(pos)+cv_tcostm(nextpos) nextpos=cv_frere(nextpos) end do endif return end subroutine MUMPS_TREECOSTS recursive subroutine MUMPS_TYPEINSSARBR(inode) implicit none integer, intent(in)::inode integer in cv_nodetype(inode)=-1 in=cv_fils(inode) do while (in>0) in=cv_fils(in) end do in=-in do while(in.gt.0) call MUMPS_TYPEINSSARBR(in) in=cv_frere(in) enddo end subroutine MUMPS_TYPEINSSARBR subroutine MUMPS_WORKMEM_IMBALANCE(workload,memused, & maxwork,minwork,maxmem,minmem) implicit none DOUBLE PRECISION,dimension(:),intent(in)::workload, & memused DOUBLE PRECISION,intent(out)::maxwork,minwork,maxmem,minmem intrinsic maxval,minval maxwork=maxval(workload) minwork=minval(workload, mask= workload > dble(0)) maxmem=maxval(memused) minmem=minval(memused, mask= memused > dble(0)) end subroutine MUMPS_WORKMEM_IMBALANCE subroutine MUMPS_FIX_ACCEPTED_MASTER(layernumber,nodenumber) implicit none integer layernumber,nodenumber integer i integer inode integer current_max,current_proc current_max = 0 score = 0 allowed_nodes = .FALSE. inode=cv_layer_p2node(layernumber)%t2_nodenumbers(nodenumber) do i=1,cv_layer_p2node(layernumber)%t2_cand(nodenumber, & cv_slavef+1) current_proc=cv_layer_p2node(layernumber)%t2_cand(nodenumber,i) if ( current_proc .ge. 0) then score(mem_distribmpi(current_proc)) = & score(mem_distribmpi(current_proc)) + 1 endif enddo current_proc = cv_procnode(inode) - 1 score(mem_distribmpi(current_proc)) = & score(mem_distribmpi(current_proc)) + 1 do i=0,nb_arch_nodes - 1 if ( score(i) .gt. current_max ) then current_max = score(i) allowed_nodes = .FALSE. allowed_nodes(i) = .TRUE. else if(score(i) .eq. current_max) then allowed_nodes(i) = .TRUE. endif endif enddo return end subroutine MUMPS_FIX_ACCEPTED_MASTER end subroutine MUMPS_DISTRIBUTE subroutine MUMPS_RETURN_CANDIDATES(par2_nodes,cand, & istat) integer, intent(out) :: par2_nodes(cv_nb_niv2), istat integer, intent(out) :: cand(:,:) character (len=48):: subname integer iloop istat=-1 subname='MUMPS_RETURN_CANDIDATES' par2_nodes=cv_par2_nodes do iloop=1, cv_slavef+1 cand(iloop,:)=cv_cand(:,iloop) enddo deallocate(cv_par2_nodes,cv_cand,STAT=istat) if(istat.ne.0) then if(cv_lp.gt.0) & write(cv_lp,*)'Memory deallocation error in ',subname istat = cv_error_memdeloc return end if istat = 0 return end subroutine MUMPS_RETURN_CANDIDATES subroutine MUMPS_INIT_ARCH_PARAMETERS( & total_comm,working_comm,keep69,par, & nbslaves,mem_distrib,informerr) implicit none include 'mpif.h' integer nbslaves integer, dimension(0:) :: mem_distrib integer total_comm,working_comm,keep69,par integer, dimension(:) ::informerr integer myrank integer host,i,ierr integer,dimension(:),allocatable :: buffer_memdistrib ierr = 0 myrank = -1 host = -1 ke69 = keep69 cv_slavef = nbslaves if (ke69 .eq. 1) then return endif if ( allocated(mem_distribtmp) ) deallocate(mem_distribtmp ) allocate( mem_distribtmp( 0:cv_slavef-1 ), & buffer_memdistrib( 0:cv_slavef-1 ), stat=ierr ) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) 'pb allocation mem_dist' informerr(1) = -13 informerr(2) = cv_slavef return end if mem_distribtmp = -1 call MPI_COMM_RANK( total_comm, host, ierr ) if ((par .eq. 1) .or. (host .ne. 0)) then call MPI_COMM_RANK( working_comm, myrank, ierr ) call MUMPS_COMPUTE_DISTRIB(ierr,myrank, & working_comm,mem_distrib) if ( ierr .ne. 0 ) then if(cv_mp.gt.0) & write(cv_mp,*) 'pb in mumps_init_arch_parameters' informerr(1) = -13 informerr(2) = cv_slavef return end if mem_distribtmp = mem_distrib call MUMPS_FIX_NODE_MASTER(ierr) if ( ierr .ne. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) &'pb in mumps_init_arch_parameters' informerr(1) = -13 informerr(2) = cv_slavef return endif endif if(ke69 .le. 0) then deallocate(mem_distribtmp) deallocate(buffer_memdistrib) return endif call MPI_ALLREDUCE(mem_distribtmp(0),buffer_memdistrib(0), & cv_slavef,MPI_INTEGER, & MPI_MAX,total_comm,ierr) mem_distribtmp = buffer_memdistrib deallocate (buffer_memdistrib) call MUMPS_COMPUTE_NB_ARCH_NODES() if((cv_slavef/nb_arch_nodes) .le. 4) then do i = 0, cv_slavef-1 if ( mem_distrib(i) .NE. 1 ) then mem_distrib(i)=max(ke69/2,2) endif enddo endif if((nb_arch_nodes .eq. 1) .or. & (nb_arch_nodes .eq. cv_slavef)) then ke69 = 1 keep69 = 1 deallocate(mem_distribtmp) return endif if (host .eq. 0) then if ( allocated(mem_distribmpi) ) deallocate(mem_distribmpi ) allocate( mem_distribmpi( 0:cv_slavef-1 ), stat=ierr ) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) 'pb allocation mem_dist' informerr(1) = -13 informerr(2) = cv_slavef return endif call MUMPS_ALLOC_ALLOW_MASTER(ierr) if(ierr .ne. 0 ) then return endif mem_distribmpi = mem_distribtmp call MUMPS_FIX_TABLE_OF_PROCESS(ierr) if ( ierr .ne. 0 ) then if(cv_mp.gt.0) & write(cv_mp,*) 'pb in mumps_init_arch_parameters' informerr(1) = -13 informerr(2) = cv_slavef return endif else deallocate(mem_distribtmp) endif return end subroutine MUMPS_INIT_ARCH_PARAMETERS subroutine MUMPS_COMPUTE_NB_ARCH_NODES() implicit none integer i nb_arch_nodes = 0 do i=0,cv_slavef-1 if(mem_distribtmp(i) .eq. i) then nb_arch_nodes = nb_arch_nodes + 1 endif enddo return end subroutine MUMPS_COMPUTE_NB_ARCH_NODES subroutine MUMPS_FIX_TABLE_OF_PROCESS(ierr) implicit none external MUMPS_SORT_INT integer i,precnode,nodecount integer sizesmp integer ierr ierr = 0 sizesmp = 0 if ( allocated(table_of_process) ) & deallocate(table_of_process ) allocate( table_of_process(0:cv_slavef-1), stat=ierr ) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation in MUMPS_FIX_TABLE_OF_PROCESS' return end if do i=0,cv_slavef - 1 table_of_process(i) = i enddo call MUMPS_SORT_INT(cv_slavef,mem_distribtmp(0), & table_of_process(0)) precnode = 0 nodecount = 0 do i=0,cv_slavef-1 if(mem_distribtmp(i) .eq. precnode) then sizesmp = sizesmp + 1 mem_distribtmp(i) = nodecount mem_distribmpi(table_of_process(i)) = nodecount else score(nodecount) = sizesmp sizesmp = 1 nodecount = nodecount + 1 precnode = mem_distribtmp(i) mem_distribtmp(i) = nodecount mem_distribmpi(table_of_process(i)) = nodecount endif enddo score(nodecount) = sizesmp do i=0,cv_slavef-1 mem_distribtmp(i) = score(mem_distribtmp(i)) enddo CALL MUMPS_SORT_INT_DEC(cv_slavef,mem_distribtmp(0), & table_of_process(0)) ierr = 0 return end subroutine MUMPS_FIX_TABLE_OF_PROCESS subroutine MUMPS_FIX_NODE_MASTER(ierr) implicit none integer i,j,ierr integer idmaster idmaster = -1 ierr = 0 do i=0,cv_slavef-1 if (mem_distribtmp(i) .eq. 1) then idmaster = i do j=i,cv_slavef-1 if (mem_distribtmp(j) .eq. 1) then mem_distribtmp(j) = idmaster else mem_distribtmp(j) = 0 endif enddo return else mem_distribtmp(i) = 0 endif enddo if(cv_mp.gt.0) write(cv_mp,*)'problem in MUMPS_FIX_NODE_MASTER: & cannot find a master' ierr = 1 return end subroutine MUMPS_FIX_NODE_MASTER subroutine MUMPS_COMPUTE_DISTRIB(ierr,myrank,working_comm, & mem_distrib) implicit none include 'mpif.h' integer ierr,resultlen,myrank,i,working_comm integer , dimension(0:) :: mem_distrib integer allocok character(len=MPI_MAX_PROCESSOR_NAME) name integer, dimension(:),allocatable :: namercv integer, dimension(:),allocatable :: myname integer lenrcv external MUMPS_COMPARE_TAB logical MUMPS_COMPARE_TAB ierr = 0 call MPI_GET_PROCESSOR_NAME(name,resultlen,ierr) allocate(myname(resultlen),stat=allocok) if ( allocok .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation in compute_dist for myname' ierr = 1 return end if do i=1, resultlen myname(i) = ichar(name(i:i)) enddo do i=0, cv_slavef-1 if(myrank .eq. i) then lenrcv = resultlen else lenrcv = 0 endif call MPI_BCAST(lenrcv,1,MPI_INTEGER,i, & working_comm,ierr) allocate(namercv(lenrcv),stat=allocok) if ( allocok .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation in compute_dist for namercv' ierr = 1 return end if if(myrank .eq. i) then namercv = myname endif call MPI_BCAST(namercv,lenrcv,MPI_INTEGER,i, & working_comm,ierr) if( MUMPS_COMPARE_TAB(myname,namercv, & resultlen,lenrcv)) then mem_distrib(i)=1 else mem_distrib(i)=ke69 endif deallocate(namercv) enddo deallocate(myname) ierr = 0 return end subroutine MUMPS_COMPUTE_DISTRIB subroutine MUMPS_GET_IDP1_PROC(current_proc,idarch,ierr) implicit none integer current_proc integer idarch,ierr ierr = 0 if (current_proc .ge. cv_slavef) then ierr = -1 return endif if (current_proc .lt. 0) then idarch = 1 return else idarch = table_of_process(current_proc) + 1 endif return end subroutine MUMPS_GET_IDP1_PROC subroutine MUMPS_END_ARCH_CV() if (allocated(table_of_process)) deallocate(table_of_process) if (allocated(allowed_nodes)) deallocate(allowed_nodes) if (allocated(score)) deallocate(score) if (allocated(mem_distribtmp)) deallocate(mem_distribtmp) if (allocated(mem_distribmpi)) deallocate(mem_distribmpi) return end subroutine MUMPS_END_ARCH_CV subroutine MUMPS_ALLOC_ALLOW_MASTER(ierr) integer ierr ierr = 0 if (allocated(allowed_nodes)) deallocate(allowed_nodes) allocate( allowed_nodes(0:nb_arch_nodes-1),stat=ierr) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation MUMPS_ALLOC_ALLOW_MASTER' ierr = -13 return end if allowed_nodes = .FALSE. if (allocated(score)) deallocate(score) allocate( score(0:nb_arch_nodes-1),stat=ierr) if ( ierr .gt. 0 ) then if(cv_mp.gt.0) write(cv_mp,*) & 'pb allocation MUMPS_ALLOC_ALLOW_MASTER' ierr = -13 return end if score = 0 ierr = 0 return end subroutine MUMPS_ALLOC_ALLOW_MASTER SUBROUTINE MUMPS_SORT_MMERGE(start1st,end1st,dim1, & start2nd,end2nd,dim2, & indx, & val, istat) implicit none integer, intent(in):: start1st,end1st,dim1,start2nd,end2nd,dim2 integer, intent(inout):: indx(:) DOUBLE PRECISION, intent(inout):: val(:) INTEGER, intent(out) :: istat INTEGER, ALLOCATABLE, DIMENSION(:) :: index DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: dummy1 integer :: a,b,c integer :: allocok character (len=48):: subname subname = "MUMPS_SORT_MMERGE" istat=-1 ALLOCATE(index(dim1+dim2),dummy1(dim1+dim2),stat=allocok) if ( allocok .gt. 0 ) then cv_info(1) = cv_error_memalloc cv_info(2) = dim1+dim2+dim1+dim2 istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*) & 'memory allocation error in ',subname return end if a=start1st b=start2nd c=1 do while((a.LT.end1st+1).AND.(b.LT.end2nd+1)) if(val(a).GT.val(b))then index(c)=indx(a) dummy1(c)=val(a) a=a+1 c=c+1 else index(c)=indx(b) dummy1(c)=val(b) b=b+1 c=c+1 endif end do if(a.LT.end1st+1) then do while(a.LT.end1st+1) index(c)=indx(a) dummy1(c)=val(a) a=a+1 c=c+1 enddo elseif(b.LT.end2nd+1) then do while(b.LT.end2nd+1) index(c)=indx(b) dummy1(c)=val(b) b=b+1 c=c+1 enddo endif indx(start1st:end1st)=index(1:dim1) val(start1st:end1st)=dummy1(1:dim1) indx(start2nd:end2nd)=index(dim1+1:dim1+dim2) val(start2nd:end2nd)=dummy1(dim1+1:dim1+dim2) DEALLOCATE(index,dummy1) istat=0 return end SUBROUTINE MUMPS_SORT_MMERGE SUBROUTINE MUMPS_SORT_MSORT(istat,dim,indx,val1,val2) implicit none integer, intent(in):: dim integer, intent(inout):: indx(:) integer, intent(out)::istat DOUBLE PRECISION, intent(inout):: val1(:) DOUBLE PRECISION, intent(inout),optional:: val2(:) INTEGER, ALLOCATABLE, DIMENSION(:) :: index, dummy1 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: dummy2 integer, parameter :: ss = 35 integer :: a,b,c,i,k,l,r,s,stackl(ss),stackr(ss) integer :: allocok character (len=48):: subname istat=-1 subname = "MUMPS_SORT_MSORT" ALLOCATE(index(dim),dummy1(dim),dummy2(dim),stat=allocok) if (allocok.gt.0) then cv_info(1) = cv_error_memalloc cv_info(2) = 3*dim istat = cv_error_memalloc if(cv_lp.gt.0) & write(cv_lp,*)'memory allocation error in ',subname return end if do i=1,dim index(i)=i enddo s = 1 stackl(1) = 1 stackr(1) = dim 5511 CONTINUE l = stackl(s) r = stackr(s) k = (l+r) / 2 if(l.LT.k) then if(s.GE.ss) stop 'maxsize of stack reached' s = s + 1 stackl(s) = l stackr(s) = k goto 5511 endif 5512 CONTINUE l = stackl(s) r = stackr(s) k = (l+r) / 2 if(k+1.LT.r) then if(s.GE.ss) stop 'maxsize of stack reached' s = s + 1 stackl(s) = k+1 stackr(s) = r goto 5511 endif 5513 CONTINUE l = stackl(s) r = stackr(s) k = (l+r) / 2 a=l b=k+1 c=1 do while((a.LT.k+1).AND.(b.LT.r+1)) if(val1(index(a)).GT.val1(index(b)))then dummy1(c)=index(a) a=a+1 c=c+1 else dummy1(c)=index(b) b=b+1 c=c+1 endif end do if(a.LT.k+1) then dummy1(c:r-l+1)=index(a:k) elseif(b.LT.r+1) then dummy1(c:r-l+1)=index(b:r) endif index(l:r)=dummy1(1:r-l+1) if(s.GT.1) then s = s - 1 if(l.EQ.stackl(s)) goto 5512 if(r.EQ.stackr(s)) goto 5513 endif do i=1,dim dummy1(i)=indx(index(i)) enddo indx=dummy1 do i=1,dim dummy2(i)=val1(index(i)) enddo val1=dummy2 if(present(val2)) then do i=1,dim dummy2(i)=val2(index(i)) enddo val2=dummy2 endif istat=0 DEALLOCATE(index,dummy1,dummy2) return end subroutine MUMPS_SORT_MSORT END MODULE MUMPS_STATIC_MAPPING SUBROUTINE MUMPS_SELECT_K38K20(N, SLAVEF, MP, & ICNTL13, KEEP, FRERE, ND, ISTAT) IMPLICIT NONE INTEGER, intent(in) :: N, SLAVEF, ICNTL13, MP INTEGER KEEP(500) INTEGER FRERE(N), ND(N) INTEGER, intent(out) :: ISTAT INTEGER IROOTTREE, SIZEROOT, NFRONT, I ISTAT = 0 IF (KEEP(60).EQ.2 .or. KEEP(60).EQ.3 ) THEN ELSE IF((SLAVEF.EQ.1).OR.(ICNTL13.GT.0).OR. & (KEEP(60).NE.0)) THEN KEEP(38) = 0 ELSE IROOTTREE=-1 SIZEROOT=-1 DO I=1,N IF (FRERE(I).EQ.0) THEN NFRONT = ND(I) IF (NFRONT .GT.SIZEROOT) THEN IROOTTREE = I SIZEROOT = NFRONT END IF END IF END DO IF ((IROOTTREE.EQ.-1).OR.(SIZEROOT.EQ.-1)) THEN ISTAT = -1 RETURN ENDIF IF (SIZEROOT.LE.SLAVEF) THEN KEEP(38) = 0 ELSE IF((SIZEROOT.GT.KEEP(37)) & .AND. (KEEP(53).EQ.0) & ) THEN IF (MP.GT.0) WRITE(MP,*) 'A root of estimated size ', & SIZEROOT,' has been selected for Scalapack.' KEEP(38) = IROOTTREE ELSE KEEP(38) = 0 IF (MP.GT.0) WRITE(MP,'(A,I9,A)') & ' WARNING: Largest root node of size ', SIZEROOT, & ' not selected for parallel execution' END IF IF ((KEEP(38).EQ.0).AND.(KEEP(53).NE.0)) THEN KEEP(20) = IROOTTREE ELSE IF (KEEP(60).EQ.0) THEN KEEP(20) = 0 ENDIF ENDIF ENDIF RETURN END SUBROUTINE MUMPS_SELECT_K38K20 SUBROUTINE MUMPS_SPLITNODE_INTREE(inode,nfront,npiv,k, & lnpivsplit, npivsplit, keep, n, fils, frere, & nfsiz, ne, info5_nfrmax, k28_nsteps, nodetype, & istat & , SIZEOFBLOCKS, LSIZEOFBLOCKS & , BLKON & ) implicit none integer, intent(in)::nfront,npiv integer, intent(in):: k integer, intent(in)::lnpivsplit integer, intent(in)::npivsplit(lnpivsplit) integer, intent(in):: inode integer, intent(out)::istat integer, intent(inout):: keep(500) integer, intent(inout):: k28_nsteps integer, intent(in) :: info5_nfrmax integer, intent(in) :: n integer, intent(inout)::frere(n), fils(n), nfsiz(n), ne(n) integer, intent(inout):: nodetype(n) integer, intent(in) :: LSIZEOFBLOCKS integer, intent(in) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) logical,intent(in) :: BLKON integer i,lev,in,in_son,in_father,in_grandpa,npiv_father, & npiv_son,nfrontk,npivk,d1,f1,e1,dk,fk,next_father integer::ison,ifather character (len=48):: subname integer, parameter:: tsplit_beg=4 integer, parameter:: tsplit_mid=5 integer, parameter:: tsplit_last=6 istat=-1 subname='SPLITNODE_INTREE' ison=-1 ifather=-1 nfrontk = nfront npivk = npiv npiv_son = npivsplit(1) keep(2)=max(keep(2),nfront-npiv_son) d1 = inode f1 = d1 e1 = frere(d1) if (BLKON) then i= SIZEOFBLOCKS(f1) do while (i.lt.npiv_son) f1 = fils(f1) i = i + SIZEOFBLOCKS(f1) enddo else do i=1,npiv_son-1 f1 = fils(f1) enddo endif ison = d1 in_son = f1 next_father = fils(in_son) do lev = 1, k-1 ifather = next_father in_father = ifather npiv_son= abs(npivsplit(lev)) npiv_father=abs(npivsplit(lev+1)) if (BLKON) then i= SIZEOFBLOCKS(in_father) do while (i.lt.npiv_father) in_father=fils(in_father) i = i + SIZEOFBLOCKS(in_father) enddo else do i=1,npiv_father-1 in_father=fils(in_father) enddo endif frere(ison)=-ifather next_father = fils(in_father) fils(in_father)=-ison nfsiz(ison)=nfrontk nfsiz(ifather)=nfrontk-npiv_son ne(ifather)=1 keep(61)=keep(61)+1 IF (keep(79).EQ.0) THEN if( nfront-npiv_son > keep(9)) then nodetype(ifather) = 2 else nodetype(ifather) = 1 endif ELSE if (lev.EQ.1) then nodetype(ison) = tsplit_beg endif if (lev.eq.k-1) then nodetype(ifather) = tsplit_last else nodetype(ifather) = tsplit_mid endif if (npivsplit(lev+1) < 0) then if (lev.eq.k-1) then nodetype(ifather)=-tsplit_last else nodetype(ifather)=-tsplit_mid endif endif ENDIF nfrontk = nfrontk-npiv_son npivk = npivk - npiv_son ison = ifather in_son = in_father enddo dk = ifather fk = in_father # if (check_mumps_static_mapping >= 3) write(6,*) ' Last (close to root) node in chain :', ifather #endif fils(f1) = next_father frere(dk) = e1 in = e1 do while (in.gt.0) in=frere(in) end do in = -in do while(fils(in).gt.0) in=fils(in) end do in_grandpa = in if(fils(in_grandpa).eq.-d1) then fils(in_grandpa)=-dk else in=-fils(in_grandpa) do while(frere(in) .ne. d1) in=frere(in) end do frere(in) = dk end if k28_nsteps = k28_nsteps + k-1 istat = 0 return END SUBROUTINE MUMPS_SPLITNODE_INTREE subroutine MUMPS_SETUP_CAND_CHAIN(n, nb_niv2, & frere, nodetype, par2_nodes, & procnode, cand, inode_chain, slavef, dummy, nbcand, istat) implicit none integer, intent(in) :: n, nb_niv2, slavef integer,intent(in)::frere(n) integer, intent(inout) :: par2_nodes(nb_niv2), procnode(n) integer,intent(inout)::nodetype(n) integer,intent(inout)::cand(nb_niv2, slavef+1) integer,intent(in)::inode_chain integer,intent(inout)::dummy, nbcand integer,intent(out):: istat integer, parameter:: tsplit_beg=4 integer, parameter:: tsplit_mid=5 integer, parameter:: tsplit_last=6 integer, parameter:: invalid=-9999 integer :: inode, ifather, k logical :: last_iteration_reached istat = -1 inode = inode_chain k = 1 do if (.not. (frere(inode) .lt. 0) ) then write(*,*) " Internal error 0 in SETUP_CAND", & frere(inode), inode CALL MUMPS_ABORT() endif ifather = -frere(inode) last_iteration_reached = (abs(nodetype(ifather)).eq.tsplit_last) par2_nodes(dummy+1) = ifather procnode(ifather) = cand(dummy,1) + 1 if ( (nodetype(ifather).eq.tsplit_mid) .or. & (nodetype(ifather).eq.tsplit_last) ) then if (nbcand.lt.2) then par2_nodes(dummy+1) = ifather procnode(ifather) = procnode(inode) cand(dummy+1,:) = cand(dummy,:) dummy = dummy + 1 write(6,*) ' Mapping property', & ' of procs in chain lost ' CALL MUMPS_ABORT() endif cand(dummy+1,1:nbcand-1+k-1) = cand(dummy,2:nbcand+k-1) cand(dummy+1,nbcand-1+k) = procnode(inode)-1 cand(dummy+1,nbcand-1+k+1:slavef) = invalid nbcand = nbcand -1 k = k + 1 else if ( (nodetype(ifather).eq.-tsplit_mid) .or. & (nodetype(ifather).eq.-tsplit_last) ) then if (nodetype(inode).eq.tsplit_beg) then nodetype(inode)=2 else nodetype(inode)=tsplit_last endif if (nodetype(ifather) .eq. -tsplit_last) then nodetype(ifather) = 2 else nodetype(ifather) = tsplit_beg endif cand(dummy+1,1:nbcand-1+k-1) = cand(dummy,2:nbcand+k-1) cand(dummy+1,nbcand-1+k) = procnode(inode)-1 nbcand = nbcand+k-1 k = 1 else write(6,*) ' Internal error 2 in SETUP_CAND', & ' in, ifather =', inode, ifather, & ' nodetype(ifather) ', nodetype(ifather) CALL MUMPS_ABORT() endif cand(dummy+1,slavef+1)= nbcand dummy = dummy+1 if (last_iteration_reached) exit inode = ifather end do istat = 0 end subroutine MUMPS_SETUP_CAND_CHAIN subroutine MUMPS_GET_SPLIT_4_PERF(inode, nfront, npiv, nproc, & k, lnpivsplit, npivsplit, & n, frere, keep, & fils, BLKON, sizeofblocks, & istat) implicit none integer,intent(in)::inode, nfront, npiv, lnpivsplit, n integer,intent(in)::frere(n) integer,intent(in) :: fils(n) logical, intent(in) :: BLKON integer, intent(in) :: sizeofblocks(*) integer,intent(in)::keep(500) double precision, intent(in):: nproc integer,intent(out)::k, npivsplit(lnpivsplit), istat logical :: nosplit integer :: inode_tmp integer :: kk, optimization_strategy, nass, npiv2 double precision :: nproc2 integer :: npivOld, npivNew double precision :: timeFacOld, timeFacNew, timeAss double precision ,parameter :: alpha=8.0D9 double precision ,parameter :: gamma=1.2D9 nosplit = npiv .le. npiv4equilibreRows(nfront, nproc) optimization_strategy = 0 nosplit = nosplit .or. (frere(inode) .eq. 0) if ( nosplit ) then k = 1 npivsplit(1) = npiv istat = 0 return endif if (nproc .le. 1.0d0) then k = 1 npivsplit(1) = npiv istat = -1 return endif nproc2 = nproc nass = 0 kk = 0 inode_tmp = inode do while (nass .lt. npiv) if ((nproc2 .eq. 2.0d0) .or. & (nfront - nass .le. 6*keep(9))) then npiv2 = npiv - nass else if (nproc2 .gt. 2) then if (optimization_strategy .eq. 0) then npiv2 = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 )) else if (optimization_strategy .eq. 1) then if (nproc2 .eq. nproc) then npiv2 = min(npiv - nass, & npiv4equilibreFlops(nfront - nass, nproc2 )) else npiv2 = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 )) endif else write(*,*) "Internal error in MUMPS_GET_SPLIT_4_PERF," write(*,*) "optimization_strategy not implemented" call MUMPS_ABORT() endif endif kk = kk + 1 IF (BLKON) THEN npivsplit(kk) = 0 DO WHILE (npivsplit(kk) .LT. npiv2 .and. inode_tmp .gt. 0) npivsplit(kk) = npivsplit(kk) + sizeofblocks(inode_tmp) inode_tmp= fils(inode_tmp) ENDDO npiv2 = npivsplit(kk) ELSE npivsplit(kk) = npiv2 ENDIF if (keep(79) .ge. 1 & .and. kk .ne. 1) then if (optimization_strategy .eq. 0) then npivOld = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc )) npivNew = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 - 1.0d0)) else if (optimization_strategy .eq. 1) then npivOld = min(npiv - nass, & npiv4equilibreFlops(nfront - nass, nproc )) npivNew = min(npiv - nass, & npiv4equilibreRows(nfront - nass, nproc2 - 1.0d0)) else write(*,*) "Internal error in MUMPS_GET_SPLIT_4_PERF," write(*,*) "optimization_strategy not implemented" call MUMPS_ABORT() endif timeAss = timeAssembly(int(nfront-nass,8), nproc2) timeFacOld = timeFacto(int(nfront-nass,8), int(npivOld,8), & nproc) timeFacNew = timeFacto(int(nfront-nass,8),int(npivNew,8), & nproc2-1) if ( (flopsFactoPanel(int(npivOld,8),int(nfront-nass,8))+ & flopsUpdate(int(nfront-nass-npivOld,8), & int(nfront-nass-npivOld,8), int(npivOld,8)))/ & (timeFacOld+timeAss) & .gt. (flopsFactoPanel(int(npivNew,8),int(nfront-nass,8))+ & flopsUpdate(int(nfront-nass-npivNew,8), & int(nfront-nass-npivNew,8), int(npivNew,8)))/ & timeFacNew ) then npivsplit(kk) = -npiv2 nproc2 = nproc else nproc2 = nproc2 - 1.0d0 npiv2 = npivNew npivsplit(kk)=npivNew endif endif nass = nass + npiv2 enddo k = kk istat=0 return CONTAINS function npiv4equilibreRows(nfront, nproc) implicit none integer npiv4equilibreRows integer, intent(in) :: nfront double precision, intent(in) :: nproc npiv4equilibreRows = max(1, int(dble(nfront)/nproc)) return end function npiv4equilibreRows function npiv4equilibreFlops(nfront, nproc) implicit none integer npiv4equilibreFlops integer, intent(in) :: nfront double precision, intent(in) :: nproc double precision::n,s,a,b,c,sdelta,npiv n = dble(nfront) s = nproc - 1.0d0 a = s/3.+1. b = -3.*n - s*n - s/2. c = 2.*n**2 + s*n + s/6. sdelta = (b*b) - 4*a*c if (sdelta < 0.0E0) then WRITE(*,*) "Delta < 0 in npiv4equilibreFlops" call MUMPS_ABORT() endif sdelta = sqrt(sdelta) npiv = (-b - sdelta)/(2*a) npiv4equilibreFlops = max(1, int(npiv)) return end function npiv4equilibreFlops function flopsFactoPanel(nbrows, nbcols) integer(8) :: nbrows, nbcols double precision :: flopsFactoPanel flopsFactoPanel = (nbrows*((-1.d0/3.d0)*nbrows**2 + & (nbcols + 1.d0/2.d0)*nbrows + & (nbcols + 1.d0/6.d0))) end function flopsFactoPanel function flopsUpdate(m, n, k) integer(8) :: m, n, k double precision :: flopsUpdate flopsUpdate = dble(2*m*n*k + m*k**2) end function flopsUpdate function timeFacto(nfront, npiv, nproc) integer(8), intent(in) :: nfront, npiv double precision, intent(in) :: nproc double precision :: timeFacto timeFacto = (max(flopsFactoPanel(npiv,nfront), & flopsUpdate(nfront-npiv, nfront-npiv, npiv)/ & (nproc-1))/alpha) end function timeFacto function timeNIV1(nfront, npiv) integer(8) :: nfront, npiv double precision :: timeNIV1 timeNIV1 = ((flopsFactoPanel(npiv, nfront) + & flopsUpdate(nfront - npiv, nfront - npiv, npiv))/alpha) end function timeNIV1 function timeAssembly(n, p) integer(8) :: n double precision, intent(in) :: p double precision :: timeAssembly timeAssembly = ((n*n/p)/(gamma/(log(p)/log(2.0d0)))) end function timeAssembly end subroutine MUMPS_GET_SPLIT_4_PERF MUMPS_5.4.1/src/cfac_scalings_simScaleAbs.F0000664000175000017500000013563114102210526020653 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SIMSCALEABS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & SYM, NB1, NB2, NB3, EPS, & ONENORMERR,INFNORMERR) C---------------------------------------------------------------------- C IF SYM=0 CALLs unsymmetric variant CMUMPS_SIMSCALEABSUNS. C IF SYM=2 CALLS symmetric variant where only one of a_ij and a_ji C is stored. CMUMPS_SIMSCALEABSSYM C--------------------------------------------------------------------- C For details, see the two subroutines below C CMUMPS_SIMSCALEABSUNS and CMUMPS_SIMSCALEABSSYM C --------------------------------------------------------------------- C IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CPARTVEC(N) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR C LOCALS C IMPORTANT POINTERS C FOR the scaling phase INTEGER SYM, NB1, NB2, NB3 REAL EPS C EXTERNALS EXTERNAL CMUMPS_SIMSCALEABSUNS,CMUMPS_SIMSCALEABSSYM, & CMUMPS_INITREAL C MUST HAVE IT INTEGER I IF(SYM.EQ.0) THEN CALL CMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, & NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) ELSE CALL CMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, & NZ_loc, & N, NUMPROCS, MYID, COMM, & RPARTVEC, & RSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) DO I=1,N COLSCA(I) = ROWSCA(I) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_SIMSCALEABS SUBROUTINE CMUMPS_SIMSCALEABSUNS(IRN_loc, JCN_loc, A_loc, NZ_loc, & M, N, NUMPROCS, MYID, COMM, & RPARTVEC, CPARTVEC, & RSNDRCVSZ, CSNDRCVSZ, REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & ROWSCA, COLSCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C M, N: size of matrix (in general M=N, but the algorithm C works for rectangular matrices as well (norms other than C inf-norm are not possible mathematically in this case). C NUMPROCS, MYID, COMM: guess what are those C RPARTVEC: row partvec to be filled when OP=1 C CPARTVEC: col partvec to be filled when OP=1 C RSNDRCVSZ: send recv sizes for row operations. C to be filled when OP=1 C CSNDRCVSZ: send recv sizes for col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc) C IWRK: working space. when OP=1 IWRKSZ.GE.4*MAXMN C when OP=2 INTSZ portion is used. Thus, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into RPARTVEC,CPARTVEC,RSNDRCVSZ,CSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C ROWSCA: space for row scaling factor; has size M C COLSCA: space for col scaling factor; has size N C WRKRC: real working space. when OP=1, is not accessed. Thus, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C If convergence occured during the first set of inf-norm C iterations, we start performing one-norm iterations. C If convergence occured during the one-norm iterations, C we start performing the second set of inf-norm iterations. C If convergence occured during the second set of inf-norm, C we prepare to return. C ONENORMERR : error in one norm scaling (associated with the scaling C arrays of the previous iterations), C INFNORMERR : error in inf norm scaling (associated with the scaling C arrays of the previous iterations). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.4*MAXMN C RPARTVEC of size M C CPARTVEC of size N C RSNDRCVSZ of size 2*NUMPROCS C CSNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C ROWSCA and COLSCA C at processor 0 of COMM: complete factors. C at other processors : only the ROWSCA(i) or COLSCA(j) C for which there is a nonzero a_i* or a_*j are useful. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is discussed in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, C "A parallel matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) NZ_loc INTEGER IWRKSZ, INTSZ, ISZWRKRC INTEGER M, N, OP INTEGER NUMPROCS, MYID, COMM INTEGER RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX A_loc(NZ_loc) INTEGER RPARTVEC(M) INTEGER CPARTVEC(N) INTEGER RSNDRCVSZ(2*NUMPROCS) INTEGER CSNDRCVSZ(2*NUMPROCS) INTEGER REGISTRE(12) INTEGER IWRK(IWRKSZ) REAL ROWSCA(M) REAL COLSCA(N) REAL WRKRC(ISZWRKRC) REAL ONENORMERR,INFNORMERR C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER ICSNDRCVNUM, OCSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER ICSNDRCVVOL, OCSNDRCVVOL INTEGER INUMMYR, INUMMYC C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ICNGHBPRCS, ICSNDRCVIA,ICSNDRCVJA INTEGER OCNGHBPRCS, OCSNDRCVIA,OCSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ITDCPTR, ISRRPTR INTEGER OSRRPTR, ISRCPTR, OSRCPTR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_COL PARAMETER(TAG_COMM_COL=100) INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL CMUMPS_CREATEPARTVEC, & CMUMPS_NUMVOLSNDRCV, & CMUMPS_SETUPCOMMS, & CMUMPS_FINDNUMMYROWCOL, & CMUMPS_CHKCONVGLO, & CMUMPS_CHK1CONV, & CMUMPS_FILLMYROWCOLINDICES, & CMUMPS_INITREAL, & CMUMPS_INITREALLST, & CMUMPS_DOCOMMINF, & CMUMPS_DOCOMM1N INTEGER CMUMPS_CHKCONVGLO INTEGER CMUMPS_CHK1CONV REAL CMUMPS_ERRSCALOC REAL CMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER RESZR, RESZC INTEGER INTSZR, INTSZC INTEGER MAXMN INTEGER I, IERROR REAL ONEERRROW, ONEERRCOL, ONEERRL, ONEERRG REAL INFERRROW, INFERRCOL, INFERRL, INFERRG INTEGER OORANGEIND INFERRG = -RONE ONEERRG = -RONE OORANGEIND = 0 MAXMN = M IF(MAXMN < N) MAXMN = N C Create row partvec and col partvec IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.4*MAXMN) THEN ERROR.... CALL CMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, M, N, & IWRK, IWRKSZ) CALL CMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & JCN_loc, IRN_loc, NZ_loc, & CPARTVEC, N, M, & IWRK, IWRKSZ) C Compute sndrcv sizes, store them for later use CALL CMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc, N, JCN_loc, & IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM,ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) CALL CMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM,ICSNDRCVVOL, & OCSNDRCVNUM,OCSNDRCVVOL, & IWRK,IWRKSZ, & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), COMM) CALL CMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWRKSZ) INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZC = ICSNDRCVNUM + OCSNDRCVNUM + & ICSNDRCVVOL + OCSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYC INTSZ = INTSZR + INTSZC + MAXMN + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 ICSNDRCVNUM = 0 OCSNDRCVNUM = 0 ICSNDRCVVOL = 0 OCSNDRCVVOL = 0 INUMMYC = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY REAL SPACE RESZR = M + IRSNDRCVVOL + ORSNDRCVVOL RESZC = N + ICSNDRCVVOL + OCSNDRCVVOL RESZ = RESZR + RESZC C CALCULATE NECESSARY INT SPACE C The last maxmn is tmpwork for setup comm and fillmyrowcol REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(5) = ICSNDRCVNUM REGISTRE(6) = OCSNDRCVNUM REGISTRE(7) = ICSNDRCVVOL REGISTRE(8) = OCSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(10) = INUMMYC REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) ICSNDRCVNUM = REGISTRE(5) OCSNDRCVNUM = REGISTRE(6) ICSNDRCVVOL = REGISTRE(7) OCSNDRCVVOL = REGISTRE(8) INUMMYR = REGISTRE(9) INUMMYC = REGISTRE(10) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL CMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & RPARTVEC, CPARTVEC, M, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), INUMMYC, & IWRK(1+INUMMYR+INUMMYC), IWRKSZ-INUMMYR-INUMMYC ) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (4 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR+ INUMMYC IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C COLS [---------------------------------------------] ICNGHBPRCS = ORSNDRCVJA + ORSNDRCVVOL ICSNDRCVIA = ICNGHBPRCS + ICSNDRCVNUM ICSNDRCVJA = ICSNDRCVIA + NUMPROCS+1 OCNGHBPRCS = ICSNDRCVJA + ICSNDRCVVOL OCSNDRCVIA = OCNGHBPRCS + OCSNDRCVNUM OCSNDRCVJA = OCSNDRCVIA + NUMPROCS + 1 C C MPI [-----------------] REQUESTS = OCSNDRCVJA + OCSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL CMUMPS_SETUPCOMMS(MYID, NUMPROCS, M, RPARTVEC, & NZ_loc, IRN_loc,N, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL CMUMPS_SETUPCOMMS(MYID, NUMPROCS, N, CPARTVEC, & NZ_loc, JCN_loc, M, IRN_loc, & ICSNDRCVNUM, ICSNDRCVVOL, & IWRK(ICNGHBPRCS), & IWRK(ICSNDRCVIA), & IWRK(ICSNDRCVJA), & OCSNDRCVNUM, OCSNDRCVVOL, & IWRK(OCNGHBPRCS),IWRK(OCSNDRCVIA),IWRK(OCSNDRCVJA), & CSNDRCVSZ(1), CSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_COL, COMM) CALL CMUMPS_INITREAL(ROWSCA, M, RZERO) CALL CMUMPS_INITREAL(COLSCA, N, RZERO) CALL CMUMPS_INITREALLST(ROWSCA, M, & IWRK(IMYRPTR),INUMMYR, RONE) CALL CMUMPS_INITREALLST(COLSCA, N, & IWRK(IMYCPTR),INUMMYC, RONE) ELSE CALL CMUMPS_INITREAL(ROWSCA, M, RONE) CALL CMUMPS_INITREAL(COLSCA, N, RONE) ENDIF ITDRPTR = 1 ITDCPTR = ITDRPTR + M C ISRRPTR = ITDCPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C ISRCPTR = OSRRPTR + ORSNDRCVVOL OSRCPTR = ISRCPTR + ICSNDRCVVOL C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRCPTR = OSRCPTR - 1 ISRCPTR = ISRCPTR - 1 OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 IF(ICSNDRCVVOL == 0) ISRCPTR = ISRCPTR - 1 IF(OCSNDRCVVOL == 0) OSRCPTR = OSRCPTR - 1 ENDIF ITER = 1 DO WHILE (ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL CMUMPS_ZEROOUT(WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) CALL CMUMPS_ZEROOUT(WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) ELSE CALL CMUMPS_INITREAL(WRKRC(ITDRPTR),M, RZERO) CALL CMUMPS_INITREAL(WRKRC(ITDCPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL CMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM,IWRK(ICNGHBPRCS), & ICSNDRCVVOL,IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM,IWRK(OCNGHBPRCS), & OCSNDRCVVOL,IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) C CALL CMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = CMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols INFERRCOL = CMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL ) THEN INFERRL = INFERRROW ENDIF C CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL CMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRROW = CMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols INFERRCOL = CMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors INFERRL = INFERRCOL IF(INFERRROW > INFERRL) THEN INFERRL = INFERRROW ENDIF INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL CMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER .EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.M).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0) THEN DO NZIND=1,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*ROWSCA(IR)*COLSCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM WRKRC(ITDCPTR-1+IC) = WRKRC(ITDCPTR-1+IC) + ELM ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDCPTR), N, TAG_ITERS+ITER, & ICSNDRCVNUM, IWRK(ICNGHBPRCS), & ICSNDRCVVOL, IWRK(ICSNDRCVIA), IWRK(ICSNDRCVJA), & WRKRC(ISRCPTR), & OCSNDRCVNUM, IWRK(OCNGHBPRCS), & OCSNDRCVVOL, IWRK(OCSNDRCVIA), IWRK(OCSNDRCVJA), & WRKRC( OSRCPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) C CALL CMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), M, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = CMUMPS_ERRSCALOC(ROWSCA, & WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C find error for the cols ONEERRCOL = CMUMPS_ERRSCALOC(COLSCA, & WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL ) THEN ONEERRL = ONEERRROW ENDIF C CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(COLSCA, & WRKRC(ITDCPTR),N, & IWRK(IMYCPTR),INUMMYC) CALL CMUMPS_UPDATESCALE(ROWSCA, & WRKRC(ITDRPTR),M, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRROW = CMUMPS_ERRSCA1(ROWSCA, & WRKRC(ITDRPTR), M) C find error for the cols ONEERRCOL = CMUMPS_ERRSCA1(COLSCA, & WRKRC(ITDCPTR), N) C get max of those two errors ONEERRL = ONEERRCOL IF(ONEERRROW > ONEERRL) THEN ONEERRL = ONEERRROW ENDIF ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL CMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_UPDATESCALE(COLSCA, WRKRC(ITDCPTR), N, & IWRK(IMYCPTR),INUMMYC) CALL CMUMPS_UPDATESCALE(ROWSCA, WRKRC(ITDRPTR), M, & IWRK(IMYRPTR),INUMMYR) C ELSE C SINGLE PROCESSOR CASE: Conv check and update of sca arrays CALL CMUMPS_UPSCALE1(COLSCA, WRKRC(ITDCPTR), N) CALL CMUMPS_UPSCALE1(ROWSCA, WRKRC(ITDRPTR), M) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(ROWSCA, WRKRC(1), M, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, M ROWSCA(I) = WRKRC(I) ENDDO ENDIF C Scaling factors are printed C WRITE (6,*) MYID, 'ROWSCA=',ROWSCA C WRITE (6,*) MYID, 'COLSCA=',COLSCA C CALL FLUSH(6) c REduce the whole scaling factors to processor 0 of COMM CALL MPI_REDUCE(COLSCA, WRKRC(1+M), N, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) If(MYID.EQ.0) THEN DO I=1, N COLSCA(I) = WRKRC(I+M) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SIMSCALEABSUNS C C C SEPARATOR: Another function begins C C SUBROUTINE CMUMPS_SIMSCALEABSSYM(IRN_loc, JCN_loc, A_loc, NZ_loc, & N, NUMPROCS, MYID, COMM, & PARTVEC, & RSNDRCVSZ, & REGISTRE, & IWRK, IWRKSZ, & INTSZ, RESZ, OP, & SCA, WRKRC, ISZWRKRC, & NB1, NB2, NB3, EPS, & ONENORMERR, INFNORMERR) C---------------------------------------------------------------------- C Input parameters: C N: size of matrix (sym matrix, square). C NUMPROCS, MYID, COMM: guess what are those C PARTVEC: row/col partvec to be filled when OP=1 C RSNDRCVSZ:send recv sizes for row/col operations. C to be filled when OP=1 C REGISTRE: to store some pointers (size etc). Its size is 12, C but we do not use all in this routine. C IWRK: working space. when OP=1 IWRKSZ.GE.2*MAXMN C when OP=2 INTSZ portion is used. Donc, IWRKSZ>INTSZ C when OP=2 C IWRKSZ: size C INTSZ: to be computed when OP=1, necessary integer space to run C scaling algo when OP=2 C RESZ: to be computed when OP=1, necessary real space to run C scaling algo when OP=2 C OP: C =1 estimation of memory and construction of partvecs C writes into PARTVEC,RSNDRCVSZ,REGISTRE C does not access WRKRC, uses IWRK as workspace C computes INTSZ and RESZ. C =2 Compute scalings C restores pointers from REGISTRE, C stores communication structure in IWRK (from the start). C C SCA: space for row/col scaling factor; has size M C WRKRC: real working space. when OP=1, is not accessed. Donc, it C can be declared to be of size 1 at OP=1 call. C ISZWRKRC: size C SYM: is matrix symmetric C NB1, NB2, NB3: algo runs C NB1 iters of inf-norm (default 1/1), C NB2 iters of 1-norm (default 3/10), C NB3 iters of inf-norm (default 3/10). C in succession. C EPS: tolerance for concergence. C IF EPS < 0.R0 then does not test convergence. C See comments for the uns case above. C ONENORMERR : error in one norm scaling (see comments for the C uns case above), C INFNORMERR : error in inf norm scaling (see comments for the C uns case above). C--------------------------------------------------------------------- C On input: C OP=1==>Requirements C IWRKSZ.GE.2*MAXMN XXXX compare with uns variant. C PARTVEC of size N C SNDRCVSZ of size 2*NUMPROCS C REGISTRE of size 12 C C OP=2==>Requirements C INTSZ .GE. REGISTRE(11) C RESZ .GE. REGISTRE(12) C--------------------------------------------------------------------- C On output: C SCA C at processor 0 of COMM: complete factors. C at other processors : only the SCA(i) and SCA(j) C for which there is a nonzero a_ij. C ONENORMERR : error in one norm scaling C = -1.0 if iter2=0. C INFNORMERR : error in inf norm scaling C = inf norm error at iter3 if iter3 > 0 C = inf norm error at iter1 if iter1 > 0, iter3=0 C = -1.0 if iter1=iter3=0 C --------------------------------------------------------------------- C NOTE: some variables are named in such a way that they correspond C to the row variables in unsym case. They are used for both C row and col communications. C --------------------------------------------------------------------- C References: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C C The parallelization approach is based on discussion in C [3] P. R. Amestoy, I. S. Duff, D. Ruiz, and B. Ucar, "A parallel C matrix scaling algorithm", accepted for publication, C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, Jan'08. C and was supported by ANR-SOLSTICE project (ANR-06-CIS6-010) C --------------------------------------------------------------------- IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER N, IWRKSZ, OP INTEGER NUMPROCS, MYID, COMM INTEGER INTSZ, RESZ INTEGER IRN_loc(NZ_loc) INTEGER JCN_loc(NZ_loc) COMPLEX A_loc(NZ_loc) INTEGER PARTVEC(N), RSNDRCVSZ(2*NUMPROCS) INTEGER IWRK(IWRKSZ) INTEGER REGISTRE(12) REAL SCA(N) INTEGER ISZWRKRC REAL WRKRC(ISZWRKRC) C LOCALS INTEGER IRSNDRCVNUM, ORSNDRCVNUM INTEGER IRSNDRCVVOL, ORSNDRCVVOL INTEGER INUMMYR C IMPORTANT POINTERS INTEGER IMYRPTR,IMYCPTR INTEGER IRNGHBPRCS, IRSNDRCVIA,IRSNDRCVJA INTEGER ORNGHBPRCS, ORSNDRCVIA,ORSNDRCVJA INTEGER ISTATUS, REQUESTS, TMPWORK INTEGER ITDRPTR, ISRRPTR, OSRRPTR REAL ONENORMERR,INFNORMERR C FOR the scaling phase INTEGER NB1, NB2, NB3 REAL EPS C Iteration vars INTEGER ITER, IR, IC INTEGER(8) :: NZIND REAL ELM C COMM TAGS.... INTEGER TAG_COMM_ROW PARAMETER(TAG_COMM_ROW=101) INTEGER TAG_ITERS PARAMETER(TAG_ITERS=102) C FUNCTIONS EXTERNAL CMUMPS_CREATEPARTVECSYM, & CMUMPS_NUMVOLSNDRCVSYM, & CMUMPS_SETUPCOMMSSYM, & CMUMPS_FINDNUMMYROWCOLSYM, & CMUMPS_CHKCONVGLOSYM, & CMUMPS_CHK1CONV, & CMUMPS_FILLMYROWCOLINDICESSYM, & CMUMPS_DOCOMMINF, & CMUMPS_DOCOMM1N, & CMUMPS_INITREAL, & CMUMPS_INITREALLST INTEGER CMUMPS_CHKCONVGLOSYM INTEGER CMUMPS_CHK1CONV REAL CMUMPS_ERRSCALOC REAL CMUMPS_ERRSCA1 INTRINSIC abs REAL RONE, RZERO PARAMETER(RONE=1.0E0,RZERO=0.0E0) C TMP VARS INTEGER INTSZR INTEGER MAXMN INTEGER I, IERROR REAL ONEERRL, ONEERRG REAL INFERRL, INFERRG INTEGER OORANGEIND OORANGEIND = 0 INFERRG = -RONE ONEERRG = -RONE MAXMN = N IF(OP == 1) THEN IF(NUMPROCS > 1) THEN C Check done outside C IF(IWRKSZ.LT.2*MAXMN) THEN ERROR.... CALL CMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK, IWRKSZ) C CALL CMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, IRSNDRCVNUM,IRSNDRCVVOL, & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK,IWRKSZ, & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), COMM) C CALL CMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWRKSZ) C INTSZR = IRSNDRCVNUM + ORSNDRCVNUM + & IRSNDRCVVOL + ORSNDRCVVOL + & 2*(NUMPROCS+1) + INUMMYR INTSZ = INTSZR + N + & (MPI_STATUS_SIZE +1) * NUMPROCS ELSE C NUMPROCS IS 1 IRSNDRCVNUM = 0 ORSNDRCVNUM = 0 IRSNDRCVVOL = 0 ORSNDRCVVOL = 0 INUMMYR = 0 INTSZ = 0 ENDIF C CALCULATE NECESSARY REAL SPACE RESZ = N + IRSNDRCVVOL + ORSNDRCVVOL REGISTRE(1) = IRSNDRCVNUM REGISTRE(2) = ORSNDRCVNUM REGISTRE(3) = IRSNDRCVVOL REGISTRE(4) = ORSNDRCVVOL REGISTRE(9) = INUMMYR REGISTRE(11) = INTSZ REGISTRE(12) = RESZ ELSE C else of op=1. That is op=2 now. C restore the numbers IRSNDRCVNUM = REGISTRE(1) ORSNDRCVNUM = REGISTRE(2) IRSNDRCVVOL = REGISTRE(3) ORSNDRCVVOL = REGISTRE(4) INUMMYR = REGISTRE(9) IF(NUMPROCS > 1) THEN C Check done outsize C IF(INTSZ < REGISTRE(11)) THEN ERROR C IF(RESZ < REGISTRE(12)) THEN ERROR C Fill up myrows and my colsX CALL CMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & IWRK(1), INUMMYR, & IWRK(1+INUMMYR), IWRKSZ-INUMMYR) IMYRPTR = 1 IMYCPTR = IMYRPTR + INUMMYR C Set up comm and run. C set pointers in iwrk (3 parts) C C ROWS [---------------------------------------------] IRNGHBPRCS = IMYCPTR IRSNDRCVIA = IRNGHBPRCS+IRSNDRCVNUM IRSNDRCVJA = IRSNDRCVIA + NUMPROCS+1 ORNGHBPRCS = IRSNDRCVJA + IRSNDRCVVOL ORSNDRCVIA = ORNGHBPRCS + ORSNDRCVNUM ORSNDRCVJA = ORSNDRCVIA + NUMPROCS + 1 C MPI [-----------------] REQUESTS = ORSNDRCVJA + ORSNDRCVVOL ISTATUS = REQUESTS + NUMPROCS C TMPWRK [-----------------] TMPWORK = ISTATUS + MPI_STATUS_SIZE * NUMPROCS CALL CMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, N, PARTVEC, & NZ_loc, IRN_loc, JCN_loc, & IRSNDRCVNUM, IRSNDRCVVOL, & IWRK(IRNGHBPRCS),IWRK(IRSNDRCVIA),IWRK(IRSNDRCVJA), & ORSNDRCVNUM, ORSNDRCVVOL, & IWRK(ORNGHBPRCS),IWRK(ORSNDRCVIA),IWRK(ORSNDRCVJA), & RSNDRCVSZ(1), RSNDRCVSZ(1+NUMPROCS), & IWRK(TMPWORK), & IWRK(ISTATUS), IWRK(REQUESTS), & TAG_COMM_ROW, COMM) CALL CMUMPS_INITREAL(SCA, N, RZERO) CALL CMUMPS_INITREALLST(SCA, N, & IWRK(IMYRPTR),INUMMYR, RONE) ELSE CALL CMUMPS_INITREAL(SCA, N, RONE) ENDIF ITDRPTR = 1 ISRRPTR = ITDRPTR + N OSRRPTR = ISRRPTR + IRSNDRCVVOL C C To avoid bound check errors... IF(NUMPROCS == 1)THEN OSRRPTR = OSRRPTR - 1 ISRRPTR = ISRRPTR - 1 ELSE IF(IRSNDRCVVOL == 0) ISRRPTR = ISRRPTR - 1 IF(ORSNDRCVVOL == 0) OSRRPTR = OSRRPTR - 1 ENDIF C computation starts ITER = 1 DO WHILE(ITER.LE.NB1+NB2+NB3) C CLEAR temporary Dr and Dc IF(NUMPROCS > 1) THEN CALL CMUMPS_ZEROOUT(WRKRC(ITDRPTR),N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL CMUMPS_INITREAL(WRKRC(ITDRPTR),N, RZERO) ENDIF IF((ITER.LE.NB1).OR.(ITER > NB1+NB2)) THEN C INF-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1)) THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) IF(WRKRC(ITDRPTR-1+IR) 1) THEN CALL CMUMPS_DOCOMMINF(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM,IWRK(IRNGHBPRCS), & IRSNDRCVVOL,IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM,IWRK(ORNGHBPRCS), & ORSNDRCVVOL,IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS),IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = CMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) CALL MPI_ALLREDUCE(INFERRL, INFERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ELSE C SINGLE PROCESSOR CASE: INF-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & (ITER.EQ.NB1).OR. & ((ITER.EQ.NB1+NB2+NB3).AND. & (NB1+NB3.GT.0))) THEN INFERRL = CMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) INFERRG = INFERRL IF(INFERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) IF(ITER .LE. NB1) THEN ITER = NB1+1 CYCLE ELSE EXIT ENDIF ENDIF ENDIF ENDIF ELSE C WE HAVE ITER.GT.NB1 AND ITER.LE.NB1+NB2. C ONE-NORM ITERATION IF((ITER.EQ.1).OR.(OORANGEIND.EQ.1))THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) IF((IR.GE.1).AND.(IR.LE.N).AND. & (IC.GE.1).AND.(IC.LE.N)) THEN ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = & WRKRC(ITDRPTR-1+IC) + ELM ENDIF ELSE OORANGEIND = 1 ENDIF ENDDO ELSEIF(OORANGEIND.EQ.0)THEN DO NZIND=1_8,NZ_loc IR = IRN_loc(NZIND) IC = JCN_loc(NZIND) ELM = abs(A_loc(NZIND))*SCA(IR)*SCA(IC) WRKRC(ITDRPTR-1+IR) = WRKRC(ITDRPTR-1+IR) + ELM IF(IR.NE.IC) THEN WRKRC(ITDRPTR-1+IC) = WRKRC(ITDRPTR-1+IC) + ELM ENDIF ENDDO ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_DOCOMM1N(MYID, NUMPROCS, & WRKRC(ITDRPTR), N, TAG_ITERS+2+ITER, & IRSNDRCVNUM, IWRK(IRNGHBPRCS), & IRSNDRCVVOL, IWRK(IRSNDRCVIA), IWRK(IRSNDRCVJA), & WRKRC(ISRRPTR), & ORSNDRCVNUM, IWRK(ORNGHBPRCS), & ORSNDRCVVOL, IWRK(ORSNDRCVIA), IWRK(ORSNDRCVJA), & WRKRC( OSRRPTR), & IWRK(ISTATUS), IWRK(REQUESTS), & COMM) IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = CMUMPS_ERRSCALOC(SCA, & WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) C mpi allreduce. CALL MPI_ALLREDUCE(ONEERRL, ONEERRG, & 1, MPI_REAL, & MPI_MAX, COMM, IERROR) IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ELSE C SINGLE-PROCESSOR CASE: ONE-NORM ERROR COMPUTATION IF((EPS .GT. RZERO) .OR. & ((ITER.EQ.NB1+NB2).AND. & (NB2.GT.0))) THEN ONEERRL = CMUMPS_ERRSCA1(SCA, & WRKRC(ITDRPTR), N) ONEERRG = ONEERRL IF(ONEERRG.LE.EPS) THEN CALL CMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ITER = NB1+NB2+1 CYCLE ENDIF ENDIF ENDIF ENDIF IF(NUMPROCS > 1) THEN CALL CMUMPS_UPDATESCALE(SCA, WRKRC(ITDRPTR), N, & IWRK(IMYRPTR),INUMMYR) ELSE CALL CMUMPS_UPSCALE1(SCA, WRKRC(ITDRPTR), N) ENDIF ITER = ITER + 1 ENDDO ONENORMERR = ONEERRG INFNORMERR = INFERRG IF(NUMPROCS > 1) THEN CALL MPI_REDUCE(SCA, WRKRC(1), N, MPI_REAL, & MPI_MAX, 0, & COMM, IERROR) IF(MYID.EQ.0) THEN DO I=1, N SCA(I) = WRKRC(I) ENDDO ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SIMSCALEABSSYM MUMPS_5.4.1/src/sana_aux.F0000664000175000017500000041151314102210521015414 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE SMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) REAL :: CNTL4 REAL, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif REAL, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED, WEIGHTREQUESTED LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB EXTERNAL MUMPS_ANA_H, SMUMPS_ANA_J, & SMUMPS_ANA_K, SMUMPS_ANA_GNEW, & SMUMPS_ANA_LNEW, SMUMPS_ANA_M #if defined(OLDDFS) EXTERNAL SMUMPS_ANA_L #endif EXTERNAL SMUMPS_GNEW_SCHUR EXTERNAL SMUMPS_LDLT_COMPRESS, SMUMPS_EXPAND_PERMUTATION, & SMUMPS_SET_CONSTRAINTS IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF ( (LIWALLOC.EQ.0_8).AND.(.not.GCOMP_PROVIDED)) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.2) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL SMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: SMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0E0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF IF (PROK) & WRITE(MP,*) 'Setting static pivoting ON, COMPRESS =', & COMPRESS ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL SMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL SMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, & WEIGHTUSED, WEIGHTREQUESTED) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL SMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL SMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL SMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL SMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.3) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL SMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF (KEEP(106).EQ.3.AND.KEEP(60).EQ.0) THEN ELSE ALLOCATE( WTEMP ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF ELSE CALL SMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL SMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) IF (KEEP(60) .EQ. 0) THEN IF (KEEP(60) .EQ. 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF ENDIF ENDIF #if defined(OLDDFS) CALL SMUMPS_ANA_L & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ, INFO(6), FILS(1), FRERE(1), PTRAR(1,3), & NEMIN, KEEP(60)) #else IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (present(SIZEOFBLOCKS)) THEN CALL SMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .TRUE. , SIZEOFBLOCKS, N & ) ELSE CALL SMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .FALSE., IDUMMY, LIDUMMY ) ENDIF DEALLOCATE(WTEMP) #endif IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL SMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL SMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) THEN KEEP(210)=0 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) THEN KEEP(210)=1 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) THEN KEEP(210)=2 ENDIF IF (KEEP(210).EQ.2) THEN KEEP8(79)=huge(KEEP8(79)) ENDIF IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL SMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 INFO(1) = -4 INFO(2) = K GOTO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE SMUMPS_ANA_F SUBROUTINE SMUMPS_ANA_N_DIST( id, PTRAR ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(SMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER(8), POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => PTRAR(id%N+1:id%N+id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N) IWORK2 => PTRAR(id%N+1:id%N+id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1_8 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1_8 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1_8 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1_8 END IF ENDIF ENDIF 70 CONTINUE END IF IF (id%KEEP(54) .EQ. 3) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(id%N+1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR(1), 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE SMUMPS_ANA_N_DIST SUBROUTINE SMUMPS_ANA_O( N, NZ, MTRANS, PERM, IKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN REAL, POINTER, DIMENSION(:) :: idA REAL, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER, TARGET :: IKEEPALLOC(3*N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW REAL, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) REAL CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT REAL THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK REAL ZERO,TWO,ONE PARAMETER(ZERO = 0.0E0,TWO = 2.0E0,ONE = 1.0E0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) ) THEN MTRANS = 0 KEEP(95) =1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS=0 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(N+1:2*N) CALL SMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*KEEP(10) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8*N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8*N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2*N+1:3*N) IF(MTRANSLOC.NE.1) THEN CALL SMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL SMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL SMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) GO TO 400 IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC(N+1:2*N) FLAG => IKEEPALLOC(2*N+1:3*N) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL SMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in SMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in SMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE SMUMPS_ANA_O END MODULE SMUMPS_ANA_AUX_M SUBROUTINE SMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL SMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE SMUMPS_ANA_K SUBROUTINE SMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max0(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM SMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE SMUMPS_ANA_J SUBROUTINE SMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE SMUMPS_ANA_D #if defined(OLDDFS) SUBROUTINE SMUMPS_ANA_L(N, IPE, NV, IPS, NE, NA, NFSIZ, & NSTEPS, & FILS, FRERE,NDD,NEMIN, KEEP60) INTEGER N,NSTEPS INTEGER NDD(N) INTEGER FILS(N), FRERE(N) INTEGER IPS(N), NE(N), NA(N), NFSIZ(N) INTEGER IPE(N), NV(N) INTEGER NEMIN, KEEP60 INTEGER I,IF,IS,NR,NR1,INS,INL,INB,INF,INFS,INSW INTEGER K,L,ISON,IN,INP,IFSON,INC,INO INTEGER INOS,IB,IL DO 10 I=1,N IPS(I) = 0 NE(I) = 0 10 CONTINUE DO 20 I=1,N IF (NV(I).GT.0) GO TO 20 IF = -IPE(I) IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I 20 CONTINUE NR = N + 1 DO 50 I=1,N IF (NV(I).LE.0) GO TO 50 IF = -IPE(I) IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF 50 CONTINUE DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (IPE(INS).LT.0) THEN INS = -IPE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (IPE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = IPE(INS) IF (NV(INB).EQ.0) THEN INS = INB GO TO 1070 ENDIF IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = IPE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB IPE(INS) = IPE(INB) IPE(INB) = INS INS = INB GO TO 1070 ENDIF INSW = INFS 1100 INFS = IPE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF IPE(INS) = IPE(INB) IPE(INB) = INS IPE(INSW)= INB INS =INB GO TO 1070 1151 CONTINUE DO 51 I=1,N FRERE(I) = IPE(I) FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IL = 0 DO 160 K=1,N IF (I.GT.0) GO TO 60 I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 60 DO 70 L=1,N IF (IPS(I).GE.0) GO TO 80 ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE 80 IPS(I) = K NE(IS) = NE(IS) + 1 IF (NV(I).GT.0) GO TO 89 IN = I 81 IN = FRERE(IN) IF (IN.GT.0) GO TO 81 IF = -IN IN = IF 82 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 82 IFSON = -IN FILS(INL) = I IN = I 83 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 83 IF (IFSON .EQ. I) GO TO 86 FILS(INP) = -IFSON IN = IFSON 84 INC =IN IN = FRERE(IN) IF (IN.NE.I) GO TO 84 FRERE(INC) = FRERE(I) GO TO 120 86 IF (FRERE(I).LT.0) FILS(INP) = 0 IF (FRERE(I).GT.0) FILS(INP) = -FRERE(I) GO TO 120 89 IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) NDD(IS) = NV(I) NFSIZ(I) = NV(I) IF (NA(IS).LT.1) GO TO 110 IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.NDD(IS)) ) GOTO 110 IF (NDD(IS-1)-NE(IS-1).EQ.NDD(IS)) GO TO 100 IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(NDD(IS)-NDD(IS-1)+NE(IS-1)).GE. & ((NDD(IS)+NE(IS-1))* & (NDD(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 NDD(IS-1) = NDD(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 IN=I 101 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 101 IFSON = -IN IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 FILS(INL) = INO NFSIZ(I) = NDD(IS-1) IN = INO 103 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 103 INOS = -IN IF (IFSON.EQ.INO) GO TO 107 IN = IFSON FILS(INP) = -IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) FRERE(INS) = -I IF (INOS.NE.0) FRERE(INS) = INOS IF (INOS.EQ.0) GO TO 109 107 IN = INOS IF (IN.EQ.0) GO TO 109 108 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -I 109 CONTINUE GO TO 120 110 IS = IS + 1 120 IB = IPE(I) IF (IB.LT.0) GOTO 150 IF (IB.EQ.0) GOTO 140 NA(IL) = 0 140 I = IB GO TO 160 150 I = -IB IL = IL + 1 160 CONTINUE NSTEPS = IS - 1 DO 170 I=1,N K = FILS(I) IF (K.GT.0) THEN FRERE(K) = N + 1 NFSIZ(K) = 0 ENDIF 170 CONTINUE RETURN END SUBROUTINE SMUMPS_ANA_L #else SUBROUTINE SMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 ENDIF DO 70 L=1,N IF (IPS(I).GE.0) EXIT ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE #if ! defined(NOAMALGTOFATHER) DADI = -IPE(I) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF IF ( (NV(I).GT. 50*NV(DADI)).AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. 0.2 ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & NODE(I) * 900 .LE. NV(DADI) - NAMALG(DADI)) THEN IF ( NAMALG(DADI) < (NV(DADI)-NAMALG(DADI))/50 ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ANA_LNEW #endif SUBROUTINE SMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE SMUMPS_ANA_M SUBROUTINE SMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ANA_R SUBROUTINE SMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(80), ICNTL(60), INFOG(80) INTEGER(8) KEEP8(150) REAL RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN WRITE(MPG, 99992) INFO(1), INFO(2), & KEEP8(109), KEEP8(111), INFOG(4), & INFOG(5), KEEP(28), INFOG(32), INFOG(7), KEEP(23), & ICNTL(7), KEEP(12), & ICNTL(18), & KEEP(56), KEEP(61), RINFOG(1) IF (KEEP(95).GT.1) & WRITE(MPG, 99993) KEEP(95) IF (KEEP(54).GT.0) WRITE(MPG, 99994) KEEP(54) IF (KEEP(60).GT.0) WRITE(MPG, 99995) KEEP(60) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' Number of level 2 nodes =',I16/ & ' Number of split nodes =',I16/ & ' RINFOG(1) Operations during elimination (estim)=', & 1PD10.3) 99993 FORMAT(' Ordering compressed/constrained (ICNTL(12)) =',I16) 99994 FORMAT(' Distributed matrix entry format (ICNTL(18)) =',I16) 99995 FORMAT(' Effective Schur option (ICNTL(19)) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) END SUBROUTINE SMUMPS_DIAG_ANA SUBROUTINE SMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER NFRONT, K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( real( NSLAVES - 1 ) ) & / log(2.0E0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) INODE = abs(IPOOL(1)) NFRONT = NFSIZ( INODE ) K79 = max( & int(NFRONT,8)*int(NFRONT,8)/(int(K82+1,8)*int(K82+1,8)), & 9_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL SMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE SMUMPS_CUTNODES RECURSIVE SUBROUTINE SMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM REAL WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( real(NSLAVESMAX-NSLAVESMIN)/real(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667E0 * & real(NPIV)*real(NPIV)*real(NPIV) + & real(NPIV)*real(NPIV)*real(NCB) WK_SLAVE = real( NPIV ) * real( NCB ) * & ( 2.0E0 * real(NFRONT) - real(NPIV) ) & / real(NSLAVES_ESTIM) ELSE WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV) / real(3) WK_SLAVE = & (real(NPIV)*real(NCB)*real(NFRONT)) & / real(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( real( 100 + STRAT ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ELSE IF ( real( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(real(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL SMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL SMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE SMUMPS_SPLIT_1NODE SUBROUTINE SMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0E0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE SMUMPS_ANA_GNEW SUBROUTINE SMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE SMUMPS_SET_K821_SURFACE SUBROUTINE SMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) REAL :: A(LA) REAL :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K REAL :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0E+00,ONE=1.0E+0) EXTERNAL SMUMPS_MTRANSZ,SMUMPS_MTRANSB,SMUMPS_MTRANSR, & SMUMPS_MTRANSS,SMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/real(2*N) RINF3 = 0.0E0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = int(4*N + M,8) IF (JOB.EQ.2) K = int(N + 2*M,8) IF (JOB.EQ.3) K = int(8*N + 2*M + NE,8) IF (JOB.EQ.4) K = int(N + M,8) IF (JOB.EQ.5) K = int(3*N + 2*M,8) IF (JOB.EQ.6) K = int(3*N + 2*M + NE,8) IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int( M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = int( 2*M,8) IF (JOB.EQ.5) K = int(N + 2*M,8) IF (JOB.EQ.6) K = int(N + 3*M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL SMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL SMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(N+1),IW(N+M+1),DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL SMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL SMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1), & IW(NE+N+1),IW(NE+2*N+1),IW(NE+3*N+1),IW(NE+4*N+1), & IW(NE+5*N+1),IW(NE+5*N+M+1),FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(M+N+N), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 INFOMUMPS(2) = M+N+N GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL SMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3*N+2*M+K) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2*M+N+I) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2*M+N+I)) THEN DW(2*M+N+I) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2*M+N+I).NE.ZERO) THEN DW(2*M+N+I) = 1.0E0/DW(2*M+N+I) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2*M+N+I) * A(K) 65 CONTINUE 66 CONTINUE CALL SMUMPS_MTRANSR(N,NE,IP,IW(3*N+2*M+1),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL SMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL SMUMPS_MTRANSW(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2*M+N+I).NE.0.0E0) THEN DW(I) = DW(I) + log(DW(2*M+N+I)) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2*M+J).NE.ZERO) THEN DW(M+J) = DW(M+J) - log(DW(2*M+J)) ELSE DW(M+J) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5E0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(M+J),J=1,min(10,N)) ENDIF ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,M) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,M) WRITE(ICNTL(3),9034) (DW(M+J),J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in SMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from SMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for SMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for SMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE SMUMPS_MTRANS_DRIVER SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) REAL, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE SMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE SMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE SMUMPS_SORT_PERM SUBROUTINE SMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, LRGROUPS_OLD, LRGROUPS_NEW, & K20, K38 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(NBLK) INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(N) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20, K38 INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO RETURN END SUBROUTINE SMUMPS_EXPAND_TREE_STEPS SUBROUTINE SMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) REAL PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE SMUMPS_DIST_AVOID_COPIES SUBROUTINE SMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE SMUMPS_SET_PROCNODE MUMPS_5.4.1/src/zsol_bwd_aux.F0000664000175000017500000020645414102210525016327 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE ZMUMPS_OOC USE ZMUMPS_BUF USE ZMUMPS_SOL_LR, only : ZMUMPS_SOL_BWD_LR_SU INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) :: A(LA), W(LWC) COMPLEX(kind=8) :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL COMPLEX(kind=8) ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR = 0_8 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) CALL ZMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 ZMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR = PTRACB(STEP( INODE )) - 1_8 CALL ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL ZMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL ZMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) ELSE IPOSINRHSCOMP = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL ZMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB_PANEL = PTWCB + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL ZMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL zgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL zgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE CALL ztrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ELSE CALL ztrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL ZMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL zgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL zgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL zgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSCOMP,8) & + int(IPOSINRHSCOMP,8) CALL ZMUMPS_SOLVE_BWD_TRSOLVE( A(1), LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSCOMP(1,1), KEEP8(25), LRHSCOMP, PPIV_COURANT, & MTYPE, KEEP) ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL ZMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE )) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL ZMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE ZMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX(kind=8) W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL ZMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE ZMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE ZMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE ZMUMPS_OOC USE ZMUMPS_SOL_LR, ONLY: ZMUMPS_SOL_SLAVE_LR_U, & ZMUMPS_SOL_BWD_LR_SU USE ZMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX(kind=8) W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG COMPLEX(kind=8) ZERO, ALPHA, ONE PARAMETER (ZERO=(0.0D0,0.0D0), & ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL ZMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_DOUBLE_COMPLEX, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSCOMP = abs( POSINRHSCOMP_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF ( (IPOSINRHSCOMP.EQ.0) .OR. & ( IPOSINRHSCOMP.GT.N ) ) CYCLE RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL ZMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL ZMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL ZMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_DOUBLE_COMPLEX, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL ZMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN CALL ZMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( LIELL*NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 260 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 260 END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - LIELL*NRHS_B PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTRACB(STEP(INODE))+NPIV-1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR8 = IFR8 + J2-KEEP(253)-J1+1 IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL ZMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, & NROW_L, NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL=NPANELS,1,-1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) PTWCB_PANEL = PTRACB(STEP(INODE)) + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL ZMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL zgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL zgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF CALL ztrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL zgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+NPIV ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF CALL ztrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL ZMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(1) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NRHS_B == 1 ) THEN CALL zgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE CALL zgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE #endif CALL ztrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(IPOS)) IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL ZMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IN))) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CONTINUE CALL ZMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, KEEP, & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL ZMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE ZMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE ZMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in ZMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE ZMUMPS_BUILD_PANEL_POS MUMPS_5.4.1/src/zfac_process_message.F0000664000175000017500000010400714102210524020002 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_LOAD USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(N) COMPLEX(kind=8) A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER MP, LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL ZMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="ZMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL ZMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL ZMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="ZMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL ZMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="ZMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL ZMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL ZMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL ZMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL ZMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL ZMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="ZMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL ZMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="ZMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL ZMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="ZMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL ZMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL ZMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL ZMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL ZMUMPS_PROCESS_RTNELIND( root, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="ZMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine ZMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE ZMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL ZMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) RETURN END SUBROUTINE ZMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE ZMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE ZMUMPS_LOAD USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL ZMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN IF (KEEP(117).NE.0) THEN WRITE(*,*) "Problem of active IRECV with KEEP(117)=",KEEP(117) CALL MUMPS_ABORT() ENDIF RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in ZMUMPS_TRY_RECVTREAT' CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL ZMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL ZMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE ZMUMPS_TRY_RECVTREAT SUBROUTINE ZMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE ZMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL ZMUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE ZMUMPS_CANCEL_IRECV SUBROUTINE ZMUMPS_CLEAN_PENDING( & INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & CLEAN_COMM_NODES, CLEAN_COMM_LOAD ) USE ZMUMPS_BUF IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR, LBUFR_BYTES INTEGER, INTENT(OUT) :: BUFR( LBUFR ) INTEGER, INTENT(IN) :: COMM_NODES, COMM_LOAD, SLAVEF, INFO1 INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, INTENT(IN) :: CLEAN_COMM_LOAD, CLEAN_COMM_NODES INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER :: MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER :: COMM_EFF INTEGER :: IERR INTEGER :: IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS INTEGER :: TOTAL_SEND_MINUS_RECV266 INTEGER :: TOTAL_SEND_MINUS_RECV267 IF (SLAVEF.EQ.1) RETURN IF (.NOT. CLEAN_COMM_NODES .AND. .NOT. CLEAN_COMM_LOAD) THEN RETURN ENDIF DO WHILE (.TRUE.) FLAG = .TRUE. DO WHILE ( FLAG ) FLAG = .FALSE. IF (CLEAN_COMM_NODES) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) END IF END IF IF (CLEAN_COMM_LOAD) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) IF (COMM_EFF .EQ. COMM_NODES) THEN KEEP(266) = KEEP(266) - 1 ELSE KEEP(267) = KEEP(267) - 1 ENDIF CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (MSGLEN_LOC .LE. LBUFR_BYTES) THEN CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF ENDIF END DO CALL ZMUMPS_BUF_ALL_EMPTY( CLEAN_COMM_NODES, & CLEAN_COMM_LOAD, & BUFFERS_EMPTY ) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF IF (CLEAN_COMM_NODES) THEN COMM_EFF = COMM_NODES ELSE COMM_EFF = COMM_LOAD ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_EFF, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN IF (CLEAN_COMM_NODES) THEN CALL MPI_ALLREDUCE(KEEP(266), & TOTAL_SEND_MINUS_RECV266, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV266 = 0 ENDIF IF (CLEAN_COMM_LOAD) THEN CALL MPI_ALLREDUCE(KEEP(267), & TOTAL_SEND_MINUS_RECV267, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV267 = 0 ENDIF IF (TOTAL_SEND_MINUS_RECV266 .EQ. 0 .AND. & TOTAL_SEND_MINUS_RECV267 .EQ. 0) THEN EXIT ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_CLEAN_PENDING MUMPS_5.4.1/src/ctype3_root.F0000664000175000017500000015157114102210523016076 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ASS_ROOT( root, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N COMPLEX VAL_SON( NCOL_SON, NROW_SON ) COMPLEX VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT COMPLEX RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ASS_ROOT RECURSIVE SUBROUTINE CMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_OOC USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX, DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL CMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in CMUMPS_BUILD_AND_SEND_CB_ROOT' CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ELSE IF (IGLOB .GT. N) THEN POS_IN_ROOT = IGLOB - N ELSE POS_IN_ROOT = root%RG2L_COL( IGLOB ) ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL(JGLOB) ELSE POS_IN_ROOT = JGLOB-N ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) IF (JGLOB.GT.N) THEN NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 ENDIF PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_COL(JGLOB) JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN POS_IN_ROOT = root%RG2L_ROW(JGLOB) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) NSUPROW(IROW+1) = NSUPROW(IROW+1)+1 PTRROW( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ENDIF ELSE IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod( ( POS_IN_ROOT - 1 ) / root%MBLOCK, & root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW ( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ELSE IF (IGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL( IGLOB ) ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_COL( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / & root%NBLOCK, root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ELSE IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 END IF END DO IF (BCP_SYM_NONEMPTY) THEN DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (IGLOB.LE.N) CYCLE POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ENDDO DO I=1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF (JGLOB.GT.N) THEN EXIT ELSE POS_IN_ROOT = root%RG2L_ROW(JGLOB) ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL CMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL CMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL CMUMPS_ROOT_LOCAL_ASSEMBLY( N, & root%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL CMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL CMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "CMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL CMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L_ROW(1), root%RG2L_COL(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW,INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL CMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING CMUMPS_BUILD_AND_SEND_CB_ROOT" CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING CMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE CMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in CMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE CMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE CMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L_ROW, RG2L_COL, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N COMPLEX VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL COMPLEX VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L_ROW( N ), RG2L_COL( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC COMPLEX RHS_ROOT( LOCAL_M, NLOC) INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB IF (KEEP(50).EQ.0) THEN DO ISUB = 1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL-NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL -NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IPOS_ROOT = RG2L_ROW(IGLOB) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( I, J ) END DO END DO ELSE DO ISUB = 1, NSUBSET_COL-NSUPCOL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = RG2L_COL( IGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = IGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE CMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE CMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (CMUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE, NPROWtemp, NPCOLtemp LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL CMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_INIT_ROOT_ANA SUBROUTINE CMUMPS_INIT_ROOT_FAC( N, root, FILS, IROOT, & KEEP, INFO ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( CMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(80), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) THEN DEALLOCATE( root%RG2L_ROW ) NULLIFY( root%RG2L_ROW ) ENDIF IF ( associated( root%RG2L_COL ) ) THEN DEALLOCATE( root%RG2L_COL ) NULLIFY( root%RG2L_COL ) ENDIF ALLOCATE( root%RG2L_ROW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=N RETURN ENDIF ALLOCATE( root%RG2L_COL( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN DEALLOCATE( root%RG2L_ROW ); NULLIFY( root%RG2L_ROW ) INFO(1)=-13 INFO(2)=N RETURN ENDIF INODE = IROOT I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L_ROW( INODE ) = I root%RG2L_COL( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE CMUMPS_INIT_ROOT_FAC SUBROUTINE CMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(real(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE CMUMPS_DEF_GRID SUBROUTINE CMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX APAR( LOCAL_M, LOCAL_N ) COMPLEX ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX, DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine CMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE CMUMPS_SCATTER_ROOT SUBROUTINE CMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX APAR( LOCAL_M, LOCAL_N ) COMPLEX ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX,DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine CMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_COMPLEX, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE CMUMPS_GATHER_ROOT SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (CMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) INTEGER numroc EXTERNAL numroc COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max(1, root%RHS_NLOC) ELSE root%RHS_NLOC = 1 ENDIF IF (associated( root%RHS_ROOT) ) & DEALLOCATE (root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(LOCAL_M,root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = LOCAL_M*root%RHS_NLOC RETURN ENDIF IF (KEEP(253).NE.0) THEN root%RHS_ROOT = ZERO CALL CMUMPS_ASM_RHS_ROOT ( N, FILS, & root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL CMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL CMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL CMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL CMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL CMUMPS_ASM_ELT_ROOT( N, root, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL CMUMPS_ASM_ELT_ROOT( N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ROOT_ALLOC_STATIC SUBROUTINE CMUMPS_ASM_ELT_ROOT( N, root, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) COMPLEX VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) COMPLEX DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, JGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI JGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L_ROW(JGLOB) ENDDO DO J = 1, SIZEI JGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = INTARR(J1+I-1) IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE CMUMPS_ASM_ELT_ROOT SUBROUTINE CMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER FILS(N) TYPE (CMUMPS_ROOT_STRUC ) :: root COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER JCOL, IPOS_ROOT, JPOS_ROOT, & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS, & INODE INODE = KEEP(38) DO WHILE (INODE.GT.0) IPOS_ROOT = root%RG2L_ROW( INODE ) IROW_GRID = mod( ( IPOS_ROOT - 1 ) / root%MBLOCK, root%NPROW ) IF ( IROW_GRID .NE. root%MYROW ) GOTO 100 ILOCRHS = root%MBLOCK * ( ( IPOS_ROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOS_ROOT - 1, root%MBLOCK ) + 1 DO JCOL = 1, KEEP(253) JPOS_ROOT = JCOL JCOL_GRID = mod((JPOS_ROOT-1)/root%NBLOCK, root%NPCOL) IF (JCOL_GRID.NE.root%MYCOL ) CYCLE JLOCRHS = root%NBLOCK * ( ( JPOS_ROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOS_ROOT - 1, root%NBLOCK ) + 1 root%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE CMUMPS_ASM_RHS_ROOT SUBROUTINE CMUMPS_ASM_ARR_ROOT( N, root, IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRARW( N ), PTRAIW( N ) COMPLEX VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) COMPLEX DBLARR(LDBLARR) COMPLEX VAL INTEGER(8) :: JJ, J1,JK, J2,J3, J4, AINPUT INTEGER IORG, IBROT, NUMORG, & IROW, JCOL INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IBROT = IROOT DO IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) IBROT = FILS(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ASM_ARR_ROOT MUMPS_5.4.1/src/estim_flops.F0000664000175000017500000001213614102210475016147 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_ESTIM_FLOPS( INODE, N, PROCNODE_STEPS, & KEEP199, & ND, FILS, FRERE_STEPS, STEP, PIMASTER, & KEEP28, KEEP50, KEEP253, & FLOP1, & IW, LIW, XSIZE ) IMPLICIT NONE INTEGER INODE, N, KEEP50, LIW, KEEP199, KEEP28, KEEP253 INTEGER PROCNODE_STEPS(KEEP28), ND(KEEP28), & FILS(N), FRERE_STEPS(KEEP28), & STEP(N), & PIMASTER(KEEP28), & IW( LIW ) INTEGER XSIZE DOUBLE PRECISION FLOP1 INTEGER NUMORG, IN, NASS, IFSON, NUMSTK, NFRONT, NPIV, NCB, & LEVEL, ISON LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_IN_OR_ROOT_SSARBR, MUMPS_TYPENODE INCLUDE 'mumps_headers.h' FLOP1 = 0.0D0 IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP199) ) RETURN IN = INODE NUMORG = 0 10 NUMORG = NUMORG + 1 IN = FILS(IN) IF (IN .GT. 0) GOTO 10 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .EQ. 0) GOTO 30 20 NUMSTK = NUMSTK + 1 NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 +XSIZE) ISON = FRERE_STEPS(STEP(ISON)) IF (ISON .GT. 0) GOTO 20 30 NFRONT = ND(STEP(INODE)) + NASS + KEEP253 NPIV = NASS + NUMORG NCB = NFRONT - NPIV LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP199) CALL MUMPS_GET_FLOPS_COST(NFRONT,NPIV,NPIV,KEEP50,LEVEL,FLOP1) RETURN END SUBROUTINE MUMPS_ESTIM_FLOPS SUBROUTINE MUMPS_UPDATE_FLOPS_ROOT(OPELIW, KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) OPELIW = OPELIW + COST_PER_PROC RETURN END SUBROUTINE MUMPS_UPDATE_FLOPS_ROOT SUBROUTINE MUMPS_GET_FLOPS_COST(NFRONT,NPIV,NASS, & KEEP50,LEVEL,COST) IMPLICIT NONE INTEGER, intent(in) :: NFRONT,NPIV,KEEP50,LEVEL, NASS DOUBLE PRECISION, intent(out) :: COST IF (KEEP50.EQ.0) THEN IF (LEVEL.EQ.1 .OR. LEVEL.EQ.3) THEN COST = dble(2) * dble(NFRONT) * dble(NPIV) * & dble(NFRONT - NPIV - 1) + & dble(NPIV) * dble(NPIV + 1) * dble(2 * NPIV + 1) & / dble(3) COST = COST + dble(2 * NFRONT - NPIV - 1) & * dble(NPIV) /dble(2) ELSEIF (LEVEL.EQ.2) THEN COST = dble(2*NASS)*dble(NFRONT) - & dble(NASS+NFRONT)*dble(NPIV+1) COST = dble(NPIV)*COST + & dble(2 * NASS - NPIV - 1) * dble(NPIV) / dble(2) + & dble(NPIV) * dble(NPIV + 1) * & dble(2 * NPIV + 1) /dble(3) ENDIF ELSE IF (LEVEL.EQ.1 .OR. (LEVEL.EQ.3 .AND. KEEP50.EQ.1)) THEN COST = dble(NPIV) * ( & dble( NFRONT ) * dble( NFRONT ) + & dble( NFRONT ) - ( & dble( NFRONT)*dble(NPIV) + dble(NPIV+1) & )) +( dble(NPIV)*dble(NPIV+1) & *dble(2*NPIV+1))/ dble(6) ELSE IF (LEVEL.EQ.3.AND.KEEP50.EQ.2) THEN COST = dble(2) * dble(NFRONT) * dble(NPIV) * & dble(NFRONT - NPIV - 1) + & dble(NPIV) * dble(NPIV + 1) * & dble(2 * NPIV + 1) / dble(3) COST = COST + dble(2 * NFRONT - NPIV - 1) & * dble(NPIV) / dble(2) ELSE COST = dble(NPIV) * ( & dble( NASS ) * dble( NASS ) + dble( NASS ) & - ( dble( NASS) * dble(NPIV) + dble( NPIV + 1 ) ) ) & + ( dble(NPIV)*dble(NPIV+1)*dble(2*NPIV+1) ) & / dble( 6 ) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_GET_FLOPS_COST SUBROUTINE MUMPS_PRINT_STILL_ACTIVE(MYID, KEEP, DKEEP17, OPELIW, & OPLAST_PRINTED, MPA) IMPLICIT NONE INTEGER, intent(in) :: KEEP (500), MYID, MPA DOUBLE PRECISION :: DKEEP17 DOUBLE PRECISION, intent(in) :: OPELIW DOUBLE PRECISION, intent(inout) :: OPLAST_PRINTED IF (MPA.GT.0) THEN IF ( (OPELIW-OPLAST_PRINTED).GT. DKEEP17) THEN WRITE(MPA,'(A,I6,A,A,1PD10.3)') & ' ... MPI process', MYID, & ': theoretical number of flops locally performed', & ' so far = ', & OPELIW OPLAST_PRINTED = OPELIW ENDIF ENDIF RETURN END SUBROUTINE MUMPS_PRINT_STILL_ACTIVE MUMPS_5.4.1/src/cfac_scalings_simScale_util.F0000664000175000017500000011755214102210526021264 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_CREATEPARTVEC(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, OSZ, & IWRK, IWSZ) C IMPLICIT NONE EXTERNAL CMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWSZ INTEGER, INTENT(IN) :: ISZ, OSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 4*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(CMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL CMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL CMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif C WE FIRST ZERO OUT DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.OSZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_CREATEPARTVEC C C SEPARATOR: Another function begins C C SUBROUTINE CMUMPS_FINDNUMMYROWCOL(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & INUMMYR, & INUMMYC, & IWRK, IWSZ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: MYID, NUMPROCS, M, N, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C [ROW/COL]PARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: ROWPARTVEC(M) INTEGER, INTENT(IN) :: COLPARTVEC(N) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C INUMMYR < M and INUMMYC < N (CPA or <= ??) C INUMMYR holds the number of rows allocated to me C or non empty on my proc C INUMMYC idem with columns INTEGER INUMMYR, INUMMYC C C INTERNAL working array INTEGER IWRK(IWSZ) C C Local variables INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 INUMMYC = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED C INUMMYR first counts number of rows affected to me C (that will be centralized on MYID) DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) THEN IWRK(I)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IC = JCN_loc(I8) IR = IRN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) THEN IWRK(IC)= 1 INUMMYC = INUMMYC + 1 ENDIF ENDIF ENDDO C RETURN END SUBROUTINE CMUMPS_FINDNUMMYROWCOL SUBROUTINE CMUMPS_FILLMYROWCOLINDICES(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & ROWPARTVEC, COLPARTVEC, M, N, & MYROWINDICES, INUMMYR, & MYCOLINDICES, INUMMYC, & IWRK, IWSZ ) IMPLICIT NONE INTEGER(8) :: NZ_loc INTEGER MYID, NUMPROCS, M, N INTEGER INUMMYR, INUMMYC, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER ROWPARTVEC(M) INTEGER COLPARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER MYCOLINDICES(INUMMYC) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = M IF(N > MAXMN) MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,M IWRK(I) = 0 IF(ROWPARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,M IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C DO THE SMAME THING FOR COLS DO I=1,N IWRK(I) = 0 IF(COLPARTVEC(I).EQ.MYID) IWRK(I)= 1 ENDDO DO I8=1,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.M).AND. & ((IC.GE.1).AND.(IC.LE.N)) ) THEN IF(IWRK(IC) .EQ. 0) IWRK(IC)= 1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYCOLINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C RETURN END SUBROUTINE CMUMPS_FILLMYROWCOLINDICES C C SEPARATOR: Another function begins C C INTEGER FUNCTION CMUMPS_CHK1LOC(D, DSZ, INDX, INDXSZ, EPS) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL EPS C LOCAL VARS INTEGER I, IID REAL RONE PARAMETER(RONE=1.0E0) CMUMPS_CHK1LOC = 1 DO I=1, INDXSZ IID = INDX(I) IF (.NOT.( (D(IID).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(IID)) )) THEN CMUMPS_CHK1LOC = 0 ENDIF ENDDO RETURN END FUNCTION CMUMPS_CHK1LOC INTEGER FUNCTION CMUMPS_CHK1CONV(D, DSZ, EPS) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL EPS C LOCAL VARS INTEGER I REAL RONE PARAMETER(RONE=1.0E0) CMUMPS_CHK1CONV = 1 DO I=1, DSZ IF (.NOT.( (D(I).LE.(RONE+EPS)).AND. & ((RONE-EPS).LE.D(I)) )) THEN CMUMPS_CHK1CONV = 0 ENDIF ENDDO RETURN END FUNCTION CMUMPS_CHK1CONV C C SEPARATOR: Another function begins C INTEGER FUNCTION CMUMPS_CHKCONVGLO(DR, M, INDXR, INDXRSZ, & DC, N, INDXC, INDXCSZ, EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER M, N, INDXRSZ, INDXCSZ REAL DR(M), DC(N) INTEGER INDXR(INDXRSZ), INDXC(INDXCSZ) REAL EPS INTEGER COMM EXTERNAL CMUMPS_CHK1LOC INTEGER CMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRESC, MYRES INTEGER IERR MYRESR = CMUMPS_CHK1LOC(DR, M, INDXR, INDXRSZ, EPS) MYRESC = CMUMPS_CHK1LOC(DC, N, INDXC, INDXCSZ, EPS) MYRES = MYRESR + MYRESC CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) CMUMPS_CHKCONVGLO = GLORES RETURN END FUNCTION CMUMPS_CHKCONVGLO C C SEPARATOR: Another function begins C REAL FUNCTION CMUMPS_ERRSCALOC(D, TMPD, DSZ, & INDX, INDXSZ) C THE VAR D IS NOT USED IN COMPUTATIONS. C IT IS THERE FOR READIBLITY OF THE *simScaleAbs.F IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I, IIND REAL ERRMAX INTRINSIC abs ERRMAX = -RONE DO I=1,INDXSZ IIND = INDX(I) IF(abs(RONE-TMPD(IIND)).GT.ERRMAX) THEN ERRMAX = abs(RONE-TMPD(IIND)) ENDIF ENDDO CMUMPS_ERRSCALOC = ERRMAX RETURN END FUNCTION CMUMPS_ERRSCALOC REAL FUNCTION CMUMPS_ERRSCA1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) C LOCAL VARS REAL RONE PARAMETER(RONE=1.0E0) INTEGER I REAL ERRMAX1 INTRINSIC abs ERRMAX1 = -RONE DO I=1,DSZ IF(abs(RONE-TMPD(I)).GT.ERRMAX1) THEN ERRMAX1 = abs(RONE-TMPD(I)) ENDIF ENDDO CMUMPS_ERRSCA1 = ERRMAX1 RETURN END FUNCTION CMUMPS_ERRSCA1 C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_UPDATESCALE(D, TMPD, DSZ, & INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) REAL TMPD(DSZ) INTEGER INDX(INDXSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I, IIND REAL RZERO PARAMETER(RZERO=0.0E0) DO I=1,INDXSZ IIND = INDX(I) IF (TMPD(IIND).NE.RZERO) D(IIND) = D(IIND)/sqrt(TMPD(IIND)) ENDDO RETURN END SUBROUTINE CMUMPS_UPDATESCALE SUBROUTINE CMUMPS_UPSCALE1(D, TMPD, DSZ) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL TMPD(DSZ) INTRINSIC sqrt C LOCAL VARS INTEGER I REAL RZERO PARAMETER(RZERO=0.0E0) DO I=1,DSZ IF (TMPD(I) .NE. RZERO) D(I) = D(I)/sqrt(TMPD(I)) ENDDO RETURN END SUBROUTINE CMUMPS_UPSCALE1 C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_INITREALLST(D, DSZ, INDX, INDXSZ, VAL) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) REAL VAL C LOCAL VARS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = VAL ENDDO RETURN END SUBROUTINE CMUMPS_INITREALLST C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_INVLIST(D, DSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER DSZ, INDXSZ REAL D(DSZ) INTEGER INDX(INDXSZ) C LOCALS INTEGER I, IIND DO I=1,INDXSZ IIND = INDX(I) D(IIND) = 1.0E0/D(IIND) ENDDO RETURN END SUBROUTINE CMUMPS_INVLIST C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_INITREAL(D, DSZ, VAL) IMPLICIT NONE INTEGER DSZ REAL D(DSZ) REAL VAL C LOCAL VARS INTEGER I DO I=1,DSZ D(I) = VAL ENDDO RETURN END SUBROUTINE CMUMPS_INITREAL C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_ZEROOUT(TMPD, TMPSZ, INDX, INDXSZ) IMPLICIT NONE INTEGER TMPSZ,INDXSZ REAL TMPD(TMPSZ) INTEGER INDX(INDXSZ) C LOCAL VAR INTEGER I REAL DZERO PARAMETER(DZERO=0.0E0) DO I=1,INDXSZ TMPD(INDX(I)) = DZERO ENDDO RETURN END SUBROUTINE CMUMPS_ZEROOUT C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_BUREDUCE(INV, INOUTV, LEN, DTYPE) C C Like MPI_MINLOC operation (with ties broken sometimes with min C and sometimes with max) C The objective is find for each entry row/col C the processor with largest number of entries in its row/col C When 2 procs have the same number of entries in the row/col C then C if this number of entries is odd we take the proc with largest id C if this number of entries is even we take the proc with smallest id C IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: LEN INTEGER(4) :: INV(2*LEN) INTEGER(4) :: INOUTV(2*LEN) INTEGER(4) :: DTYPE #else INTEGER :: LEN INTEGER :: INV(2*LEN) INTEGER :: INOUTV(2*LEN) INTEGER :: DTYPE #endif INTEGER I #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) DIN, DINOUT, PIN, PINOUT #else INTEGER DIN, DINOUT, PIN, PINOUT #endif DO I=1,2*LEN-1,2 DIN = INV(I) ! nb of entries in row/col PIN = INV(I+1) ! proc number C DINOUT DINOUT = INOUTV(I) PINOUT = INOUTV(I+1) IF (DINOUT < DIN) THEN INOUTV(I) = DIN INOUTV(I+1) = PIN ELSE IF (DINOUT == DIN) THEN C --INOUTV(I) = DIN C --even number I take smallest Process number (pin) IF ((mod(DINOUT,2).EQ.0).AND.(PINPINOUT)) THEN C --odd number I take largest Process number (pin) INOUTV(I+1) = PIN ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_BUREDUCE C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_IBUINIT(IW, IWSZ, IVAL) IMPLICIT NONE INTEGER IWSZ #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) IW(IWSZ) INTEGER(4) IVAL #else INTEGER IW(IWSZ) INTEGER IVAL #endif INTEGER I DO I=1,IWSZ IW(I)=IVAL ENDDO RETURN END SUBROUTINE CMUMPS_IBUINIT C C SEPARATOR: Another function begins C C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_NUMVOLSNDRCV(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX,ISNDRCVNUM,ISNDRCVVOL, & OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ, OSZ INTEGER, INTENT(IN) :: COMM C When INDX holds row indices O(ther)INDX hold col indices INTEGER, INTENT(IN) :: INDX(NZ_loc) INTEGER, INTENT(IN) :: OINDX(NZ_loc) C On entry IPARTVEC(I) holds proc number with largest number of entries C in row/col I INTEGER, INTENT(IN) :: IPARTVEC(ISZ) C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER, INTENT(OUT) :: SNDSZ(NUMPROCS) INTEGER, INTENT(OUT) :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, OSNDRCVNUM INTEGER, INTENT(OUT) :: ISNDRCVVOL, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ))THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE CMUMPS_NUMVOLSNDRCV C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_SETUPCOMMS(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OSZ, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER(8) :: NZ_loc INTEGER ISNDVOL, OSNDVOL INTEGER MYID, NUMPROCS, ISZ, OSZ C ISZ is either M or N INTEGER INDX(NZ_loc) INTEGER OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER :: ISNDRCVNUM INTEGER INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM INTEGER ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND, IIND2, IPID, OFFS INTEGER IWHERETO, POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND. & (IIND2.GE.1).AND.(IIND2.LE.OSZ) ) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE CMUMPS_SETUPCOMMS C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_DOCOMMINF(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) IF(TMPD(IID) < ISNDRCVA(J)) TMPD(IID)= ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_DOCOMMINF C C SEPARATOR: Another function begins C SUBROUTINE CMUMPS_DOCOMM1N(MYID, NUMPROCS,TMPD, IDSZ, ITAGCOMM, & ISNDRCVNUM, INGHBPRCS, & ISNDRCVVOL, ISNDRCVIA, ISNDRCVJA, ISNDRCVA, & OSNDRCVNUM, ONGHBPRCS, & OSNDRCVVOL, OSNDRCVIA, OSNDRCVJA, OSNDRCVA, & ISTATUS, REQUESTS, & COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, IDSZ, ITAGCOMM INTEGER ISNDRCVNUM,OSNDRCVNUM, ISNDRCVVOL, OSNDRCVVOL REAL TMPD(IDSZ) INTEGER INGHBPRCS(ISNDRCVNUM), ONGHBPRCS(OSNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1), ISNDRCVJA(ISNDRCVVOL) REAL ISNDRCVA(ISNDRCVVOL) INTEGER OSNDRCVIA(NUMPROCS+1), OSNDRCVJA(OSNDRCVVOL) REAL OSNDRCVA(OSNDRCVVOL) INTEGER ISTATUS(MPI_STATUS_SIZE, max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER REQUESTS(max(ISNDRCVNUM,OSNDRCVNUM)) INTEGER COMM, IERROR C LOCAL VARS INTEGER I, PID, OFFS, SZ, J, JS, JE, IID DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1) - ISNDRCVIA(PID) CALL MPI_IRECV(ISNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS, JE IID = OSNDRCVJA(J) OSNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(OSNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM, COMM, IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF C FOLD INTO MY D DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1)-1 DO J=JS,JE IID = ISNDRCVJA(J) TMPD(IID) = TMPD(IID)+ ISNDRCVA(J) ENDDO ENDDO C COMMUNICATE THE UPDATED ONES DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) OFFS = OSNDRCVIA(PID) SZ = OSNDRCVIA(PID+1) - OSNDRCVIA(PID) CALL MPI_IRECV(OSNDRCVA(OFFS), SZ, & MPI_REAL, PID-1, & ITAGCOMM+1,COMM,REQUESTS(I), IERROR) ENDDO DO I=1,ISNDRCVNUM PID = INGHBPRCS(I) OFFS = ISNDRCVIA(PID) SZ = ISNDRCVIA(PID+1)-ISNDRCVIA(PID) JS = ISNDRCVIA(PID) JE = ISNDRCVIA(PID+1) -1 DO J=JS, JE IID = ISNDRCVJA(J) ISNDRCVA(J) = TMPD(IID) ENDDO CALL MPI_SEND(ISNDRCVA(OFFS), SZ, MPI_REAL, PID-1, & ITAGCOMM+1, COMM, IERROR) ENDDO IF(OSNDRCVNUM > 0) THEN CALL MPI_WAITALL(OSNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF DO I=1,OSNDRCVNUM PID = ONGHBPRCS(I) JS = OSNDRCVIA(PID) JE = OSNDRCVIA(PID+1) - 1 DO J=JS,JE IID = OSNDRCVJA(J) TMPD(IID)=OSNDRCVA(J) ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_DOCOMM1N SUBROUTINE CMUMPS_CREATEPARTVECSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & IPARTVEC, ISZ, & IWRK, IWSZ) IMPLICIT NONE EXTERNAL CMUMPS_BUREDUCE INTEGER, INTENT(IN) :: MYID, NUMPROCS, COMM INTEGER(8) :: NZ_loc INTEGER, INTENT(IN) :: ISZ, IWSZ INTEGER, INTENT(IN) :: IRN_loc(NZ_loc), JCN_loc(NZ_loc) C C OUTPUT C IPARTVEC(I) = proc number with largest number of entries C in row/col I INTEGER, INTENT(OUT) :: IPARTVEC(ISZ) C C INTERNAL WORKING ARRAY C IWRK (1:2*ISZ) is initialized to couples (MYID, Nb of entries C on my proc and in row/col I) for I=1,ISZ C (2*ISZ+1: 4*ISZ) is then set to C the processor with largest number of entries in its row/col C and its value (that is copied back into IPARTVEC(I) #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(OUT) :: IWRK(IWSZ) #else INTEGER, INTENT(OUT) :: IWRK(IWSZ) #endif INCLUDE 'mpif.h' C C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER OP, IERROR INTEGER IR, IC C IF(NUMPROCS.NE.1) THEN C CHECK done outsize C IF(IWSZ < 2*ISZ) THEN C CHECK ENDS CALL MPI_OP_CREATE(CMUMPS_BUREDUCE, .TRUE., OP, IERROR) C PERFORM THE REDUCTION #if defined(WORKAROUNDINTELILP64MPI2INTEGER) CALL CMUMPS_IBUINIT(IWRK, 4*ISZ, int(ISZ,4)) #else CALL CMUMPS_IBUINIT(IWRK, 4*ISZ, ISZ) #endif DO I=1,ISZ IWRK(2*I-1) = 0 IWRK(2*I) = MYID ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.ISZ).AND. & (IC.GE.1).AND.(IC.LE.ISZ)) THEN IWRK(2*IR-1) = IWRK(2*IR-1) + 1 IWRK(2*IC-1) = IWRK(2*IC-1) + 1 ENDIF ENDDO CALL MPI_ALLREDUCE(IWRK(1), IWRK(1+2*ISZ), ISZ, & MPI_2INTEGER, OP, COMM, IERROR) DO I=1,ISZ IPARTVEC(I) = IWRK(2*I+2*ISZ) ENDDO C FREE THE OPERATOR CALL MPI_OP_FREE(OP, IERROR) ELSE DO I=1,ISZ IPARTVEC(I) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_CREATEPARTVECSYM SUBROUTINE CMUMPS_NUMVOLSNDRCVSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX,OINDX,ISNDRCVNUM,ISNDRCVVOL,OSNDRCVNUM,OSNDRCVVOL, & IWRK,IWRKSZ, SNDSZ, RCVSZ, COMM) IMPLICIT NONE INTEGER(8), INTENT(IN) :: NZ_loc INTEGER, INTENT(IN) :: IWRKSZ INTEGER, INTENT(IN) :: MYID, NUMPROCS, ISZ INTEGER, INTENT(IN) :: INDX(NZ_loc), OINDX(NZ_loc) INTEGER, INTENT(IN) :: IPARTVEC(ISZ) INTEGER, INTENT(IN) :: COMM C C OUTPUT PARAMETERS C SNDSZ (IPROC+1) is set to the number of rows (or col) that C MYID will have to send to IPROC C RCVSZ(IPROC+1) is set to the nb of row/cols that C MYID will receive from IPROC INTEGER :: SNDSZ(NUMPROCS) INTEGER :: RCVSZ(NUMPROCS) C OSNDRCVNUM is set to the total number of procs C destination of messages from MYID (< NUMPROCS) C ISNDRCVNUM is set to the total number procs C that will send messages to MYID (< NUMPROCS) C ISNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C OSNDRCVVOL is set to the total number of row/col that C MYID will have to send to other procs C (bounded by N) C Knowing that for each row the process with the largest C number of entries will centralize all indices then C ISNDRCVVOL and OSNDRCVVOL are bounded by N INTEGER, INTENT(OUT) :: ISNDRCVNUM, ISNDRCVVOL INTEGER, INTENT(OUT) :: OSNDRCVNUM, OSNDRCVVOL C C INTERNAL WORKING ARRAY INTEGER, INTENT(OUT) :: IWRK(IWRKSZ) INCLUDE 'mpif.h' C LOCAL VARS INTEGER I INTEGER(8) :: I8 INTEGER IIND, IIND2, PIND INTEGER IERROR C check done outsize C IF(ISZ>IWRKSZ) THEN ERROR DO I=1,NUMPROCS SNDSZ(I) = 0 RCVSZ(I) = 0 ENDDO DO I=1,IWRKSZ IWRK(I) = 0 ENDDO C C set SNDSZ DO I8=1_8,NZ_loc IIND = INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN C MYID will send row/col IIND to proc PIND C (PIND has the largest nb of entries in row/con IIND IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF IIND = OINDX(I8) PIND = IPARTVEC(IIND) IF(PIND .NE. MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWRK(IIND) = 1 SNDSZ(PIND+1) = SNDSZ(PIND+1)+1 ENDIF ENDIF ENDIF ENDDO C C use SNDSZ to set RCVSZ CALL MPI_ALLTOALL(SNDSZ, 1, MPI_INTEGER, & RCVSZ, 1, MPI_INTEGER, COMM, IERROR) C C compute number of procs destinations of messages from MYID C number of row/col sent by MYID. ISNDRCVNUM = 0 ISNDRCVVOL = 0 OSNDRCVNUM = 0 OSNDRCVVOL = 0 DO I=1, NUMPROCS IF(SNDSZ(I) > 0) OSNDRCVNUM = OSNDRCVNUM + 1 OSNDRCVVOL = OSNDRCVVOL + SNDSZ(I) IF(RCVSZ(I) > 0) ISNDRCVNUM = ISNDRCVNUM + 1 ISNDRCVVOL = ISNDRCVVOL + RCVSZ(I) ENDDO RETURN END SUBROUTINE CMUMPS_NUMVOLSNDRCVSYM SUBROUTINE CMUMPS_FINDNUMMYROWCOLSYM(MYID, NUMPROCS, COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & INUMMYR, & IWRK, IWSZ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER INUMMYR INTEGER IWSZ INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC INTEGER(8) :: I8 C check done outsize C IF(IWSZ < M) THEN ERROR C IF(IWSZ < N) THEN ERROR INUMMYR = 0 C MARK MY ROWS. FIRST COUNT, C IF DYNAMIC MEMORY ALLOCATIOn WILL USED DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) THEN IWRK(I)=1 INUMMYR = INUMMYR + 1 ENDIF ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) THEN IWRK(IR)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC).EQ.0) THEN IWRK(IC)= 1 INUMMYR = INUMMYR + 1 ENDIF ENDIF ENDDO C THE SMAME THING APPLIES FOR COLS C No need to do anything C RETURN END SUBROUTINE CMUMPS_FINDNUMMYROWCOLSYM INTEGER FUNCTION CMUMPS_CHKCONVGLOSYM(D, N, INDXR, INDXRSZ, & EPS, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER N, INDXRSZ REAL D(N) INTEGER INDXR(INDXRSZ) REAL EPS INTEGER COMM EXTERNAL CMUMPS_CHK1LOC INTEGER CMUMPS_CHK1LOC INTEGER GLORES, MYRESR, MYRES INTEGER IERR MYRESR = CMUMPS_CHK1LOC(D, N, INDXR, INDXRSZ, EPS) MYRES = 2*MYRESR CALL MPI_ALLREDUCE(MYRES, GLORES, 1, MPI_INTEGER, & MPI_SUM, COMM, IERR) CMUMPS_CHKCONVGLOSYM = GLORES RETURN END FUNCTION CMUMPS_CHKCONVGLOSYM SUBROUTINE CMUMPS_FILLMYROWCOLINDICESSYM(MYID, NUMPROCS,COMM, & IRN_loc, JCN_loc, NZ_loc, & PARTVEC, N, & MYROWINDICES, INUMMYR, & IWRK, IWSZ ) IMPLICIT NONE INTEGER MYID, NUMPROCS, N INTEGER(8) :: NZ_loc INTEGER INUMMYR, IWSZ INTEGER IRN_loc(NZ_loc), JCN_loc(NZ_loc) INTEGER PARTVEC(N) INTEGER MYROWINDICES(INUMMYR) INTEGER IWRK(IWSZ) INTEGER COMM C INTEGER I, IR, IC, ITMP, MAXMN INTEGER(8) :: I8 C MAXMN = N C check done outsize C IF(IWSZ < MAXMN) THEN ERROR C MARK MY ROWS. DO I=1,N IWRK(I) = 0 IF(PARTVEC(I).EQ.MYID) IWRK(I)=1 ENDDO DO I8=1_8,NZ_loc IR = IRN_loc(I8) IC = JCN_loc(I8) IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IR) .EQ. 0) IWRK(IR)= 1 ENDIF IF((IR.GE.1).AND.(IR.LE.N).AND. & ((IC.GE.1).AND.(IC.LE.N))) THEN IF(IWRK(IC) .EQ.0) IWRK(IC)=1 ENDIF ENDDO C PUT MY ROWS INTO MYROWINDICES ITMP = 1 DO I=1,N IF(IWRK(I).EQ.1) THEN MYROWINDICES(ITMP) = I ITMP = ITMP + 1 ENDIF ENDDO C C C THE SMAME THING APPLY TO COLS C RETURN END SUBROUTINE CMUMPS_FILLMYROWCOLINDICESSYM SUBROUTINE CMUMPS_SETUPCOMMSSYM(MYID, NUMPROCS, ISZ, IPARTVEC, & NZ_loc, INDX, OINDX, & ISNDRCVNUM, ISNDVOL, INGHBPRCS, ISNDRCVIA, ISNDRCVJA, & OSNDRCVNUM, OSNDVOL, ONGHBPRCS, OSNDRCVIA, OSNDRCVJA, & SNDSZ, RCVSZ, IWRK, & ISTATUS, REQUESTS, & ITAGCOMM, COMM ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER MYID, NUMPROCS, ISZ, ISNDVOL, OSNDVOL INTEGER(8) :: NZ_loc C ISZ is either M or N INTEGER INDX(NZ_loc), OINDX(NZ_loc) C INDX is either IRN_loc or JCN_col INTEGER IPARTVEC(ISZ) C IPARTVEC is either rowpartvec or colpartvec INTEGER ISNDRCVNUM, INGHBPRCS(ISNDRCVNUM) INTEGER ISNDRCVIA(NUMPROCS+1) INTEGER ISNDRCVJA(ISNDVOL) INTEGER OSNDRCVNUM, ONGHBPRCS(OSNDRCVNUM) INTEGER OSNDRCVIA(NUMPROCS+1) INTEGER OSNDRCVJA(OSNDVOL) INTEGER SNDSZ(NUMPROCS) INTEGER RCVSZ(NUMPROCS) INTEGER IWRK(ISZ) INTEGER ISTATUS(MPI_STATUS_SIZE, ISNDRCVNUM) INTEGER REQUESTS(ISNDRCVNUM) INTEGER ITAGCOMM, COMM C LOCAL VARS INTEGER I, IIND,IIND2,IPID,OFFS,IWHERETO,POFFS, ITMP, IERROR INTEGER(8) :: I8 C COMPUATIONs START DO I=1,ISZ IWRK(I) = 0 ENDDO C INITIALIZE ONGHBPRCS using SNDSZ C INITIALIZE THE OSNDRCVIA using SNDSZ OFFS = 1 POFFS = 1 DO I=1,NUMPROCS OSNDRCVIA(I) = OFFS + SNDSZ(I) IF(SNDSZ(I) > 0) THEN ONGHBPRCS(POFFS)=I POFFS = POFFS + 1 ENDIF OFFS = OFFS + SNDSZ(I) ENDDO OSNDRCVIA(NUMPROCS+1) = OFFS C CHECK STARTS C check done outsize C IF(POFFS .NE. OSNDRCVNUM + 1)THEN ERROR C INIT DONE. FILL UP THE OSNDRCVJA(OSNDVOL) DO I8=1_8,NZ_loc IIND=INDX(I8) IIND2 = OINDX(I8) IF((IIND.GE.1).AND.(IIND.LE.ISZ).AND.(IIND2.GE.1) & .AND.(IIND2.LE.ISZ)) THEN IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF IIND = OINDX(I8) IPID=IPARTVEC(IIND) IF(IPID.NE.MYID) THEN IF(IWRK(IIND).EQ.0) THEN IWHERETO = OSNDRCVIA(IPID+1)-1 OSNDRCVIA(IPID+1) = OSNDRCVIA(IPID+1)-1 OSNDRCVJA(IWHERETO) = IIND IWRK(IIND) = 1 ENDIF ENDIF ENDIF ENDDO C FILLED UP, WHAT I WILL RECEIVE (My requests from others) C FILL UP ISNDRCVJA. It will be received to fill up CALL MPI_BARRIER(COMM,IERROR) OFFS = 1 POFFS = 1 ISNDRCVIA(1) = 1 DO I=2,NUMPROCS+1 ISNDRCVIA(I) = OFFS + RCVSZ(I-1) IF(RCVSZ(I-1) > 0) THEN INGHBPRCS(POFFS)=I-1 POFFS = POFFS + 1 ENDIF OFFS = OFFS + RCVSZ(I-1) ENDDO CALL MPI_BARRIER(COMM,IERROR) DO I=1, ISNDRCVNUM IPID = INGHBPRCS(I) OFFS = ISNDRCVIA(IPID) ITMP = ISNDRCVIA(IPID+1) - ISNDRCVIA(IPID) CALL MPI_IRECV(ISNDRCVJA(OFFS), ITMP, MPI_INTEGER,IPID-1, & ITAGCOMM, COMM, REQUESTS(I),IERROR) ENDDO DO I=1,OSNDRCVNUM IPID = ONGHBPRCS(I) OFFS = OSNDRCVIA(IPID) ITMP = OSNDRCVIA(IPID+1)-OSNDRCVIA(IPID) CALL MPI_SEND(OSNDRCVJA(OFFS), ITMP, MPI_INTEGER, IPID-1, & ITAGCOMM, COMM,IERROR) ENDDO IF(ISNDRCVNUM > 0) THEN CALL MPI_WAITALL(ISNDRCVNUM, REQUESTS(1),ISTATUS(1,1),IERROR) ENDIF CALL MPI_BARRIER(COMM,IERROR) RETURN END SUBROUTINE CMUMPS_SETUPCOMMSSYM MUMPS_5.4.1/src/zsol_bwd.F0000664000175000017500000001503414102210525015442 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE ZMUMPS_STATIC_PTR_M, ONLY : ZMUMPS_SET_STATIC_PTR, & ZMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS COMPLEX(kind=8) A(LA), W(LWC) COMPLEX(kind=8) W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine ZMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) BLOQ = ( III .EQ. IIPOOL ) CALL ZMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 CALL ZMUMPS_SET_STATIC_PTR(A) CALL ZMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL ZMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .EQ. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE ZMUMPS_SOL_S MUMPS_5.4.1/src/dfac_front_LU_type1.F0000664000175000017500000012153714102210523017452 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC1_LU_M CONTAINS SUBROUTINE DMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & , PERM & ) USE DMUMPS_FAC_FRONT_AUX_M USE DMUMPS_OOC USE DMUMPS_FAC_LR USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) DOUBLE PRECISION UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL DOUBLE PRECISION, POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR DOUBLE PRECISION, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) DOUBLE PRECISION, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC DOUBLE PRECISION :: ZERO PARAMETER (ZERO=0.0D0) INCLUDE 'mumps_headers.h' INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U) CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL DMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL DMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL DMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif CALL DMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL DMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL DMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL DMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL DMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL DMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL DMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL DMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL DMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL DMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0)) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL DMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL DMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) END SUBROUTINE DMUMPS_FAC1_LU END MODULE DMUMPS_FAC1_LU_M MUMPS_5.4.1/src/cmumps_f77.F0000664000175000017500000003601214102210523015603 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, & PERM_IN, PERM_INhere, RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, & SAVE_DIR, SAVE_PREFIX, & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, & SAVE_DIRLEN, SAVE_PREFIXLEN, & METIS_OPTIONS & ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=63, OOC_TMPDIR_MAX_LENGTH=255) PARAMETER(PB_MAX_LENGTH=255) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) COMPLEX, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) COMPLEX, TARGET :: WK_USER(*) COMPLEX, TARGET :: REDRHS(*) REAL, TARGET :: ROWSCA(*), COLSCA(*) COMPLEX, TARGET :: SCHUR(*) COMPLEX, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE CMUMPS_STRUC_PTR TYPE (CMUMPS_STRUC), POINTER :: PTR END TYPE CMUMPS_STRUC_PTR TYPE (CMUMPS_STRUC), POINTER :: mumps_par TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: CMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER CMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (CMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM EXTERNAL CMUMPS_ASSIGN_COLSCA, & CMUMPS_ASSIGN_ROWSCA IF (JOB == -1) THEN DO I = 1, CMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(CMUMPS_STRUC_ARRAY_SIZE + & CMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in CMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, CMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = CMUMPS_STRUC_ARRAY_SIZE+1, CMUMPS_STRUC_ARRAY_SIZE + & CMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = CMUMPS_STRUC_ARRAY_SIZE+1 CMUMPS_STRUC_ARRAY_SIZE = CMUMPS_STRUC_ARRAY_SIZE + & CMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in CMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0E0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0E0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & CMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in CMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in CMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%SCHUR_MLOC = SCHUR_MLOC mumps_par%SCHUR_NLOC = SCHUR_NLOC mumps_par%SCHUR_LLD = SCHUR_LLD mumps_par%MBLOCK = MBLOCK mumps_par%NBLOCK = NBLOCK mumps_par%NPROW = NPROW mumps_par%NPCOL = NPCOL IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO CALL CMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc SIZE_SCHUR = mumps_par%SIZE_SCHUR LWK_USER = mumps_par%LWK_USER NELT = mumps_par%NELT DEFICIENCY = mumps_par%Deficiency SCHUR_MLOC = mumps_par%SCHUR_MLOC SCHUR_NLOC = mumps_par%SCHUR_NLOC SCHUR_LLD = mumps_par%SCHUR_LLD MBLOCK = mumps_par%MBLOCK NBLOCK = mumps_par%NBLOCK NPROW = mumps_par%NPROW NPCOL = mumps_par%NPCOL IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF (associated( mumps_par%COLSCA)) THEN CALL CMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL CMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA)) THEN CALL CMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL CMUMPS_NULLIFY_C_ROWSCA() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,OOC_TMPDIR_MAX_LENGTH OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,OOC_PREFIX_MAX_LENGTH OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) CMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE CMUMPS_F77 MUMPS_5.4.1/src/mumps_register_thread.c0000664000175000017500000000106114102210474020246 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ void mumps_register_thread_return() { /* * Registering tools will be available in the future. */ } MUMPS_5.4.1/src/sfac_mem_stack_aux.F0000664000175000017500000001542214102210521017430 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_COMPACT_FACTORS(A, LDA, NPIV, NBROW, K50, & SIZEA ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 INTEGER(8), INTENT(IN) :: SIZEA REAL A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500 IF ( K50.NE.0 ) THEN IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN INEW = INEW + int(NPIV,8) * int(NPIV - 1,8) IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8) ELSE DO I = 1, NPIV - 1 IF ( I .LE. NPIV-2 ) THEN ILAST = I+1 ELSE ILAST = I ENDIF DO J8 = 0_8, int(ILAST,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) END DO ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW ELSE INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8) IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8) NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1 ENDIF DO I = 1, NBROW_L_RECTANGLE_TO_MOVE DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) ENDDO 500 RETURN END SUBROUTINE SMUMPS_COMPACT_FACTORS SUBROUTINE SMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA REAL, INTENT(INOUT) :: A(SIZEA) INTEGER I, J INTEGER(8) :: INEW, IOLD INEW = int(NPIV+1,8) IOLD = int(LDA+1,8) DO I = 2, NCONTIG DO J = 1, NPIV A(INEW)=A(IOLD) INEW = INEW + 1_8 IOLD = IOLD + 1_8 ENDDO IOLD = IOLD + int(LDA - NPIV,8) ENDDO RETURN END SUBROUTINE SMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE SMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB REAL A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) REAL ZERO PARAMETER( ZERO = 0.0E0 ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE SMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE SMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB REAL A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) REAL ZERO PARAMETER( ZERO = 0.0E0 ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE SMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.4.1/src/zmumps_driver.F0000664000175000017500000030333014102210526016525 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for ZMUMPS C (MPI based code) C =========================== C SUBROUTINE ZMUMPS( id ) USE ZMUMPS_OOC USE MUMPS_MEMORY_MOD USE ZMUMPS_STRUC_DEF USE ZMUMPS_STATIC_PTR_M ! For Schur pointer USE ZMUMPS_SAVE_RESTORE C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C C P. Amestoy, J.-Y. L'Excellent, G. Moreau, On exploiting sparsity of C multiple right-hand sides in sparse direct solvers, C SIAM Journal on Scientific Computing, volume 41, number 2, C pages A269-A291 (2019) C C G. Moreau, PhD Thesis, ENS-Lyon, University of Lyon, C On the solution phase of direct methods for sparse linear systems C with multiple sparse right-hand sides, December 10th, 2018 C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C Performance and scalability of the block low-rank multifrontal C factorization on multicore architectures, C ACM Transactions on Mathematical Software (2018) C C T. Mary, PhD Thesis, University of Toulouse, C Block Low-Rank multifrontal solvers: complexity, performance, and C scalability, November 2017. C C S. de la Kethulle de Ryhove, P. Jaysaval and D.V. Shantsev, C P. R. Amestoy, J.-Y. L'Excellent and T. Mary, C Large-scale 3D EM modeling with a Block Low-Rank MUMPS solver, C Geophysical Journal International, volume 209, number 3, C pages 1558-1571 (2017) . C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C On the complexity of the Block Low-Rank multifrontal factorization, C SIAM Journal on Scientific Computing, volume 39, C number 4, pages A1710-A1740 (2017). C C P. Amestoy, R. Brossier, A. Buttari, J.-Y. L'Excellent, T. Mary, C L. Metivier, A. Miniussi, and S. Operto. C Fast 3D frequency-domain full waveform inversion with a parallel C Block Low-Rank multifrontal direct solver: application to OBC data C from the North Sea, Geophysics, 81(6):R363--R383, (2016). C C P. Amestoy, C. Ashcraft, O. Boiteau, A. Buttari, J.-Y. L'Excellent, C and C. Weisbecker. C Improving multifrontal methods by means of block low-rank representations. C SIAM Journal on Scientific Computing, 37(3):A1451--A1474 (2015). C C W. M. Sid-Lakhdar, PhD Thesis from Universite de Lyon prepared at ENS Lyon, C Scaling the solution of large sparse linear systems using multifrontal C methods on hybrid shared-distributed memory architectures (2014). C C P. Amestoy, J.-Y. L'Excellent, W. Sid-Lakhdar, C Characterizing asynchronous broadcast trees for multifrontal factorizations, C Workshop on Combinatorial Scientific Computing, C Lyon, France, July 21-23 (2014). C C P. Amestoy, J.-Y. L'Excellent, F.-H. Rouet, W. Sid-Lakhdar, C Modeling 1D distributed-memory dense kernels for an asynchronous C multifrontal sparse solver, High-Performance Computing for Computational C Science, VECPAR 2014, Eugene, Oregon, USA, June 30 - July 3 (2014). C C J.-Y. L'Excellent and W. M. Sid-Lakhdar, C Introduction of shared-memory parallelism in a distributed-memroy C multifrontal solver, Parallel Computing (40):3-4, pages 34-46 (2014). C C C. Weisbecker, PhD Thesis supported by EDF, INPT-IRIT, C Improving multifrontal solvers by means of algebraic block low-rank C representations (2013). C C E. Agullo, P. Amestoy, A. Buttari, A. Guermouche, G. Joslin, J.-Y. C L'Excellent, X. S. Li, A. Napov, F.-H. Rouet, M. Sid-Lakhdar, S. Wang, C. C Weisbecker, I. Yamazaki, C Recent Advances in Sparse Direct Solvers, 22nd Conference on Structural C Mechanics in Reactor Technology, San Francisco (2013). C C P. Amestoy, A. Buttari, G. Joslin, J.-Y. L'Excellent, W. Sid-Lakhdar, C. C Weisbecker, M. Forzan, C. Pozza, R. Perrin, V. Pellissier, C Shared memory parallelism and low-rank approximation techniques applied C applied to direct solvers in FEM simulation in IEEE Transactions on C Magnetics, IEEE, Special issue, Compumag 2013 (2013). C C L. Boucher, P. Amestoy, A, Buttari, F.-H. Rouet and M. Chauvin, C INTEGRAL/SPI data segmentation to retrieve sources intensity variations, C Astronomy & Astrophysics, Article 52, 20 pages, C http://dx.doi.org/10.1051/0004-6361/201219605 (2013). C C F.-H. Rouet, PhD thesis from INPT, Toulouse, France, C Memory and Performance issues in parallel multifrontal factorization and C triangular solutions with sparse right-hand sides (2014). C C J.-Y. L'Excellent, Habilitation thesis from ENS Lyon, C Multifrontal methods: Parallelism, Memory Usage and Numerical C Aspects (2012). C C P. Amestoy, I.S. Duff, J.-Y. L'Excellent, Y. Robert, F.H. Rouet C and B. Ucar, On computing inverse entries of a sparse matrix in C an out-of-core environment, C SIAM J. on Scientific Computing Vol. 34 N. 4, p. 1975-1999 (2012). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C The Multifrontal Method, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C MUMPS, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Agullo, Guermouche and L'Excellent, Reducing the {I/O} Volume in C Sparse Out-of-core Multifrontal Methods}, SIAM SISC, Vol 31, Nb. 6, C 4774-4794 (2010). C C Amestoy, Duff, Guermouche, Slavova, Analysis of the Solution Phase of a C Parallel Multifrontal Approach, Parallel Computing, Vol. 36, 3--15 (2010). C C Tzvetomila Slavova, PhD from INPT prepared at CERFACS, C Parallel triangular solution in the out-of-core multifrontal approach C for solving large sparse linear systems, available as CERFACS C Report TH/PA/09/59 (2009). C C Agullo, Guermouche and L'Excellent, A Parallel Out-of-core Multifrontal C Method: Storage of Factors on Disk and Analysis of Models for an C Out-of-core Active Memory, Parallel Computing, Special Issue on Parallel C Matrix Algorithms, Vol. 34, Nb 6-8, 296--317 (2008). C C Emmanuel Agullo, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C On the Out-of-core Factorization of Large Sparse Matrices (Nov 2008). C C Amestoy, Duff, Ruiz, and Ucar, "A parallel C matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, (Jan 2008). C C Guermouche and L'Excellent, Constructing Memory-minimizing Schedules C for Multifrontal Methods, ACM TOMS, Vol. 32, Nb. 1, 17--32 (2006). C C Amestoy, Guermouche, L'Excellent, and Pralet, C Hybrid scheduling for the parallel solution C of linear systems. Vol 32 (2), pp 136-156 (2006). C C Stephane Pralet, PhD from INPT prepared at CERFACS, C Constrained orderings and scheduling for parallel sparse linear algebra, C available as CERFACS technical report, TH/PA/04/105, (Sept 2004). C C Abdou Guermouche, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C Etude et optimisation du comportement memoire dans les methodes paralleles C de factorisation de matrices creuses (2004). C C Guermouche, L'Excellent and Utard, Impact of Reordering on the Memory of a C Multifrontal Solver, Parallel Computing, Vol. 29, Nb. 9, 1191--1218 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Impact of the Implementation C of MPI Point-to-Point Communications on the Performance of Two General C Sparse Solvers, Parallel Computing, Vol. 29, Nb 7, 833--847 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Analysis and Comparison of C Two General Sparse Solvers for Distributed Memory Computers, ACM TOMS, C Vol. 27, Nb 4, 388--421 (2001). C C Amestoy, Duff, Koster and L'Excellent (2001), C A fully asynchronous multifrontal solver using distributed dynamic C scheduling, SIAM Journal of Matrix Analysis and Applications, C Vol 23, No 1, pp 15-41 (2001). C C Amestoy, Duff and L'Excellent (2000), C Multifrontal parallel distributed symmetric and unsymmetric solvers, C Comput. Methods in Appl. Mech. Eng., 184, 501-520 (2000) C C Amestoy, Duff and L'Excellent (1998), C Parallelisation de la factorisation LU de matrices C creuses non-symmetriques pour des architectures a memoire distribuee, C Calculateurs Paralleles Reseaux et systemes repartis, C Vol 10(5), 509-520 (1998). C C PARASOL Deliverable D2.1d (final report), C ZMUMPS Version 3.1, A MUltifrontal Massively Parallel Solver, C PARASOL project, EU ESPRIT IV LTR project 20160, (June 1999). C C Jacko Koster, PhD from INPT prepared at CERFACS, On the parallel solution C and the reordering of unsymmetric sparse linear systems (1997). C C Vincent Espirat, Master's thesis from INPT(ENSEEIHT)-IRIT, Developpement C d'une approche multifrontale pour machines a memoire distribuee et C reseau heterogene de stations de travail (1996). C C Patrick Amestoy, PhD from INPT prepared at CERFACS, Factorization of large C sparse matrices based on a multifrontal approach in a multiprocessor C environment, Available as CERFACS report TH/PA/91/2 (1991). C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine ZMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine ZMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of ZMUMPS_STRUC, which may then be altered before C subsequent calls to ZMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE ZMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE ZMUMPS_CHECK_DENSE_RHS SUBROUTINE ZMUMPS_ANA_DRIVER( id ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id END SUBROUTINE ZMUMPS_ANA_DRIVER SUBROUTINE ZMUMPS_FAC_DRIVER( id ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id END SUBROUTINE ZMUMPS_FAC_DRIVER SUBROUTINE ZMUMPS_SOLVE_DRIVER( id ) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id END SUBROUTINE ZMUMPS_SOLVE_DRIVER SUBROUTINE ZMUMPS_PRINT_ICNTL(id, LP) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE ZMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (ZMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a COMPLEX(kind=8) array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a COMPLEX(kind=8) array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are DOUBLE PRECISION C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF C Initialize id%MYID now because it is C required by MUMPS_PROPINFO. id%MYID C used to be initialized inside ZMUMPS_INI_DRIVER, C leading to an uninitialized access here. CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN C C If there was an error, then initialization C was already called and we can rely on the null C or non null value of the pointers related to OOC C stuff. C We use ZMUMPS_CLEAN_OOC_DATA that should work even C on the master. Note that KEEP(201) was also C initialized in a previous call to Mumps. C C If ZMUMPS_END_DRIVER or ZMUMPS_FAC_DRIVER is called after C this error, then ZMUMPS_CLEAN_OOC_DATA will be called C a second time, though. C IF (id%KEEP(201).GT.0) THEN CALL ZMUMPS_CLEAN_OOC_DATA(id, IERR) ENDIF GOTO 499 ENDIF C ---------------------------------------- C Initialization ZMUMPS_INI_DRIVER C ---------------------------------------- C - Default values for ICNTL, KEEP,KEEP8, CNTL C - Attach emission buffer for buffered Send C - Nullify pointers in the structure C - Get rank and size of the communicator C ---------------------------------------- CALL ZMUMPS_INI_DRIVER( id ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN C ------------------------------------- C Deallocation of the instance id C ------------------------------------- id%KEEP(40)= -2 - 456789 CALL ZMUMPS_END_DRIVER( id ) GOTO 500 END IF C C TIMINGS: for JOBS different from -1 and -2, C we measure TIMETOTAL: C IF (id%MYID.EQ.MASTER) THEN id%DKEEP(70)=0.0D0 CALL MUMPS_SECDEB(TIMETOTAL) ENDIF C C---------------------------------------------------------------- C C JOB = 7 : SAVE THE INSTANCE C C JOB = 8 : RESTORE THE INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. 7 .OR. JOB .EQ. 8 ) THEN IF( JOB.EQ.8 .AND. OLDJOB.NE.-1) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 IF ( JOB .EQ. 7 ) THEN IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL ZMUMPS_SAVE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in save structure driver= ', TIMEG END IF ENDIF ELSE IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL ZMUMPS_RESTORE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in restore structure driver= ' & , TIMEG ENDIF END IF ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C JOB = -3 : REMOVE SAVED INSTANCE C C---------------------------------------------------------------- C IF (JOB .EQ. -3) THEN CALL ZMUMPS_REMOVE_SAVED(id) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF IF (JOB.EQ.9) THEN C Check that factorization was performed IF ( OLDJOB .LT. 2 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ELSE CALL ZMUMPS_SOL_INIT_IRHS_loc(id) ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C MAIN DRIVER C OTHER VALUES OF JOB : 1 to 6 C C---------------------------------------------------------------- CALL MUMPS_MEMORY_SET_DATA_SIZES() IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF C C Propagate possible error to all nodes CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 C C Print ICNTL and KEEP C IF (PROK) CALL ZMUMPS_PRINT_ICNTL(id, MP) C----------------------------------------------------------------------- C C CHECK SEQUENCE C C----------------------------------------------------------------------- IF ( LANA ) THEN IF ( PROKG .AND. OLDJOB .EQ. -1 ) THEN C Print compilation options at first call to analysis CALL MUMPS_PRINT_IF_DEFINED(MPG) ENDIF C C User wants to perform analysis. Previous value of C JOB must be -1, 1, 2 or 3. C IF ( OLDJOB .EQ. 0 .OR. OLDJOB .GT. 3 .OR. OLDJOB .LT. -1 ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( OLDJOB .GE. 2 ) THEN C ----------------------------------------- C Previous step was factorization or solve. C As analysis is now performed, deallocate C at least some big arrays from facto. C ----------------------------------------- IF (associated(id%IS)) THEN DEALLOCATE (id%IS) NULLIFY (id%IS) END IF IF (associated(id%S)) THEN DEALLOCATE (id%S) NULLIFY (id%S) END IF END IF END IF IF ( LFACTO ) THEN C ------------------------------------ C User wants to perform factorization. C Analysis must have been performed. C ------------------------------------ IF ( OLDJOB .LT. 1 .and. .NOT. LANA ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN C ------------------------------- C User wants to perform solve. C Facto must have been performed. C ------------------------------- IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF C ------------------------------------------ C Permute JCN on entry to JOB if no analysis C to be performed and IRN/JCN are needed. C (facto: arrowheads + solve: iterative C refinement and error analysis) C ------------------------------------------ #if ! defined (LARGEMATRICES) NOERRORBEFOREPERM =.TRUE. UNS_PERM_DONE=.FALSE. IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF ( id%JOB .EQ. 2 .OR. id%JOB .EQ. 5 .OR. & (id%JOB .EQ. 3 .AND. (id%ICNTL(10) .NE.0 .OR. & id%ICNTL(11).NE. 0))) THEN UNS_PERM_DONE = .TRUE. ALLOCATE(UNS_PERM_INV(id%N),stat=IERR) IF (IERR .GT. 0) THEN C -------------------------------- C Exit with an error. C We are not able to permute C JCN correctly after a MAX-TRANS C permutation resulting from a C previous call to ZMUMPS. C -------------------------------- id%INFO(1)=-13 id%INFO(2)=id%N IF (LPOK) WRITE(LP,99993) GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I8 = 1_8, id%KEEP8(28) J = id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 * ********* * MaxTrans-Analysis-Distri, Scale-Arrowhead-factorize, and * Solve-IR-Error_Analysis (depending on the value of JOB) ********* * C IF ( LANA ) THEN C----------------------------------------------------- C- C- ANALYSIS : Max-Trans, Analysis, Distribution C- C----------------------------------------------------- C C Few checks + allocations C C IS : will be allocated on the slaves later C PROCNODE : on the master only, C because slave does not know N yet. C Will be allocated in analysis for the slave. C C For assembled entry: C IRN, JCN : check that they have been allocated by the C user on the master, and if their size is adequate C C For element entry: C ELTPTR, ELTVAR : check that they have been allocated by the C user on the master, and if their size is adequate C ---------------------------- C Reset KEEP(40) to -1 for the C case where an error occurs C ---------------------------- id%KEEP(40)=-1 -456789 C IF (id%MYID.EQ.MASTER) THEN C Check N, [N]NZ, NELT IF ((id%N.LE.0).OR.((id%N+id%N+id%N)/3.NE.id%N)) THEN id%INFO(1) = -16 id%INFO(2) = id%N GOTO 100 END IF IF (id%ICNTL(5).NE.1) THEN C Assembled input IF (id%ICNTL(18) .LT. 1 .OR. id%ICNTL(18) .GT. 3) THEN C Centralized input IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) GOTO 100 ENDIF ENDIF ELSE C Element entry: check NELT on the master IF (id%NELT .LE. 0) THEN id%INFO(1) = -24 id%INFO(2) = id%NELT GOTO 100 ENDIF ENDIF C -- initialize values of respectively C icntl(6), (7) and (12) to not done/chosen id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 C --------------------------------------- C Element entry: allocate ELTPROC(1:NELT) C --------------------------------------- IF ( id%ICNTL(5) .EQ. 1 ) THEN ! Elemental matrix IF ( associated( id%ELTPROC ) ) & DEALLOCATE( id%ELTPROC ) ALLOCATE( id%ELTPROC(id%NELT), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%NELT IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array ELTPROC' GOTO 100 END IF END IF C --------------------------------------------------- C Assembled centralized entry: check input parameters C IRN/JCN C Element entry: check input parameters ELTPTR/ELTVAR C --------------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! Assembled matrix id%KEEP8(30)=0_8 IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available before f2002. One can C still check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: IRN/JCN badly allocated.' END IF ELSE IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE id%LELTVAR = id%ELTPTR( id%NELT+1 ) - 1 IF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE C If no error, we compute KEEP8(30) (formerly NA_ELT), C required for ZMUMPS_MAX_MEM already in analysis, and C then later during facto to check the size of A_ELT id%KEEP8(30) = 0_8 IF ( id%KEEP(50) .EQ. 0 ) THEN C Unsymmetric elements (but symmetric structure) DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + int(J,8) * int(J,8) ENDDO ELSE C Symmetric elements DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + & (int(J,8) *int(J+1,8))/2_8 ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 C ----------------------------------------- C Call analysis procedure ZMUMPS_ANA_DRIVER C ----------------------------------------- IF (id%MYID .eq. MASTER) THEN id%DKEEP(71)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C ------------------------------------------------- C Set scaling option for analysis in KEEP(52) C (ICNTL(8) only defined on host at analysis phase) C ------------------------------------------------- IF (id%MYID.EQ.MASTER) THEN C{ id%KEEP(52) = id%ICNTL(8) C Out-of-range values => automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after ZMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL ZMUMPS_ANA_DRIVER( id ) C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL ZMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL ZMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_F2003) ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_F2003) IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #else IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL ZMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ------------------------ C If Schur has been asked C for, scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with Schur)' END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: This scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: Scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of ZMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL ZMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks CALL ZMUMPS_SET_K221(id) CALL ZMUMPS_CHECK_REDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in ZMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C ZMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ C & id%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL ZMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(id%root%SCHUR_NLOC-1,8)+ & int(id%root%SCHUR_MLOC,8)) CALL ZMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < id%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & id%root%SCHUR_MLOC id%INFO(1)=-30 id%INFO(2)=id%SCHUR_LLD ELSE IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF (size(id%SCHUR) < & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) THEN IF (LP.GT.0) THEN write(LP,'(A)') & ' SCHUR allocated but too small' write(LP,*) id%MYID, ' : Size Schur=', & size(id%SCHUR), & ' SCHUR_LLD= ', id%SCHUR_LLD, & ' SCHUR_MLOC=', id%root%SCHUR_NLOC, & ' SCHUR_NLOC=', id%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within ZMUMPS here. id%root%SCHUR_LLD=id%SCHUR_LLD IF (id%root%SCHUR_NLOC==0) THEN ALLOCATE(id%root%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE id%root%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure ZMUMPS_FAC_DRIVER C ----------------------------------------------- CALL ZMUMPS_FAC_DRIVER(id) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C id%root%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (id%root%yes) THEN IF (id%root%SCHUR_NLOC==0) THEN DEALLOCATE(id%root%SCHUR_POINTER) NULLIFY(id%root%SCHUR_POINTER) ELSE NULLIFY(id%root%SCHUR_POINTER) ENDIF ENDIF ENDIF C root%RG2L_ROW and root%RG2L_COL C are not used outside of the facto IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver= ', TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C Free id%S if facto failed if (associated(id%S)) then DEALLOCATE(id%S) NULLIFY(id%S) endif GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0D0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure ZMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL ZMUMPS_SOLVE_DRIVER(id) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = TIMEG ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL ZMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to ZMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO ENDIF END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL ZMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = TIMETOTAL ENDIF ENDIF *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN CALL ZMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=dble(id%KEEP8(55))/1D6 id%RINFO(8)=dble(id%KEEP8(56))/1D6 id%RINFOG(17)=dble(id%KEEP8(57))/1D6 id%RINFOG(18)=dble(id%KEEP8(58))/1D6 ENDIF !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from ZMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from ZMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM ZMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE ZMUMPS * SUBROUTINE ZMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE ZMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE ZMUMPS_PRINT_ICNTL (id, LP) USE ZMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL DOUBLE PRECISION, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Null pivot detection threshold =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE ZMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE ZMUMPS_PRINT_KEEP(id, LP) USE ZMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (ZMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).NE.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) KEEP(12) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),KEEP(248),ICNTL(21) WRITE (LP,993) KEEP(12) END SELECT ENDIF 980 FORMAT (/'******INTERNAL VALUE OF PARAMETERS (ICNTL/KEEP)****'/) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=Off, >0=ON) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) END SUBROUTINE ZMUMPS_PRINT_KEEP SUBROUTINE ZMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C COMPLEX(kind=8), DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_F2003) & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #else C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE ZMUMPS_CHECK_DENSE_RHS C SUBROUTINE ZMUMPS_SET_K221(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C Constraint: must be called before ZMUMPS_CHECK_REDRHS. C Can be called at factorization or solve phase C TYPE (ZMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).ne.0 .and. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).ne.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE ZMUMPS_SET_K221 C SUBROUTINE ZMUMPS_CHECK_REDRHS(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)=1 is C forbidden in case of fwd in facto. C TYPE (ZMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID .EQ. MASTER) THEN IF ( id%KEEP(221) == 1 .or. id%KEEP(221) == 2 ) THEN IF (id%KEEP(221) == 2 .and. id%JOB == 2) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF (id%KEEP(221) == 1 .and. id%KEEP(252) == 1 & .and. id%JOB == 3) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) ENDIF IF ( id%KEEP(60).eq. 0 .or. id%SIZE_SCHUR.EQ.0 ) THEN id%INFO(1)=-33 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF ( .NOT. associated( id%REDRHS)) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ELSE IF (id%NRHS.EQ.1) THEN IF (size(id%REDRHS) < id%SIZE_SCHUR ) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ELSE IF (id%LREDRHS < id%SIZE_SCHUR) THEN id%INFO(1)=-34 id%INFO(2)=id%LREDRHS GOTO 333 ELSE IF & (size(id%REDRHS)< & id%NRHS*id%LREDRHS-id%LREDRHS+id%SIZE_SCHUR) & THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ENDIF ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE ZMUMPS_CHECK_REDRHS MUMPS_5.4.1/src/smumps_load.F0000664000175000017500000066467714102210521016165 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_LOAD implicit none PUBLIC :: SMUMPS_LOAD_SET_INICOST, SMUMPS_LOAD_INIT, & SMUMPS_LOAD_SET_SLAVES, SMUMPS_LOAD_UPDATE, & SMUMPS_LOAD_END, SMUMPS_LOAD_PROCESS_MESSAGE, & SMUMPS_LOAD_LESS, SMUMPS_LOAD_LESS_CAND, & SMUMPS_LOAD_SET_SLAVES_CAND, SMUMPS_LOAD_MASTER_2_ALL, & SMUMPS_LOAD_RECV_MSGS, SMUMPS_LOAD_MEM_UPDATE, & SMUMPS_LOAD_SET_PARTITION, & SMUMPS_SPLIT_PREP_PARTITION, SMUMPS_SPLIT_POST_PARTITION, & SMUMPS_SPLIT_PROPAGATE_PARTI, SMUMPS_LOAD_POOL_UPD_NEW_POOL, & SMUMPS_LOAD_SBTR_UPD_NEW_POOL, SMUMPS_LOAD_POOL_CHECK_MEM, & SMUMPS_LOAD_SET_SBTR_MEM, & SMUMPS_REMOVE_NODE, SMUMPS_UPPER_PREDICT & ,SMUMPS_LOAD_SEND_MD_INFO, & SMUMPS_LOAD_CLEAN_MEMINFO_POOL, SMUMPS_LOAD_COMP_MAXMEM_POOL, & SMUMPS_LOAD_CHK_MEMCST_POOL, SMUMPS_CHECK_SBTR_COST, & SMUMPS_FIND_BEST_NODE_FOR_MEM, & SMUMPS_LOAD_INIT_SBTR_STRUCT DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE, PRIVATE :: LOAD_FLOPS INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: BUF_LOAD_RECV INTEGER, SAVE, PRIVATE :: LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES INTEGER, SAVE, PRIVATE :: K50, K69, K35 INTEGER(8), SAVE, PRIVATE :: MAX_SURF_MASTER LOGICAL, SAVE, PRIVATE :: BDC_MEM, BDC_POOL, BDC_SBTR, & BDC_POOL_MNG, & BDC_M2_MEM,BDC_M2_FLOPS,BDC_MD,REMOVE_NODE_FLAG, & REMOVE_NODE_FLAG_MEM DOUBLE PRECISION, SAVE, PRIVATE :: REMOVE_NODE_COST, & REMOVE_NODE_COST_MEM INTEGER, SAVE, PRIVATE :: SBTR_WHICH_M DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, TARGET, SAVE, PRIVATE :: WLOAD DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM LOGICAL, SAVE, PRIVATE :: IS_MUMPS_LOAD_ENABLED PUBLIC:: MUMPS_LOAD_ENABLE, MUMPS_LOAD_DISABLE INTEGER(8), SAVE, PRIVATE :: CHECK_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, TARGET, PRIVATE :: & IDWLOAD DOUBLE PRECISION, SAVE, PRIVATE :: COST_SUBTREE DOUBLE PRECISION, SAVE, PRIVATE :: ALPHA DOUBLE PRECISION, SAVE, PRIVATE :: BETA INTEGER, SAVE, PRIVATE :: MYID, NPROCS, COMM_LD INTEGER, SAVE, PRIVATE :: COMM_NODES DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE :: POOL_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, PRIVATE, & SAVE :: SBTR_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: SBTR_CUR INTEGER, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: NB_SON DOUBLE PRECISION, & PRIVATE, SAVE :: SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: PEAK_SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: MAX_PEAK_STK DOUBLE PRECISION, SAVE, & PRIVATE :: POOL_LAST_COST_SENT DOUBLE PRECISION, SAVE, & PRIVATE :: MIN_DIFF INTEGER, SAVE :: POS_ID,POS_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: CB_COST_ID INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE & :: CB_COST_MEM PUBLIC :: CB_COST_ID, CB_COST_MEM,POS_MEM,POS_ID DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: LU_USAGE INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE::MD_MEM, TAB_MAXS DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE ::MEM_SUBTREE INTEGER :: NB_SUBTREES,NIV1_FLAG INTEGER, PRIVATE :: INDICE_SBTR,INDICE_SBTR_ARRAY INTEGER :: POOL_NIV2_SIZE INTEGER,SAVE :: INSIDE_SUBTREE PUBLIC :: NB_SUBTREES,MEM_SUBTREE,INSIDE_SUBTREE,NIV1_FLAG DOUBLE PRECISION, SAVE, PRIVATE :: DM_SUMLU, & DM_THRES_MEM DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE , PRIVATE:: DM_MEM INTEGER, SAVE, PRIVATE :: POOL_SIZE,ID_MAX_M2 DOUBLE PRECISION, SAVE, PRIVATE :: MAX_M2,TMP_M2 INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, PRIVATE:: POOL_NIV2 DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE :: POOL_NIV2_COST, NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: CHK_LD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: & PROCNODE_LOAD, STEP_TO_NIV2_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: KEEP_LOAD INTEGER, SAVE, PRIVATE :: N_LOAD INTEGER(8), DIMENSION(:), POINTER, SAVE, PRIVATE:: KEEP8_LOAD INTEGER, DIMENSION(:),POINTER, SAVE :: & FILS_LOAD, STEP_LOAD, & FRERE_LOAD, ND_LOAD, & NE_LOAD,DAD_LOAD INTEGER, DIMENSION(:,:),POINTER, SAVE, PRIVATE :: CAND_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, & PRIVATE :: MY_FIRST_LEAF,MY_NB_LEAF, MY_ROOT_SBTR INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_FIRST_POS_IN_POOL DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_PEAK_ARRAY, & SBTR_CUR_ARRAY DOUBLE PRECISION,DIMENSION(:),POINTER, SAVE :: COST_TRAV INTEGER, DIMENSION(:),POINTER, SAVE :: DEPTH_FIRST_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD PUBLIC :: DEPTH_FIRST_LOAD,COST_TRAV, FILS_LOAD,STEP_LOAD, & FRERE_LOAD, ND_LOAD,NE_LOAD,DAD_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD INTEGER, SAVE :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST PUBLIC :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST CONTAINS SUBROUTINE MUMPS_LOAD_ENABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .TRUE. RETURN END SUBROUTINE MUMPS_LOAD_ENABLE SUBROUTINE MUMPS_LOAD_DISABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .FALSE. RETURN END SUBROUTINE MUMPS_LOAD_DISABLE SUBROUTINE SMUMPS_LOAD_SET_INICOST( COST_SUBTREE_ARG, K64, DK15, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K375 REAL, INTENT(IN) :: DK15 INTEGER(8)::MAXS DOUBLE PRECISION :: T64, T66 LOGICAL :: AVOID_LOAD_MESSAGES T64 = max ( dble(K64), dble(1) ) T64 = min ( T64, dble(1000) ) T66 = max (dble(DK15), dble(100)) MIN_DIFF = ( T64 / dble(1000) )* & T66 * dble(1000000) DM_THRES_MEM = dble(MAXS/300_8) COST_SUBTREE = COST_SUBTREE_ARG AVOID_LOAD_MESSAGES = .FALSE. IF (K375.EQ.1) THEN AVOID_LOAD_MESSAGES = .TRUE. ENDIF IF (AVOID_LOAD_MESSAGES) THEN MIN_DIFF = MIN_DIFF * 1000.D0 DM_THRES_MEM = DM_THRES_MEM * 1000_8 ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_SET_INICOST SUBROUTINE SMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND, ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, SLAVES_LIST, & SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SIZE_SLAVES_LIST, SLAVEF, & KEEP(500) INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), CAND(SLAVEF+1), & FILS(N) INTEGER, intent(out) :: NBSPLIT, NUMORG_SPLIT INTEGER, intent(inout) :: SLAVES_LIST(SIZE_SLAVES_LIST), & COPY_CAND(SLAVEF+1) INTEGER :: IN, LP, II INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT = NBSPLIT + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG_SPLIT = NUMORG_SPLIT + 1 II = FILS(II) ENDDO END DO SLAVES_LIST(1:NBSPLIT) = CAND(1:NBSPLIT) COPY_CAND(1:SIZE_SLAVES_LIST-NBSPLIT) = & CAND(1+NBSPLIT:SIZE_SLAVES_LIST) COPY_CAND(SIZE_SLAVES_LIST-NBSPLIT+1:SLAVEF) = -1 COPY_CAND(SLAVEF+1) = SIZE_SLAVES_LIST-NBSPLIT RETURN END SUBROUTINE SMUMPS_SPLIT_PREP_PARTITION SUBROUTINE SMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & TAB_POS, NSLAVES_NODE & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SLAVEF, NCB, & KEEP(500), NBSPLIT INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N) INTEGER, intent(inout) :: TAB_POS ( SLAVEF+2 ), NSLAVES_NODE INTEGER :: IN, LP, II, NUMORG, NBSPLIT_LOC, I INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT DO I= NSLAVES_NODE+1, 1, -1 TAB_POS(I+NBSPLIT) = TAB_POS(I) END DO LP = ICNTL(1) IN = INODE NBSPLIT_LOC = 0 NUMORG = 0 TAB_POS(1) = 1 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT_LOC = NBSPLIT_LOC + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG = NUMORG + 1 II = FILS(II) ENDDO TAB_POS(NBSPLIT_LOC+1) = NUMORG + 1 END DO DO I = NBSPLIT+2, NBSPLIT+NSLAVES_NODE+1 TAB_POS(I) = TAB_POS(I) + NUMORG ENDDO NSLAVES_NODE = NSLAVES_NODE + NBSPLIT TAB_POS (NSLAVES_NODE+2:SLAVEF+1) = -9999 TAB_POS ( SLAVEF+2 ) = NSLAVES_NODE RETURN END SUBROUTINE SMUMPS_SPLIT_POST_PARTITION SUBROUTINE SMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND, SIZE_CAND, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES_NODE, & SLAVES_LIST, SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, TYPESPLIT, IFSON, N, SLAVEF, & KEEP(500), & NSLSON, SIZE_SLAVES_LIST, SIZE_CAND INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N), INIV2, & SON_SLAVE_LIST (NSLSON), & ISTEP_TO_INIV2(KEEP(71)), & CAND(SIZE_CAND) INTEGER, intent(out) :: NSLAVES_NODE INTEGER, intent(inout) :: & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(out) :: SLAVES_LIST (SIZE_SLAVES_LIST) INTEGER :: IN, LP, I, NSLAVES_SONS, & INIV2_FILS, ISHIFT LP = ICNTL(1) IN = INODE INIV2_FILS = ISTEP_TO_INIV2( STEP( IFSON )) NSLAVES_SONS = TAB_POS_IN_PERE (SLAVEF+2, INIV2_FILS) TAB_POS_IN_PERE (1,INIV2) = 1 ISHIFT = TAB_POS_IN_PERE (2, INIV2_FILS) -1 DO I = 2, NSLAVES_SONS TAB_POS_IN_PERE (I,INIV2) = & TAB_POS_IN_PERE (I+1,INIV2_FILS) - ISHIFT SLAVES_LIST(I-1) = SON_SLAVE_LIST (I) END DO TAB_POS_IN_PERE(NSLAVES_SONS+1:SLAVEF+1,INIV2) = -9999 NSLAVES_NODE = NSLAVES_SONS - 1 TAB_POS_IN_PERE (SLAVEF+2, INIV2) = NSLAVES_NODE RETURN END SUBROUTINE SMUMPS_SPLIT_PROPAGATE_PARTI SUBROUTINE SMUMPS_LOAD_SET_PARTITION( & NCBSON_MAX, SLAVEF, & KEEP,KEEP8,ICNTL, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,INODE &) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: SLAVEF, NFRONT INTEGER, intent (inout) ::NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER i INTEGER LP,MP INTEGER(8) DUMMY1 INTEGER DUMMY2 INTEGER TMP_ARRAY(2) LP=ICNTL(4) MP=ICNTL(2) IF ( KEEP(48) == 0 .OR. KEEP(48) .EQ. 3 ) THEN CALL SMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) ELSE IF ( KEEP(48) == 4 ) THEN CALL SMUMPS_SET_PARTI_ACTV_MEM( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'probleme de partition dans &SMUMPS_LOAD_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN IF (KEEP(375).EQ.1) THEN GOTO 458 ENDIF CALL SMUMPS_SET_PARTI_FLOP_IRR( & NCBSON_MAX, & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & MP,LP) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'problem with partition in &SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO GOTO 457 458 CONTINUE IF ( KEEP(375).EQ.1 )THEN TMP_ARRAY(1)=0 TMP_ARRAY(2)=0 ENDIF CALL SMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS,TMP_ARRAY,DUMMY1,DUMMY2 & ) ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF 457 CONTINUE RETURN END SUBROUTINE SMUMPS_LOAD_SET_PARTITION SUBROUTINE SMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER ITEMP, NMB_OF_CAND, NSLAVES_LESS DOUBLE PRECISION MSG_SIZE LOGICAL FORCE_CAND INTEGER MUMPS_REG_GET_NSLAVES EXTERNAL MUMPS_REG_GET_NSLAVES IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in SMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in SMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF MSG_SIZE = dble( NFRONT - NCB ) * dble(NCB) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF (FORCE_CAND) THEN ITEMP=SMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=SMUMPS_LOAD_LESS(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_REG_GET_NSLAVES(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND, & KEEP(375), KEEP(119)) CALL MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL SMUMPS_LOAD_SET_SLAVES_CAND(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL SMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_PARTI_REGULAR SUBROUTINE SMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) USE SMUMPS_BUF USE SMUMPS_STRUC_DEF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC INTEGER(8) :: I8SIZE INTEGER allocok, IERR, IERR_MPI, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_DBLE(2) INTEGER WHAT INTEGER(8) MEMORY_MD, LA CALL MUMPS_LOAD_ENABLE() STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP8_LOAD=>id%KEEP8 FILS_LOAD=>id%FILS FRERE_LOAD=>id%FRERE_STEPS DAD_LOAD=>id%DAD_STEPS PROCNODE_LOAD=>id%PROCNODE_STEPS STEP_LOAD=>id%STEP NE_LOAD=>id%NE_STEPS N_LOAD=id%N ROOT_CURRENT_SUBTREE=-9999 MEMORY_MD=MEMORY_MD_ARG LA=MAXS MAX_SURF_MASTER=id%MAX_SURF_MASTER+ & (int(id%KEEP(12),8)*int(id%MAX_SURF_MASTER,8)/int(100,8)) COMM_LD = id%COMM_LOAD COMM_NODES = id%COMM_NODES MAX_PEAK_STK = 0.0D0 K69 = id%KEEP(69) IF ( id%KEEP(47) .le. 0 .OR. id%KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in SMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( id%KEEP(47) >= 2 ) BDC_POOL = ( id%KEEP(47) >= 3 ) BDC_SBTR = ( id%KEEP(47) >= 4 ) BDC_M2_MEM = ( ( id%KEEP(80) == 2 .OR. id%KEEP(80) == 3 ) & .AND. id%KEEP(47) == 4 ) BDC_M2_FLOPS = ( id%KEEP(80) == 1 & .AND. id%KEEP(47) .GE. 1 ) BDC_MD = (id%KEEP(86)==1) SBTR_WHICH_M = id%KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (id%KEEP(80) .LT. 0 .OR. id%KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((id%KEEP(80) == 2 .OR. id%KEEP(80)==3).AND. id%KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in SMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF IF (id%KEEP(81) == 1 .AND. id%KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in SMUMPS_LOAD_INIT" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((id%KEEP(81) == 1).AND.(id%KEEP(47) >= 2)) IF(id%KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(id%KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(id%KEEP(76).EQ.6)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST DEPTH_FIRST_SEQ_LOAD=>id%DEPTH_FIRST_SEQ SBTR_ID_LOAD=>id%SBTR_ID ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN POOL_NIV2_SIZE=max(1,min(id%NBSA+id%KEEP(262),id%NA(1))) ALLOCATE(NIV2(id%NSLAVES), NB_SON(id%KEEP(28)), & POOL_NIV2(POOL_NIV2_SIZE), & POOL_NIV2_COST(POOL_NIV2_SIZE), & stat=allocok) DO i = 1, id%KEEP(28) NB_SON(i)=id%NE_STEPS(i) ENDDO NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + id%KEEP(28) + 200 RETURN ENDIF ENDIF K50 = id%KEEP(50) CALL MPI_COMM_RANK( COMM_LD, MYID, IERR_MPI ) NPROCS = id%NSLAVES DM_SUMLU=ZERO POOL_SIZE=0 IF(BDC_MD)THEN IF ( allocated(MD_MEM) ) DEALLOCATE(MD_MEM) ALLOCATE( MD_MEM( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(TAB_MAXS) ) DEALLOCATE(TAB_MAXS) ALLOCATE( TAB_MAXS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF TAB_MAXS=0_8 IF ( allocated(LU_USAGE) ) DEALLOCATE(LU_USAGE) ALLOCATE( LU_USAGE( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((id%KEEP(81).EQ.2).OR.(id%KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_MEM=int(0,8) ALLOCATE(CB_COST_ID(2000*3), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_ID=0 POS_MEM=1 POS_ID=1 ENDIF ALLOCATE(FUTURE_NIV2(NPROCS), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN ENDIF DO i = 1, NPROCS FUTURE_NIV2(i) = id%FUTURE_NIV2(i) IF(BDC_MD)THEN IF(FUTURE_NIV2(i).EQ.0)THEN MD_MEM(i-1)=999999999_8 ENDIF ENDIF ENDDO DELTA_MEM=ZERO DELTA_LOAD=ZERO CHECK_MEM=0_8 IF(BDC_SBTR.OR.BDC_POOL_MNG)THEN NB_SUBTREES=id%NBSA_LOCAL IF (allocated(MEM_SUBTREE)) DEALLOCATE(MEM_SUBTREE) ALLOCATE(MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF DO i=1,id%NBSA_LOCAL MEM_SUBTREE(i)=id%MEM_SUBTREE(i) ENDDO MY_FIRST_LEAF=>id%MY_FIRST_LEAF MY_NB_LEAF=>id%MY_NB_LEAF MY_ROOT_SBTR=>id%MY_ROOT_SBTR IF (allocated(SBTR_FIRST_POS_IN_POOL)) & DEALLOCATE(SBTR_FIRST_POS_IN_POOL) ALLOCATE(SBTR_FIRST_POS_IN_POOL(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF INSIDE_SUBTREE=0 PEAK_SBTR_CUR_LOCAL = dble(0) SBTR_CUR_LOCAL = dble(0) IF (allocated(SBTR_PEAK_ARRAY)) DEALLOCATE(SBTR_PEAK_ARRAY) ALLOCATE(SBTR_PEAK_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_CUR_ARRAY=dble(0) INDICE_SBTR_ARRAY=1 NIV1_FLAG=0 INDICE_SBTR=1 ENDIF IF ( allocated(LOAD_FLOPS) ) DEALLOCATE( LOAD_FLOPS ) ALLOCATE( LOAD_FLOPS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(WLOAD) ) DEALLOCATE( WLOAD ) ALLOCATE( WLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(IDWLOAD) ) DEALLOCATE( IDWLOAD ) ALLOCATE( IDWLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( BDC_MEM ) THEN IF ( allocated(DM_MEM) ) DEALLOCATE( DM_MEM ) ALLOCATE( DM_MEM( 0:NPROCS-1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF END IF IF ( BDC_POOL ) THEN IF ( allocated(POOL_MEM) ) DEALLOCATE(POOL_MEM) ALLOCATE( POOL_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF POOL_MEM = dble(0) POOL_LAST_COST_SENT = dble(0) END IF IF ( BDC_SBTR ) THEN IF ( allocated(SBTR_MEM) ) DEALLOCATE(SBTR_MEM) ALLOCATE( SBTR_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(SBTR_CUR) ) DEALLOCATE(SBTR_CUR) ALLOCATE( SBTR_CUR(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF K34_LOC=id%KEEP(34) CALL MUMPS_SIZE_C(SIZE_DBLE(1),SIZE_DBLE(2),I8SIZE) K35 = int(I8SIZE) BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35 + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 ENDIF LBUF_LOAD_RECV = (BUF_LOAD_SIZE+K34_LOC)/K34_LOC LBUF_LOAD_RECV_BYTES = LBUF_LOAD_RECV * K34_LOC IF ( allocated(BUF_LOAD_RECV) ) DEALLOCATE(BUF_LOAD_RECV) ALLOCATE( BUF_LOAD_RECV( LBUF_LOAD_RECV), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL SMUMPS_BUF_ALLOC_LOAD_BUFFER( BUF_LOAD_SIZE, IERR ) IF ( IERR .LT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = BUF_LOAD_SIZE RETURN END IF DO i = 0, NPROCS - 1 LOAD_FLOPS( i ) = ZERO END DO IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO ENDIF CALL SMUMPS_INIT_ALPHA_BETA(id%KEEP(69)) IF(BDC_MD)THEN MAX_SBTR=0.0D0 IF(BDC_SBTR)THEN DO i=1,id%NBSA_LOCAL MAX_SBTR=max(id%MEM_SUBTREE(i),MAX_SBTR) ENDDO ENDIF MD_MEM(MYID)=MEMORY_MD WHAT=8 CALL SMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & dble(MEMORY_MD),dble(0) ,MYID, id%KEEP, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * & dble(max(id%KEEP(5),id%KEEP(6))) * dble(id%KEEP(127))) IF (id%KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(id%KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF IF (id%KEEP(375).EQ.1) THEN MEMORY_SENT=dble(LA) ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL SMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & MEMORY_SENT, & dble(0),MYID, id%KEEP, IERR ) ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_INIT SUBROUTINE SMUMPS_LOAD_UPDATE( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG INTEGER CHECK_FLOPS INTEGER IERR DOUBLE PRECISION ZERO, SEND_MEM, SEND_LOAD,SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN IF (INC_LOAD == 0.0D0) THEN IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN ENDIF IF((CHECK_FLOPS.NE.0).AND. & (CHECK_FLOPS.NE.1).AND.(CHECK_FLOPS.NE.2))THEN WRITE(*,*)MYID,': Bad value for CHECK_FLOPS' CALL MUMPS_ABORT() ENDIF IF(CHECK_FLOPS.EQ.1)THEN CHK_LD=CHK_LD+INC_LOAD ELSE IF(CHECK_FLOPS.EQ.2)THEN RETURN ENDIF ENDIF IF ( PROCESS_BANDE ) THEN RETURN ENDIF LOAD_FLOPS( MYID ) = max( LOAD_FLOPS( MYID ) + INC_LOAD, ZERO) IF(BDC_M2_FLOPS.AND.REMOVE_NODE_FLAG)THEN IF(INC_LOAD.NE.REMOVE_NODE_COST)THEN IF(INC_LOAD.GT.REMOVE_NODE_COST)THEN DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 ELSE DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_LOAD = DELTA_LOAD + INC_LOAD 888 CONTINUE IF ( DELTA_LOAD > MIN_DIFF .OR. DELTA_LOAD < -MIN_DIFF) THEN SEND_LOAD = DELTA_LOAD IF (BDC_MEM) THEN SEND_MEM = DELTA_MEM ELSE SEND_MEM = ZERO END IF IF(BDC_SBTR)THEN SBTR_TMP=SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF 111 CONTINUE CALL SMUMPS_BUF_SEND_UPDATE_LOAD( BDC_SBTR,BDC_MEM, & BDC_MD,COMM_LD, NPROCS, & SEND_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_UPDATE SUBROUTINE SMUMPS_LOAD_MEM_UPDATE( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLUS) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLUS LOGICAL, INTENT(IN) :: PROCESS_BANDE_ARG, SSARBR INTEGER IERR, KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION ZERO, SEND_MEM, SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs INTEGER(8) :: INC_MEM LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG IF ( PROCESS_BANDE .AND. NEW_LU .NE. 0_8) THEN WRITE(*,*) " Internal Error in SMUMPS_LOAD_MEM_UPDATE." WRITE(*,*) " NEW_LU must be zero if called from PROCESS_BANDE" CALL MUMPS_ABORT() ENDIF DM_SUMLU = DM_SUMLU + dble(NEW_LU) IF(KEEP_LOAD(201).EQ.0)THEN CHECK_MEM = CHECK_MEM + INC_MEM ELSE CHECK_MEM = CHECK_MEM + INC_MEM - NEW_LU ENDIF IF ( MEM_VALUE .NE. CHECK_MEM ) THEN WRITE(*,*)MYID, & ':Problem with increments in SMUMPS_LOAD_MEM_UPDATE', & CHECK_MEM, MEM_VALUE, INC_MEM,NEW_LU CALL MUMPS_ABORT() ENDIF IF (PROCESS_BANDE) THEN RETURN ENDIF IF(BDC_POOL_MNG) THEN IF(SBTR_WHICH_M.EQ.0)THEN IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM-NEW_LU) ELSE IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM) ENDIF ENDIF IF ( .NOT. BDC_MEM ) THEN RETURN ENDIF IF (BDC_SBTR .AND. SSARBR) THEN IF((SBTR_WHICH_M.EQ.0).AND.(KEEP(201).NE.0))THEN SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM-NEW_LU) ELSE SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM) ENDIF SBTR_TMP = SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF IF ( NEW_LU > 0_8 ) THEN INC_MEM = INC_MEM - NEW_LU ENDIF DM_MEM( MYID ) = DM_MEM(MYID) + dble(INC_MEM) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MYID)) IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(dble(INC_MEM).NE.REMOVE_NODE_COST_MEM)THEN IF(dble(INC_MEM).GT.REMOVE_NODE_COST_MEM)THEN DELTA_MEM = DELTA_MEM + & (dble(INC_MEM)-REMOVE_NODE_COST_MEM) GOTO 888 ELSE DELTA_MEM = DELTA_MEM - & (REMOVE_NODE_COST_MEM-dble(INC_MEM)) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_MEM = DELTA_MEM + dble(INC_MEM) 888 CONTINUE IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND.(abs(DELTA_MEM) & .GE.0.2d0*dble(LRLUS))))THEN IF ( abs(DELTA_MEM) > DM_THRES_MEM ) THEN SEND_MEM = DELTA_MEM 111 CONTINUE CALL SMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, & DELTA_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO DELTA_MEM = ZERO ENDIF ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG_MEM)THEN REMOVE_NODE_FLAG_MEM=.FALSE. ENDIF END SUBROUTINE SMUMPS_LOAD_MEM_UPDATE INTEGER FUNCTION SMUMPS_LOAD_LESS( K69, MEM_DISTRIB,MSG_SIZE ) IMPLICIT NONE INTEGER i, NLESS, K69 INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION LREF DOUBLE PRECISION MSG_SIZE NLESS = 0 DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO WLOAD(1:NPROCS) = LOAD_FLOPS(0:NPROCS-1) IF(BDC_M2_FLOPS)THEN DO i=1,NPROCS WLOAD(i)=WLOAD(i)+NIV2(i) ENDDO ENDIF IF(K69 .gt. 1) THEN CALL SMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,IDWLOAD,NPROCS) ENDIF LREF = LOAD_FLOPS(MYID) DO i=1, NPROCS IF (WLOAD(i).LT.LREF) NLESS=NLESS+1 ENDDO SMUMPS_LOAD_LESS = NLESS RETURN END FUNCTION SMUMPS_LOAD_LESS SUBROUTINE SMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB,MSG_SIZE,DEST, & NSLAVES) IMPLICIT NONE INTEGER NSLAVES INTEGER DEST(NSLAVES) INTEGER, DIMENSION(0:NPROCS - 1) :: MEM_DISTRIB INTEGER i,J,NBDEST DOUBLE PRECISION MSG_SIZE IF ( NSLAVES.eq.NPROCS-1 ) THEN J = MYID+1 DO i=1,NSLAVES J=J+1 IF (J.GT.NPROCS) J=1 DEST(i) = J - 1 ENDDO ELSE DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO CALL MUMPS_SORT_DOUBLES(NPROCS, WLOAD, IDWLOAD) NBDEST = 0 DO i=1, NSLAVES J = IDWLOAD(i) IF (J.NE.MYID) THEN NBDEST = NBDEST+1 DEST(NBDEST) = J ENDIF ENDDO IF (NBDEST.NE.NSLAVES) THEN DEST(NSLAVES) = IDWLOAD(NSLAVES+1) ENDIF IF(BDC_MD)THEN J=NSLAVES+1 do i=NSLAVES+1,NPROCS IF(IDWLOAD(i).NE.MYID)THEN DEST(J)= IDWLOAD(i) J=J+1 ENDIF end do ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_SET_SLAVES SUBROUTINE SMUMPS_LOAD_END( INFO1, NSLAVES, IERR ) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT(IN) :: INFO1 INTEGER, INTENT(IN) :: NSLAVES INTEGER, INTENT(OUT) :: IERR INTEGER :: DUMMY_COMMUNICATOR IERR=0 DUMMY_COMMUNICATOR = -999 CALL SMUMPS_CLEAN_PENDING( INFO1, KEEP_LOAD(1), BUF_LOAD_RECV(1), & LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES, DUMMY_COMMUNICATOR, COMM_LD, & NSLAVES, & .FALSE., & .TRUE. & ) DEALLOCATE( LOAD_FLOPS ) DEALLOCATE( WLOAD ) DEALLOCATE( IDWLOAD ) DEALLOCATE(FUTURE_NIV2) IF(BDC_MD)THEN DEALLOCATE(MD_MEM) DEALLOCATE(LU_USAGE) DEALLOCATE(TAB_MAXS) ENDIF IF ( BDC_MEM ) DEALLOCATE( DM_MEM ) IF ( BDC_POOL) DEALLOCATE( POOL_MEM ) IF ( BDC_SBTR) THEN DEALLOCATE( SBTR_MEM ) DEALLOCATE( SBTR_CUR ) DEALLOCATE(SBTR_FIRST_POS_IN_POOL) NULLIFY(MY_FIRST_LEAF) NULLIFY(MY_NB_LEAF) NULLIFY(MY_ROOT_SBTR) ENDIF IF(KEEP_LOAD(76).EQ.4)THEN NULLIFY(DEPTH_FIRST_LOAD) ENDIF IF(KEEP_LOAD(76).EQ.5)THEN NULLIFY(COST_TRAV) ENDIF IF((KEEP_LOAD(76).EQ.4).OR.(KEEP_LOAD(76).EQ.6))THEN NULLIFY(DEPTH_FIRST_LOAD) NULLIFY(DEPTH_FIRST_SEQ_LOAD) NULLIFY(SBTR_ID_LOAD) ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN DEALLOCATE(NB_SON,POOL_NIV2,POOL_NIV2_COST, NIV2) END IF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN DEALLOCATE(CB_COST_MEM) DEALLOCATE(CB_COST_ID) ENDIF NULLIFY(ND_LOAD) NULLIFY(KEEP_LOAD) NULLIFY(KEEP8_LOAD) NULLIFY(FILS_LOAD) NULLIFY(FRERE_LOAD) NULLIFY(PROCNODE_LOAD) NULLIFY(STEP_LOAD) NULLIFY(NE_LOAD) NULLIFY(CAND_LOAD) NULLIFY(STEP_TO_NIV2_LOAD) NULLIFY(DAD_LOAD) IF (BDC_SBTR.OR.BDC_POOL_MNG) THEN DEALLOCATE(MEM_SUBTREE) DEALLOCATE(SBTR_PEAK_ARRAY) DEALLOCATE(SBTR_CUR_ARRAY) ENDIF CALL SMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) DEALLOCATE(BUF_LOAD_RECV) RETURN END SUBROUTINE SMUMPS_LOAD_END RECURSIVE SUBROUTINE SMUMPS_LOAD_RECV_MSGS(COMM) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGLEN, MSGSOU,COMM INTEGER IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR_MPI ) IF (FLAG) THEN KEEP_LOAD(65)=KEEP_LOAD(65)+1 KEEP_LOAD(267)=KEEP_LOAD(267)-1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in SMUMPS_LOAD_RECV_MSGS", & MSGTAG CALL MUMPS_ABORT() ENDIF CALL MPI_GET_COUNT(STATUS, MPI_PACKED, MSGLEN, IERR_MPI) IF ( MSGLEN > LBUF_LOAD_RECV_BYTES ) THEN write(*,*) "Internal error 2 in SMUMPS_LOAD_RECV_MSGS", & MSGLEN, LBUF_LOAD_RECV_BYTES CALL MUMPS_ABORT() ENDIF CALL MPI_RECV( BUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES, & MPI_PACKED, MSGSOU, MSGTAG, COMM_LD, STATUS, IERR_MPI) CALL SMUMPS_LOAD_PROCESS_MESSAGE( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_RECV_MSGS RECURSIVE SUBROUTINE SMUMPS_LOAD_PROCESS_MESSAGE & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, WHAT, NSLAVES, i INTEGER IERR_MPI DOUBLE PRECISION LOAD_RECEIVED INTEGER INODE_RECEIVED,NCB_RECEIVED DOUBLE PRECISION SURF INTEGER, POINTER, DIMENSION (:) :: LIST_SLAVES DOUBLE PRECISION, POINTER, DIMENSION (:) :: LOAD_INCR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WHAT, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) IF ( WHAT == 0 ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MSGSOU)) END IF IF(BDC_SBTR)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_CUR(MSGSOU)=LOAD_RECEIVED ENDIF IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(KEEP_LOAD(201).EQ.0)THEN LU_USAGE(MSGSOU)=LOAD_RECEIVED ENDIF ENDIF ELSEIF (( WHAT == 1).OR.(WHAT.EQ.19)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) + & LOAD_INCR(i) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(LIST_SLAVES(i))) END DO END IF IF(WHAT.EQ.19)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) CALL SMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE_RECEIVED) CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES WRITE(*,*)MYID,':',LIST_SLAVES(i),'->',LOAD_INCR(i) CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(LOAD_INCR(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF NULLIFY( LIST_SLAVES ) NULLIFY( LOAD_INCR ) ELSE IF (WHAT == 2 ) THEN IF ( .not. BDC_POOL ) THEN WRITE(*,*) "Internal error 2 in SMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) POOL_MEM(MSGSOU)=LOAD_RECEIVED ELSE IF ( WHAT == 3 ) THEN IF ( .NOT. BDC_SBTR) THEN WRITE(*,*) "Internal error 3 in SMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED ELSE IF (WHAT == 4) THEN FUTURE_NIV2(MSGSOU+1)=0 IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SURF, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF IF(BDC_M2_MEM.OR.BDC_M2_FLOPS)THEN ENDIF ELSE IF (WHAT == 5) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 7 in SMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN CALL SMUMPS_PROCESS_NIV2_MEM_MSG(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL SMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE_RECEIVED) ENDIF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & KEEP_LOAD(199)).EQ.1 & )THEN CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MSGSOU,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB_RECEIVED,8)* & int(NCB_RECEIVED,8) POS_MEM=POS_MEM+1 ENDIF ENDIF ELSE IF ( WHAT == 6 ) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 8 in SMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSEIF(WHAT == 17)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_MD)THEN DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED ELSEIF(BDC_POOL)THEN POOL_MEM(MSGSOU)=LOAD_RECEIVED ENDIF ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED ENDIF ELSEIF ( WHAT == 7 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 4 &in SMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF END DO ELSEIF ( WHAT == 8 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 5 &in SMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF ELSEIF ( WHAT == 9 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 6 &in SMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) TAB_MAXS(MSGSOU)=int(LOAD_RECEIVED,8) ELSE WRITE(*,*) "Internal error 1 in SMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE SMUMPS_LOAD_PROCESS_MESSAGE integer function SMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB,CAND, & K69, & SLAVEF,MSG_SIZE, & NMB_OF_CAND ) implicit none integer, intent(in) :: K69, SLAVEF INTEGER, intent(in) :: CAND(SLAVEF+1) INTEGER, DIMENSION(0:NPROCS - 1), intent(in) :: MEM_DISTRIB INTEGER, intent(out) :: NMB_OF_CAND integer i,nless DOUBLE PRECISION lref DOUBLE PRECISION MSG_SIZE nless = 0 NMB_OF_CAND=CAND(SLAVEF+1) do i=1,NMB_OF_CAND WLOAD(i)=LOAD_FLOPS(CAND(i)) IF(BDC_M2_FLOPS)THEN WLOAD(i)=WLOAD(i)+NIV2(CAND(i)+1) ENDIF end do IF(K69 .gt. 1) THEN CALL SMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE, & CAND,NMB_OF_CAND) ENDIF lref = LOAD_FLOPS(MYID) do i=1, NMB_OF_CAND if (WLOAD(i).lt.lref) nless=nless+1 end do SMUMPS_LOAD_LESS_CAND = nless return end function SMUMPS_LOAD_LESS_CAND subroutine SMUMPS_LOAD_SET_SLAVES_CAND & (MEM_DISTRIB,CAND, & & SLAVEF, & nslaves_inode, DEST) implicit none integer, intent(in) :: nslaves_inode, SLAVEF integer, intent(in) :: CAND(SLAVEF+1) integer, dimension(0:NPROCS - 1), intent(in) :: MEM_DISTRIB integer, intent(out) :: DEST(CAND(SLAVEF+1)) integer i,j,NMB_OF_CAND external MUMPS_SORT_DOUBLES NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in SMUMPS_LOAD_SET_SLAVES_CAND', & nslaves_inode, NPROCS, NMB_OF_CAND CALL MUMPS_ABORT() end if if (nslaves_inode.eq.NPROCS-1) then j=MYID+1 do i=1,nslaves_inode if(j.ge.NPROCS) j=0 DEST(i)=j j=j+1 end do else do i=1,NMB_OF_CAND IDWLOAD(i)=i end do call MUMPS_SORT_DOUBLES(NMB_OF_CAND, & WLOAD(1),IDWLOAD(1) ) do i=1,nslaves_inode DEST(i)= CAND(IDWLOAD(i)) end do IF(BDC_MD)THEN do i=nslaves_inode+1,NMB_OF_CAND DEST(i)= CAND(IDWLOAD(i)) end do ENDIF end if return end subroutine SMUMPS_LOAD_SET_SLAVES_CAND SUBROUTINE SMUMPS_INIT_ALPHA_BETA(K69) IMPLICIT NONE INTEGER K69 IF (K69 .LE. 4) THEN ALPHA = 0.0d0 BETA = 0.0d0 RETURN ENDIF IF (K69 .EQ. 5) THEN ALPHA = 0.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 6) THEN ALPHA = 0.5d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 7) THEN ALPHA = 0.5d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 8) THEN ALPHA = 1.0d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 9) THEN ALPHA = 1.0d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 10) THEN ALPHA = 1.0d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 11) THEN ALPHA = 1.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 12) THEN ALPHA = 1.5d0 BETA = 100000.0d0 RETURN ENDIF ALPHA = 1.5d0 BETA = 150000.0d0 RETURN END SUBROUTINE SMUMPS_INIT_ALPHA_BETA SUBROUTINE SMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,ARRAY_ADM,LEN) IMPLICIT NONE INTEGER i,LEN INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION MSG_SIZE,FORBIGMSG INTEGER ARRAY_ADM(LEN) DOUBLE PRECISION MY_LOAD FORBIGMSG = 1.0d0 IF (K69 .lt.2) THEN RETURN ENDIF IF(BDC_M2_FLOPS)THEN MY_LOAD=LOAD_FLOPS(MYID)+NIV2(MYID+1) ELSE MY_LOAD=LOAD_FLOPS(MYID) ENDIF IF((MSG_SIZE * dble(K35) ) .gt. 3200000.0d0) THEN FORBIGMSG = 2.0d0 ENDIF IF (K69 .le. 4) THEN DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i)/MY_LOAD ELSE IF ( MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1 ) THEN WLOAD(i) = WLOAD(i) * & dble(MEM_DISTRIB(ARRAY_ADM(i))) & * FORBIGMSG & + dble(2) ENDIF ENDIF ENDDO RETURN ENDIF DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i) / MY_LOAD ELSE IF(MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1) THEN WLOAD(i) = (WLOAD(i) + & ALPHA * MSG_SIZE * dble(K35) + & BETA) * FORBIGMSG ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ARCHGENWLOAD SUBROUTINE SMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: MYID, SLAVEF, COMM, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES( NSLAVES ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER NCB, NFRONT, NBROWS_SLAVE INTEGER i, IERR,WHAT,INODE, allocok LOGICAL :: EXIT_FLAG DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: FLOPS_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: CB_BAND ALLOCATE(MEM_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of MEM_INCREMENT ' & // 'in routine SMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(FLOPS_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of FLOPS_INCREMENT ' & // 'in routine SMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(CB_BAND(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of CB_BAND ' & // 'in routine SMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in SMUMPS_LOAD_MASTER_2_ALL" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL SMUMPS_BUF_SEND_NOT_MSTR(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),KEEP,IERR) IF (IERR == -1 ) THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in SMUMPS_LOAD_MASTER_2_ALL", & NSLAVES, TAB_POS(SLAVEF+2) CALL MUMPS_ABORT() ENDIF NCB = TAB_POS(NSLAVES+1) - 1 NFRONT = NCB + NASS DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) IF ( KEEP(50) == 0 ) THEN FLOPS_INCREMENT( i ) = (dble(NBROWS_SLAVE)*dble( NASS ))+ & dble(NBROWS_SLAVE) * dble(NASS) * & dble(2*NFRONT-NASS-1) ELSE FLOPS_INCREMENT( i ) = dble(NBROWS_SLAVE) * dble(NASS ) * & dble( 2 * ( NASS + TAB_POS(i+1) - 1 ) & - NBROWS_SLAVE - NASS + 1 ) ENDIF IF ( BDC_MEM ) THEN IF ( KEEP(50) == 0 ) THEN MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT) ELSE MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble( NASS + TAB_POS(i+1) - 1 ) END IF ENDIF IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN CB_BAND(i)=dble(-999999) ELSE IF ( KEEP(50) == 0 ) THEN CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT-NASS) ELSE CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(TAB_POS(i+1)-1) END IF ENDIF END DO IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(CB_BAND(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF 111 CONTINUE CALL SMUMPS_BUF_BCAST_ARRAY(BDC_MEM, COMM, MYID, SLAVEF, & FUTURE_NIV2, & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = LOAD_FLOPS(LIST_SLAVES(i)) & + FLOPS_INCREMENT(i) IF ( BDC_MEM ) THEN DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) & + MEM_INCREMENT(i) END IF ENDDO ENDIF 100 CONTINUE DEALLOCATE(MEM_INCREMENT,FLOPS_INCREMENT,CB_BAND) RETURN END SUBROUTINE SMUMPS_LOAD_MASTER_2_ALL SUBROUTINE SMUMPS_LOAD_POOL_UPD_NEW_POOL( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL, SLAVEF, COMM, MYID INTEGER N, KEEP(500) INTEGER(8) KEEP8(150) INTEGER POOL( LPOOL ), PROCNODE( KEEP(28) ), STEP( N ) INTEGER ND( KEEP(28) ), FILS( N ) INTEGER i, INODE, NELIM, NFR, LEVEL, IERR, WHAT DOUBLE PRECISION COST LOGICAL :: EXIT_FLAG INTEGER NBINSUBTREE,NBTOP,INSUBTREE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF(BDC_MD)THEN RETURN ENDIF IF((KEEP(76).EQ.0).OR.(KEEP(76).EQ.2))THEN IF(NBTOP.NE.0)THEN DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE IF(KEEP(76).EQ.1)THEN IF(INSUBTREE.EQ.1)THEN DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE WRITE(*,*) & 'Internal error: Unknown pool management strategy' CALL MUMPS_ABORT() ENDIF ENDIF 20 CONTINUE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS(i) GOTO 10 ENDIF NFR = ND( STEP(INODE) ) LEVEL = MUMPS_TYPENODE( PROCNODE(STEP(INODE)), KEEP(199) ) IF (LEVEL .EQ. 1) THEN COST = dble( NFR ) * dble( NFR ) ELSE IF ( KEEP(50) == 0 ) THEN COST = dble( NFR ) * dble( NELIM ) ELSE COST = dble( NELIM ) * dble( NELIM ) ENDIF ENDIF 30 CONTINUE IF ( abs(POOL_LAST_COST_SENT-COST).GT.DM_THRES_MEM ) THEN WHAT = 2 111 CONTINUE CALL SMUMPS_BUF_BROADCAST( WHAT, & COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_POOL_UPD_NEW_POOL SUBROUTINE SMUMPS_LOAD_SBTR_UPD_NEW_POOL( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL,MYID,SLAVEF,COMM,INODE INTEGER POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER WHAT,IERR LOGICAL OK DOUBLE PRECISION COST LOGICAL FLAG, EXIT_FLAG EXTERNAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_LOAD(STEP_LOAD(INODE)), KEEP(199)) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)))THEN IF(NE_LOAD(STEP_LOAD(INODE)).EQ.0)THEN RETURN ENDIF ENDIF FLAG=.FALSE. IF(INDICE_SBTR.LE.NB_SUBTREES)THEN IF(INODE.EQ.MY_FIRST_LEAF(INDICE_SBTR))THEN FLAG=.TRUE. ENDIF ENDIF IF(FLAG)THEN SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY)=MEM_SUBTREE(INDICE_SBTR) SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY)=SBTR_CUR(MYID) INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY+1 WHAT = 3 IF(dble(MEM_SUBTREE(INDICE_SBTR)).GE.DM_THRES_MEM)THEN 111 CONTINUE CALL SMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in SMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF SBTR_MEM(MYID)=SBTR_MEM(MYID)+ & dble(MEM_SUBTREE(INDICE_SBTR)) INDICE_SBTR=INDICE_SBTR+1 IF(INSIDE_SUBTREE.EQ.0)THEN INSIDE_SUBTREE=1 ENDIF ELSE IF(INODE.EQ.MY_ROOT_SBTR(INDICE_SBTR-1))THEN WHAT = 3 COST=-SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY-1) IF(abs(COST).GE.DM_THRES_MEM)THEN 112 CONTINUE CALL SMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in SMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY-1 SBTR_MEM(MYID)=SBTR_MEM(MYID)- & SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY) SBTR_CUR(MYID)=SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY) IF(INDICE_SBTR_ARRAY.EQ.1)THEN SBTR_CUR(MYID)=dble(0) INSIDE_SUBTREE=0 ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_LOAD_SBTR_UPD_NEW_POOL SUBROUTINE SMUMPS_SET_PARTI_ACTV_MEM & (SLAVEF,KEEP,KEEP8,PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47, K48, K50 INTEGER(8) :: K821 DOUBLE PRECISION DK821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS INTEGER(8)::TOTAL_MEM LOGICAL FORCE_CAND DOUBLE PRECISION TEMP(SLAVEF),PEAK INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME IF (KEEP8(21) .GT. 0_8) THEN write(*,*)MYID, & ": Internal Error 1 in SMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF K821=abs(KEEP8(21)) DK821=dble(K821) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF(K48.NE.4)THEN WRITE(*,*)'SMUMPS_COMPUTE_PARTI_ACTV_MEM_K821 & should be called with KEEP(48) different from 4' CALL MUMPS_ABORT() ENDIF KMIN=1 KMAX=int(K821/int(NFRONT,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=DM_MEM(PROCS(i)) IDWLOAD(i)=PROCS(i) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = DM_MEM(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) TOTAL_MEM=int(NCB,8)*int(NFRONT,8) SOMME=dble(0) J=1 PEAK=dble(0) DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN PEAK=max(PEAK,WLOAD(i)) TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_SBTR)THEN TEMP(J)=TEMP(J)+SBTR_MEM(IDWLOAD(i))- & SBTR_CUR(IDWLOAD(i)) ENDIF IF(BDC_POOL)THEN TEMP(J)=TEMP(J)+POOL_MEM(TEMP_ID(J)) ENDIF IF(BDC_M2_MEM)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) IF(K50.EQ.0)THEN PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT)*dble(NFRONT-NCB)) ELSE PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT-NCB)*dble(NFRONT-NCB)) ENDIF PEAK=max(PEAK,TEMP(OTHERS)) SOMME=dble(0) DO i=1,NUMBER_OF_PROCS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(SOMME.LE.dble(TOTAL_MEM)) THEN GOTO 096 ENDIF 096 CONTINUE SOMME=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(dble(TOTAL_MEM).GE.SOMME) THEN AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,OTHERS IF(K50.EQ.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC IF(X.LE.0) THEN WRITE(*,*)"Internal Error 2 in & SMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 111 IF(NCB.EQ.ACC) GOTO 111 ENDDO 111 CONTINUE IF((ACC.GT.NCB))THEN X=0 DO i=1,OTHERS X=X+NB_ROWS(i) ENDDO WRITE(*,*)'NCB=',NCB,',SOMME=',X WRITE(*,*)MYID, & ": Internal Error 3 in SMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF IF((NCB.NE.ACC))THEN IF(K50.NE.0)THEN IF(CHOSEN.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+ADDITIONNAL_ROWS ELSE TMP_SUM=dble(TOTAL_MEM)/dble(NUMBER_OF_PROCS) CHOSEN=0 ACC=0 DO i=1,OTHERS X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 002 IF(NCB.EQ.ACC) GOTO 002 ENDDO 002 CONTINUE IF(ACC.LT.NCB)THEN NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+(NCB-ACC) ENDIF ENDIF GOTO 333 ENDIF ADDITIONNAL_ROWS=NCB-ACC DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 222 ENDIF ENDDO 222 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 333 CONTINUE IF(NB_ROWS(CHOSEN).EQ.0) CHOSEN=CHOSEN-1 GOTO 889 ELSE DO i=OTHERS,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(dble(TOTAL_MEM).GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i DO J=1,i IF(TEMP(J).EQ.TEMP(i)) THEN SMALL_SET=J GOTO 123 ENDIF ENDDO 123 CONTINUE IF(i.EQ.1)THEN NB_ROWS(i)=NCB CHOSEN=1 GOTO 666 ENDIF 323 CONTINUE AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 4 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 5 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ':Internal error 6 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LT.OTHERS)THEN SMALL_SET=REF+1 REF=SMALL_SET GOTO 323 ELSE NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+NCB-ACC GOTO 666 ENDIF ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 X=int(ADDITIONNAL_ROWS/(i-1)) IF((X.EQ.0).AND.(ADDITIONNAL_ROWS.NE.0))THEN DO WHILE ((J.LT.i).AND.(ADDITIONNAL_ROWS.GT.0)) NB_ROWS(J)=NB_ROWS(J)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 J=J+1 ENDDO IF(ADDITIONNAL_ROWS.NE.0)THEN WRITE(*,*)MYID, & ':Internal error 7 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF GOTO 047 ENDIF IF((TEMP(1)+dble((NB_ROWS(1)+X)*NFRONT)).LE. & TEMP(i))THEN DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=X IF((AFFECTED+NB_ROWS(J)).GT. & KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED J=J+1 ENDDO ELSE DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))*dble(NFRONT)))) & /dble(NFRONT)) IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO ENDIF i=i+1 ENDDO 047 CONTINUE IF((ADDITIONNAL_ROWS.EQ.0).AND. & (i.LT.NUMBER_OF_PROCS))THEN CHOSEN=i-1 ELSE CHOSEN=i-2 ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))* & dble(NFRONT))))/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO i=i+1 ENDDO CHOSEN=i-2 ENDIF CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN IF(K50.NE.0) THEN IF((TEMP(i)+dble(NB_ROWS(i)) & *dble(X+NB_ROWS(i)+NFRONT-NCB)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF IF(K50.EQ.0) THEN IF((TEMP(i)+dble(NB_ROWS(i))*dble(NFRONT)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO ENDIF 889 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN IF(X.EQ.1)THEN WRITE(*,*)MYID, & ':Internal error 12 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 DO i=1,CHOSEN SLAVES_LIST(i)=TEMP_ID(i) TAB_POS(i)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*) & 'Internal error 14 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*) & 'Internal error 15 in SMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF END SUBROUTINE SMUMPS_SET_PARTI_ACTV_MEM SUBROUTINE SMUMPS_SET_PARTI_FLOP_IRR & (NCBSON_MAX,SLAVEF,KEEP,KEEP8, & PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID,INODE,MP,LP) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: MP,LP INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47,K48, K50,K83,K69 INTEGER(8) :: K821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM,DELTA,A,B,C,MASTER_WORK INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS,NELIM INTEGER(8) X8 LOGICAL FORCE_CAND,SMP DOUBLE PRECISION BANDE_K821 INTEGER NB_SAT,NB_ZERO DOUBLE PRECISION TEMP(SLAVEF),TOTAL_COST, MAX_MEM_ALLOW INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) INTEGER NSLAVES_REF,NCB_FILS EXTERNAL MPI_WTIME,MUMPS_GETKMIN INTEGER MUMPS_GETKMIN INTEGER POS_MIN_LOAD,SIZE_MY_SMP,WHAT,ADDITIONNAL_ROWS_SPECIAL LOGICAL HAVE_TYPE1_SON DOUBLE PRECISION MIN_LOAD,MAX_LOAD,TEMP_MAX_LOAD DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION BUF_SIZE,NELIM_MEM_SIZE DOUBLE PRECISION MEM_SIZE_STRONG(SLAVEF),MEM_SIZE_WEAK(SLAVEF) K821=abs(KEEP8(21)) TEMP_MAX_LOAD=dble(0) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) K83=KEEP(83) K69=0 NCB_FILS=NCBSON_MAX IF(int(NCB_FILS,8)*int(min(NCB,NCB_FILS),8).GT.K821)THEN HAVE_TYPE1_SON=.TRUE. ELSE HAVE_TYPE1_SON=.FALSE. ENDIF SMP=(K69.NE.0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF NELIM=NFRONT-NCB KMAX=int(K821/int(NCB,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=LOAD_FLOPS(PROCS(i)) IDWLOAD(i)=PROCS(i) WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = LOAD_FLOPS(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Negative load ', & WLOAD(i) ENDIF ENDIF WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF KMAX=int(NCB/OTHERS) KMIN=MUMPS_GETKMIN(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) IF(K50.EQ.0)THEN TOTAL_COST=dble( NELIM ) * dble ( NCB ) + & dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE TOTAL_COST=dble(NELIM) * dble ( NCB ) * & dble(NFRONT+1) ENDIF CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM,K50, & 2,MASTER_WORK) SOMME=dble(0) J=1 IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.GT.K83))THEN MASTER_WORK=dble(KEEP(88))*MASTER_WORK/dble(100) ENDIF IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.LE.K83))THEN MASTER_WORK=dble(KEEP(87))*MASTER_WORK/dble(100) ENDIF IF(MASTER_WORK.LT.dble(1))THEN MASTER_WORK=dble(1) ENDIF NSLAVES_REF=int(TOTAL_COST/MASTER_WORK)+1 IF(FORCE_CAND)THEN NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS) ELSE NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS-1) ENDIF DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_M2_FLOPS)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) SOMME=dble(0) TMP_SUM=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) TMP_SUM=TMP_SUM+TEMP(i) ENDDO TMP_SUM=(TMP_SUM/dble(OTHERS))+ & (TOTAL_COST/dble(OTHERS)) SIZE_MY_SMP=OTHERS MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 IF(.NOT.SMP) MAX_LOAD=TEMP(OTHERS) IF(SMP)THEN J=1 DO i=1,OTHERS IF(MEM_DISTRIB(TEMP_ID(i)).EQ.1)THEN IF(TEMP(i).LE.TMP_SUM)THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ELSE ENDIF ENDIF ENDDO MAX_LOAD=WLOAD(J-1) SIZE_MY_SMP=J-1 DO i=1,OTHERS IF((MEM_DISTRIB(TEMP_ID(i)).NE.1).OR. & ((MEM_DISTRIB(TEMP_ID(i)).EQ.1).AND. & (TEMP(i).GE.TMP_SUM)))THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ENDIF ENDDO TEMP=WLOAD TEMP_ID=IDWLOAD ENDIF IF(BDC_MD)THEN BUF_SIZE=dble(K821) IF (KEEP(201).EQ.2) THEN A=dble(int((dble(KEEP(100))/dble(2))/dble(NELIM))) IF(K50.EQ.0)THEN BUF_SIZE=min(BUF_SIZE,A*dble(NCB)) ELSE BUF_SIZE=min(BUF_SIZE,A*A) ENDIF ENDIF BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS A=dble(MD_MEM(TEMP_ID(i)))/ & dble(NELIM) A=A*dble(NFRONT) IF(K50.EQ.0)THEN B=dble(int(dble(NCB)/dble(NUMBER_OF_PROCS))+1)* & dble(NFRONT) ELSE WHAT = 5 CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) B=dble(X8)+(dble(J)*dble(NELIM)) ENDIF NELIM_MEM_SIZE=A+B MEM_SIZE_WEAK(i)=NELIM_MEM_SIZE IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF IF(min(MEM_SIZE_STRONG(i),MEM_SIZE_WEAK(i)).LT.dble(0))THEN IF(MEM_SIZE_STRONG(i).LT.0.0d0)THEN MEM_SIZE_STRONG(i)=dble(0) ELSE MEM_SIZE_WEAK(i)=dble(0) ENDIF ENDIF ENDDO ELSE BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF MEM_SIZE_STRONG(i)=max(dble(0),MEM_SIZE_STRONG(i)) MEM_SIZE_WEAK(i)=huge(MEM_SIZE_WEAK(i)) ENDDO ENDIF IF((((NUMBER_OF_PROCS.LE.K83).AND.FORCE_CAND).AND. & (TOTAL_COST.GE.SOMME)).OR. & (.NOT.FORCE_CAND).OR. & (((NUMBER_OF_PROCS+1).GT.K83).AND.FORCE_CAND))THEN REF=NSLAVES_REF SMALL_SET=NSLAVES_REF IF(.NOT.SMP)THEN DO i=NSLAVES_REF,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(TOTAL_COST.GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) 450 CONTINUE SOMME=dble(0) DO J=1,X SOMME=SOMME+(TEMP(X)-TEMP(J)) ENDDO IF(SOMME.GT.TOTAL_COST)THEN X=X-1 GOTO 450 ELSE IF(X.LT.SIZE_MY_SMP) THEN REF=X SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) J=X+1 MAX_LOAD=TEMP(X) TMP_SUM=MAX_LOAD DO i=X+1,OTHERS IF(TEMP(i).GT.MAX_LOAD)THEN SOMME=SOMME+(dble(i-1)*(TEMP(i)-MAX_LOAD)) TMP_SUM=MAX_LOAD MAX_LOAD=TEMP(i) ELSE SOMME=SOMME+(MAX_LOAD-TEMP(i)) ENDIF IF(i.EQ.NSLAVES_REF)THEN SMALL_SET=NSLAVES_REF REF=SMALL_SET GOTO 323 ENDIF IF(SOMME.GT.TOTAL_COST)THEN REF=i-1 SMALL_SET=i-1 MAX_LOAD=TMP_SUM GOTO 323 ENDIF ENDDO ENDIF ENDIF ENDIF 323 CONTINUE MAX_LOAD=dble(0) DO i=1,SMALL_SET MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO TEMP_MAX_LOAD=MAX_LOAD NB_ROWS=0 TMP_SUM=dble(0) CHOSEN=0 ACC=0 NB_SAT=0 NB_ZERO=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) X=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 1 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF TMP_SUM=MAX_LOAD IF(K50.EQ.0)THEN MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM)* & dble(2*NFRONT-NELIM-1)))) ELSE MAX_LOAD=max(MAX_LOAD, & TEMP(i)+(dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ACC)-NB_ROWS(i) & -NELIM+1)) ENDIF IF(TMP_SUM.LT.MAX_LOAD)THEN ENDIF IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 2 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ': Internal error 3 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LE.OTHERS)THEN IF((NB_SAT.EQ.SMALL_SET).AND.(SMALL_SET.LT. & NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ADDITIONNAL_ROWS_SPECIAL=NCB-ACC DO i=1,SMALL_SET MAX_LOAD=TEMP_MAX_LOAD ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS-NELIM & +1) SOMME=SOMME/dble(SMALL_SET-NB_SAT) NB_ROWS=0 NB_ZERO=0 ACC=0 CHOSEN=0 NB_SAT=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO J=1,SMALL_SET A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=(dble(NELIM)*dble(NELIM+2*ACC+1)) C=-(MAX_LOAD-TEMP(J)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) X=X+1 IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 4 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE NB_ZERO=NB_ZERO+1 X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN NB_ZERO=NB_ZERO+1 X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X TMP_SUM=MAX_LOAD TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(J)+(dble(NELIM) * & dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(NCB.EQ.ACC) GOTO 666 ENDDO IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF(NB_ZERO.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF((NB_SAT+NB_ZERO).EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF ENDDO 434 CONTINUE ADDITIONNAL_ROWS=NCB-ACC IF(ADDITIONNAL_ROWS.NE.0)THEN IF(ADDITIONNAL_ROWS.LT.KMIN)THEN i=CHOSEN J=ACC 436 CONTINUE IF(NB_ROWS(i).NE.0)THEN J=J-NB_ROWS(i) A=dble(1) B=dble(J+2) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(J+2+NELIM) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(J+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(NB_ROWS(i).NE.KMAX)THEN IF(NCB-J.LE.KMAX)THEN NB_ROWS(i)=+NCB-J ADDITIONNAL_ROWS=0 ENDIF ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(i)+ & (dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(i) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF ELSE i=i-1 IF(i.NE.0)GOTO 436 ENDIF IF(ADDITIONNAL_ROWS.NE.0)THEN i=CHOSEN IF(i.NE.SMALL_SET)THEN i=i+1 IF(NB_ROWS(i).NE.0)THEN WRITE(*,*)MYID, & ': Internal error 5 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF CHOSEN=i ENDIF ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X ACC=ACC+X ADDITIONNAL_ROWS=NCB-ACC ELSE IF((TEMP(i).GT.MAX_LOAD))THEN MAX_LOAD=TEMP(i) NB_SAT=0 ACC=0 NB_ROWS=0 DO J=1,i A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(J)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 6 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF ACC=ACC+X MAX_LOAD=max(MAX_LOAD, & TEMP(J)+ & (dble(NELIM)*dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(NCB.EQ.ACC) GOTO 741 IF(NCB-ACC.LT.KMIN) GOTO 210 ENDDO 210 CONTINUE ENDIF 741 CONTINUE i=i+1 ADDITIONNAL_ROWS=NCB-ACC ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)*dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 7 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=min(KMAX,KMIN) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 488 ENDDO 488 CONTINUE ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 8 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=KMIN ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 477 ENDDO 477 CONTINUE IF(ACC.NE.NCB)THEN NB_SAT=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN NB_SAT=NB_SAT+1 ENDIF ACC=ACC+NB_ROWS(i) IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 834 ENDDO 834 CONTINUE ENDIF IF(ACC.NE.NCB)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS-NB_SAT) ACC=0 DO i=1,CHOSEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN GOTO 102 ENDIF A=dble(NELIM) B=dble(NELIM)* & dble(NELIM+2*(ACC+NB_ROWS(i))+1) C=-(SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(1) B=dble(ACC+NELIM) C=dble(-BANDE_K821) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 9 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC+X+NB_ROWS(i)).GT.NCB)THEN IF((NCB-ACC).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NCB-ACC ENDIF ELSE IF((NB_ROWS(i)+X).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+X ENDIF ENDIF 102 CONTINUE ACC=ACC+NB_ROWS(i) IF(NCB.EQ.ACC) THEN CHOSEN=i GOTO 666 ENDIF IF(NCB-ACC.LT.KMIN) THEN CHOSEN=i GOTO 007 ENDIF ENDDO 007 CONTINUE DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ACC=ACC+1 IF(ACC.EQ.NCB)GOTO 666 ENDDO IF(ACC.LT.NCB)THEN IF(SMP)THEN NB_ROWS(1)=NB_ROWS(1)+NCB-ACC ELSE NB_ROWS(POS_MIN_LOAD)= & NB_ROWS(POS_MIN_LOAD)+NCB-ACC ENDIF ENDIF ENDIF GOTO 666 ENDIF ENDIF GOTO 666 ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 IF(NB_SAT.EQ.SMALL_SET) GOTO 777 DO i=1,SMALL_SET IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & (dble(NFRONT+1))) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF WLOAD(i)=MAX_MEM_ALLOW ENDDO CALL MUMPS_SORT_DOUBLES(SMALL_SET, WLOAD, IDWLOAD) NB_ZERO=0 IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LT.NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LE.NUMBER_OF_PROCS))GOTO 777 AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) DO i=1,SMALL_SET KMAX=int(WLOAD(i)/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN GOTO 912 ENDIF IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GT.KMAX)THEN IF(NB_ROWS(IDWLOAD(i)).GT.KMAX)THEN ENDIF ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX NB_SAT=NB_SAT+1 IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.NE.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM) * & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))* & dble(NELIM))* & dble(2*NFRONT-NELIM-1))) GOTO 777 ENDIF ENDIF AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) ELSE IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GE.KMIN)THEN X=min(AFFECTED,ADDITIONNAL_ROWS) NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE X=int((MAX_LOAD-TEMP(IDWLOAD(i)))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X+AFFECTED.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ELSE X=AFFECTED+X ENDIF IF(X.GE.KMIN)THEN NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & X ELSE NB_ZERO=NB_ZERO+1 ENDIF ENDIF ENDIF 912 CONTINUE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM)* & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(SMALL_SET.LT.NUMBER_OF_PROCS)THEN IF(MAX_LOAD.GT.TEMP(SMALL_SET+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(SMALL_SET.EQ.NB_SAT)GOTO 777 IF(ADDITIONNAL_ROWS.EQ.0)THEN CHOSEN=SMALL_SET GOTO 049 ENDIF ENDDO 777 CONTINUE IF((NB_ZERO.NE.0).AND.(ADDITIONNAL_ROWS.GE.KMIN))THEN J=NB_ZERO 732 CONTINUE X=int(ADDITIONNAL_ROWS/(J)) IF(X.LT.KMIN)THEN J=J-1 GOTO 732 ENDIF IF(X*J.LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,SMALL_SET AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(i).EQ.0)THEN IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(X.GT.KMAX)THEN X=KMAX ENDIF IF(X.GT.KMIN)THEN NB_ROWS(i)=X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) ENDIF ENDIF ENDDO ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) AFFECTED=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF ELSE IF((TEMP(i).GT.MAX_LOAD))THEN IF(NB_SAT.EQ.i-1) GOTO 218 X=(ADDITIONNAL_ROWS/(i-1-NB_SAT)) ACC=1 DO J=1,i-1 TMP_SUM=((dble(NELIM) * dble(NB_ROWS(J)+X)) & +(dble(NB_ROWS(J)+X)*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) IF((TEMP(J)+TMP_SUM).GT.MAX_LOAD)THEN ACC=0 ENDIF ENDDO IF(ACC.EQ.1)THEN MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ELSE MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF TMP_SUM=((dble(NELIM)* dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 10 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ENDIF ENDIF 218 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN IF(NB_ROWS(i)+1.GE.KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 ENDIF MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((ADDITIONNAL_ROWS.NE.0))THEN IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN i=CHOSEN+1 ELSE IF(CHOSEN.NE.NUMBER_OF_PROCS)THEN WRITE(*,*)MYID, & ': Internal error 11 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF i=CHOSEN ENDIF DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(TEMP(i).LE.MAX_LOAD)THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) AFFECTED=X IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 12 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF IF(i.NE.NUMBER_OF_PROCS) GOTO 624 ELSE IF((TEMP(i).GT.MAX_LOAD))THEN X=int(ADDITIONNAL_ROWS/i-1) X=max(X,1) IF((MAX_LOAD+((dble(NELIM)* & dble(X))+(dble( & X)*dble(NELIM))*dble( & (2*NFRONT-NELIM-1)))).LE.TEMP(i))THEN AFFECTED=X POS=1 ELSE POS=0 ENDIF MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) MAX_MEM_ALLOW=BANDE_K821 IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(POS.EQ.0)THEN TMP_SUM=((dble(NELIM) * & dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((TEMP(i)-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT- & NELIM))) ELSE X=int(TMP_SUM) ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((X+NB_ROWS(J)).GT.KMAX)THEN X=KMAX-NB_ROWS(J) ELSE IF((NB_ROWS(J)+X).LT. & KMIN)THEN X=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF J=J+1 ENDDO ENDIF 624 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ACC=0 DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 13 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((X+NB_ROWS(i)).GE.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF((X+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ACC=ACC+1 ELSE ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN CHOSEN=CHOSEN+1 ENDIF IF(ACC.EQ.0)THEN ACC=1 ENDIF X=int(ADDITIONNAL_ROWS/ACC) X=max(X,1) ACC=0 DO i=1,CHOSEN J=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(J)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN J=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(J)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) J=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).LT.KMAX)THEN IF((min(X,J)+NB_ROWS(i)).GE.KMAX)THEN IF((KMAX-NB_ROWS(i)).GT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ENDIF ELSE IF((min(X,J)+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+min(X,J) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & min(X,J) ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(ACC.GT.0)THEN DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT. & ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF(NB_ROWS(i).EQ.0)THEN IF(min(KMIN,KMAX).LT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=min(KMIN,KMAX) ADDITIONNAL_ROWS= & ADDITIONNAL_ROWS- & min(KMIN,KMAX) ENDIF ELSE NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO ENDIF DO i=1,CHOSEN IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-dble(NB_ROWS(i)*NFRONT)) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 049 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO i=1,CHOSEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(i)=NB_ROWS(i)+X IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 049 CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO GOTO 890 ELSE IF((KEEP(83).GE.NUMBER_OF_PROCS).AND.FORCE_CAND)THEN MAX_LOAD=dble(0) DO i=1,OTHERS MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO ACC=0 CHOSEN=0 X=1 DO i=1,OTHERS ENDDO DO i=2,OTHERS IF(TEMP(i).EQ.TEMP(1))THEN X=X+1 ELSE GOTO 329 ENDIF ENDDO 329 CONTINUE TMP_SUM=TOTAL_COST/dble(X) TEMP_MAX_LOAD=dble(0) DO i=1,OTHERS IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i))) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN SOMME=MAX_LOAD-TEMP(i) ELSE SOMME=TMP_SUM ENDIF X=int(SOMME/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GT.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=min(KMIN,KMAX) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN C=-(MAX_LOAD-TEMP(i)) ELSE C=-TMP_SUM ENDIF DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 14 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GT.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LE.min(KMIN,KMAX))THEN IF(KMAX.LT.KMIN)THEN X=0 ELSE X=min(KMIN,KMAX) ENDIF ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD,TEMP(i)) NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(ACC.EQ.NCB) GOTO 541 ENDDO 541 CONTINUE IF(ACC.LT.NCB)THEN IF(K50.EQ.0)THEN ADDITIONNAL_ROWS=NCB-ACC DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)).LT.KMAX)THEN IF(ADDITIONNAL_ROWS.GT.(KMAX-NB_ROWS(J)))THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(J)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)+X).GT.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(J)=NB_ROWS(J)+X ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,NUMBER_OF_PROCS IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-(dble(NB_ROWS(i))* & dble(NFRONT))) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 889 ENDDO GOTO 994 ELSE ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC ENDIF ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC 994 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(OTHERS)) IF((X*OTHERS).LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,OTHERS NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X IF(ADDITIONNAL_ROWS.LT.X)X=ADDITIONNAL_ROWS ENDDO CHOSEN=OTHERS ENDIF ENDIF 889 CONTINUE MAX_LOAD=TEMP_MAX_LOAD 890 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*)MYID, & ': Internal error 15 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 X=1 DO i=1,J IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(X)=TEMP_ID(i) TAB_POS(X)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*)MYID, & ': Internal error 16 in SMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in SMUMPS_SET_PARTI_FLOP_IRR', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE SMUMPS_SET_PARTI_FLOP_IRR SUBROUTINE SMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(KEEP(28)), POOL(LPOOL), PROCNODE(KEEP(28)) LOGICAL UPPER INTEGER J DOUBLE PRECISION MEM_COST INTEGER NBINSUBTREE,i,NBTOP EXTERNAL SMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR LOGICAL SMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'SMUMPS_LOAD_POOL_CHECK_MEM must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=SMUMPS_LOAD_GET_MEM(INODE) IF((DM_MEM(MYID)+dble(MEM_COST)+ PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL) & .GT.MAX_PEAK_STK)THEN DO i=NBTOP-1,1,-1 INODE = POOL( LPOOL - 2 - i) MEM_COST=SMUMPS_LOAD_GET_MEM(INODE) IF((INODE.LT.0).OR.(INODE.GT.N)) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF IF((DM_MEM(MYID)+dble(MEM_COST)+PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL).LE. & MAX_PEAK_STK) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF ENDDO IF(NBINSUBTREE.NE.0)THEN INODE = POOL( NBINSUBTREE ) IF(.NOT.MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*) & 'Internal error 1 in SMUMPS_LOAD_POOL_CHECK_MEM' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE SMUMPS_LOAD_POOL_CHECK_MEM SUBROUTINE SMUMPS_LOAD_SET_SBTR_MEM(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'SMUMPS_LOAD_SET_SBTR_MEM & should be called when K81>0 and K47>2' ENDIF IF(WHAT)THEN PEAK_SBTR_CUR_LOCAL=PEAK_SBTR_CUR_LOCAL+ & dble(MEM_SUBTREE(INDICE_SBTR)) IF(.NOT.BDC_SBTR) INDICE_SBTR=INDICE_SBTR+1 ELSE PEAK_SBTR_CUR_LOCAL=dble(0) SBTR_CUR_LOCAL=dble(0) ENDIF END SUBROUTINE SMUMPS_LOAD_SET_SBTR_MEM DOUBLE PRECISION FUNCTION SMUMPS_LOAD_GET_MEM( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFR = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) IF (LEVEL .EQ. 1) THEN COST = dble(NFR) * dble(NFR) ELSE IF ( K50 == 0 ) THEN COST = dble(NFR) * dble(NELIM) ELSE COST = dble(NELIM) * dble(NELIM) ENDIF ENDIF SMUMPS_LOAD_GET_MEM=COST RETURN END FUNCTION SMUMPS_LOAD_GET_MEM RECURSIVE SUBROUTINE SMUMPS_NEXT_NODE(FLAG,COST,COMM) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG, EXIT_FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF(FLAG)THEN WHAT=17 IF(BDC_M2_FLOPS)THEN TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) ELSE IF(BDC_M2_MEM)THEN IF(BDC_POOL.AND.(.NOT.BDC_MD))THEN TO_BE_SENT=max(TMP_M2,POOL_LAST_COST_SENT) POOL_LAST_COST_SENT=TO_BE_SENT ELSE IF(BDC_MD)THEN DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM ELSE TO_BE_SENT=dble(0) ENDIF ENDIF ELSE WHAT=6 TO_BE_SENT=dble(0) ENDIF 111 CONTINUE CALL SMUMPS_BUF_BROADCAST( WHAT, & COMM, NPROCS, & FUTURE_NIV2, & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 100 CONTINUE RETURN END SUBROUTINE SMUMPS_NEXT_NODE SUBROUTINE SMUMPS_UPPER_PREDICT(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE SMUMPS_BUF IMPLICIT NONE INTEGER INODE,NSTEPS,MYID,SLAVEF,COMM,N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE(NSTEPS),NE(NSTEPS),STEP(N),PROCNODE(NSTEPS) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_PROCNODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER i,NCB,NELIM INTEGER MUMPS_PROCNODE INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE LOGICAL :: EXIT_FLAG IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in SMUMPS_UPPER_PREDICT' CALL MUMPS_ABORT() ENDIF IF((INODE.LT.0).OR.(INODE.GT.N)) THEN RETURN ENDIF i=INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NCB=ND_LOAD(STEP_LOAD(INODE))-NELIM + KEEP_LOAD(253) WHAT=5 FATHER_NODE=DAD_LOAD(STEP_LOAD(INODE)) IF (FATHER_NODE.EQ.0) THEN RETURN ENDIF IF((FRERE(STEP(FATHER_NODE)).EQ.0).AND. & ((FATHER_NODE.EQ.KEEP(38)).OR. & (FATHER_NODE.EQ.KEEP(20))))THEN RETURN ENDIF IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(FATHER_NODE)), & KEEP(199))) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),KEEP(199)) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL SMUMPS_PROCESS_NIV2_MEM_MSG(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL SMUMPS_PROCESS_NIV2_FLOPS_MSG(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)).EQ.1)THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MYID,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB,8)*int(NCB,8) POS_MEM=POS_MEM+1 ENDIF ENDIF GOTO 666 ENDIF 111 CONTINUE CALL SMUMPS_BUF_SEND_FILS(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP,MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 666 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in SMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE RETURN END SUBROUTINE SMUMPS_UPPER_PREDICT SUBROUTINE SMUMPS_REMOVE_NODE(INODE,NUM_CALL) IMPLICIT NONE DOUBLE PRECISION MAXI INTEGER i,J,IND_MAXI INTEGER INODE,NUM_CALL IF(BDC_M2_MEM)THEN IF(((NUM_CALL.EQ.1).AND.(BDC_MD)).OR. & ((NUM_CALL.EQ.2).AND.(.NOT.BDC_MD)))THEN RETURN ENDIF ENDIF IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0).AND. & ((INODE.EQ.KEEP_LOAD(38)).OR. & (INODE.EQ.KEEP_LOAD(20)))) THEN RETURN ENDIF DO i=POOL_SIZE,1,-1 IF(POOL_NIV2(i).EQ.INODE) GOTO 666 ENDDO NB_SON(STEP_LOAD(INODE))=-1 RETURN 666 CONTINUE IF(BDC_M2_MEM)THEN IF(POOL_NIV2_COST(i).EQ.MAX_M2)THEN TMP_M2=MAX_M2 MAXI=dble(0) IND_MAXI=-9999 DO J=POOL_SIZE,1,-1 IF(J.NE.i) THEN IF(POOL_NIV2_COST(J).GT.MAXI)THEN MAXI=POOL_NIV2_COST(J) IND_MAXI=J ENDIF ENDIF ENDDO MAX_M2=MAXI J=IND_MAXI REMOVE_NODE_FLAG_MEM=.TRUE. REMOVE_NODE_COST_MEM=TMP_M2 CALL SMUMPS_NEXT_NODE(REMOVE_NODE_FLAG,MAX_M2,COMM_LD) NIV2(MYID+1)=MAX_M2 ENDIF ELSEIF(BDC_M2_FLOPS)THEN REMOVE_NODE_COST=POOL_NIV2_COST(i) REMOVE_NODE_FLAG=.TRUE. CALL SMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & -POOL_NIV2_COST(i),COMM_LD) NIV2(MYID+1)=NIV2(MYID+1)-POOL_NIV2_COST(i) ENDIF DO J=i+1,POOL_SIZE POOL_NIV2(J-1)=POOL_NIV2(J) POOL_NIV2_COST(J-1)=POOL_NIV2_COST(J) ENDDO POOL_SIZE=POOL_SIZE-1 END SUBROUTINE SMUMPS_REMOVE_NODE RECURSIVE SUBROUTINE SMUMPS_PROCESS_NIV2_MEM_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in SMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &SMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & SMUMPS_LOAD_GET_MEM(INODE) POOL_SIZE=POOL_SIZE+1 IF(POOL_NIV2_COST(POOL_SIZE).GT.MAX_M2)THEN MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL SMUMPS_NEXT_NODE(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_NIV2_MEM_MSG RECURSIVE SUBROUTINE SMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in SMUMPS_PROCESS_NIV2_FLOPS_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &SMUMPS_PROCESS_NIV2_FLOPS_MSG',POOL_NIV2_SIZE, & POOL_SIZE CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & SMUMPS_LOAD_GET_FLOPS_COST(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL SMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & POOL_NIV2_COST(POOL_SIZE), & COMM_LD) NIV2(MYID+1)=POOL_NIV2_COST(POOL_SIZE)+NIV2(MYID+1) ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_NIV2_FLOPS_MSG DOUBLE PRECISION FUNCTION SMUMPS_LOAD_GET_FLOPS_COST(INODE) USE MUMPS_FUTURE_NIV2 INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION COST i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFRONT = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) COST=dble(0) CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) SMUMPS_LOAD_GET_FLOPS_COST=COST RETURN END FUNCTION SMUMPS_LOAD_GET_FLOPS_COST INTEGER FUNCTION SMUMPS_LOAD_GET_CB_FREED( INODE ) IMPLICIT NONE INTEGER INODE,NELIM,NFR,SON,IN,i INTEGER COST_CB COST_CB=0 i = INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i DO i=1, NE_LOAD(STEP_LOAD(INODE)) NFR = ND_LOAD( STEP_LOAD(SON) ) + KEEP_LOAD(253) IN=SON NELIM = 0 20 CONTINUE IF ( IN > 0 ) THEN NELIM = NELIM + 1 IN = FILS_LOAD(IN) GOTO 20 ENDIF COST_CB=COST_CB+((NFR-NELIM)*(NFR-NELIM)) SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO SMUMPS_LOAD_GET_CB_FREED=COST_CB RETURN END FUNCTION SMUMPS_LOAD_GET_CB_FREED SUBROUTINE SMUMPS_LOAD_SEND_MD_INFO(SLAVEF,NMB_OF_CAND, & LIST_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE SMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_OF_CAND(NMB_OF_CAND) INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES(NSLAVES) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: DELTA_MD INTEGER, DIMENSION(:), ALLOCATABLE :: IPROC2POSINDELTAMD INTEGER, DIMENSION(:), ALLOCATABLE :: P_TO_UPDATE INTEGER NBROWS_SLAVE,i,WHAT,IERR INTEGER :: NP_TO_UPDATE, K LOGICAL FORCE_CAND LOGICAL :: EXIT_FLAG MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF CALL SMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NMB_OF_CAND,NASS) ALLOCATE(IPROC2POSINDELTAMD(0:SLAVEF-1), & DELTA_MD(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & P_TO_UPDATE(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) "PB ALLOC IN SMUMPS_LOAD_SEND_MD_INFO", & SLAVEF, NMB_OF_CAND, NSLAVES CALL MUMPS_ABORT() ENDIF IPROC2POSINDELTAMD = -99 NP_TO_UPDATE = 0 DO i = 1, NSLAVES NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_SLAVES(i)) = NP_TO_UPDATE NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD(NP_TO_UPDATE)=-dble(NBROWS_SLAVE)* & dble(NASS) P_TO_UPDATE(NP_TO_UPDATE) = LIST_SLAVES(i) ENDDO DO i = 1, NMB_OF_CAND K = IPROC2POSINDELTAMD(LIST_OF_CAND(i)) IF ( K > 0 ) THEN DELTA_MD(K)=DELTA_MD(K)+FCT_COST ELSE NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_OF_CAND(i)) = NP_TO_UPDATE DELTA_MD (NP_TO_UPDATE) = FCT_COST P_TO_UPDATE(NP_TO_UPDATE) = LIST_OF_CAND(i) ENDIF ENDDO WHAT=7 111 CONTINUE CALL SMUMPS_BUF_BCAST_ARRAY(.FALSE., COMM_LD, MYID, SLAVEF, & FUTURE_NIV2, & NP_TO_UPDATE, P_TO_UPDATE,0, & DELTA_MD, & DELTA_MD, & DELTA_MD, & WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL SMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in SMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF ENDDO ENDIF 100 CONTINUE DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) RETURN END SUBROUTINE SMUMPS_LOAD_SEND_MD_INFO SUBROUTINE SMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NSLAVES,NELIM) IMPLICIT NONE INTEGER INODE,NSLAVES,NFR,NELIM,IN DOUBLE PRECISION MEM_COST,FCT_COST NFR=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) IN = INODE FCT_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NELIM) MEM_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NFR) END SUBROUTINE SMUMPS_LOAD_GET_ESTIM_MEM_COST SUBROUTINE SMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN RETURN ENDIF IF(POS_ID.GT.1)THEN i=INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i IF(POS_ID.LT.NE_LOAD(STEP_LOAD(INODE))*3)THEN i=1 ENDIF DO i=1, NE_LOAD(STEP_LOAD(INODE)) J=1 DO WHILE (J.LT.POS_ID) IF(CB_COST_ID(J).EQ.SON)GOTO 295 J=J+3 ENDDO 295 CONTINUE IF(J.GE.POS_ID)THEN IF ( MUMPS_PROCNODE( & PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) .EQ. MYID ) THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 ENDIF ELSE GOTO 666 ENDIF ENDIF NSLAVES_TEMP=CB_COST_ID(J+1) POS_TEMP=CB_COST_ID(J+2) DO K=J,POS_ID-1 CB_COST_ID(K)=CB_COST_ID(K+3) ENDDO K=POS_TEMP DO WHILE (K.LE.POS_MEM-1) CB_COST_MEM(K)=CB_COST_MEM(K+2*NSLAVES_TEMP) K=K+1 ENDDO POS_MEM=POS_MEM-2*NSLAVES_TEMP POS_ID=POS_ID-3 IF((POS_MEM.LT.1).OR.(POS_ID.LT.1))THEN WRITE(*,*)MYID,': negative pos_mem or pos_id' CALL MUMPS_ABORT() ENDIF 666 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO ENDIF END SUBROUTINE SMUMPS_LOAD_CLEAN_MEMINFO_POOL SUBROUTINE SMUMPS_LOAD_CHK_MEMCST_POOL(FLAG) IMPLICIT NONE LOGICAL FLAG INTEGER i DOUBLE PRECISION MEM FLAG=.FALSE. DO i=0,NPROCS-1 MEM=DM_MEM(i)+LU_USAGE(i) IF(BDC_SBTR)THEN MEM=MEM+SBTR_MEM(i)-SBTR_CUR(i) ENDIF IF((MEM/dble(TAB_MAXS(i))).GT.0.8d0)THEN FLAG=.TRUE. GOTO 666 ENDIF ENDDO 666 CONTINUE END SUBROUTINE SMUMPS_LOAD_CHK_MEMCST_POOL SUBROUTINE SMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IMPLICIT NONE INTEGER NBINSUBTREE,INSUBTREE,NBTOP DOUBLE PRECISION MIN_COST LOGICAL SBTR INTEGER i DOUBLE PRECISION TMP_COST,TMP_MIN TMP_MIN=huge(TMP_MIN) DO i=0,NPROCS-1 IF(i.NE.MYID)THEN IF(BDC_SBTR)THEN TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i))-(SBTR_MEM(i)-SBTR_CUR(i))) ELSE TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))- & (DM_MEM(i)+LU_USAGE(i))) ENDIF ENDIF ENDDO IF(NBINSUBTREE.GT.0)THEN IF(INSUBTREE.EQ.1)THEN TMP_COST=dble(TAB_MAXS(MYID))-(DM_MEM(MYID)+ & LU_USAGE(MYID)) & -(SBTR_MEM(MYID)-SBTR_CUR(MYID)) ELSE SBTR=.FALSE. GOTO 777 ENDIF ENDIF TMP_MIN=min(TMP_COST,TMP_MIN) IF(TMP_MIN.GT.MIN_COST) SBTR=.TRUE. 777 CONTINUE END SUBROUTINE SMUMPS_CHECK_SBTR_COST SUBROUTINE SMUMPS_LOAD_COMP_MAXMEM_POOL(INODE,MAX_MEM,PROC) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION MAX_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_ON_PROCS, & RECV_BUF LOGICAL, DIMENSION(:), ALLOCATABLE :: CONCERNED DOUBLE PRECISION MAX_SENT_MSG IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF ALLOCATE( MEM_ON_PROCS(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in SMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF RECV_BUF=dble(0) MAX_SENT_MSG=dble(0) i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i NFRONT=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) NCB=NFRONT-NELIM IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN NCAND=CAND_LOAD(NPROCS+1, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) ENDIF DO i=0,NPROCS-1 IF(i.EQ.MYID)THEN MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i)+ & SMUMPS_LOAD_GET_MEM(INODE)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF CONCERNED(i)=.TRUE. ELSE MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF IF(BDC_M2_MEM)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-NIV2(i+1) ENDIF ENDIF IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN IF(BDC_MD.AND.(KEEP_LOAD(48).EQ.5))THEN DO J=1,NCAND IF(CAND_LOAD(J, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) & .EQ.i)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)- & ((dble(NFRONT)*dble(NCB))/dble(NCAND)) CONCERNED(i)=.TRUE. GOTO 666 ENDIF ENDDO ENDIF ENDIF 666 CONTINUE ENDDO DO K=1, NE_LOAD(STEP_LOAD(INODE)) i=1 DO WHILE (i.LE.POS_ID) IF(CB_COST_ID(i).EQ.SON)GOTO 295 i=i+3 ENDDO 295 CONTINUE IF(i.GE.POS_ID)THEN IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': ',SON,'has not been found & in SMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF GOTO 777 ENDIF NSLAVES=CB_COST_ID(i+1) POS=CB_COST_ID(i+2) DO i=1,NSLAVES SLAVE=int(CB_COST_MEM(POS)) IF(.NOT.CONCERNED(SLAVE))THEN MEM_ON_PROCS(SLAVE)=MEM_ON_PROCS(SLAVE)+ & dble(CB_COST_MEM(POS+1)) ENDIF DO J=0,NPROCS-1 IF(CONCERNED(J))THEN IF(SLAVE.NE.J)THEN RECV_BUF(J)=max(RECV_BUF(J), & dble(CB_COST_MEM(POS+1))) ENDIF ENDIF ENDDO POS=POS+2 ENDDO 777 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO MAX_MEM=huge(MAX_MEM) WRITE(*,*)'NPROCS=',NPROCS,MAX_MEM DO i=0,NPROCS-1 IF(MAX_MEM.GT.MEM_ON_PROCS(i))THEN PROC=i ENDIF MAX_MEM=min(MEM_ON_PROCS(i),MAX_MEM) ENDDO DEALLOCATE(MEM_ON_PROCS) DEALLOCATE(CONCERNED) DEALLOCATE(RECV_BUF) END SUBROUTINE SMUMPS_LOAD_COMP_MAXMEM_POOL SUBROUTINE SMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER i,NBTOP,INSUBTREE,NBINSUBTREE,NODE,FATHER,SON,J INTEGER SBTR_NB_LEAF,POS,K,allocok,L INTEGER, ALLOCATABLE, DIMENSION (:) :: TMP_SBTR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF((KEEP_LOAD(47).EQ.4).AND. & ((NBINSUBTREE.NE.0)))THEN DO J=INDICE_SBTR,NB_SUBTREES NODE=MY_ROOT_SBTR(J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 110 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 110 ENDIF SON=-i i=SON 120 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN SBTR_NB_LEAF=MY_NB_LEAF(J) POS=SBTR_FIRST_POS_IN_POOL(J) IF(POOL(POS+SBTR_NB_LEAF).NE.MY_FIRST_LEAF(J))THEN WRITE(*,*)MYID,': The first leaf is not ok' CALL MUMPS_ABORT() ENDIF ALLOCATE (TMP_SBTR(SBTR_NB_LEAF), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*)MYID,': Not enough space & for allocation' CALL MUMPS_ABORT() ENDIF POS=SBTR_FIRST_POS_IN_POOL(J) DO K=1,SBTR_NB_LEAF TMP_SBTR(K)=POOL(POS+K-1) ENDDO DO K=POS+1,NBINSUBTREE-SBTR_NB_LEAF POOL(K)=POOL(K+SBTR_NB_LEAF) ENDDO POS=1 DO K=NBINSUBTREE-SBTR_NB_LEAF+1,NBINSUBTREE POOL(K)=TMP_SBTR(POS) POS=POS+1 ENDDO DO K=INDICE_SBTR,J SBTR_FIRST_POS_IN_POOL(K)=SBTR_FIRST_POS_IN_POOL(K) & -SBTR_FIRST_POS_IN_POOL(J) ENDDO SBTR_FIRST_POS_IN_POOL(J)=NBINSUBTREE-SBTR_NB_LEAF POS=MY_FIRST_LEAF(J) L=MY_NB_LEAF(J) DO K=INDICE_SBTR,J MY_FIRST_LEAF(J)=MY_FIRST_LEAF(J+1) MY_NB_LEAF(J)=MY_NB_LEAF(J+1) ENDDO MY_FIRST_LEAF(INDICE_SBTR)=POS MY_NB_LEAF(INDICE_SBTR)=L INODE=POOL(NBINSUBTREE) DEALLOCATE(TMP_SBTR) RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 120 ENDIF ENDDO ENDIF DO J=NBTOP,1,-1 NODE=POOL(LPOOL-2-J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 11 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 11 ENDIF SON=-i i=SON 12 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN INODE=NODE RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 12 ENDIF ENDDO END SUBROUTINE SMUMPS_FIND_BEST_NODE_FOR_MEM SUBROUTINE SMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_ROOTSSARBR LOGICAL MUMPS_ROOTSSARBR IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_ROOTSSARBR( & PROCNODE_LOAD(STEP_LOAD(POOL(POS+1))), & KEEP(199))) POS=POS+1 ENDDO SBTR_FIRST_POS_IN_POOL(i)=POS+1 POS=POS+MY_NB_LEAF(i) ENDDO END SUBROUTINE SMUMPS_LOAD_INIT_SBTR_STRUCT END MODULE SMUMPS_LOAD SUBROUTINE SMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & PROCS, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1) INTEGER, intent(in) :: SUP_PROC_ARG(2) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX INTEGER(8), intent(out):: MAX_SURF LOGICAL :: FORCE_LDLTRegular_NIV2 INTEGER NSLAVES,ACC INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1)) INTEGER TMP_NROW,X,K LOGICAL SUP,MEM_CSTR DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA, & LOAD_CORR INTEGER IDWLOAD(SLAVEF) INTEGER(8) MEM_CONSTRAINT(2) K50=KEEP(50) FORCE_LDLTRegular_NIV2 = .FALSE. MAX_SURF=0 NB_ROW_MAX=0 NELIM=NFRONT-NCB NB_SUP=0 TOTAL_LOAD=0.0D0 SUP=.FALSE. IF(SUP_PROC_ARG(1).NE. & 0)THEN MEM_CONSTRAINT(1)=TAB_MAXS_ARG(PROCS(1)) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(1))/100.0D0 NB_SUP=NB_SUP+1 ENDIF IF(SUP_PROC_ARG(2).NE. & 0)THEN MEM_CONSTRAINT(2)=TAB_MAXS_ARG(PROCS(PROCS(SLAVEF+1))) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(2))/100.0D0 NB_SUP=NB_SUP+1 ENDIF TOTAL_LOAD=TOTAL_LOAD+(PROCS(SLAVEF+1)-NB_SUP) IF(K50.EQ.0)THEN MAX_LOAD=dble( NELIM ) * dble ( NCB ) + * dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE MAX_LOAD=dble(NELIM) * dble ( NCB ) * * dble(NFRONT+1) ENDIF TMP=min(MAX_LOAD,MAX_LOAD/TOTAL_LOAD) J=1 DO i=1,PROCS(SLAVEF+1) IF((NB_SUP.GT.0).AND.(i.EQ.1))THEN CYCLE ELSEIF((NB_SUP.EQ.2).AND.(i.EQ.PROCS(SLAVEF+1)))THEN CYCLE ENDIF IDWLOAD(J)=PROCS(i) J=J+1 ENDDO DO i=1,NB_SUP IF(i.EQ.1)THEN IDWLOAD(J)=PROCS(1) ELSE IDWLOAD(J)=PROCS(PROCS(SLAVEF+1)) ENDIF J=J+1 ENDDO IF ((K50.EQ.0).OR.FORCE_LDLTRegular_NIV2) THEN ACC=0 J=PROCS(SLAVEF+1)-NB_SUP+1 DO i=1,NB_SUP VAR=dble(SUP_PROC_ARG(i))/100.0D0 TMP_NROW=int(dble(MEM_CONSTRAINT(i))/dble(NFRONT)) NB_ROWS(J)=int(max((VAR*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM)), & dble(1))) IF(NB_ROWS(J).GT.TMP_NROW)THEN NB_ROWS(J)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(J)) THEN NB_ROWS(J)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(J) J=J+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF DO i=1,PROCS(SLAVEF+1)-NB_SUP VAR=1.0D0 TMP_NROW=int((dble(TAB_MAXS_ARG(IDWLOAD(i))))/dble(NFRONT)) NB_ROWS(i)=int((dble(VAR)*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(i)) THEN NB_ROWS(i)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE TMP_NROW=(NCB-ACC)/(PROCS(SLAVEF+1)-NB_SUP)+1 DO i=1,PROCS(SLAVEF+1)-NB_SUP NB_ROWS(i)=NB_ROWS(i)+TMP_NROW ACC=ACC+TMP_NROW IF(ACC.GT.NCB) THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+ & (NCB-(ACC-TMP_NROW)) EXIT ENDIF ENDDO ENDIF ENDIF ELSE ACC=0 i=PROCS(SLAVEF+1)-NB_SUP+1 X=NCB LOAD_CORR=0.0D0 MEM_CSTR=.FALSE. DO J=1,NB_SUP VAR=DBLE(SUP_PROC_ARG(J))/DBLE(100) A=1.0D0 B=dble(X+NELIM) C=-dble(max(MEM_CONSTRAINT(J),0_8)) DELTA=((B*B)-(4*A*C)) TMP_NROW=int((-B+sqrt(DELTA))/(2*A)) A=dble(-NELIM) B=dble(NELIM)*(dble(-NELIM)+dble(2*(X+NELIM)+1)) C=-(VAR*TMP) DELTA=(B*B-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW MEM_CSTR=.TRUE. ENDIF IF(ACC+NB_ROWS(i).GT.NCB)THEN NB_ROWS(i)=NCB-ACC ACC=NCB X=0 EXIT ENDIF X=X-NB_ROWS(i) ACC=ACC+NB_ROWS(i) LOAD_CORR=LOAD_CORR+(dble(NELIM) * dble (NB_ROWS(i)) * * dble(2*(X+NELIM) - NELIM - NB_ROWS(i) + 1)) i=i+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF IF((PROCS(SLAVEF+1).NE.NB_SUP).AND.MEM_CSTR)THEN TMP=(MAX_LOAD-LOAD_CORR)/(PROCS(SLAVEF+1)-NB_SUP) ENDIF X=ACC ACC=0 DO i=1,PROCS(SLAVEF+1)-NB_SUP IF (KEEP(375) .EQ. 1) THEN VAR=1.0D0 A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(VAR*TMP) ELSE A=1.0D0 B=dble(ACC+NELIM) C=-TMP ENDIF DELTA=((B*B)-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NCB-ACC-X.LT.NB_ROWS(i))THEN NB_ROWS(i)=NCB-ACC-X ACC=NCB-X EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO ACC=ACC+X IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE NB_ROWS(PROCS(SLAVEF+1)-NB_SUP)= & NB_ROWS(PROCS(SLAVEF+1) & -NB_SUP)+NCB-ACC ENDIF ENDIF ENDIF 777 CONTINUE NSLAVES=0 ACC=1 J=1 K=1 DO i=1,PROCS(SLAVEF+1) IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(J)=IDWLOAD(i) TAB_POS(J)=ACC ACC=ACC+NB_ROWS(i) NB_ROW_MAX=max(NB_ROW_MAX,NB_ROWS(i)) IF(K50.EQ.0)THEN MAX_SURF=max(int(NB_ROWS(i),8)*int(NCB,8),int(0,8)) ELSE MAX_SURF=max(int(NB_ROWS(i),8)*int(ACC,8),int(0,8)) ENDIF NSLAVES=NSLAVES+1 J=J+1 ELSE SLAVES_LIST(PROCS(SLAVEF+1)-K+1)=IDWLOAD(i) K=K+1 ENDIF ENDDO TAB_POS(SLAVEF+2) = NSLAVES TAB_POS(NSLAVES+1)= NCB+1 NSLAVES_NODE=NSLAVES END SUBROUTINE SMUMPS_SET_PARTI_REGULAR MUMPS_5.4.1/src/zfac_front_LDLT_type1.F0000664000175000017500000011351314102210525017714 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE ZMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_OOC USE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW DOUBLE PRECISION MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION,ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL ZMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0D0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTBL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if defined(BLR_MT) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL ZMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC) #endif IF ( (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL ZMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif END IF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL ZMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL ZMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL ZMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC1_LDLT END MODULE ZMUMPS_FAC1_LDLT_M MUMPS_5.4.1/src/ssol_fwd.F0000664000175000017500000001447014102210521015436 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE SMUMPS_STATIC_PTR_M, ONLY : SMUMPS_SET_STATIC_PTR, & SMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS REAL A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), LRHSCOMP REAL, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL SMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL SMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL SMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL SMUMPS_SET_STATIC_PTR(A) CALL SMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL SMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error SMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL SMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE SMUMPS_SOL_R MUMPS_5.4.1/src/sfac_mem_alloc_cb.F0000664000175000017500000001563614102210521017213 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE SMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP REAL A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in SMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL SMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL SMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL SMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) ENDIF ENDIF CALL SMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in SMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE SMUMPS_ALLOC_CB MUMPS_5.4.1/src/cfac_process_band.F0000664000175000017500000002611114102210523017231 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE CMUMPS_LOAD USE CMUMPS_LR_DATA_M, ONLY: CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_RECU = BUFR( 8 ) LRSTATUS = BUFR( 9 ) ESTIM_NFS4FATHER_ATSON = BUFR(10) IBUFR = 11 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL CMUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_RECU + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_RECU + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) CALL CMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_RECU : & IBUFR + NSLAVES_RECU + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) THEN write(6,*) " Internal error in CMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_RECU ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL CMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL CMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE CMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL CMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in CMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_TREAT_DESCBAND MUMPS_5.4.1/src/zmumps_ooc.F0000664000175000017500000036151614102210525016023 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_OOC USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ DOUBLE PRECISION,SAVE :: MAX_OOC_FILE_SIZE INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER ZMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: ZMUMPS_OOC_INIT_FACTO,ZMUMPS_NEW_FACTOR, & ZMUMPS_READ_OOC, & ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & ZMUMPS_IS_THERE_FREE_SPACE, & ZMUMPS_OOC_END_SOLVE, & ZMUMPS_SOLVE_INIT_OOC_FWD,ZMUMPS_SOLVE_INIT_OOC_BWD, & ZMUMPS_INITIATE_READ_OPS,ZMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC ZMUMPS_OOC_IO_LU_PANEL, & ZMUMPS_OOC_PANEL_SIZE PRIVATE ZMUMPS_OOC_STORE_LorU, & ZMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE ZMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_STRAT_IO_FLAGS FUNCTION ZMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL ZMUMPS_IS_THERE_FREE_SPACE ZMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION ZMUMPS_IS_THERE_FREE_SPACE SUBROUTINE ZMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE ZMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE ZMUMPS_OOC_INIT_FACTO(id, MAXS) USE ZMUMPS_STRUC_DEF USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER TMPDIR_MAX_LENGTH, PREFIX_MAX_LENGTH PARAMETER (TMPDIR_MAX_LENGTH=255, PREFIX_MAX_LENGTH=63) INTEGER(8), intent(in) :: MAXS TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER allocok INTEGER ASYNC CHARACTER(len=1):: TMP_DIR(TMPDIR_MAX_LENGTH), & TMP_PREFIX(PREFIX_MAX_LENGTH) INTEGER DIM_DIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER K211_LOC ICNTL1=id%ICNTL(1) MAX_SIZE_FACTOR_OOC=0_8 N_OOC=id%N ASYNC=0 SOLVE=.FALSE. IERR=0 IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) IF (id%KEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS MYID_OOC=id%MYID SLAVEF_OOC=id%NSLAVES KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_VADDR=>id%OOC_VADDR IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(19),int(dble(MAXS)* & 0.9d0*0.2d0,8)) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF ZMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(id%OOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF id%OOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL ZMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(99), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO ) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 MAX_NB_NODES_FOR_ZONE=0 OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL ZMUMPS_INIT_OOC_BUF(id%INFO(1),id%INFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ENDIF DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) DIM_DIR=len(trim(id%OOC_TMPDIR)) DIM_PREFIX=len(trim(id%OOC_PREFIX)) CALL ZMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL ZMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_PREFIX(1), & id%OOC_PREFIX, PREFIX_MAX_LENGTH, DIM_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, TMP_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_DIR, TMP_DIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(id%KEEP8(11)/1000000_8)+1 IF((id%KEEP(201).EQ.1).AND.(id%KEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & id%KEEP(35),LOW_LEVEL_STRAT_IO,K211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0 ) THEN WRITE(ICNTL1,*)MYID_OOC,': PB in MUMPS_LOW_LEVEL_INIT_OOC_C' WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) ENDIF id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_GET_MAX_FILE_SIZE_C(MAX_OOC_FILE_SIZE) DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE ZMUMPS_OOC_INIT_FACTO SUBROUTINE ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE COMPLEX(kind=8) A(LA) INTEGER IERR,NODE,ASYNC,REQUEST LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL ZMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL ZMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF NODE=-9999 PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_NEW_FACTOR SUBROUTINE ZMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE COMPLEX(kind=8) DEST INTEGER ASYNC LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN GOTO 555 ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_READ_OOC SUBROUTINE ZMUMPS_OOC_CLEAN_PENDING(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL ZMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE ZMUMPS_OOC_CLEAN_PENDING SUBROUTINE ZMUMPS_OOC_END_FACTO(id,IERR) USE ZMUMPS_OOC_BUFFER USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF(WITH_BUF)THEN CALL ZMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF id%OOC_MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DO I=1,OOC_NB_FILE_TYPE id%OOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF id%KEEP8(20)=MAX_SIZE_FACTOR_OOC CALL ZMUMPS_STRUC_STORE_FILE_NAME(id,IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_END_FACTO SUBROUTINE ZMUMPS_OOC_CLEAN_FILES(id,IERR) USE ZMUMPS_STRUC_DEF IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(350) IERR=0 K=1 IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0)THEN WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_CLEAN_FILES SUBROUTINE ZMUMPS_CLEAN_OOC_DATA(id,IERR) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL ZMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE ZMUMPS_CLEAN_OOC_DATA SUBROUTINE ZMUMPS_OOC_INIT_SOLVE(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=id%ICNTL(1) SOLVE=.TRUE. N_OOC=id%N IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) IF(id%INFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS SLAVEF_OOC=id%NSLAVES MYID_OOC=id%MYID KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE OOC_VADDR=>id%OOC_VADDR ALLOCATE(IO_REQ(id%KEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF ZMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) MAX_NB_NODES_FOR_ZONE=id%OOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>id%OOC_TOTAL_NB_NODES CALL ZMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(20) SIZE_ZONE_SOLVE=int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) ENDIF ELSE SIZE_ZONE_SOLVE=FACT_AREA_SIZE SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF IF(SIZE_SOLVE_EMM.LT.id%KEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in ZMUMPS_OOC_INIT_SOLVE' id%INFO(1) = -11 CALL MUMPS_SET_IERROR(id%KEEP8(20), id%INFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,id%COMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ZMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(id%KEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. id%root%yes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE ZMUMPS_OOC_INIT_SOLVE SUBROUTINE ZMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_INITIATE_READ_OPS SUBROUTINE ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL ZMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL ZMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE ZMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE ZMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES COMPLEX(kind=8) DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL ZMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL ZMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE ZMUMPS_READ_SOLVE_BLOCK SUBROUTINE ZMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE ZMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE ZMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL ZMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' ZMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' ZMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' ZMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE ZMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR COMPLEX(kind=8) A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J, FREE_HOLE_FLAG INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in ZMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL ZMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE FREE_HOLE_FLAG=0 IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL ZMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3D0*dble(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL ZMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION ZMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR COMPLEX(kind=8) A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL ZMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL ZMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE ZMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION ZMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE ZMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE ZMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE ZMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL ZMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE ZMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE ZMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE ZMUMPS_SOLVE_FIND_ZONE SUBROUTINE ZMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE ZMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE ZMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE ZMUMPS_SOLVE_SELECT_ZONE SUBROUTINE ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(ZMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE ZMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS COMPLEX(kind=8) A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' ZMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' ZMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' ZMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE ZMUMPS_GET_TOP_AREA_SPACE SUBROUTINE ZMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) COMPLEX(kind=8) A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' ZMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' ZMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' ZMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'ZMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE ZMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX(kind=8) A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' ZMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE ZMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE ZMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) COMPLEX(kind=8) A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in ZMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' ZMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL ZMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE ZMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' ZMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE ZMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE ZMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE ZMUMPS_SEARCH_SOLVE FUNCTION ZMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL ZMUMPS_SOLVE_IS_END_REACHED ZMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN ZMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN ZMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION ZMUMPS_SOLVE_IS_END_REACHED SUBROUTINE ZMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL ZMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL ZMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL ZMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL ZMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE ZMUMPS_SOLVE_ZONE_READ SUBROUTINE ZMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(ZMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' ZMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE ZMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE ZMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE ZMUMPS_OOC_END_SOLVE SUBROUTINE ZMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8) :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL ZMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL ZMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN CALL ZMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to ZMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_PREPARE_PREF SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL ZMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL ZMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL ZMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR COMPLEX(kind=8) A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL ZMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL ZMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL ZMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & ZMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL ZMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL ZMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL ZMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE ZMUMPS_STRUC_STORE_FILE_NAME(id,IERR) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(350) EXTERNAL MUMPS_OOC_GET_NB_FILES_C, MUMPS_OOC_GET_FILE_NAME_C IERR=0 SIZE=0 DO J=1,OOC_NB_FILE_TYPE TMP=J-1 CALL MUMPS_OOC_GET_NB_FILES_C(TMP,I) id%OOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF ALLOCATE(id%OOC_FILE_NAMES(SIZE,350),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'ZMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(id%INFO(1).GE.0)THEN id%INFO(1) = -13 id%INFO(2) = SIZE*350 RETURN ENDIF ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(id%OOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in ZMUMPS_STRUC_STORE_FILE_NAME' ENDIF id%INFO(1) = -13 id%INFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,id%OOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 id%OOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO id%OOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO END SUBROUTINE ZMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC), TARGET :: id CHARACTER(len=1):: TMP_NAME(350) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES INTEGER K211 ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=id%OOC_NB_FILES I=id%MYID K=id%KEEP(35) L=mod(id%KEEP(204),3) K211=id%KEEP(211) CALL MUMPS_OOC_ALLOC_POINTERS_C(OOC_NB_FILE_TYPE,NB_FILES,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,K211,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=id%OOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO TMP=I1-1 CALL MUMPS_OOC_SET_FILE_NAME_C(TMP,I,DIM,IERR,TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=K+1 ENDDO ENDDO CALL MUMPS_OOC_START_LOW_LEVEL(IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE ZMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE ZMUMPS_CONVERT_STR_TO_CHR_ARRAY(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB):: SRC CHARACTER(len=1):: DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE ZMUMPS_CONVERT_STR_TO_CHR_ARRAY SUBROUTINE ZMUMPS_FORCE_WRITE_BUF(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE ZMUMPS_FORCE_WRITE_BUF SUBROUTINE ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL ZMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE ZMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE ZMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE ZMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL ZMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL ZMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE RETURN END SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL SUBROUTINE ZMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR, ILAST INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = ZMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = ZMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = ZMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in ZMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in ZMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in ZMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in ZMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL ZMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in ZMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE ILAST = ICUR IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in ZMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_STORE_LorU SUBROUTINE ZMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE ZMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL ZMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE ZMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION ZMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE ZMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION ZMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION ZMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER ZMUMPS_OOC_GET_PANEL_SIZE ZMUMPS_OOC_PANEL_SIZE=ZMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION ZMUMPS_OOC_PANEL_SIZE SUBROUTINE ZMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.ZMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE ZMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_SET_STATES_ES END MODULE ZMUMPS_OOC MUMPS_5.4.1/src/dmumps_sol_es.F0000664000175000017500000007012614102210523016471 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SOL_ES PRIVATE PUBLIC:: PRUNED_SIZE_LOADED PUBLIC:: DMUMPS_CHAIN_PRUN_NODES PUBLIC:: DMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: DMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: DMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: DMUMPS_TREE_PRUN_NODES PUBLIC:: DMUMPS_TREE_PRUN_NODES_STATS PUBLIC:: DMUMPS_SOL_ES_INIT INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK INTEGER(8) :: PRUNED_SIZE_LOADED INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE DMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF RETURN END SUBROUTINE DMUMPS_SOL_ES_INIT SUBROUTINE DMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(KEEP28), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE DMUMPS_TREE_PRUN_NODES SUBROUTINE DMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(nb_nodes_RHS) INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER :: Pruned_SONS(KEEP28) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE DMUMPS_CHAIN_PRUN_NODES SUBROUTINE DMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE DMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE DMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in DMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) RETURN END SUBROUTINE DMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION DMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN DMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN DMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE DMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV+1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE DMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION DMUMPS_LOCAL_FACTOR_SIZE INTEGER(8) FUNCTION DMUMPS_LOCAL_FACTOR_SIZE_BLR(IW,LIW,PTR, & LRSTATUS, IWHANDLER, & PHASE, LDLT, IS_ROOT) USE DMUMPS_LR_DATA_M USE DMUMPS_LR_TYPE INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: LRSTATUS, IWHANDLER INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW, FACTOR_SIZE INTEGER :: NB_PANELS, IPANEL, LorU, IBLOCK LOGICAL :: LR_ACTIVATED TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: LRB_PANEL NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB LR_ACTIVATED=(LRSTATUS.GE.2) IF (LR_ACTIVATED) THEN FACTOR_SIZE = 0_8 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IWHANDLER, NB_PANELS) IF (LDLT.EQ.0) THEN LorU = PHASE ELSE LorU = 0 ENDIF DO IPANEL=1,NB_PANELS IF (IS_ROOT.AND.IPANEL.EQ.NB_PANELS) THEN CYCLE ENDIF IF (DMUMPS_BLR_EMPTY_PANEL_LORU(IWHANDLER, LorU, IPANEL)) & THEN CYCLE ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU(IWHANDLER, LorU, & IPANEL, LRB_PANEL) IF (size(LRB_PANEL).GT.0) THEN IF (PHASE.EQ.0) THEN FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)-1_8)/2_8 ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)+1_8)/2_8 ENDIF ENDIF DO IBLOCK=1,size(LRB_PANEL) IF (LRB_PANEL(IBLOCK)%ISLR) THEN FACTOR_SIZE = FACTOR_SIZE + int(LRB_PANEL(IBLOCK)%K,8)* & int(LRB_PANEL(IBLOCK)%M+LRB_PANEL(IBLOCK)%M,8) ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(IBLOCK)%M*LRB_PANEL(IBLOCK)%N,8) ENDIF ENDDO ENDDO DMUMPS_LOCAL_FACTOR_SIZE_BLR = FACTOR_SIZE ELSE DMUMPS_LOCAL_FACTOR_SIZE_BLR = & DMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, PTR, PHASE, LDLT, IS_ROOT) ENDIF RETURN END FUNCTION DMUMPS_LOCAL_FACTOR_SIZE_BLR SUBROUTINE DMUMPS_TREE_PRUN_NODES_STATS(MYID, N, KEEP28, KEEP201, & FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC) INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, MYID, N INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INTEGER I, ISTEP INTEGER(8) :: Pruned_Size IF (KEEP201 .GT. 0) THEN Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDDO PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF RETURN END SUBROUTINE DMUMPS_TREE_PRUN_NODES_STATS SUBROUTINE DMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) IF (KEEP201 .GT. 0) THEN Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDIF ENDDO IF (KEEP201.GT.0) THEN IF (FR_FACT .NE. 0_8) THEN PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_CHAIN_PRUN_NODES_STATS END MODULE DMUMPS_SOL_ES SUBROUTINE DMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " DMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN DMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " DMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " DMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE DMUMPS_PERMUTE_RHS_GS SUBROUTINE DMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE DMUMPS_PERMUTE_RHS_AM1 SUBROUTINE DMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE, & PERM_PO LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & LOAD_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in DMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in DMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) LOAD_PROCS = 0 USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO IF(reorder) THEN posintmprhs = 0 ALLOCATE(PERM_PO(N),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO J=1,N PERM_PO(SYM_PERM(J))=J END DO nblocks = N/NBRHS DO I = 1, nblocks USED = .FALSE. DO J=1, NBRHS USED(TMP_RHS(NBRHS*(I-1)+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END DO IF(mod(N,NBRHS).NE.0) THEN USED = .FALSE. DO J=1, mod(N,NBRHS) USED(TMP_RHS(NBRHS*nblocks+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END IF DEALLOCATE(PERM_PO) ELSE PERM_RHS = TMP_RHS END IF DEALLOCATE(TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & USED, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE) RETURN END SUBROUTINE DMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.4.1/src/sfac_mem_compress_cb.F0000664000175000017500000005047014102210521017747 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE SMUMPS_SIZEFREEINREC SUBROUTINE SMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE SMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE SMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE SMUMPS_MOVETONEXTRECORD SUBROUTINE SMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ISHIFT SUBROUTINE SMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT REAL A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_RSHIFT SUBROUTINE SMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP199, PROCNODE_STEPS, DAD) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF, KEEP199 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) REAL, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: SMUMPS_ISBAND EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_REF, TIME_COMP TIME_REF = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL SMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP216) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL SMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP28, KEEP199, & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL SMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL SMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL SMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP216) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL SMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL SMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL SMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL SMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in SMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in SMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in SMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = MPI_WTIME() - TIME_REF ACC_TIME = ACC_TIME + real(TIME_COMP) RETURN END SUBROUTINE SMUMPS_COMPRE_NEW SUBROUTINE SMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE SMUMPS_GET_SIZEHOLE SUBROUTINE SMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT REAL A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN SMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in SMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in SMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE SMUMPS_MAKECBCONTIG SUBROUTINE SMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) REAL, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL SMUMPS_COMPRE_NEW_CALLED SMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF SMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.SMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) SMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. SMUMPS_COMPRE_NEW_CALLED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL SMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL SMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in SMUMPS_GET_SIZE_NEEDED ', & 'PB compress... SMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_GET_SIZE_NEEDED MUMPS_5.4.1/src/sana_reordertree.F0000664000175000017500000012342114102210521017137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE REAL PEAK REAL, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,NSTK,INODE,I,allocok,LOCAL_PERM INTEGER(8) NCB INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER, DIMENSION (:), POINTER :: TAB INTEGER dernier,fin INTEGER cour,II INTEGER CB_current,CB_MAX,ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE,SUM,MEM_SEC_PERM,FACT_SIZE_T, & MEM_SIZE_T,TOTAL_MEM_SIZE,TMP_TOTAL_MEM_SIZE,TMP_SUM, & SIZECB, SIZECB_LASTSON INTEGER(8) TMP8 LOGICAL SBTR_M INTEGER FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in SMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL SMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NSTK = NE(STEP(INODE)) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL SMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL SMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL SMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF CONTINUE IFATH=INODE DO II=1,2 SUM=0_8 FACT_SIZE=0_8 FACT_SIZE_T=0_8 MEM_SIZE=0_8 MEM_SIZE_T=0_8 CB_MAX=0 CB_current=0 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in SMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL SMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(real(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL SMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_REORDER_TREE SUBROUTINE SMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE REAL PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR REAL COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok,LOCAL_PERM INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER x,dernier,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE, & TOTAL_MEM_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF IF (K47 == 4 .OR. ((K47.GE.2).AND.(K81.GE. 1))) THEN DO I=1,SLAVEF INDICE(I)=1 ENDDO DO I=1,SLAVEF DO x=1,SIZE_MEM_SBTR MEM_SUBTREE(x,I)=-1.0D0 ENDDO ENDDO ENDIF SBTR_M=((K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1)))) MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in SMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL SMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & SMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE SMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL SMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL SMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE SMUMPS_FUSION_SORT MUMPS_5.4.1/src/dfac_process_message.F0000664000175000017500000010402014102210522017745 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_LOAD USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER MP, LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL DMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL DMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="DMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL DMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL DMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="DMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL DMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="DMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL DMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL DMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL DMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL DMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL DMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="DMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL DMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="DMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL DMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="DMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL DMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL DMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL DMUMPS_PROCESS_RTNELIND( root, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="DMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in DMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine DMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE DMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL DMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) RETURN END SUBROUTINE DMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE DMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE DMUMPS_LOAD USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL DMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN IF (KEEP(117).NE.0) THEN WRITE(*,*) "Problem of active IRECV with KEEP(117)=",KEEP(117) CALL MUMPS_ABORT() ENDIF RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in DMUMPS_TRY_RECVTREAT' CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL DMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL DMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE DMUMPS_TRY_RECVTREAT SUBROUTINE DMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE DMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL DMUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE DMUMPS_CANCEL_IRECV SUBROUTINE DMUMPS_CLEAN_PENDING( & INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & CLEAN_COMM_NODES, CLEAN_COMM_LOAD ) USE DMUMPS_BUF IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR, LBUFR_BYTES INTEGER, INTENT(OUT) :: BUFR( LBUFR ) INTEGER, INTENT(IN) :: COMM_NODES, COMM_LOAD, SLAVEF, INFO1 INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, INTENT(IN) :: CLEAN_COMM_LOAD, CLEAN_COMM_NODES INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER :: MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER :: COMM_EFF INTEGER :: IERR INTEGER :: IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS INTEGER :: TOTAL_SEND_MINUS_RECV266 INTEGER :: TOTAL_SEND_MINUS_RECV267 IF (SLAVEF.EQ.1) RETURN IF (.NOT. CLEAN_COMM_NODES .AND. .NOT. CLEAN_COMM_LOAD) THEN RETURN ENDIF DO WHILE (.TRUE.) FLAG = .TRUE. DO WHILE ( FLAG ) FLAG = .FALSE. IF (CLEAN_COMM_NODES) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) END IF END IF IF (CLEAN_COMM_LOAD) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) IF (COMM_EFF .EQ. COMM_NODES) THEN KEEP(266) = KEEP(266) - 1 ELSE KEEP(267) = KEEP(267) - 1 ENDIF CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (MSGLEN_LOC .LE. LBUFR_BYTES) THEN CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF ENDIF END DO CALL DMUMPS_BUF_ALL_EMPTY( CLEAN_COMM_NODES, & CLEAN_COMM_LOAD, & BUFFERS_EMPTY ) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF IF (CLEAN_COMM_NODES) THEN COMM_EFF = COMM_NODES ELSE COMM_EFF = COMM_LOAD ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_EFF, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN IF (CLEAN_COMM_NODES) THEN CALL MPI_ALLREDUCE(KEEP(266), & TOTAL_SEND_MINUS_RECV266, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV266 = 0 ENDIF IF (CLEAN_COMM_LOAD) THEN CALL MPI_ALLREDUCE(KEEP(267), & TOTAL_SEND_MINUS_RECV267, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV267 = 0 ENDIF IF (TOTAL_SEND_MINUS_RECV266 .EQ. 0 .AND. & TOTAL_SEND_MINUS_RECV267 .EQ. 0) THEN EXIT ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_CLEAN_PENDING MUMPS_5.4.1/src/mumps_metis.c0000664000175000017500000001347514102210474016230 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include /* For NULL constant (stddef.h) and debug printings */ #include "mumps_metis.h" #if defined(parmetis) || defined(parmetis3) /*PARMETIS*/ #if defined(parmetis3) /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void ParMETIS_V3_NodeND(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MPI_Comm *Ccomm); #else #include "metis.h" #include "parmetis.h" /* Prototypes from parmetis.h will be used */ #endif void MUMPS_CALL MUMPS_PARMETIS(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MUMPS_INT *comm, MUMPS_INT *ierr) { MPI_Comm int_comm; int iierr; int_comm = MPI_Comm_f2c(*comm); #if defined(parmetis3) ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); #elif defined(parmetis) # if (IDXTYPEWIDTH == 32) *ierr=0; iierr=ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); if(iierr != METIS_OK) *ierr=1; # else /* SHOULD NEVER BE CALLED */ printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_PARMETIS_64 was called\n"); *ierr=1; # endif #endif return; } #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #if defined(metis4) || defined(parmetis3) /* parmetis3 comes with metis4 */ /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void METIS_PartGraphKway(int *, MUMPS_INT *, MUMPS_INT *, MUMPS_INT *, MUMPS_INT *, int *, int *, int *, int *, int *, MUMPS_INT *); #else /* Prototype properly defined in metis.h * One can rely on IDXTYPEWIDTH to know at compilation/preprocessing * time whether we use a 32-bit or a 64-bit metis */ #include "metis.h" #endif /* Interface for metis k-way partitioning with standard ints */ void MUMPS_CALL MUMPS_METIS_KWAY(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(n, iptr, jcn, NULL, NULL, &wgtflag, &numflag, k, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 32) MUMPS_INT ncon, edgecut, options[40]; ierr=METIS_SetDefaultOptions(options); options[0] = 0; /* Use 1-based fortran numbering */ options[17] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, NULL, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else /* SHOULD NEVER BE CALLED */ printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=32, but MUMPS_METIS_KWAY was called\n"); ierr=1; # endif #endif return; } /* Interface for metis k-way partitioning with standard ints and weights on vertices*/ void MUMPS_CALL MUMPS_METIS_KWAY_AB(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part, MUMPS_INT *vwgt) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to vwgt -- weights of the vertices*/ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(n, iptr, jcn, vwgt, NULL, &wgtflag, &numflag, k, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 32) MUMPS_INT ncon, edgecut, options[40]; ierr=METIS_SetDefaultOptions(options); options[0] = 0; /* Use 1-based fortran numbering */ options[17] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, vwgt, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else /* SHOULD NEVER BE CALLED */ printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=32, but MUMPS_METIS_KWAY_AB was called\n"); ierr=1; # endif #endif return; } #endif MUMPS_5.4.1/src/cfac_asm_master_ELT_m.F0000664000175000017500000020412114102210524017742 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE CMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) !$ USE OMP_LIB USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_IS_DYNAMIC, & CMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & CMUMPS_BLR_ASM_NIV1 USE CMUMPS_LR_DATA_M, ONLY : CMUMPS_BLR_INIT_FRONT, & CMUMPS_BLR_SAVE_NFS4FATHER USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 COMPLEX, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in CMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress CMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL CMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL CMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL CMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL CMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL CMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) IF (IS_DYNAMIC_CB) THEN CALL CMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL CMUMPS_BUF_SEND_MAPLIG( INODE, NFRONT, & NASS1, NFS4FATHER,ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, & SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING CMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING CMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE CMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_IS_DYNAMIC USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE COMPLEX, DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX ZERO REAL RZERO PARAMETER( RZERO = 0.0E0 ) PARAMETER( ZERO = (0.0E0,0.0E0) ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX REAL MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL CMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL CMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL CMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL CMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress CMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL CMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL CMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL CMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL CMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL CMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL CMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & CMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL CMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))=cmplx( & max(real(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))), & kind=kind(A) & ) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = cmplx( & max( MAXARR, real(A(APOSMAX+int(I-1,8)))), & kind=kind(A) & ) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL CMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL CMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL CMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL CMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL CMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING CMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING CMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING CMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_FAC_ASM_NIV2_ELT END MODULE CMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.4.1/src/zfac_process_blocfacto_LDLT.F0000664000175000017500000013344314102210524021137 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE ZMUMPS_LOAD USE ZMUMPS_BUF USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_FAC_LR USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY : ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 COMPLEX(kind=8) MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW, DEST INTEGER ICT11 INTEGER(8) LPOS, LPOS2, DPOS, UPOS INTEGER (8) IPOS, KPOS INTEGER I, IPIV, FPERE, NSLAVES_TOT, & NSLAVES_FOLLOW, NB_BLOC_FAC INTEGER IPOSK, JPOSK, NPIVSENT, Block, IROW, BLSIZE INTEGER allocok, TO_UPDATE_CPT_END COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: UIP21K, BLFCTDYN INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW, PIVDYN LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNPIVBLFCT LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ, SHIFT INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) XSIZE = KEEP(IXSZ) KEEP_BEGS_BLR_LS =.FALSE. KEEP_BEGS_BLR_COL =.FALSE. KEEP_BLR_LS =.FALSE. IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) LD_BLOCFACTO = max(NCOL,1) ENDIF IF (LR_ACTIVATED) THEN DYNPIVBLFCT = .TRUE. ELSE DYNPIVBLFCT = .FALSE. ENDIF IF ( .NOT. DYNPIVBLFCT ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL ZMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(PIVDYN(max(1,NPIV)),BLFCTDYN(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR PIVDYN and BLFCTDYN IN ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PIVDYN, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLFCTDYN, int(LA_BLOCFACTO), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL ZMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF ( LASTBL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF ( NPIV1 + NCOL .NE. NASS1 ) THEN WRITE(*,*) 'SymBLFC Error: NPIV1 + NCOL .NE. NASS1 :', & NPIV1,NCOL,NASS1 CALL MUMPS_ABORT() END IF ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNPIVBLFCT) THEN PIVI = abs(PIVDYN(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL zswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (.NOT.LR_ACTIVATED) THEN ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF ELSE ALLOCATE( UIP21K( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * 1 GOTO 700 END IF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNPIVBLFCT) THEN CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & BLFCTDYN, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ELSE CALL ztrsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ENDIF ENDIF IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A_PTR(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN LPOS = POSELT + int(NPIV1,8) IF (DYNPIVBLFCT) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNPIVBLFCT) THEN PIVI = PIVDYN(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNPIVBLFCT) THEN A11 = ONE/BLFCTDYN(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL zscal( NROW1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNPIVBLFCT) THEN A11 = BLFCTDYN(POSPV1) A22 = BLFCTDYN(POSPV2) A12 = BLFCTDYN(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = BLFCTDYN(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_LS = NPARTSCB ENDIF call MAX_CLUSTER(BEGS_BLR_LM,NB_BLR_LM+1,MAXI_CLUSTER_LM) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN IF (NPARTSASS_MASTER.GT.NPARTSASS_COL) THEN ENDIF SHIFT = NPARTSASS_COL-NPARTSASS_MASTER ALLOCATE(BEGS_BLR_COL_TMP(size(BEGS_BLR_COL)-SHIFT), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL)-SHIFT GOTO 700 END IF DO II= 1, size(BEGS_BLR_COL)-SHIFT BEGS_BLR_COL_TMP (II) = BEGS_BLR_COL(II+SHIFT) ENDDO BEGS_BLR_COL_TMP(1) = 1 DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL+NELIM) ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT=0 IF (NSLAVES_PREC.GT.0) THEN NB_ACCESSES_INIT=NSLAVES_PREC+1 ENDIF IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNPIVBLFCT) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(BLFCTDYN, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & PIVDYN, OFFSET_IW=1) ELSE CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL ZMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & BLFCTDYN, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (DYNPIVBLFCT) THEN CALL ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & BLFCTDYN, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & PIVDYN, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, 0, NPARTSCB, 'V') CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL-NPIV.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN UPOS = int(NPIV+1,8) CALL zgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA, BLFCTDYN(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL zgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL zgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL zgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL zgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL ZMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ)) IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN) ) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNPIVBLFCT) THEN CALL ZMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFCTDYN, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & PIVDYN, MAXI_CLUSTER, & IERR ) ELSE CALL ZMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) ENDIF IF (IERR .EQ. -1 ) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & ZMUMPS_PROCESS_SYM_BLOCFACTO" WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1 IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 .AND. NSLAVES_PREC.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8) ENDIF IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN)) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) THEN DEALLOCATE( UIP21K ) ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL ZMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF IF (COMPRESS_CB) THEN NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL ZMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "ZMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL ZMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV+NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1+NPIV, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL ZMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (NPIV.GT.0) THEN IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN CALL DEALLOC_BLR_PANEL (BLR_LS, NB_BLR_LS, KEEP8) IF (associated(BLR_LS)) DEALLOCATE(BLR_LS) ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.4.1/src/mumps_comm_ibcast.F0000664000175000017500000000102314102210475017315 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_COMM_IBC_RETURN() RETURN END SUBROUTINE MUMPS_COMM_IBC_RETURN MUMPS_5.4.1/src/cini_defaults.F0000664000175000017500000014050714102210526016435 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE CMUMPS_SET_TYPE_SIZES( K34, K35, K16, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (REAL, DOUBLE PRECISION, C COMPLEX or DOUBLE COMPLEX) in K35 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (REAL for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K35: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K16 = K35 for S and D arithmetics C K16 = K35 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C C INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) REAL R(2) ! Will be DOUBLE PRECISION if 0 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K16 = int(SIZE_REAL_OR_DOUBLE) K35 = K16 K35 = K35 * 2 RETURN END SUBROUTINE CMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE CMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C CMUMPS, CMUMPS_ANA_DRIVER, CMUMPS_FAC_DRIVER, CMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C REAL DKEEP(230) REAL CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C CMUMPS Default values C are set by CMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of CMUMPS. C C CNTL(1) threshold for partial pivoting C has default value 0.0 when SYM=1 and 0.01 otherwise C Values and less than zero as treated as zero. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS 10^{-5} ||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by CMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in CMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in CMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in CMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C CMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by CMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 1. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then CMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in CMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12), INFOG(34) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C C ICNTL(34) Must be set before a call to MUMPS with JOB=-2 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UCFS variant, no recompression: Compress step is C performed before the Solve; pivoting strategy is adapted C to pe performed on low-rank blocks; the low-rank updates are not C recompressed C C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 333 C (when factors of BLR fronts are compressed, C their size is 33.3% of their full- rank size). C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see CMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see CMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all CMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots. C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of CMUMPS. C C C RINFOG is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of CMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for REAL parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0E0 RINFOG(1:40)= 0.0E0 CNTL(1:15) = 0.0E0 DKEEP(1:230) = 0.0E0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C Check value of SYM IF (SYM.EQ.1) THEN C C this option is not available with the complex C code on symmetric matrices. C We set KEEP(50) to 2 and will exploit symmetry C up to the root. KEEP(50) = 2 ENDIF C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting IF ( KEEP(50) .NE. 1 ) THEN CNTL(1) = 0.01E0 ELSE CNTL(1) = 0.0E0 END IF CNTL(2) = sqrt(epsilon(0.0E0)) CNTL(3) = 0.0E0 CNTL(4) = -1.0E0 CNTL(5) = 0.0E0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off ICNTL(13) = 0 C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (33.3%) ICNTL(38) = 333 ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 1 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 50 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 50 END IF KEEP(63) = 60 KEEP(48) = 5 CALL CMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(real(NSLAVES+1))*real(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 ! old splitting IF (NSLAVES.GT.4) THEN KEEP(78)=max( & int(log(real(NSLAVES))/log(real(2))) - 2 & , 0 ) ENDIF KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 KEEP(82) = 30 KEEP(83) = min(8,NSLAVES/4) KEEP(83) = max(min(4,NSLAVES),max(KEEP(83),1)) KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)=min(8, NSLAVES) KEEP(91) = max(min(4,NSLAVES),min(KEEP(83),KEEP(91))) IF(NSLAVES.LT.48)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.128)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.256)THEN KEEP(102)=200 ELSEIF(NSLAVES.LT.512)THEN KEEP(102)=300 ELSEIF(NSLAVES.GE.512)THEN KEEP(102)=400 ENDIF #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=15 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(211)=2 IF (NSLAVES .EQ. 2) THEN KEEP(213) = 101 ELSE KEEP(213) = 201 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 KEEP(219)=1 IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0E0 DKEEP(5) = -1.0E0 C#if defined(try_null_space) DKEEP(10) = -9E0 ! default value is 10E-1 set in fac_driver.F DKEEP(13) = -9E0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0E0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0E0 ! gap precision C#endif KEEP(238)=14 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0E0 DKEEP(18)= 1.0E12 KEEP(242) = -9 KEEP(243) = -1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 C OMP parallelization of arrowheads KEEP(399) = 1 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(461) = 10 KEEP(462) = 10 KEEP(464) = 333 KEEP(465) = 200 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 512 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE CMUMPSID SUBROUTINE CMUMPS_SET_KEEP72(id, LP) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1E0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 ELSE IF (id%KEEP(72)==2) THEN id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(62) = 10 ! default is 50 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs id%KEEP(213) = 121 ! default is 201 END IF RETURN END SUBROUTINE CMUMPS_SET_KEEP72 MUMPS_5.4.1/src/mumps_numa.c0000664000175000017500000000075414102210474016043 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ int mumps_numa_return() { return 0; } MUMPS_5.4.1/src/cana_lr.F0000664000175000017500000020100014102210524015203 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_ANA_LR USE CMUMPS_LR_CORE USE CMUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) NBGROUPS_KWAY = MAX(NINT(real(NV)/real(GROUP_SIZE2)),1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB (NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR REAL :: COMPRESS_RATIO #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) COMPRESS_RATIO= real(NVEXPANDED)/real(NV) NBGROUPS_KWAY = MAX(NINT(real(NVEXPANDED)/real(GROUP_SIZE2)),1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN INTEGER :: PARTS(:) INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBGROUPS) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO NBGROUPS = NBGROUPS + NPARTS !$OMP END CRITICAL(lrgrouping_cri) SEP = NEWSEP DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(real(IPE(N+1)-1_8)/real(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE CMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, MAXFRONT INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL CMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE CMUMPS_LR_GROUPING SUBROUTINE CMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL CMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE CMUMPS_LR_GROUPING_NEW SUBROUTINE CMUMPS_AB_LR_GROUPING(N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, MYID, COMM) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, COMM TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE REAL :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 501 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP ATOMIC WRITE IERROR = 3*N ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IF (MAPCOL(NODE).NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = real(NVEXPANDED)/real(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(real(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE CMUMPS_AB_LR_GROUPING SUBROUTINE CMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, & COMM, MYID, NPROCS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE REAL :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 501 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = real(NVEXPANDED)/real(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(real(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO 498 CONTINUE !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE CMUMPS_AB_LR_MPI_GROUPING END MODULE CMUMPS_ANA_LR MUMPS_5.4.1/src/zfac_process_maprow.F0000664000175000017500000020752114102210524017670 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_DATA_M USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY : ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (ZMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER COMPLEX(kind=8) :: ADummy(1) COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL ZMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in ZMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL ZMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2( & NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN ZMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN ZMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN ZMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL ZMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL ZMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL ZMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE ZMUMPS_MAPLIG SUBROUTINE ZMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_FAC_LR, ONLY: ZMUMPS_DECOMPRESS_PANEL USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY : ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT USE ZMUMPS_LR_DATA_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR & , ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I, ISTCHK, ISTCHK_LOC INTEGER NBROWS_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP COMPLEX(kind=8) :: ADummy(1) COMPLEX(kind=8), ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in ZMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in ZMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in ZMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in ZMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in ZMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL ZMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_BLR_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT, & 1:NB_BLR_COLS-NB_BLR_SHIFT), & 0, 'V', 5, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN IF (NELIM.EQ.0) THEN POSROW = IACHK + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF (CB_IS_LR) THEN CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS) ELSE CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during ZMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL ZMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL ZMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL ZMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL ZMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING ZMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING ZMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in ZMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL ZMUMPS_DM_FREE_BLOCK( SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL ZMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL ZMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE ZMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE ZMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE ZMUMPS_BUF, ONLY: ZMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_LR_DATA_M USE ZMUMPS_FAC_LR, ONLY: ZMUMPS_DECOMPRESS_PANEL USE ZMUMPS_LOAD, ONLY : ZMUMPS_LOAD_POOL_UPD_NEW_POOL USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR & , ZMUMPS_DM_SET_PTR, ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) COMPLEX(kind=8), intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(N) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER(8) :: LA_TEMP COMPLEX(kind=8), ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL ZMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL ZMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL ZMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_COL_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT, & 1:NB_BLR_COLS-NB_COL_SHIFT), & 0, 'V', 6, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = IACHK+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE IF (CB_IS_LR) THEN CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS ) ELSE CALL ZMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON ) ENDIF ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (CB_IS_LR.AND.SON_NIV.EQ.1) & NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ( (IS_ofType5or6) .AND. & ( & ( KEEP(50).EQ.0) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.PACKED_CB) ) & ) & ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE IF (CB_IS_LR) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ELSE CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) ENDIF IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL ZMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/ZMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL ZMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL ZMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL ZMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL ZMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in ZMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL ZMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_FREE_BLOCK( SON_A_MASTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE ZMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.4.1/src/zooc_panel_piv.F0000664000175000017500000002771314102210526016636 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE ZMUMPS_OOC). INTEGER FUNCTION ZMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF ZMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION ZMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE ZMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) COMPLEX(kind=8) THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL zswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE ZMUMPS_PERMUTE_PANEL SUBROUTINE ZMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine ZMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE ZMUMPS_GET_OOC_PERM_PTR SUBROUTINE ZMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: ZMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_PP_SET_PTR SUBROUTINE ZMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE ZMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE ZMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE ZMUMPS_OOC ! To call ZMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / ZMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / ZMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_GET_PP_SIZES SUBROUTINE ZMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the ZMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.4.1/src/cfac_mem_alloc_cb.F0000664000175000017500000001564114102210523017171 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE CMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP COMPLEX A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in CMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL CMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL CMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL CMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) ENDIF ENDIF CALL CMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in CMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE CMUMPS_ALLOC_CB MUMPS_5.4.1/src/zfac_front_LDLT_type2.F0000664000175000017500000010542614102210525017721 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC2_LDLT_M CONTAINS SUBROUTINE ZMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NNEGW, NPVW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_FAC_FRONT_TYPE2_AUX_M USE ZMUMPS_OOC USE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M !$ USE OMP_LIB USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_TEST IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NNEGW, NPVW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER, TARGET :: IW( LIW ) COMPLEX(kind=8) A( LA ) DOUBLE PRECISION UU, SEUIL TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER NB_BLOC_FAC INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER INOPV, IFINB, NFRONT, NPIV, IEND_BLOCK INTEGER NASS, LDAFS, IBEG_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV LOGICAL LASTBL, LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR, CURRENT_BLR INTEGER Inextpiv LOGICAL RESET_TO_ONE INTEGER K109_SAVE INTEGER XSIZE, NBKJIB_ORIG DOUBLE PRECISION UUTEMP INCLUDE 'mumps_headers.h' INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV DOUBLE PRECISION , ALLOCATABLE, DIMENSION ( : ) :: DIAG_ORIG INTEGER :: SIZEDIAG_ORIG INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY, NELIM TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PP_FIRST2SWAP_L, IFLAG_OOC INTEGER PP_LastPIVRPTRFilled INTEGER INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_SEND COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG, APOSMAX COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER PIVOT_OPTION INTEGER LAST_ROW EXTERNAL ZMUMPS_BDC_ERROR LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC DOUBLE PRECISION GW_FACTCUMUL INTEGER PIVSIZ,IWPOSPIV COMPLEX(kind=8) ONE PARAMETER (ONE=(1.0D0,0.0D0)) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L) NULLIFY(BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY(BEGS_BLR_TMP) NULLIFY(BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC=SEUIL UUTEMP=UU ENDIF RESET_TO_ONE = ((KEEP(110).GT.0).AND.(DKEEP(2).LE.0.0D0)) IF (RESET_TO_ONE) THEN K109_SAVE = KEEP(109) ENDIF IBEG_BLOCK = 1 NB_BLOC_FAC = 0 XSIZE = KEEP(IXSZ) IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) LDAFS = NASS IF ((KEEP(219).EQ.1).AND.(KEEP(207).EQ.1)) THEN APOSMAX = POSELT + int(LDAFS,8)*int(LDAFS,8)-1 CALL ZMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS) ENDIF IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = MIN(2,KEEP(468)) IF ((UUTEMP == 0.0D0) .AND. OOC_EFFECTIVE_ON_FRONT) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, ' : ZMUMPS_FAC2_LDLT failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR=NASS GO TO 490 END IF IF (KEEP(219).GE.3) THEN SIZEDIAG_ORIG = NASS ELSE SIZEDIAG_ORIG = 1 ENDIF ALLOCATE ( DIAG_ORIG(SIZEDIAG_ORIG), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID, & ' : FAC_NIV2 failed to allocate ', & NASS, ' REAL/COMPLEX entries' IFLAG=-13 IERROR=NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -9876 TYPEFile = TYPEF_L NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NASS MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -66666 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE+IW(IOLDPS+5+XSIZE) & :IOLDPS+5+2*NFRONT+XSIZE+IW(IOLDPS+5+XSIZE)) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0D0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.2) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & 0, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL ZMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT,NASS,IBEG_BLOCK_FOR_IPIV, & IBEG_BLOCK, IEND_BLOCK, & NASS, IPIV, & N,INODE,IW,LIW,A,LA, & NNEGW,NB22T2W,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, & IFLAG,IOLDPS,POSELT,UU, SEUIL_LOC, & KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ. 1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN NPVW = NPVW + PIVSIZ CALL ZMUMPS_FAC_MQ_LDLT_NIV2(IEND_BLOCK, & NASS, IW(IOLDPS+1+XSIZE), INODE,A,LA, & LDAFS, POSELT,IFINB, & PIVSIZ, & KEEP(219), & PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IF(PIVSIZ .EQ. 2) THEN IWPOSPIV = IOLDPS+XSIZE+IW(IOLDPS+1+XSIZE)+6+ & IW(IOLDPS+5+XSIZE) IW(IWPOSPIV+NFRONT) = -IW(IWPOSPIV+NFRONT) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (.NOT.RESET_TO_ONE.OR.K109_SAVE.EQ.KEEP(109)) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) IFLAG = IFLAG_OOC IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF IF (K263.eq.0) THEN NELIM = IEND_BLR-NPIV CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR, BLR_DUMMY, LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL ZMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLOCK, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF CALL ZMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 500 ENDIF NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_FAC2_LDLT", & IEND_BLR, IEND_BLOCK CALL MUMPS_ABORT() ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) ENDIF GOTO 101 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.2) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 2, 1, 0, .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1, & NASS=NASS) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF ENDIF 101 CONTINUE IF (.NOT. LR_ACTIVATED) THEN CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS, NASS, INODE, A, LA, & LDAFS, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & -6666, -6666, & (PIVOT_OPTION.LE.1), .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF IF (K263.NE.0) THEN NELIM = IEND_BLR-NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_L)) THEN BLR_SEND=>BLR_L ENDIF CALL ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, & IOLDPS, POSELT, A, LA, LDAFS, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, NB_BLOC_FAC, & & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR , BLR_SEND , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (RESET_TO_ONE.AND.K109_SAVE.LT.KEEP(109)) THEN CALL ZMUMPS_RESET_TO_ONE( & IW(IOLDPS+KEEP(IXSZ)+IW(IOLDPS+5+KEEP(IXSZ))+6), & NPIV, IBEG_BLR, & K109_SAVE, KEEP(109), PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF ENDIF ENDIF IF (.NOT. LR_ACTIVATED) THEN IF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NASS,NASS,INODE,A,LA, & LDAFS, POSELT, & KEEP,KEEP8, & -6666, -6666, & NASS, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ELSE NELIM = IEND_BLOCK - NPIV IF (IEND_BLR.NE.IEND_BLOCK) THEN CALL MUMPS_ABORT() ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN CALL ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NASS, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 2, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8) ENDIF ENDIF IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) GOTO 450 IF (KEEP(480).LT.2) THEN CALL ZMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NASS, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 2, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (PIVOT_OPTION.LT.2) THEN IF ((UU.GT.0).OR.(KEEP(486).NE.2)) THEN CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NASS, NASS, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, & 'V', 1) ENDIF ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF NULLIFY(BLR_L) ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = .FALSE. MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEFile, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG = IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF & ( & (KEEP(486).EQ.2) & ) & THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(LDAFS,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(LDAFS,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8(68) = max(KEEP8(69), KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, LDAFS, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 440 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 440 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 490 ENDIF IF ( & (KEEP(486).EQ.2) & & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC .LT. 0 ) THEN IFLAG = IFLAG_OOC RETURN ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF(allocated(IPIV)) DEALLOCATE( IPIV ) IF (allocated(DIAG_ORIG)) DEALLOCATE(DIAG_ORIG) IF (LR_ACTIVATED) THEN CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 2, 2) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, KEEP(50), 2) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC2_LDLT SUBROUTINE ZMUMPS_RESET_TO_ONE(FRONT_INDEX_LIST, NPIV, & IBEG_BLOCK, K109_SAVE, K109, PIVNUL_LIST, LPN_LIST, & A, POSELT, LA, LDAFS) INTEGER, INTENT(IN) :: NPIV, IBEG_BLOCK INTEGER, INTENT(IN) :: FRONT_INDEX_LIST(NPIV) INTEGER, INTENT(IN) :: K109 INTEGER, INTENT(INOUT) :: K109_SAVE INTEGER, INTENT(IN) :: LPN_LIST INTEGER, INTENT(IN) :: PIVNUL_LIST(LPN_LIST) INTEGER(8), INTENT(IN) :: POSELT, LA INTEGER, INTENT(IN) :: LDAFS COMPLEX(kind=8), INTENT(INOUT) :: A(LA) LOGICAL :: TO_UPDATE INTEGER :: I, JJ, K COMPLEX(kind=8) ONE PARAMETER (ONE=(1.0D0,0.0D0)) DO K = K109_SAVE+1, K109 TO_UPDATE = .FALSE. I = PIVNUL_LIST(K) DO JJ=IBEG_BLOCK, NPIV IF (FRONT_INDEX_LIST(JJ) .EQ.I) THEN TO_UPDATE=.TRUE. EXIT ENDIF ENDDO IF (TO_UPDATE) THEN A(POSELT+int(JJ,8)+int(LDAFS,8)*int(JJ-1,8))= ONE TO_UPDATE=.FALSE. ELSE write(*,*) ' Internal error related ', & 'to null pivot row detection' CALL MUMPS_ABORT() ENDIF ENDDO K109_SAVE = K109 RETURN END SUBROUTINE ZMUMPS_RESET_TO_ONE END MODULE ZMUMPS_FAC2_LDLT_M MUMPS_5.4.1/src/dfac_process_root2son.F0000664000175000017500000003210214102210522020107 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER I, LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, & LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV LIST_NELIM_ROW = IOLDPS + H_INODE + NPIV LIST_NELIM_COL = LIST_NELIM_ROW + NFRONT IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in DMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NELIM_LOCAL = NELIM_ROOT DO I=1, NELIM root%RG2L_ROW(IW(LIST_NELIM_ROW)) = NELIM_LOCAL root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_ROW = LIST_NELIM_ROW + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) IF (IFLAG.LT.0 ) RETURN ENDIF IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) PTRFAC(STEP(INODE))=POSELT IF ( TYPE_SON .eq. 1 ) THEN NBROW = NFRONT - NPIV ELSE NBROW = NELIM END IF IF ( TYPE_SON .eq. 1 .OR. KEEP(50).EQ.0) THEN LDA = NFRONT ELSE LDA = NPIV+NBROW ENDIF CALL DMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL DMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL DMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in DMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) LIST_NELIM_COL = IOLDPS + H_INODE + NROW + NPIV NELIM_LOCAL = NELIM_ROOT DO I = 1, NELIM root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL root%RG2L_ROW(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL DMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL DMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_ROOT2SON MUMPS_5.4.1/src/zfac_process_contrib_type3.F0000664000175000017500000002514414102210524021146 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC ) :: root INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF COMPLEX(kind=8) A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW INCLUDE 'mpif.h' INTEGER IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI INTEGER(8) :: LREQA, POS_ROOT INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF INTEGER NSUPCOL_EFF INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NSUPROW, NSUPCOL, BBPCBP INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISON, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPCOL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BBPCBP, 1, MPI_INTEGER, & COMM, IERR ) IF (BBPCBP .EQ. 1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF IROOT = KEEP( 38 ) IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR. & PTLUST( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL ZMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA CALL ZMUMPS_ASS_ROOT( root, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in ZMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL ZMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL ZMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & root%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.4.1/src/dfac_distrib_ELT.F0000664000175000017500000004674614102210522016753 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) DOUBLE PRECISION ELTVAL_LOC( LDBLARR ) DOUBLE PRECISION A( LA ) TYPE(DMUMPS_STRUC) :: id TYPE(DMUMPS_ROOT_STRUC) :: root INTEGER numroc EXTERNAL numroc INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER INODE INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) DOUBLE PRECISION VAL DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI DOUBLE PRECISION, DIMENSION( :, : ), ALLOCATABLE :: BUFR DOUBLE PRECISION, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 INTEGER, DIMENSION( : ), ALLOCATABLE, TARGET :: RG2LALLOC INTEGER, DIMENSION( : ), POINTER :: RG2L MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF IF (KEEP(46) .eq. 0 ) THEN ALLOCATE( RG2LALLOC( N ), stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = N GOTO 100 END IF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2LALLOC( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO RG2L => RG2LALLOC ELSE RG2L => root%RG2L_ROW END IF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL DMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL DMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL DMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in DMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL DMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_DOUBLE_PRECISION, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_DOUBLE_PRECISION, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL DMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL DMUMPS_ARROW_FILL_SEND_BUF( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL DMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_DOUBLE_PRECISION, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE root%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) IF (KEEP(38).ne.0) THEN IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE DMUMPS_ELT_DISTRIB SUBROUTINE DMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) DOUBLE PRECISION ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(dble(BUFR(1,I))+0.5D0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_DOUBLE_PRECISION, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = dble( NBRECR + SIZER ) END IF END DO RETURN END SUBROUTINE DMUMPS_ELT_FILL_BUF SUBROUTINE DMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE DMUMPS_MAXELT_SIZE SUBROUTINE DMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) DOUBLE PRECISION ELTVAL( SIZER ) DOUBLE PRECISION SELTVAL( LSELTVAL ) DOUBLE PRECISION ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE DMUMPS_SCALE_ELEMENT MUMPS_5.4.1/src/mumps_io.c0000664000175000017500000005224114102210474015510 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io.h" #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_c_types.h" #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # include "mumps_io_thread.h" #endif #if ! defined(MUMPS_WIN32) double mumps_time_spent_in_sync; #endif double read_op_vol,write_op_vol,total_vol; void MUMPS_CALL MUMPS_DUMPRHSBINARY_C ( MUMPS_INT *N, MUMPS_INT *NRHS, MUMPS_INT *LRHS, float *RHS, MUMPS_INT *K35, char *filename, mumps_ftnlen l1 ) { float *RHSshift; /* float: arbitrary, we use binary content */ FILE *fd; int icol; fd=fopen(filename, "w"); RHSshift=RHS; for(icol=0;icol<*NRHS;icol++) { fwrite(RHSshift, (size_t)(*K35), (size_t)(*N), fd); RHSshift=RHSshift+(size_t)(*LRHS)*(size_t)(*K35/sizeof(float)); } fclose(fd); } void MUMPS_CALL MUMPS_DUMPMATBINARY_C ( MUMPS_INT *N, MUMPS_INT8 *NNZ, MUMPS_INT* K35, MUMPS_INT *irn, MUMPS_INT *jcn, void *A, MUMPS_INT *is_A_provided, char *filename, mumps_ftnlen l1 ) { int64_t i8; int32_t myN, tmpi; FILE *fd; fd=fopen(filename, "w"); /* cast to int32_t in case MUMPS_INT is 64-bits */ myN=(int32_t)(*N); fwrite( &myN, sizeof(int32_t), 1, fd); fwrite( NNZ, sizeof(int64_t), 1, fd); if (*NNZ > 0) { if ( sizeof(MUMPS_INT) == 4 ) { /* write irn and jcn contents directly */ fwrite( irn, sizeof(int32_t), (size_t)(*NNZ), fd); fwrite( jcn, sizeof(int32_t), (size_t)(*NNZ), fd); } else { for(i8=0;i8 < *NNZ;i8++) { tmpi=irn[i8]; fwrite(&tmpi, sizeof(int32_t), 1, fd); } for(i8=0;i8 < *NNZ;i8++) { tmpi=jcn[i8]; fwrite(&tmpi, sizeof(int32_t), 1, fd); } } if (*is_A_provided) { fwrite(A, (size_t)(*K35), (size_t)(*NNZ), fd); } } fclose(fd); } /* Tests if the request "request_id" has finished. It sets the flag */ /* argument to 1 if the request has finished (0 otherwise) */ void MUMPS_CALL MUMPS_TEST_REQUEST_C(MUMPS_INT *request_id,MUMPS_INT *flag,MUMPS_INT *ierr) { char buf[64]; /* for error message */ MUMPS_INT request_id_loc; #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) MUMPS_INT flag_loc; #endif #if ! defined(MUMPS_WIN32) struct timeval start_time,end_time; gettimeofday(&start_time,NULL); #endif request_id_loc=(MUMPS_INT)*request_id; switch(mumps_io_flag_async){ case IO_SYNC: /* printf("mumps_test_request_c should not be called with strategy %d\n",mumps_io_flag_async);*/ /* JY+EA: Allow for this option, since it is similar to wait_request * and wait_request is allowed in synchronous mode. * We always return TRUE. */ *flag=1; break; #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) case IO_ASYNC_TH: *ierr=(MUMPS_INT)mumps_test_request_th(&request_id_loc,&flag_loc); *flag=(MUMPS_INT)flag_loc; break; #endif default: *ierr=-92; sprintf(buf,"Error: unknown I/O strategy : %d\n",(int)mumps_io_flag_async); mumps_io_error((MUMPS_INT)*ierr,buf); return; } #if ! defined(MUMPS_WIN32) gettimeofday(&end_time,NULL); mumps_time_spent_in_sync=mumps_time_spent_in_sync+((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)start_time.tv_sec+((double)start_time.tv_usec/1000000)); #endif return; } /* Waits for the termination of the request "request_id" */ void MUMPS_CALL MUMPS_WAIT_REQUEST(MUMPS_INT *request_id,MUMPS_INT *ierr) { char buf[64]; /* for error message */ MUMPS_INT request_id_loc; #if ! defined(MUMPS_WIN32) struct timeval start_time,end_time; gettimeofday(&start_time,NULL); #endif request_id_loc=(MUMPS_INT)*request_id; if(*request_id==-1) return; switch(mumps_io_flag_async){ case IO_SYNC: /* printf("mumps_wait_request should not be called with strategy %d\n",mumps_io_flag_async); */ break; #if ! defined(MUMPS_WIN32) && ! defined(WITHOUT_PTHREAD) case IO_ASYNC_TH: *ierr=(MUMPS_INT)mumps_wait_request_th(&request_id_loc); break; #endif default: *ierr=-92; sprintf(buf,"Error: unknown I/O strategy : %d\n",(int)mumps_io_flag_async); mumps_io_error((MUMPS_INT)*ierr,buf); return; /* printf("Error: unknown I/O strategy : %d\n",mumps_io_flag_async); exit (-3);*/ } #if ! defined(MUMPS_WIN32) gettimeofday(&end_time,NULL); mumps_time_spent_in_sync=mumps_time_spent_in_sync+((double)end_time.tv_sec+((double)end_time.tv_usec/1000000))-((double)start_time.tv_sec+((double)start_time.tv_usec/1000000)); #endif return; } /** * Inits the I/O OOC mechanism. * Because on some computers, file size is limited, the I/O * mechanism must be able to handle a multi-file access to data. * Hence, we compute mumps_io_nb_file, which is the the number of files * we estimate we need. * Because of not exact matching between data packets written and size * of files, the recoverment may be imperfect. Consequently, we must * be able to reallocate if necessary. */ void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_PREFIX(MUMPS_INT *dim, char *str, mumps_ftnlen l1) { MUMPS_INT i; MUMPS_OOC_STORE_PREFIXLEN = *dim; if( *dim > MUMPS_OOC_PREFIX_MAX_LENGTH ) MUMPS_OOC_STORE_PREFIXLEN = MUMPS_OOC_PREFIX_MAX_LENGTH; for(i=0;i MUMPS_OOC_TMPDIR_MAX_LENGTH ) MUMPS_OOC_STORE_TMPDIRLEN = MUMPS_OOC_TMPDIR_MAX_LENGTH; for(i=0;i BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL cgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL cgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL cgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS COMPLEX, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & CMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL cgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL cgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL cgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP COMPLEX, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL cgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL cgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL cgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL CMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) COMPLEX :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if defined(BLR_MT) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), & BLR_L(IND_L), MIDBLK_COMPRESS, & MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(real(ACC_LRB%M*ACC_LRB%N)/real(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE COMPLEX, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & CMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE CMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN COMPLEX, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: NCB, MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) NCB = NFRONT - NASS ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'CMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT REAL,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC INTEGER :: FRONT_CB_BLR_SAVINGS LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) ACC_LRB => ACC_LUA(1) FRONT_CB_BLR_SAVINGS = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if defined(BLR_MT) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in CMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL CMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL CMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL CMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(REAL(ACC_LRB%M*ACC_LRB%N)/REAL(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & LRB%M*LRB%N - LRB%M*LRB%K - LRB%N*LRB%K ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL CMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL CMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL CMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NFRONT-NASS, NFRONT-NASS, 0, 1, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, 0, 1, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif ENDIF END SUBROUTINE CMUMPS_BLR_UPD_CB_LEFT SUBROUTINE CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN, CBASM_TOFIX_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN LOGICAL,OPTIONAL,intent(in) :: CBASM_TOFIX_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I, ONLY_NELIM LOGICAL :: CBASM_TOFIX #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT COMPLEX :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF IF (present(CBASM_TOFIX_IN)) THEN CBASM_TOFIX = CBASM_TOFIX_IN ELSE CBASM_TOFIX = .FALSE. ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP = BEGS_BLR_FIRST_OFFDIAG #if !defined(BLR_MT) IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(I)%N ELSE BIP = BIP + BLR_PANEL(I)%M ENDIF ENDDO ENDIF #endif #if defined(BLR_MT) LAST_IP = CURRENT_BLR+1 CHUNK = 1 !$OMP DO PRIVATE(POSELT_BLOCK, M, N, K, I) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN IF (CBASM_TOFIX) THEN POSELT_BLOCK = POSELT & + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) + int(BIP-1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21 & .AND..NOT.CBASM_TOFIX) THEN CALL cgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL cgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL cgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL cgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF (CBASM_TOFIX) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSEIF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ENDIF #endif ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE CMUMPS_DECOMPRESS_PANEL SUBROUTINE CMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U REAL, TARGET, DIMENSION(:) :: RWORK COMPLEX, TARGET, DIMENSION(:,:) :: BLOCK COMPLEX, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO, FRONT_CB_BLR_SAVINGS INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if defined(BLR_MT) INTEGER :: CHUNK #endif REAL, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX, POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL CMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif FRONT_CB_BLR_SAVINGS = 0 OMP_NUM = 0 IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL CMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL cungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF END IF FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO #endif #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NROWS, NCOLS, SYM, NIV, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, SYM, NIV, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif END SUBROUTINE CMUMPS_COMPRESS_CB SUBROUTINE CMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, K480, & BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) REAL, TARGET, DIMENSION(:) :: RWORK COMPLEX, TARGET, DIMENSION(:,:) :: BLOCK COMPLEX, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTRINSIC maxval INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR COMPLEX :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER :: OMP_NUM REAL, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX, POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if defined(BLR_MT) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN CMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (M.NE.BLR_PANEL(IP-CURRENT_BLR)%M) THEN write(*,*) 'Internal error in CMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & BLR_PANEL(IP-CURRENT_BLR)%M CALL MUMPS_ABORT() ENDIF IF (N.NE.BLR_PANEL(IP-CURRENT_BLR)%N) THEN write(*,*) 'Internal error in CMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & BLR_PANEL(IP-CURRENT_BLR)%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(real(M*N)/real(M+N)) IF (BLR_PANEL(IP-CURRENT_BLR)%K.GT.MAXRANK) THEN write(*,*) 'Internal error in CMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & BLR_PANEL(IP-CURRENT_BLR)%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(real(M*N)/real(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL CMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) GOTO 3000 IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J), & JPVT_THR(J)) = & BLOCK_THR(1:MIN(RANK,J),J) IF(J.LT.RANK) BLR_PANEL(IP-CURRENT_BLR)% & R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO ENDDO CALL cungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = BLOCK_THR(1:M,I) END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS( & BLR_PANEL(IP-CURRENT_BLR), FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR), & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF 3000 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE CMUMPS_COMPRESS_PANEL SUBROUTINE CMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if defined(BLR_MT) INTEGER :: CHUNK #endif COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in CMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL CMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE CMUMPS_BLR_PANEL_LRTRSM END MODULE CMUMPS_FAC_LR MUMPS_5.4.1/src/dfac_mem_alloc_cb.F0000664000175000017500000001566614102210522017200 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE DMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP DOUBLE PRECISION A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in DMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL DMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL DMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL DMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) ENDIF ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in DMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE DMUMPS_ALLOC_CB MUMPS_5.4.1/src/ssol_driver.F0000664000175000017500000070353214102210525016161 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOLVE_DRIVER(id) USE SMUMPS_STRUC_DEF USE SMUMPS_SOL_ES C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C C C USE SMUMPS_BUF USE SMUMPS_OOC USE MUMPS_MEMORY_MOD USE SMUMPS_LR_DATA_M, only : SMUMPS_BLR_STRUC_TO_MOD & , SMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC USE SMUMPS_SAVE_RESTORE IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE SMUMPS_SIZE_IN_STRUCT( id, NB_INT,NB_CMPLX,NB_CHAR ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE SMUMPS_SIZE_IN_STRUCT SUBROUTINE SMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE SMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (SMUMPS_STRUC), TARGET :: id C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,IPERM,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8, LWCB8_SOL_C C buffer sizes INTEGER SMUMPS_LBUF, SMUMPS_LBUF_INT INTEGER(8) :: SMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS C true if SMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY REAL, DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_allocated REAL, DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSCOMP_FWD, & PTR_POSINRHSCOMP_BWD REAL, DIMENSION(:), POINTER :: PTR_RHS INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ REAL ONE REAL ZERO PARAMETER( ONE = 1.0E0 ) PARAMETER( ZERO = 0.0E0 ) REAL RZERO, RONE PARAMETER( RZERO = 0.0E0, RONE = 1.0E0 ) C C RHS_IR is internal to SMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. REAL, DIMENSION(:), POINTER :: RHS_IR REAL, DIMENSION(:), POINTER :: WORK_WCB REAL, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C REAL, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK REAL, ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) REAL, ALLOCATABLE :: R_Y(:), D(:) REAL, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 REAL, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSCOMP, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS REAL, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS REAL, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs adn solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*S(ISTW3) C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D2) **(-1)] x0 and so x0= D2*y0 is modified C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2ATD1 D1-1 x0 = D2b0 C b(sca) = D2 * b0 = COLSCA*S(ISTW3) C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS we need C scaling information on each processor C type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data_sol, scaling_data_dr C To scale on the fly during GATHER SOLUTION REAL, DIMENSION(:), POINTER :: PT_SCALING REAL, TARGET :: Dummy_SCAL(1) C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG REAL ARRET REAL C_DUMMY(1) REAL R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) REAL, TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IPT_RHS_ROOT INTEGER(8) :: IBEG, IBEG_RHSCOMP, KDEC, IBEG_loc, IBEG_REDRHS INTEGER LD_RHSCOMP, NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8 INTEGER(8) K16_8, ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSCOMP LOGICAL :: BUILD_RHSMAPINFO LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER(8) :: FILE_SIZE,STRUC_SIZE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation IRHS_PTR_COPY => IDUMMY_TARGET IRHS_PTR_COPY_ALLOCATED = .FALSE. IRHS_SPARSE_COPY => IDUMMY_TARGET IRHS_SPARSE_COPY_ALLOCATED=.FALSE. RHS_SPARSE_COPY => CDUMMY_TARGET RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO C ASPK =>id%A C COLSCA =>id%COLSCA C ROWSCA =>id%ROWSCA RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) K16_8 = int(KEEP(16), 8) NBENT_RHSCOMP = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSCOMP =-152525_8 ! Should not be used BUILD_POSINRHSCOMP = .TRUE. IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C Not needed anymore (since new version of gather) C LD_RHSCOMP = max(KEEP(89),1) ! at the nb of pivots eliminated on ! that proc LD_RHSCOMP = 1 NB_FS_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Compute the number of integers and nb of reals in the structure CALL SMUMPS_SIZE_IN_STRUCT (id, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 + NB_CHAR NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok CALL SMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== C The checks below used to be in SMUMPS_DRIVER. It is much better C to have them here in SMUMPS_SOL_DRIVER because this enables C more flexibility in the management of priorities between various C checks. IF (id%MYID .EQ. MASTER) THEN c subroutine only because called at facto and solve CALL SMUMPS_SET_K221(id) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN C -- input RHS is indeed stored in REDRHS and RHSCOMP id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and RHSCOMP id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (KEEP(248) .EQ. -1) THEN C V0 distributed RHS: no ES id%KEEP(235) = 0 ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0)) THEN C In the context of null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( (id%KEEP(221).EQ.1 ).AND.(id%KEEP(235).NE.0) ) THEN C -- Do not permute RHS with REDRHS for the time being id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0E0 id%DKEEP(113)=0.0E0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0E0 id%DKEEP(120)=0.0E0 id%DKEEP(121)=0.0E0 id%DKEEP(115)=0.0E0 id%DKEEP(116)=0.0E0 id%DKEEP(122)=0.0E0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0E0 id%DKEEP(118)=0.0E0 id%DKEEP(119)=0.0E0 id%DKEEP(123)=0.0E0 id%DKEEP(124)=0.0E0 id%DKEEP(125)=0.0E0 id%DKEEP(126)=0.0E0 id%DKEEP(127)=0.0E0 id%DKEEP(128:134)=0.0E0 id%DKEEP(140:153)=0.0E0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN C RHS must be of size N on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL SMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C Check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)=-47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1) THEN C ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL SMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( I_AM_SLAVE ) THEN C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc < id%KEEP(89) ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF (id%KEEP(89) .NE. 0) THEN IF ( .not. associated(id%ISOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 ENDIF IF ( .not. associated(id%SOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 ENDIF IF (size(id%ISOL_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_F2003) IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(id%KEEP(89),8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+id%KEEP(89)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ENDIF ENDIF IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF IF (I_AM_SLAVE .AND. id%KEEP(248).EQ.-1) THEN CALL SMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & id%INFO) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to SMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF IF (I_AM_SLAVE .AND. ICNTL21.EQ.1 .AND. & KEEP(248) .EQ. -1) THEN ! Dist RHS and dist solution IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN IF (id%KEEP(89).GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks (REDRHS), depending on KEEP(221) CALL SMUMPS_CHECK_REDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ==================================== C Process case of NZ_RHS = 0 with C sparse RHS and General Sparse (NOT A-1) C ----------------------------------- IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN C CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (id%NZ_RHS.EQ.0) THEN C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL SMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , .FALSE., IDUMMY(1), 1 & ) DO J=1, id%NRHS DO I=1, KEEP(89) id%SOL_loc((J-1)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF ENDIF IF (ICNTL21.NE.1) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN C write(6,*) " NZ_RHS is zero " WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== ENDIF ! test NZ_RHS.EQ.0 C -------- ENDIF ! (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF NB_BYTES = NB_BYTES + NBT*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT * K34_8 C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN CALL SMUMPS_BUILD_MAPPING_INFO(id) END IF END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) & CALL SMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS does IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSCOMP on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. C IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(id%root%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)*int(NBRHS,8) C C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor. Note that we are C inside a block "IF (I_AM_SLAVE)" WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (id%LWK_USER.EQ.0) THEN ITMP8 = 0_8 ELSE IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ! jump to propinfo ! (S is used in between and not allocated) ! NO COMM must occur then before next propinfo ! it happens in Mila's code but only with ! KEEP(209) > 0 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF C KEEP8(24) holds the size of WK_USER provided by user. C MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN C Avoid the use of "size(id%S)" because it returns C a default integer that may overflow. Also "size(id%S,kind=8)" C will only be available with Fortran 2003 compilers. MAXS = KEEP8(23) ELSE ! S not allocated and WK_USER not provided ==> must be in OOC IF (KEEP(201).EQ.0) THEN ! incore WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' C IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C --- end of OOC case ENDIF C -- end of id%S already associated ENDIF C C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE C MAXS has normally be dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL SMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL SMUMPS_OOC_INIT_SOLVE(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in SMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in SMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL SMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== C LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. C FORBID ERROR ANALYSIS AND ITERATIVE REFINEMENT C if there are options that are not compatible IF (KEEP(111).NE.0) THEN C IF WE RETURN A NULL SPACE BASIS or compute entries in A-1 C of Fwd in facto C -When only one columns of A-1 is requested then C we could try to reactivate IR even if C -code need be updated C -accuracy could be # when one or more columns are requested IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN C Forbid error analysis and iterative refinement C in case of reduced rhs/solution IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN C Forbid error analysis and iterative refinement if C the solution is distributed or C in the case where nrhs > 1 IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN C Forbid error analysis and iterative refinement C in case of distributed RHS IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF C -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( id%MYID .eq. MASTER ) THEN IF (MAT_ALLOC.EQ.0) THEN POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL21,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(35),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety C Note that IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(MSG_MAX_BYTES_SOLVE),8)) THEN INFO(1) = -18 INFO(2) = ( huge(MSG_MAX_BYTES_SOLVE) - & ( 16 + 4 + KEEP(133) ) ) / & ( KEEP(133) * KEEP(35) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for SMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE #if defined(MPI_TO_K_OMPP) #endif C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for SMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(35) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for SMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ SMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL SMUMPS_BUF_ALLOC_SMALL_BUF( SMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = SMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (SMUMPS_LBUF) C using integer8 in SMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C SMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... SMUMPS_LBUF_8 = min(SMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously SMUMPS_LBUF_8 = max(SMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) SMUMPS_LBUF_8 = SMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. SMUMPS_LBUF_8 = min(SMUMPS_LBUF_8, & int(huge(SMUMPS_LBUF),8) & - 10_8*int(KEEP(34),8) & ) SMUMPS_LBUF = int(SMUMPS_LBUF_8, kind(SMUMPS_LBUF)) CALL SMUMPS_BUF_ALLOC_CB( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = SMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSCOMP must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C POSINRHSCOMP_ROW/COL are meaningful and could even be reused IF (.NOT.associated(id%POSINRHSCOMP_ROW) ) ! .OR. ! & .NOT.(id%POSINRHSCOMP_COL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%POSINRHSCOMP_COL_ALLOC) THEN C POSINRHSCOMP_COL that is kept from C previous call to solve must then (already) C point to id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW ENDIF ELSE C ---------------------- C Allocate POSINRHSCOMP_ROW/COL C ---------------------- C The size of POSINRHSCOMP arrays C does not depend on the block of RHS C POSINRHSCOMP_ROW/COL are initialized in the loop of RHS IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) ENDIF ALLOCATE (id%POSINRHSCOMP_ROW(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C IF ((KEEP(50).EQ.0).OR.KEEP(237).NE.0) THEN ALLOCATE (id%POSINRHSCOMP_COL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%POSINRHSCOMP_COL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_COL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate POSINRHSCOMP_COL id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after reduced RHS C -- we have to keep "old" RHSCOMP IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (SMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in SMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to SMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(SRW3),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine SMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in SMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before theC C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) ) ) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSCOMP to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF IF (LSCAL .AND. id%KEEP(248).EQ.-1) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL SMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(id%KEEP(89)), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=id%KEEP(89) GOTO 38 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF ENDIF ! LSCAL IF ( I_AM_SLAVE ) THEN C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL SMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF ENDIF ! I_AM_SLAVE IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C ---------------------------- C Preparation for reduced RHS C ---------------------------- IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL SMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL SMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within SMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in SMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN c - In case of NS/A-1 we may want to permute RHS c - for NS thus is to apply permutation to PIVNUL_LIST * - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL SMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C ============================== C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_LOC) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * SMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSCOMP to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C ====================== IF (KEEP(248)==1) THEN C ====================== C C Sparse RHS format ( A-1 or sparse input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IRHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ELSE IRHS_SPARSE_COPY = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C if scaling is on or if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one; it might be C modified if scaling is on (one first entry in each col is scaled) RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) THEN C -- Columns are not contiguous and need be copied one by one C -- This need not be done if scaling is on because it C -- will done and scaled later. IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IF (COLSIZE .EQ. 0) CYCLE RHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C ----- ENDIF ! ============ KEEP(248)==1 C ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) IF (IERR.GT.0) THEN WRITE (*,*)'NOT OK FOR ALLOC PTR ON SLAVES' call MUMPS_ABORT() ENDIF ENDIF ENDIF C C ========================================================= C INITIALIZE POSINRHSCOMP_ROW/COL, RHSCOMP and related data C For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= IF ( I_AM_SLAVE ) THEN C -------------------------------------------------- C If I am involved in the solve and if C either C no null space comput (keep(111)=0) and sparse rhs C or C null space computation C then C compute POSINRHSCOMP C endif C C Fwd in facto: in this case only POSINRHSCOMP need be computed C C (POSINRHSCOMP_ROW/COL indirection arrays should C have been allocated once outside loop) C Compute size of RHSCOMP since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize POSINRHSCOMP_ROW/COL C C Note that LD_RHSCOMP and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSCOMP is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE POSINRHSCOMP_ROW/COL C ------------------------------- C IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSCOMP was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSCOMP would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, we do not C need to compute POSINRHSCOMP BUILD_POSINRHSCOMP = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSCOMP C ------------------------ IF (BUILD_POSINRHSCOMP) THEN C -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSCOMP for next iteration in loop C C general case only POSINRHSCOMP is computed BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSCOMP to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSCOMP C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C POSINRHSCOMP_ROW will allow to find the (row) index of a C zero in RHSCOMP before calling SMUMPS_SOL_S. Then C SMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSCOMP MTYPE_LOC = 1 ! (no transpose) C BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSCOMP = .TRUE. ENDIF ENDIF C -- compute POSINRHSCOMP LIW_PASSED=max(1,LIW) IF (KEEP(237).EQ.0) THEN CALL SMUMPS_BUILD_POSINRHSCOMP( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW_PASSED, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & NBENT_RHSCOMP, NB_FS_RHSCOMP_TOT ) NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT ELSE CALL SMUMPS_BUILD_POSINRHSCOMP_AM1( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK,PERM_RHS, size(PERM_RHS) , JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_RHSCOMP_F, NB_FS_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1) THEN C C Prepare symbolic data for sends. C For the moment: MAP_RHS_loc C CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%POSINRHSCOMP_ROW(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN IF (KEEP(221).EQ.1) THEN C we need to save the reduced RHS for all RHS to perform C later the backward phase with an updated reduced RHS C thus we allocate NRHS_NONEMPTY columns in one shot. C Note that RHSCOMP might have been allocated in previous block C and RHSCOMP has been deallocated previous to entering loop on RHS IF (.not. associated(id%RHSCOMP)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSCOMP will not change in the loop C and can be used to dimension RHSCOMP C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. LD_RHSCOMP = max(NBENT_RHSCOMP,1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(id%NRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSCOMP (case of RHSCOMP allocated at each block of RHS) C ------------------ C RHSCOMP allocated per block of maximum size NBRHS LD_RHSCOMP = max(NBENT_RHSCOMP, LD_RHSCOMP) C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSCOMP)) THEN IF ( (id%KEEP8(25).LT.int(LD_RHSCOMP,8)*int(NBRHS,8)) & .OR. (KEEP(235).NE.0).OR.(KEEP(237).NE.0) ) THEN ! deallocate and reallocate if: ! _larger array needed ! OR ! _exploit sparsity/A-1: since size of RHSCOMP ! is expected to vary much in these cases ! this should improve locality NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF IF (.not. associated(id%RHSCOMP)) THEN LD_RHSCOMP = max(NBENT_RHSCOMP, 1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(NBRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF (KEEP(221).EQ.2) THEN C RHSCOMP has been allocated (call with KEEP(221).EQ.1) C even in the case fwd in facto ! Not correct: LD_RHSCOMP = LENRHSCOMP/id%NRHS_NONEMPTY LD_RHSCOMP = int(id%KEEP8(25)/int(id%NRHS,8)) ENDIF C C Shift on RHSCOMP C IF ( KEEP(221).EQ.0 ) THEN C -- RHSCOMP reused in the loop IBEG_RHSCOMP= 1_8 ELSE C Initialize IBEG_RHSCOMP C IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in SMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF C C RHS is set to scaled right hand side C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL SMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_REAL, & MASTER, id%COMM, IERR) ENDIF C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSCOMP. C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1_8:int(NBRHS_EFF,8)*int(LD_RHSCOMP,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSCOMP to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSCOMP = id%POSINRHSCOMP_ROW(J) C IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_F) C & .AND.(IPOSRHSCOMP.GT.0) ) THEN IF (IPOSRHSCOMP.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc C Note that : C In first entry in column C we have and MUST have already scaled value of diagonal. C This need have been done on master because we do not C have scaling arrays available on slaves. C Furthermore we know that only one entry is C needed the diagonal entry (for the forward with A-1). C id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8)+ & int(IPOSRHSCOMP,8)) = & RHS_SPARSE_COPY(IPOS) ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- reset to zero RHSCOMP for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(LD_RHSCOMP,8) + & IBEG_RHSCOMP - 1_8 id%RHSCOMP(KDEC+1_8:KDEC+NBENT_RHSCOMP) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSCOMP = id%POSINRHSCOMP_ROW(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSCOMP, we can compare to KEEP(89) C to know if RHSCOMP should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSCOMP so we compare to C NB_FS_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to SMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C SMUMPS_RHS must be passed to C SMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSCOMP to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHSCOMP,8) id%RHSCOMP(KDEC+1_8:KDEC+int(LD_RHSCOMP,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%POSINRHSCOMP_ROW(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = & id%DKEEP(2) ELSE ! Symmetric: always set to one id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to SMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSCOMP need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 C ------------------------------------------- C Reserve space at the end of WORK_WCB on the C master of the root node. It will be used to C store the reduced RHS. C ------------------------------------------- IF ( I_AM_SLAVE ) THEN LWCB8_SOL_C = LWCB8 IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_F2003) LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT,kind=8) # else LPTR_RHS_ROOT = int(size(id%root%RHS_CNTR_MASTER_ROOT),8) # endif ELSE C Otherwise, we use workspace in WCB LPTR_RHS_ROOT = int(NBRHS_EFF,8) * int(SIZE_ROOT,8) IPT_RHS_ROOT = LWCB8 - LPTR_RHS_ROOT + 1_8 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 IPT_RHS_ROOT = LWCB8 ! Will be passed, but not accessed PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_REAL, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN C C --- Normal case : we do not exploit sparsity of the RHS C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) PRUNED_SIZE_LOADED = 0_8 ! From SMUMPS_SOL_ES module CALL SMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, IS(1), & LIW_PASSED, WORK_WCB(1), LWCB8_SOL_C, IWCB, LIWCB, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), FROM_PP, & id%STEP(1), id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), & id%PTLUST_S(1), id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, & LIWK_PTRACB, id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1), & KEEP8(1), id%DKEEP(1), id%COMM_NODES, id%MYID, id%MYID_NODES, & BUFR(1), LBUFR, LBUFR_BYTES, id%ISTEP_TO_INIV2(1), & id%TAB_POS_IN_PERE(1,1), IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, & MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1) & , 1, 1, 1, 1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & , 1, 1, NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) ELSE C Exploit sparsity of the RHS (all cases) C Remark that JBEG_RHS is already initialized C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) CALL SMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED,IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,MTYPE,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1),LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1,PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP, id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, JBEG_RHS, id%Step2node(1), & id%KEEP(28),IRHS_SPARSE_COPY(1),IRHS_PTR_COPY(1), size(PERM_RHS), & PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT,NBSPARSE_LOC,PTR_RHS_BOUNDS(1),LPTR_RHS_BOUNDS & ) ENDIF ! end of exploit sparsity (pruning nodes of the tree) END IF C ----------------- C End of slave code C ----------------- C C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_REAL, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_REAL, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_REAL, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ====== END OF REDUCED RHS (Fwd only performed) ====== C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (SMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (MTYPE.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL SMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_COL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL SMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%POSINRHSCOMP_COL(1), id%N, NB_FS_RHSCOMP_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN CALL SMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & NBRHS_EFF, id%POSINRHSCOMP_COL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, & id%STEP(1), scaling_data_sol, LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal ERROR 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0E0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0E0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call SMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL SMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL SMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = real(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. C Test of convergence should be made IF (( id%MYID .eq. MASTER ).AND.(ICNTL10.GT.0)) THEN TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0E0) THEN ARRET = sqrt(epsilon(0.0E0)) END IF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL SMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL SMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL SMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL SMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL SMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA1) ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL SMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in SMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL SMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=real(TIMEIT) ELSE C IR has been requested id%DKEEP(114)=real(TIMEIT)-id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL SMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL SMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_REAL, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL SMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL SMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL SMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL SMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL SMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+real(TIMELCOND) IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N WRITE(*,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min0(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min0(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO C DO WHILE (BEG_RHS.LE.id%NRHS) C ========================== C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 CYCLE ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSCOMP and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP(int(JBEG_NEW -1,8)*int(LD_RHSCOMP,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=real(TIME3) id%DKEEP(113)=real(TIMEC2) id%DKEEP(115)=real(TIMESCATTER2) id%DKEEP(116)=real(TIMEGATHER2) id%DKEEP(122)=real(TIMECOPYSCALE2) C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL SMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL SMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL SMUMPS_BUF_DEALL_CB( IERR ) CALL SMUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN C Free local scaling arrays NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF C Free memory until next call to SMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be saved and is used C in incore to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN C OOC: free space for S that was allocated NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) ENDIF IF (KEEP(221).NE.1) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time to copy/scale dist. solution=',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12 & ) 151 FORMAT (' --- (25) =',I12) 152 FORMAT (' --- (26) =',I12) 153 FORMAT (' --- (32) =',I12) 160 FORMAT (' RHS'/(1X,1P,5E14.6)) 170 FORMAT (/' ERROR ANALYSIS' ) 240 FORMAT (1X, A42,I4) 270 FORMAT (//' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 131 FORMAT (/' END ITERATIVE REFINEMENT ') 141 FORMAT(1X, A52,I4) CONTAINS SUBROUTINE SMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS #if defined(MUMPS_F2003) INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) REAL, INTENT( IN ), POINTER :: idRHS_loc (:) #else INTEGER, POINTER :: idIRHS_loc (:) REAL, POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_F2003) IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #else IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN C (Warning: this assumes that size(idRHS_loc) C does not overflow) #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_CHECK_DISTRHS SUBROUTINE SMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of SMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in SMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C POSINRHSCOMP_ROW is with respect to the C original linear system (transposed or not) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL ENDIF LIW_PASSED = max( LIW, 1 ) CALL SMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 1, & PTR_POSINRHSCOMP_FWD(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_COL ELSE PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_ROW ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL SMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP,PTR_POSINRHSCOMP_FWD(1),PTR_POSINRHSCOMP_BWD(1), & 1,1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C SMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (SOLVET.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) C Solution computed during SMUMPS_SOL_C has been stored C in id%RHSCOMP and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), ! RHSCOMP not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL SMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & PTR_POSINRHSCOMP_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE SMUMPS_PP_SOLVE END SUBROUTINE SMUMPS_SOLVE_DRIVER MUMPS_5.4.1/src/cmumps_comm_buffer.F0000664000175000017500000040447114102210523017474 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_BUF PRIVATE PUBLIC :: CMUMPS_BUF_TRY_FREE_CB, CMUMPS_BUF_INIT, & CMUMPS_BUF_INI_MYID, & CMUMPS_BUF_ALLOC_CB , CMUMPS_BUF_DEALL_CB , & CMUMPS_BUF_ALLOC_SMALL_BUF, CMUMPS_BUF_DEALL_SMALL_BUF, & CMUMPS_BUF_ALLOC_LOAD_BUFFER,CMUMPS_BUF_DEALL_LOAD_BUFFER, & CMUMPS_BUF_SEND_CB, CMUMPS_BUF_SEND_VCB, & CMUMPS_BUF_SEND_1INT, CMUMPS_BUF_SEND_DESC_BANDE, & CMUMPS_BUF_SEND_MAPLIG, CMUMPS_BUF_SEND_MAITRE2, & CMUMPS_BUF_SEND_CONTRIB_TYPE2, & CMUMPS_BUF_SEND_BLOCFACTO, CMUMPS_BUF_SEND_BLFAC_SLAVE, & CMUMPS_BUF_SEND_MASTER2SLAVE, & CMUMPS_BUF_SEND_CONTRIB_TYPE3, CMUMPS_BUF_SEND_RTNELIND, & CMUMPS_BUF_SEND_ROOT2SLAVE, CMUMPS_BUF_SEND_ROOT2SON, & CMUMPS_BUF_SEND_BACKVEC,CMUMPS_BUF_SEND_UPDATE_LOAD, & CMUMPS_BUF_DIST_IRECV_SIZE, & CMUMPS_BUF_BCAST_ARRAY, CMUMPS_BUF_ALL_EMPTY, & CMUMPS_BUF_BROADCAST, CMUMPS_BUF_SEND_NOT_MSTR, & CMUMPS_BUF_SEND_FILS ,CMUMPS_BUF_DEALL_MAX_ARRAY & ,CMUMPS_BUF_MAX_ARRAY_MINSIZE & ,CMUMPS_BUF_TEST PUBLIC :: CMUMPS_BLR_PACK_CB_LRB & ,CMUMPS_MPI_PACK_LRB & ,CMUMPS_MPI_UNPACK_LRB INTEGER NEXT, REQ, CONTENT, OVHSIZE PARAMETER( NEXT = 0, REQ = 1, CONTENT = 2, OVHSIZE = 2 ) INTEGER, SAVE :: SIZEofINT, SIZEofREAL, BUF_MYID TYPE CMUMPS_COMM_BUFFER_TYPE INTEGER LBUF, HEAD, TAIL,LBUF_INT, ILASTMSG INTEGER, DIMENSION(:),POINTER :: CONTENT END TYPE CMUMPS_COMM_BUFFER_TYPE TYPE ( CMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_CB TYPE ( CMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_SMALL TYPE ( CMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_LOAD INTEGER, SAVE :: SIZE_RBUF_BYTES INTEGER, SAVE :: BUF_LMAX_ARRAY REAL, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE CMUMPS_BUF_TRY_FREE_CB() CALL CMUMPS_BUF_TRY_FREE(BUF_CB) RETURN END SUBROUTINE CMUMPS_BUF_TRY_FREE_CB SUBROUTINE CMUMPS_BUF_TRY_FREE(B) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: B INCLUDE 'mpif.h' LOGICAL :: FLAG INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, & STATUS, IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF RETURN END SUBROUTINE CMUMPS_BUF_TRY_FREE SUBROUTINE CMUMPS_BUF_INI_MYID( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE CMUMPS_BUF_INI_MYID SUBROUTINE CMUMPS_BUF_INIT( IntSize, RealSize ) IMPLICIT NONE INTEGER IntSize, RealSize SIZEofINT = IntSize SIZEofREAL = RealSize NULLIFY(BUF_CB %CONTENT) NULLIFY(BUF_SMALL%CONTENT) NULLIFY(BUF_LOAD%CONTENT) BUF_CB%LBUF = 0 BUF_CB%LBUF_INT = 0 BUF_CB%HEAD = 1 BUF_CB%TAIL = 1 BUF_CB%ILASTMSG = 1 BUF_SMALL%LBUF = 0 BUF_SMALL%LBUF_INT = 0 BUF_SMALL%HEAD = 1 BUF_SMALL%TAIL = 1 BUF_SMALL%ILASTMSG = 1 BUF_LOAD%LBUF = 0 BUF_LOAD%LBUF_INT = 0 BUF_LOAD%HEAD = 1 BUF_LOAD%TAIL = 1 BUF_LOAD%ILASTMSG = 1 RETURN END SUBROUTINE CMUMPS_BUF_INIT SUBROUTINE CMUMPS_BUF_ALLOC_CB( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE CMUMPS_BUF_ALLOC_CB SUBROUTINE CMUMPS_BUF_ALLOC_SMALL_BUF( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE CMUMPS_BUF_ALLOC_SMALL_BUF SUBROUTINE CMUMPS_BUF_ALLOC_LOAD_BUFFER( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE CMUMPS_BUF_ALLOC_LOAD_BUFFER SUBROUTINE CMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_LOAD, IERR ) RETURN END SUBROUTINE CMUMPS_BUF_DEALL_LOAD_BUFFER SUBROUTINE CMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE CMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF ALLOCATE(BUF_MAX_ARRAY(NFS4FATHER),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF BUF_LMAX_ARRAY=NFS4FATHER RETURN END SUBROUTINE CMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE CMUMPS_BUF_DEALL_CB( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_CB, IERR ) RETURN END SUBROUTINE CMUMPS_BUF_DEALL_CB SUBROUTINE CMUMPS_BUF_DEALL_SMALL_BUF( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_SMALL, IERR ) RETURN END SUBROUTINE CMUMPS_BUF_DEALL_SMALL_BUF SUBROUTINE BUF_ALLOC( BUF, SIZE, IERR ) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE, IERR IERR = 0 BUF%LBUF = SIZE BUF%LBUF_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT IF ( associated ( BUF%CONTENT ) ) DEALLOCATE( BUF%CONTENT ) ALLOCATE( BUF%CONTENT( BUF%LBUF_INT ), stat = IERR ) IF (IERR .NE. 0) THEN NULLIFY( BUF%CONTENT ) IERR = -1 BUF%LBUF = 0 BUF%LBUF_INT = 0 END IF BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_ALLOC SUBROUTINE BUF_DEALL( BUF, IERR ) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER :: IERR INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( .NOT. associated ( BUF%CONTENT ) ) THEN BUF%HEAD = 1 BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END IF DO WHILE ( BUF%HEAD.NE.0 .AND. BUF%HEAD .NE. BUF%TAIL ) CALL MPI_TEST(BUF%CONTENT( BUF%HEAD + REQ ), FLAG, & STATUS, IERR_MPI) IF ( .not. FLAG ) THEN WRITE(*,*) '** Warning: trying to cancel a request.' WRITE(*,*) '** This might be problematic' CALL MPI_CANCEL( BUF%CONTENT( BUF%HEAD + REQ ), IERR_MPI ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), & IERR_MPI ) END IF BUF%HEAD = BUF%CONTENT( BUF%HEAD + NEXT ) END DO DEALLOCATE( BUF%CONTENT ) NULLIFY( BUF%CONTENT ) BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_DEALL SUBROUTINE CMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) COMPLEX A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL CMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_CB SUBROUTINE CMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN COMPLEX CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) COMPLEX SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_COMPLEX, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE CMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, IPOSINRHSCOMP, NPIV COMPLEX W( max( 1, LDW * NRHS_B ) ) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_VCB SUBROUTINE CMUMPS_BUF_SEND_1INT( I, DEST, TAG, COMM, & KEEP, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER IPOS, IREQ, MSG_SIZE, POSITION INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 CALL MPI_PACK_SIZE( 1, MPI_INTEGER, & COMM, MSG_SIZE, IERR_MPI ) CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in CMUMPS_BUF_SEND_1INT', & ' Buf size (bytes)= ',BUF_SMALL%LBUF RETURN ENDIF POSITION=0 CALL MPI_PACK( I, 1, & MPI_INTEGER, BUF_SMALL%CONTENT( IPOS ), & MSG_SIZE, & POSITION, COMM, IERR_MPI ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_1INT SUBROUTINE CMUMPS_BUF_ALL_EMPTY(CHECK_COMM_NODES, & CHECK_COMM_LOAD,FLAG) LOGICAL, INTENT(IN) :: CHECK_COMM_NODES, CHECK_COMM_LOAD LOGICAL, INTENT(OUT) :: FLAG LOGICAL FLAG1, FLAG2, FLAG3 FLAG = .TRUE. IF (CHECK_COMM_NODES) THEN CALL CMUMPS_BUF_EMPTY( BUF_SMALL, FLAG1 ) CALL CMUMPS_BUF_EMPTY( BUF_CB, FLAG2 ) FLAG = FLAG .AND. FLAG1 .AND. FLAG2 ENDIF IF ( CHECK_COMM_LOAD ) THEN CALL CMUMPS_BUF_EMPTY( BUF_LOAD, FLAG3 ) FLAG = FLAG .AND. FLAG3 ENDIF RETURN END SUBROUTINE CMUMPS_BUF_ALL_EMPTY SUBROUTINE CMUMPS_BUF_EMPTY( B, FLAG ) TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL CMUMPS_BUF_SIZE_AVAILABLE(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE CMUMPS_BUF_EMPTY SUBROUTINE CMUMPS_BUF_SIZE_AVAILABLE( B, SIZE_AV ) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER SIZE_AV INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END IF IF ( B%HEAD .LE. B%TAIL ) THEN SIZE_AV = max( B%LBUF_INT - B%TAIL, B%HEAD - 2 ) ELSE SIZE_AV = B%HEAD - B%TAIL - 1 END IF SIZE_AV = min(SIZE_AV - OVHSIZE, SIZE_AV) SIZE_AV = SIZE_AV * SIZEofINT RETURN END SUBROUTINE CMUMPS_BUF_SIZE_AVAILABLE SUBROUTINE CMUMPS_BUF_TEST() INTEGER :: IPOS, IREQ, IERR INTEGER, PARAMETER :: IONE=1 INTEGER :: MSG_SIZE INTEGER :: DEST2(1) DEST2=-10 MSG_SIZE=1 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2,.TRUE.) RETURN END SUBROUTINE CMUMPS_BUF_TEST SUBROUTINE BUF_LOOK( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST, TEST_ONLY) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR LOGICAL, INTENT(IN), OPTIONAL :: TEST_ONLY INTEGER NDEST INTEGER, INTENT(IN) :: PDEST(max(1,NDEST)) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: MSG_SIZE_INT INTEGER :: IBUF LOGICAL :: FLAG INTEGER :: STATUS(MPI_STATUS_SIZE) IERR = 0 IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF MSG_SIZE_INT = ( MSG_SIZE + ( SIZEofINT - 1 ) ) / SIZEofINT MSG_SIZE_INT = MSG_SIZE_INT + OVHSIZE IF (present(TEST_ONLY)) RETURN FLAG = ( ( B%HEAD .LE. B%TAIL ) & .AND. ( & ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL ) & .OR. ( MSG_SIZE_INT .LE. B%HEAD - 2 ) ) ) & .OR. & ( ( B%HEAD .GT. B%TAIL ) & .AND. ( MSG_SIZE_INT .LE. B%HEAD - B%TAIL - 1 ) ) IF ( .NOT. FLAG & ) THEN IERR = -1 IF ( MSG_SIZE_INT .GT. B%LBUF_INT - 1 ) THEN IERR = -2 ENDIF IPOS = -1 IREQ = -1 RETURN END IF IF ( B%HEAD .LE. B%TAIL ) THEN IF ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL + 1 ) THEN IBUF = B%TAIL ELSE IF ( MSG_SIZE_INT .LE. B%HEAD - 1 ) THEN IBUF = 1 END IF ELSE IBUF = B%TAIL END IF B%CONTENT( B%ILASTMSG + NEXT ) = IBUF B%ILASTMSG = IBUF B%TAIL = IBUF + MSG_SIZE_INT B%CONTENT( IBUF + NEXT ) = 0 IPOS = IBUF + CONTENT IREQ = IBUF + REQ RETURN END SUBROUTINE BUF_LOOK SUBROUTINE BUF_ADJUST( BUF, SIZE ) IMPLICIT NONE TYPE ( CMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE INTEGER SIZE_INT SIZE_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT SIZE_INT = SIZE_INT + OVHSIZE BUF%TAIL = BUF%ILASTMSG + SIZE_INT RETURN END SUBROUTINE BUF_ADJUST SUBROUTINE CMUMPS_BUF_SEND_DESC_BANDE( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & ESTIM_NFS4FATHER_ATSON, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER, intent(in) :: INODE INTEGER, intent(in) :: NLIG, NCOL, NASS, NSLAVES INTEGER, intent(in) :: ESTIM_NFS4FATHER_ATSON INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER, INTENT(IN) :: IBC_SOURCE INTEGER LIST_SLAVES( NSLAVES ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: LRSTATUS INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 9 + NLIG + NCOL + NSLAVES + 1 ) SIZE_BYTES = SIZE_INT * SIZEofINT IF (SIZE_INT.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_BYTES, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = SIZE_INT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NBPROCFILS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NLIG POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCOL POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = LRSTATUS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ESTIM_NFS4FATHER_ATSON POSITION = POSITION + 1 IF (NSLAVES.GT.0) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = & LIST_SLAVES( 1: NSLAVES ) POSITION = POSITION + NSLAVES ENDIF BUF_CB%CONTENT( POSITION:POSITION + NLIG - 1 ) = ILIG POSITION = POSITION + NLIG BUF_CB%CONTENT( POSITION:POSITION + NCOL - 1 ) = ICOL POSITION = POSITION + NCOL POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE_BYTES ) THEN WRITE(*,*) 'Error in CMUMPS_BUF_SEND_DESC_BANDE :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE_BYTES, & MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_DESC_BANDE SUBROUTINE CMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) COMPLEX VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL CMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 2 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_MAITRE2 SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, PERM, IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID, NPIV_CHECK ) USE CMUMPS_LR_TYPE USE CMUMPS_LR_DATA_M IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT (in), OPTIONAL :: NPIV_CHECK INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ), PERM( max(1, NBROW )) INTEGER IW_CBSON( * ) COMPLEX A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX REAL, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER NBINT, L INTEGER(8) :: APOS, SHIFTCB_SON, LDA_SON8 INTEGER IPOS_IN_SLAVE INTEGER STATE_SON INTEGER INDICE_PERE, NROW, IPOS, IREQ, NOSLA INTEGER IONE, J, THIS_ROW_LENGTH INTEGER SIZE_DESC_BANDE, DESC_BANDE_BYTES LOGICAL RECV_BUF_SMALLER_THAN_SEND LOGICAL NOT_ENOUGH_SPACE INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & NBROWS_PACKET_2PACK, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' REAL ZERO PARAMETER (ZERO = 0.0E0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+PERM(1)-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = PERM(1) + NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL CMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(7+SLAVEF+KEEP(127)*2) SIZE_DESC_BANDE=SIZE_DESC_BANDE+int(real(KEEP(12))* & real(SIZE_DESC_BANDE)/100.0E0) SIZE_DESC_BANDE=max(SIZE_DESC_BANDE, & 7+NSLAVES_PERE+NFRONT_PERE+NFRONT_PERE-NASS_PERE) ENDIF DESC_BANDE_BYTES=SIZE_DESC_BANDE*SIZEofINT IF ( SIZE_AV .LT. SIZE_RBUF_BYTES-DESC_BANDE_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES-DESC_BANDE_BYTES ENDIF SIZE1=0 IF (NBROWS_ALREADY_SENT==0) THEN IF(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_REAL, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN ONEorTWO = 1 ELSE ONEorTWO = 2 ENDIF IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + PERM(1) - LMAP + NBROWS_ALREADY_SENT - 1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 2 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( 1 + 2 * LROW + 2 * PERM(1) + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) NBROWS_PACKET_2PACK = NBROWS_PACKET IF (CB_IS_LR) THEN NBROWS_PACKET_2PACK = CURRENT_PANEL_SIZE CALL MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_REALS, CB_LRB, & NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND) NOT_ENOUGH_SPACE = (SIZE_AV.LT.SIZE_REALS) IF (.NOT.NOT_ENOUGH_SPACE) THEN NBROWS_PACKET = min(NBROWS_PACKET, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) ENDIF ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET_2PACK * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET_2PACK + ( NBROWS_PACKET_2PACK * & ( NBROWS_PACKET_2PACK + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET_2PACK CALL MPI_PACK_SIZE( SIZE_REALS, MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND .AND. & .NOT. CB_IS_LR) & THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR) THEN CALL CMUMPS_BLR_PACK_CB_LRB(CB_LRB, NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND, & PANEL_BEG_OFFSET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR) IF (KEEP(50).ne.0) THEN DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL CMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/CMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_REAL, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_OUT, & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND) USE CMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND INTEGER, intent(out) :: SIZE_OUT INTEGER :: J TYPE(LRB_TYPE), POINTER :: LRB SIZE_OUT = 0 DO J=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J) IF (LRB%ISLR) THEN SIZE_OUT = SIZE_OUT + LRB%K*(LRB%M+LRB%N) ELSE SIZE_OUT = SIZE_OUT + LRB%M*LRB%N ENDIF ENDDO RETURN END SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB SUBROUTINE CMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET, & BUF, LBUF, POSITION, COMM, IERR) USE CMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET INTEGER, intent(out) :: IERR INTEGER, intent(in) :: COMM, LBUF INTEGER, intent(inout) :: POSITION INTEGER, intent(inout) :: BUF(:) INTEGER :: J, IERR_MPI INCLUDE 'mpif.h' IERR = 0 CALL MPI_PACK( NB_BLR_COLS-NB_COL_SHIFT, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( PANEL_BEG_OFFSET, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) DO J=1,NB_BLR_COLS-NB_COL_SHIFT CALL CMUMPS_MPI_PACK_LRB( & CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J), & BUF, LBUF, POSITION, COMM, IERR ) ENDDO END SUBROUTINE CMUMPS_BLR_PACK_CB_LRB SUBROUTINE CMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, NSLAVES, SLAVES_PERE, & TROW, NCBSON, & COMM, IERR, & DEST, NDEST, SLAVEF, & & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) IMPLICIT NONE INTEGER INODE, NFRONT, NASS1, NCBSON, NSLAVES, & NDEST INTEGER SLAVEF, MYID, ISON INTEGER TROW( NCBSON ) INTEGER DEST( NDEST ) INTEGER SLAVES_PERE( NSLAVES ) INTEGER COMM, IERR INTEGER KEEP(500), N INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_AV, IDEST, NSEND, SIZE, NFS4FATHER INTEGER TROW_SIZE, POSITION, INDX, INIV2 INTEGER IPOS, IREQ INTEGER IONE PARAMETER ( IONE=1 ) INTEGER NASS_SON NASS_SON = -99998 IERR = 0 IF ( NDEST .eq. 1 ) THEN IF ( DEST(1).EQ.MYID ) GOTO 500 SIZE = SIZEofINT * ( 7 + NSLAVES + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+NCBSON-1 ) = & TROW( 1: NCBSON ) POSITION = POSITION + NCBSON POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) 'Error in CMUMPS_BUF_SEND_MAPLIG :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( NDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) ELSE NSEND = 0 DO IDEST = 1, NDEST IF ( DEST( IDEST ) .ne. MYID ) NSEND = NSEND + 1 END DO SIZE = SIZEofINT * & ( ( OVHSIZE + 7 + NSLAVES )* NSEND + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL CMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IDEST, NCBSON, & NDEST, & TROW_SIZE, INDX ) SIZE = SIZEofINT * ( NSLAVES + TROW_SIZE + 7 ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error CMUMPS_BUF_SEND_MAPLIG', & 'IERR after BUF_LOOK=',IERR CALL MUMPS_ABORT() END IF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+TROW_SIZE-1 ) = & TROW( INDX: INDX + TROW_SIZE - 1 ) POSITION = POSITION + TROW_SIZE POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:', & 'Wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( IDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) END IF END DO END IF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_BUF_SEND_MAPLIG SUBROUTINE CMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, & WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & & IERR ) USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) COMPLEX, intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTBL LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE3, SIZET, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS INTEGER :: NBMSGS INTEGER, ALLOCATABLE, DIMENSION(:) :: RELAY_INFO INTEGER :: LRELAY_INFO, DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT IERR = 0 LRELAY_INFO = 0 NBMSGS = NDEST IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE( 4, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE( 1, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_COMPLEX, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LorU, SIZE3, COMM, IERR ) SIZE2 = SIZE2+SIZE3 ENDIF ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF END IF SSS = SSS + SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF ENDIF IF (LRELAY_INFO.GT.0) THEN CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , RELAY_INFO(2)) ELSE CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , PDEST) ENDIF IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NBMSGS - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NBMSGS - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NBMSGS - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NBMSGS POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTBL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF ( (NPIV.GT.0) & ) THEN IF (NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO CALL CMUMPS_MPI_PACK_LR( BLR_LorU, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1), & SIZET, POSITION, COMM, IERR) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) DO IDEST = 1, NBMSGS IF (LRELAY_INFO .GT. 0) THEN DEST_BLOCFACTO = RELAY_INFO(IDEST+1) ELSE DEST_BLOCFACTO = PDEST(IDEST) ENDIF IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO SIZET = SIZET - ( NBMSGS - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE CMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR ) USE CMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE COMPLEX UIP21K( NPIV, * ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL COMPLEX, intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZET, & IDEST, IPOSMSG, SSS, SSLR IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_COMPLEX, & COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR ELSE CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LS, SSLR, COMM, IERR ) SIZE2=SIZE2+SSLR ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SSS = SSS+SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL MUMPS_MPI_PACK_SCALE_LR( BLR_LS, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1 ), & SIZET, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR ) ELSE CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO SIZET = SIZET - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL CMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_COMPLEX, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_COMPLEX, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW(INDCOL_SON( I )) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW( INDROW_SON( I ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = RG2L_COL( INDCOL_SON( J ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IPOS_ROOT = RG2L_ROW( INDCOL_SON( J ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = RG2L_COL( INDROW_SON( I ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_COMPLEX, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_COMPLEX, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) RETURN END SUBROUTINE MUMPS_MPI_PACK_SCALE_LR END MODULE CMUMPS_BUF MUMPS_5.4.1/src/sfac_process_rtnelind.F0000664000175000017500000001116614102210521020166 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_RTNELIND( ROOT, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE SMUMPS_LOAD USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: ROOT INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : SMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE SMUMPS_PROCESS_RTNELIND MUMPS_5.4.1/src/dooc_panel_piv.F0000664000175000017500000002771414102210525016610 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C This file contains routines related to OOC, C panels, and pivoting. They are used to store C permutation information of what is already on C disk to be able to permute things back at the C solve stage. C They do not need to be in the MUMPS_OOC C module (most of them do not use any variable C from the module, or are called from routines C where we do not necessarily want to do a C USE DMUMPS_OOC). INTEGER FUNCTION DMUMPS_OOC_GET_PANEL_SIZE & ( HBUF_SIZE, NNMAX, K227, K50 ) IMPLICIT NONE C C Arguments: C ========= C INTEGER, INTENT(IN) :: NNMAX, K227, K50 INTEGER(8), INTENT(IN) :: HBUF_SIZE C C Purpose: C ======= C C - Compute the effective size (maximum number of pivots in a panel) C for a front with NNMAX entries in its row (for U) / C column (for L). C - Be able to adapt the fixed number of columns in panel C depending on NNMAX, and size of IO buffer HBUF_SIZE C C Local variables C =============== C INTEGER K227_LOC INTEGER NBCOL_MAX INTEGER EFFECTIVE_SIZE NBCOL_MAX=int(HBUF_SIZE / int(NNMAX,8)) C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC = abs(K227) IF (K50.EQ.2) THEN C for 2x2 pivots we may end-up having the first part C of a 2x2 pivot in the last col of the panel; the C adopted solution consists in adding the next column C to the panel; therefore we need be able to C dynamically increase the panel size by one. C note that we also maintain property: C KEEP(227): Maximum size (nb of col/row) of a panel K227_LOC=max(K227_LOC,2) EFFECTIVE_SIZE = min(NBCOL_MAX-1, K227_LOC-1) cN - during bwd the effective size is useless ELSE C complete buffer space can be used for a panel EFFECTIVE_SIZE = min(NBCOL_MAX, K227_LOC) ENDIF IF (EFFECTIVE_SIZE.LE.0) THEN write(6,*) 'Internal buffers too small to store ', & ' ONE col/row of size', NNMAX CALL MUMPS_ABORT() ENDIF DMUMPS_OOC_GET_PANEL_SIZE = EFFECTIVE_SIZE RETURN END FUNCTION DMUMPS_OOC_GET_PANEL_SIZE C SUBROUTINE DMUMPS_PERMUTE_PANEL( IPIV, LPIV, ISHIFT, & THE_PANEL, NBROW, NBCOL, KbeforePanel ) IMPLICIT NONE C C Purpose: C ======= C C Permute rows of a panel, stored by columns, according C to permutation array IPIV. C IPIV is such that, for I = 1 to LPIV, row ISHIFT + I C in the front must be permuted with row IPIV( I ) C C Since the panel is not necessary at the beginning of C the front, let KbeforePanel be the number of pivots in the C front before the first pivot of the panel. C C In the panel, row ISHIFT+I-KbeforePanel is permuted with C row IPIV(I)-KbeforePanel C C Note: C ==== C C This routine can also be used to permute the columns of C a matrix (U) stored by rows. In that case, the argument C NBROW represents the number of columns, and NBCOL represents C the number of rows. C C C Arguments: C ========= C INTEGER LPIV, ISHIFT, NBROW, NBCOL, KbeforePanel INTEGER IPIV(LPIV) DOUBLE PRECISION THE_PANEL(NBROW, NBCOL) C C Local variables: C =============== C INTEGER I, IPERM C C Executable statements C ===================== C DO I = 1, LPIV C Swap rows ISHIFT + I and PIV(I) IPERM=IPIV(I) IF ( I+ISHIFT.NE.IPERM) THEN CALL dswap(NBCOL, & THE_PANEL(I+ISHIFT-KbeforePanel,1), NBROW, & THE_PANEL(IPERM-KbeforePanel,1), NBROW) ENDIF END DO RETURN END SUBROUTINE DMUMPS_PERMUTE_PANEL SUBROUTINE DMUMPS_GET_OOC_PERM_PTR(TYPEF, & NBPANELS, & I_PIVPTR, I_PIV, IPOS, IW, LIW) USE MUMPS_OOC_COMMON ! To access TYPEF_L and TYPEF_U IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C C Get the pointers in IW on pivoting information to be stored C during factorization and used during the solve phase. This C routine is both for the symmetric (TYPEF=TYPEF_L) and unsymmetric C cases (TYPEF=TYPEF_L or TYPEF_U). C The total size of this space is estimated during C fac_ass.F / fac_ass_ELT.F and must be: C * Symmetric case: 1 for NASS + 1 for NBPANELS_L + NBPANELS_L + NASS C * Unsymmetric case: 1 + (1+NBPANELS_L+NASS) + (1+NBPANELS_U+NASS) C Size computation is in routine DMUMPS_OOC_GET_PP_SIZES. C C At the end of the standard description of the structure of a node C (header, nb slaves, , row indices, col indices), we C add, when panel version with pivoting is used: C C NASS (nb of fully summed variables) C NBPANELS_L C PIVRPTR(1:NBPANELS_L) C PIV_L (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C NBPANELS_U C PIVRPTR(1:NBPANELS_U) C PIV_U (1:NASS) NASS (=IW(IPOS)(or NASS-PIVRPTR(1) in C the future, after compression) C C C Output parameters: C ================= C NBPANELS : nb of panels as estimated during assembly C I_PIVPTR : position in IW of the starting of the pointer list C (of size NBPANELS) of the pointers to the list of pivots C I_PIV : position in IW of the starting of the pivot permutation list C INTEGER, intent(out) :: NBPANELS, I_PIVPTR, I_PIV INTEGER, intent(in) :: TYPEF ! TYPEF_L or TYPEF_U INTEGER, intent(in) :: LIW, IPOS INTEGER IW(LIW) C Locals INTEGER I_NBPANELS, I_NASS C I_NASS = IPOS I_NBPANELS = I_NASS + 1 ! L NBPANELS = IW(I_NBPANELS) ! L I_PIVPTR = I_NBPANELS + 1 ! L I_PIV = I_PIVPTR + NBPANELS ! L C ... of size NASS = IW(I_NASS) IF (TYPEF==TYPEF_U) THEN I_NBPANELS = I_PIV+IW(I_NASS) ! U NBPANELS = IW(I_NBPANELS) ! U I_PIVPTR = I_NBPANELS + 1 ! U I_PIV = I_PIVPTR + NBPANELS ! U ENDIF RETURN END SUBROUTINE DMUMPS_GET_OOC_PERM_PTR SUBROUTINE DMUMPS_OOC_PP_SET_PTR(K50,NBPANELS_L,NBPANELS_U, & NASS, IPOS, IW, LIW ) IMPLICIT NONE C C Purpose: C ======= C C Initialize the contents of PIV/PIVPTR/etc. that will store C pivoting information during the factorization. C NASS and NBPANELS are recorded. PIVPTR(1:NBPANELS) C is initialized to NASS+1. This will be modified during C the factorization in cases where permutations have to C be performed during the solve phase. C C Arguments: C ========= C INTEGER K50 INTEGER IPOS, NASS, NBPANELS_L, NBPANELS_U, LIW INTEGER IW(LIW) C C Local variables: C =============== C INTEGER IPOS_U C Executable statements IF (K50.EQ.1) THEN WRITE(*,*) "Internal error: DMUMPS_OOC_PP_SET_PTR called" ENDIF IW(IPOS)=NASS IW(IPOS+1)=NBPANELS_L IW(IPOS+2:IPOS+1+NBPANELS_L)=NASS+1 IF (K50 == 0) THEN IPOS_U=IPOS+2+NASS+NBPANELS_L IW(IPOS_U)=NBPANELS_U IW(IPOS_U+1:IPOS_U+NBPANELS_U)=NASS+1 ENDIF RETURN END SUBROUTINE DMUMPS_OOC_PP_SET_PTR SUBROUTINE DMUMPS_OOC_PP_TRYRELEASE_SPACE ( & IWPOS, IOLDPS, IW, LIW, MonBloc, NFRONT, KEEP & ) USE DMUMPS_OOC IMPLICIT NONE INCLUDE 'mumps_headers.h' C C Purpose: C ======= C If space used was at the top of the stack then C try to free space by detecting that C no permutation needs to be applied during C solve on panels. C One position is left (I_NASS) and set to -1 C to indicate that permutation not needed at solve. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IOLDPS, LIW, NFRONT, & KEEP(500) INTEGER, INTENT(INOUT) :: IWPOS, IW(LIW) TYPE(IO_BLOCK), INTENT(IN):: MonBloc C C Local variables: C =============== C INTEGER :: NBPANELS_L,I_PIVRPTR_L, I_PIVR_L, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, XSIZE, IBEGOOC LOGICAL FREESPACE ! set to true when permutation not needed C Executable statements IF (KEEP(50).EQ.1) RETURN ! no pivoting C -------------------------------- C quick return if record is not at C the top of stack of L factors IF ((IOLDPS+IW(IOLDPS+XXI)).NE.IWPOS) RETURN C --------------------------------------------- C Panel+pivoting: get pointers on each subarray C --------------------------------------------- XSIZE = KEEP(IXSZ) IBEGOOC = IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE C -- get L related data CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IBEGOOC, IW, LIW) FREESPACE = & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_L)-1)) IF (KEEP(50).EQ.0) THEN C -- get U related dataA CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IBEGOOC, IW, LIW) FREESPACE = FREESPACE .AND. & (MonBloc%LastPiv.EQ.(IW(I_PIVRPTR_U)-1)) ENDIF C --------------------------------- C Check if permutations eed be C performed on panels during solve C -------------------------------- IF (FREESPACE) THEN C -- compress memory for that node: keep one entry set to -7777 IW(IBEGOOC) = -7777 ! will be tested during solve IW(IOLDPS+XXI) = IBEGOOC & - IOLDPS + 1 ! new size of inode's record IWPOS = IBEGOOC+1 ! move back to top of stack ENDIF RETURN END SUBROUTINE DMUMPS_OOC_PP_TRYRELEASE_SPACE C SUBROUTINE DMUMPS_OOC_GET_PP_SIZES(K50, NBROW_L, NBCOL_U, NASS, & NBPANELS_L, NBPANELS_U, LREQ) USE DMUMPS_OOC ! To call DMUMPS_OOC_PANEL_SIZE IMPLICIT NONE C C Purpose C ======= C C Compute the size of the workspace required to store the permutation C information during factorization, so that solve can permute back C what has to be permuted (this could not be done during factorization C because it was already on disk). C C Arguments C ========= C INTEGER, intent(IN) :: K50, NBROW_L, NBCOL_U, NASS INTEGER, intent(OUT) :: NBPANELS_L, NBPANELS_U, LREQ NBPANELS_L=-99999 NBPANELS_U=-99999 C C Quick return in SPD case (no pivoting) C IF (K50.EQ.1) THEN LREQ = 0 RETURN ENDIF C C L information is always computed C NBPANELS_L = (NASS / DMUMPS_OOC_PANEL_SIZE(NBROW_L))+1 LREQ = 1 ! Store NASS & + 1 ! Store NBPANELS_L & + NASS ! Store permutations & + NBPANELS_L ! Store pointers on permutations IF (K50.eq.0) THEN C C Also take U information into account C NBPANELS_U = (NASS / DMUMPS_OOC_PANEL_SIZE(NBCOL_U) ) +1 LREQ = LREQ + 1 ! Store NBPANELS_U & + NASS ! Store permutations & + NBPANELS_U ! Store pointers on permutations ENDIF RETURN END SUBROUTINE DMUMPS_OOC_GET_PP_SIZES SUBROUTINE DMUMPS_OOC_PP_CHECK_PERM_FREED & (IW_LOCATION, MUST_BE_PERMUTED) IMPLICIT NONE INTEGER, INTENT(IN) :: IW_LOCATION LOGICAL, INTENT(INOUT) :: MUST_BE_PERMUTED C C Purpose C ======= C C Reset MUST_BE_PERMUTED to .FALSE. when we detect C that the DMUMPS_OOC_PP_TRY_RELEASE_SPACE has freed C the permutation information (see that routine). C IF (IW_LOCATION .EQ. -7777) THEN MUST_BE_PERMUTED = .FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_OOC_PP_CHECK_PERM_FREED MUMPS_5.4.1/src/mumps_common.h0000664000175000017500000000570714102210474016403 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_COMMON_H #define MUMPS_COMMON_H #include "mumps_compat.h" #include "mumps_c_types.h" /** * F_SYMBOL is a macro that converts a couple (lower case symbol, upper * case symbol) into the symbol defined by the compiler convention. * Example: For MUMPS_XXX, first define * #define MUMPS_XXX F_SYMBOL(xxx,XXX) and then use * MUMPS_XXX in the code to get rid of any symbol convention annoyance. * * NB: We need to provide both upper and lower case versions because to our * knowledge, there is no way to perform the conversion with CPP * directives only. */ #if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYMBOL(lower_case,upper_case) MUMPS_##upper_case #elif defined(Add_) # define F_SYMBOL(lower_case,upper_case) mumps_##lower_case##_ #elif defined(Add__) # define F_SYMBOL(lower_case,upper_case) mumps_##lower_case##__ #else # define F_SYMBOL(lower_case,upper_case) mumps_##lower_case #endif MUMPS_INT* mumps_get_mapping(); #define MUMPS_ASSIGN_MAPPING \ F_SYMBOL(assign_mapping,ASSIGN_MAPPING) void MUMPS_CALL MUMPS_ASSIGN_MAPPING(MUMPS_INT *f77mapping); #define MUMPS_NULLIFY_C_MAPPING F_SYMBOL(nullify_c_mapping,NULLIFY_C_MAPPING) void MUMPS_CALL MUMPS_NULLIFY_C_MAPPING(); MUMPS_INT* mumps_get_pivnul_list(); #define MUMPS_ASSIGN_PIVNUL_LIST \ F_SYMBOL(assign_pivnul_list,ASSIGN_PIVNUL_LIST) void MUMPS_CALL MUMPS_ASSIGN_PIVNUL_LIST(MUMPS_INT *f77pivnul_list); #define MUMPS_NULLIFY_C_PIVNUL_LIST \ F_SYMBOL(nullify_c_pivnul_list,NULLIFY_C_PIVNUL_LIST) void MUMPS_CALL MUMPS_NULLIFY_C_PIVNUL_LIST(); MUMPS_INT* mumps_get_uns_perm(); #define MUMPS_ASSIGN_UNS_PERM \ F_SYMBOL(assign_uns_perm,ASSIGN_UNS_PERM) void MUMPS_CALL MUMPS_ASSIGN_UNS_PERM(MUMPS_INT *f77sym_perm); #define MUMPS_NULLIFY_C_UNS_PERM \ F_SYMBOL(nullify_c_uns_perm,NULLIFY_C_UNS_PERM) void MUMPS_CALL MUMPS_NULLIFY_C_UNS_PERM(); MUMPS_INT* mumps_get_sym_perm(); #define MUMPS_ASSIGN_SYM_PERM \ F_SYMBOL(assign_sym_perm,ASSIGN_SYM_PERM) void MUMPS_CALL MUMPS_ASSIGN_SYM_PERM(MUMPS_INT * f77sym_perm); #define MUMPS_NULLIFY_C_SYM_PERM \ F_SYMBOL(nullify_c_sym_perm,NULLIFY_C_SYM_PERM) void MUMPS_CALL MUMPS_NULLIFY_C_SYM_PERM(); #define MUMPS_ICOPY_32TO64_64C_IP_C \ F_SYMBOL(icopy_32to64_64c_ip_c,ICOPY_32TO64_64C_IP_C) void MUMPS_CALL MUMPS_ICOPY_32TO64_64C_IP_C(MUMPS_INT *inouttab, MUMPS_INT8 *sizetab); #define MUMPS_ICOPY_64TO32_64C_IP_C \ F_SYMBOL(icopy_64to32_64c_ip_c,ICOPY_64TO32_64C_IP_C) void MUMPS_CALL MUMPS_ICOPY_64to32_64C_IP_C(MUMPS_INT8 *inouttab, MUMPS_INT8 *sizetab); #endif /* MUMPS_COMMON_H */ MUMPS_5.4.1/src/csol_matvec.F0000664000175000017500000002377514102210526016132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) COMPLEX A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 COMPLEX TEMP COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE CMUMPS_MV_ELT SUBROUTINE CMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE CMUMPS_LOC_MV8 SUBROUTINE CMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) COMPLEX ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 COMPLEX, DIMENSION(:), ALLOCATABLE :: PX COMPLEX ZERO INTEGER :: allocok PARAMETER( ZERO = (0.0E0,0.0E0) ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE CMUMPS_MV8 C C SUBROUTINE CMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX A_loc( NZ_loc8 ), X( N ) REAL Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: RZERO=0.0E0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE CMUMPS_LOC_OMEGA1 MUMPS_5.4.1/src/zana_mtrans.F0000664000175000017500000007707214102210526016147 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE ZMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) DOUBLE PRECISION CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0D0 CNTL(2) = 0.0D0 DO 20 I = 3,NCNTL CNTL(I) = 0.0D0 20 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSI SUBROUTINE ZMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) DOUBLE PRECISION :: A(NE) DOUBLE PRECISION :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 DOUBLE PRECISION CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX DOUBLE PRECISION ZERO,MINONE,ONE PARAMETER (ZERO=0.0D0,MINONE=-1.0D0,ONE=1.0D0) INTRINSIC abs,min EXTERNAL ZMUMPS_MTRANSD, ZMUMPS_MTRANSE, & ZMUMPS_MTRANSF, ZMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL ZMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL ZMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL ZMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL ZMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSB SUBROUTINE ZMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE ZMUMPS_MTRANSD SUBROUTINE ZMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE ZMUMPS_MTRANSE SUBROUTINE ZMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE ZMUMPS_MTRANSF SUBROUTINE ZMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) DOUBLE PRECISION :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) DOUBLE PRECISION SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE ZMUMPS_MTRANSQ SUBROUTINE ZMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) DOUBLE PRECISION, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S DOUBLE PRECISION :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSR SUBROUTINE ZMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) DOUBLE PRECISION A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 DOUBLE PRECISION :: BVAL,BMIN,BMAX EXTERNAL ZMUMPS_MTRANSQ,ZMUMPS_MTRANSU,ZMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL ZMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0D0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001D0 * BMAX ENDIF BVAL = 0.0D0 BMIN = 0.0D0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL ZMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL ZMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL ZMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSS C SUBROUTINE ZMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSU C SUBROUTINE ZMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP DOUBLE PRECISION :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD DOUBLE PRECISION :: ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) EXTERNAL ZMUMPS_MTRANSD, ZMUMPS_MTRANSE, & ZMUMPS_MTRANSF, ZMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL ZMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL ZMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL ZMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL ZMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSW SUBROUTINE ZMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 EXTERNAL ZMUMPS_MTRANSX DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 1000 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL ZMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE ZMUMPS_MTRANSZ SUBROUTINE ZMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K DO 10 J = 1,N CW(J) = 0 10 CONTINUE K = 0 DO 20 I = 1,M IF (IPERM(I).EQ.0) THEN K = K + 1 RW(K) = I ELSE J = IPERM(I) CW(J) = I ENDIF 20 CONTINUE K = 0 DO 30 J = 1,N IF (CW(J).NE.0) GO TO 30 K = K + 1 I = RW(K) IPERM(I) = -J 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = -J 40 CONTINUE RETURN END SUBROUTINE ZMUMPS_MTRANSX MUMPS_5.4.1/src/zfac_root_parallel.F0000664000175000017500000001711014102210525017456 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE ZMUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( ZMUMPS_ROOT_STRUC ) :: root INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK COMPLEX(kind=8) WK( LWK ) INTEGER KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR COMPLEX(kind=8) A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX(kind=8), INTENT(INOUT) :: DET_MANT INTEGER IOLDPS INTEGER(8) :: IAPOS DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER LOCAL_M, LOCAL_N, LPIV, IERR, allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE INCLUDE 'mumps_headers.h' EXTERNAL numroc INTEGER numroc IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL ZMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL ZMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL pzgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pzpotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL ZMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in ZMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL ZMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & root%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF RETURN END SUBROUTINE ZMUMPS_FACTO_ROOT MUMPS_5.4.1/src/dfac_process_contrib_type1.F0000664000175000017500000001172714102210522021116 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL DMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_DOUBLE_PRECISION, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_NODE MUMPS_5.4.1/src/dfac_asm.F0000664000175000017500000010107414102210522015351 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON ) USE DMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON, IWPOSCB INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), STEP(N), PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)), ROWLIST(NBROWS) DOUBLE PRECISION A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW LOGICAL, INTENT(IN) :: IS_ofType5or6 INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER HF,HS, NSLAVES, NFRONT, NASS1, & IOLDPS, ISTCHK, LSTK, NSLSON,NELIM, & NPIVS,NCOLS,J1,JJ,JJ1,NROWS, & LDAFS_PERE, IBEG, DIAG INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (KEEP(50).EQ.0) THEN LDAFS_PERE = NFRONT ELSE IF ( NSLAVES .eq. 0 ) THEN LDAFS_PERE = NFRONT ELSE LDAFS_PERE = NASS1 ENDIF ENDIF HF = 6 + NSLAVES + KEEP(IXSZ) POSEL1 = POSELT - int(LDAFS_PERE,8) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) OPASSW = OPASSW + dble(NBROWS*NBCOLS) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DO JJ = 1, NBROWS DO JJ1 = 1, NBCOLS JJ2 = APOS + int(JJ1-1,8) A(JJ2)=A(JJ2)+VALSON(JJ1,JJ) ENDDO APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO 170 JJ = 1, NBROWS APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO 160 JJ1 = 1, NBCOLS JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 160 CONTINUE 170 CONTINUE ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DIAG = ROWLIST(1) DO JJ = 1, NBROWS DO JJ1 = 1, DIAG JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO DIAG = DIAG+1 APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO JJ = 1, NBROWS IF (ROWLIST(JJ).LE.NASS1.and..NOT.IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(JJ) - 1,8) DO JJ1 = 1, NELIM JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO IBEG = NELIM+1 ELSE IBEG = 1 ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, NBCOLS IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_MASTER SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) DOUBLE PRECISION :: A(LA) INTEGER :: INTARR(KEEP8(27)) DOUBLE PRECISION :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) DOUBLE PRECISION A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG DOUBLE PRECISION, POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8)) + & VALSON(1:NBCOLS-IDIAG,I) APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE DMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB DOUBLE PRECISION A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO IPOSCB = IPOSCB + 1_8 ENDDO ENDIF ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE DMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB DOUBLE PRECISION A( LA ) DOUBLE PRECISION SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 DO I = 1, NELIM POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) IF (.NOT. CB_IS_COMPRESSED) THEN IPOSCB = 1_8 + int( I - 1, 8 ) * int(NCOLS,8) ENDIF DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_LDLT_ASM_NIV12 SUBROUTINE DMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_RESTORE_INDICES SUBROUTINE DMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) USE DMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON,IWPOSCB INTEGER NBCOLS INTEGER IW(LIW), STEP(N), & PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)) DOUBLE PRECISION A(LA) DOUBLE PRECISION VALSON(NBCOLS) DOUBLE PRECISION OPASSW INTEGER HF,HS, NSLAVES, NASS1, & IOLDPS, ISTCHK, & LSTK, NSLSON,NELIM,NPIVS,NCOLS, J1, & JJ1,NROWS INTEGER(8) POSELT, APOS, JJ2 INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(dble(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = VALSON(JJ1) ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ASM_MAX SUBROUTINE DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: RHS_MUMPS(KEEP(255)) DOUBLE PRECISION, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(N), PTRARW(N) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: J18, J28, JJ8, JK8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE DO WHILE (IN.GT.0) AINPUT8 = PTRARW(IN) JK8 = PTRAIW(IN) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE DMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: DMUMPS_IS_TRSM_LARGE_ENOUGH, & DMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF NCB = NFRONT-NASS1 IF (PARPIV_T1.EQ.-2) THEN IF ( & ( DMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( DMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF RETURN END SUBROUTINE DMUMPS_SET_PARPIVT1 LOGICAL FUNCTION DMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) DMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION DMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION DMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) DMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION DMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE DMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253 ) & IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 DOUBLE PRECISION, intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB DOUBLE PRECISION :: ZERO DOUBLE PRECISION :: RMAX PARAMETER( ZERO = 0.0D0 ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = dble(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = RMAX ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = dble(A(APOSMAX+int(I,8)-1_8)) DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = RMAX APOS = APOS+NFRONT_8 ENDDO ENDIF CALL DMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1) RETURN END SUBROUTINE DMUMPS_PARPIVT1_SET_MAX SUBROUTINE DMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) DOUBLE PRECISION, intent(inout):: PARPIV(LPARPIV) INTEGER :: I DOUBLE PRECISION :: EPS, RMIN, RZERO, RTMP LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0D0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) DO I = 1, LPARPIV RTMP = dble(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN EPS = sqrt(epsilon(RZERO)) RMIN = min(RMIN, EPS) DO I = 1, LPARPIV RTMP = dble(PARPIV(I)) IF (dble(PARPIV(I)).EQ.RZERO) THEN PARPIV(I) = -RMIN ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE DMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) USE DMUMPS_FAC_FRONT_AUX_M, & ONLY: DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1 INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL DMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253 ) ENDIF RETURN END SUBROUTINE DMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX MUMPS_5.4.1/src/zmumps_sol_es.F0000664000175000017500000007012614102210525016521 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SOL_ES PRIVATE PUBLIC:: PRUNED_SIZE_LOADED PUBLIC:: ZMUMPS_CHAIN_PRUN_NODES PUBLIC:: ZMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: ZMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: ZMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: ZMUMPS_TREE_PRUN_NODES PUBLIC:: ZMUMPS_TREE_PRUN_NODES_STATS PUBLIC:: ZMUMPS_SOL_ES_INIT INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK INTEGER(8) :: PRUNED_SIZE_LOADED INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE ZMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF RETURN END SUBROUTINE ZMUMPS_SOL_ES_INIT SUBROUTINE ZMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(KEEP28), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE ZMUMPS_TREE_PRUN_NODES SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(nb_nodes_RHS) INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER :: Pruned_SONS(KEEP28) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES SUBROUTINE ZMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE ZMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in ZMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) RETURN END SUBROUTINE ZMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION ZMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN ZMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN ZMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE ZMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV+1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE ZMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION ZMUMPS_LOCAL_FACTOR_SIZE INTEGER(8) FUNCTION ZMUMPS_LOCAL_FACTOR_SIZE_BLR(IW,LIW,PTR, & LRSTATUS, IWHANDLER, & PHASE, LDLT, IS_ROOT) USE ZMUMPS_LR_DATA_M USE ZMUMPS_LR_TYPE INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: LRSTATUS, IWHANDLER INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW, FACTOR_SIZE INTEGER :: NB_PANELS, IPANEL, LorU, IBLOCK LOGICAL :: LR_ACTIVATED TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: LRB_PANEL NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB LR_ACTIVATED=(LRSTATUS.GE.2) IF (LR_ACTIVATED) THEN FACTOR_SIZE = 0_8 CALL ZMUMPS_BLR_RETRIEVE_NB_PANELS(IWHANDLER, NB_PANELS) IF (LDLT.EQ.0) THEN LorU = PHASE ELSE LorU = 0 ENDIF DO IPANEL=1,NB_PANELS IF (IS_ROOT.AND.IPANEL.EQ.NB_PANELS) THEN CYCLE ENDIF IF (ZMUMPS_BLR_EMPTY_PANEL_LORU(IWHANDLER, LorU, IPANEL)) & THEN CYCLE ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU(IWHANDLER, LorU, & IPANEL, LRB_PANEL) IF (size(LRB_PANEL).GT.0) THEN IF (PHASE.EQ.0) THEN FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)-1_8)/2_8 ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)+1_8)/2_8 ENDIF ENDIF DO IBLOCK=1,size(LRB_PANEL) IF (LRB_PANEL(IBLOCK)%ISLR) THEN FACTOR_SIZE = FACTOR_SIZE + int(LRB_PANEL(IBLOCK)%K,8)* & int(LRB_PANEL(IBLOCK)%M+LRB_PANEL(IBLOCK)%M,8) ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(IBLOCK)%M*LRB_PANEL(IBLOCK)%N,8) ENDIF ENDDO ENDDO ZMUMPS_LOCAL_FACTOR_SIZE_BLR = FACTOR_SIZE ELSE ZMUMPS_LOCAL_FACTOR_SIZE_BLR = & ZMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, PTR, PHASE, LDLT, IS_ROOT) ENDIF RETURN END FUNCTION ZMUMPS_LOCAL_FACTOR_SIZE_BLR SUBROUTINE ZMUMPS_TREE_PRUN_NODES_STATS(MYID, N, KEEP28, KEEP201, & FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC) INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, MYID, N INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INTEGER I, ISTEP INTEGER(8) :: Pruned_Size IF (KEEP201 .GT. 0) THEN Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDDO PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF RETURN END SUBROUTINE ZMUMPS_TREE_PRUN_NODES_STATS SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) IF (KEEP201 .GT. 0) THEN Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDIF ENDDO IF (KEEP201.GT.0) THEN IF (FR_FACT .NE. 0_8) THEN PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_CHAIN_PRUN_NODES_STATS END MODULE ZMUMPS_SOL_ES SUBROUTINE ZMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " ZMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN ZMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " ZMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " ZMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE ZMUMPS_PERMUTE_RHS_GS SUBROUTINE ZMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE ZMUMPS_PERMUTE_RHS_AM1 SUBROUTINE ZMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE, & PERM_PO LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & LOAD_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in ZMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in ZMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) LOAD_PROCS = 0 USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO IF(reorder) THEN posintmprhs = 0 ALLOCATE(PERM_PO(N),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO J=1,N PERM_PO(SYM_PERM(J))=J END DO nblocks = N/NBRHS DO I = 1, nblocks USED = .FALSE. DO J=1, NBRHS USED(TMP_RHS(NBRHS*(I-1)+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END DO IF(mod(N,NBRHS).NE.0) THEN USED = .FALSE. DO J=1, mod(N,NBRHS) USED(TMP_RHS(NBRHS*nblocks+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END IF DEALLOCATE(PERM_PO) ELSE PERM_RHS = TMP_RHS END IF DEALLOCATE(TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & USED, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE) RETURN END SUBROUTINE ZMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.4.1/src/dmumps_lr_data_m.F0000664000175000017500000036634314102210523017140 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_LR_DATA_M USE DMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: DMUMPS_BLR_END_FRONT, DMUMPS_BLR_INIT_MODULE, & DMUMPS_BLR_END_MODULE, DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_INIT, & DMUMPS_BLR_SAVE_PANEL_LORU, DMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & DMUMPS_BLR_SAVE_BEGS_BLR_C, DMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & DMUMPS_BLR_DEC_AND_RETRIEVE_L, DMUMPS_BLR_RETRIEVE_PANEL_LORU, & DMUMPS_BLR_DEC_AND_TRYFREE_L, DMUMPS_BLR_TRY_FREE_PANEL, & DMUMPS_BLR_FREE_CB_LRB, DMUMPS_BLR_FREE_ALL_PANELS, & DMUMPS_BLR_SAVE_CB_LRB, & DMUMPS_BLR_RETRIEVE_CB_LRB, DMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & DMUMPS_BLR_SAVE_BEGS_BLR_DYN, DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & DMUMPS_BLR_RETRIEVE_NB_PANELS, DMUMPS_BLR_EMPTY_PANEL_LORU, & DMUMPS_BLR_SAVE_NFS4FATHER, DMUMPS_BLR_RETRIEVE_NFS4FATHER, & DMUMPS_BLR_SAVE_M_ARRAY, DMUMPS_BLR_RETRIEVE_M_ARRAY, & DMUMPS_BLR_FREE_M_ARRAY & , DMUMPS_BLR_STRUC_TO_MOD, DMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if ! defined(MUMPS_F2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , DMUMPS_BLR_SAVE_DIAG_BLOCK, DMUMPS_BLR_RETRIEVE_DIAG_BLOCK & , DMUMPS_SAVE_RESTORE_BLR TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type DOUBLE PRECISION, POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) CONTAINS SUBROUTINE DMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_INIT_MODULE SUBROUTINE DMUMPS_BLR_END_MODULE(INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP LOGICAL :: IS_FIXME_ALREADY_PRINTED IS_FIXME_ALREADY_PRINTED = .FALSE. IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL DMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) ELSE CALL DMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_END_MODULE SUBROUTINE DMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_MOD_TO_STRUC SUBROUTINE DMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE DMUMPS_BLR_STRUC_TO_MOD SUBROUTINE DMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE DMUMPS_BLR_INIT_FRONT SUBROUTINE DMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in DMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in DMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE DMUMPS_BLR_SAVE_INIT SUBROUTINE DMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & "NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN IF (NEEDS_THREAD_SAFETY) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ELSE KEEP8(71) = KEEP8(71) - MEM_FREED KEEP8(73) = KEEP8(73) - MEM_FREED KEEP8(69) = KEEP8(69) - MEM_FREED ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), KEEP8) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE DMUMPS_BLR_END_FRONT SUBROUTINE DMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE DMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE DMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE DMUMPS_BLR_SAVE_CB_LRB SUBROUTINE DMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D ) DOUBLE PRECISION,POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE DMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE DMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE DMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE DMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in DMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 RETURN END SUBROUTINE DMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION DMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF DMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in DMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF DMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION DMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE DMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in DMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE DMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) DOUBLE PRECISION, POINTER, INTENT(OUT) :: THEBLOCK(:) #else DOUBLE PRECISION, POINTER :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in DMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in DMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE DMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in DMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE DMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE DMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE DMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in DMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE DMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE DMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE DMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #else DOUBLE PRECISION, DIMENSION(:), POINTER :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE DMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE DMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE DMUMPS_BLR_FREE_M_ARRAY SUBROUTINE DMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 CALL DMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8) RETURN END SUBROUTINE DMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE DMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE DMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE DMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in DMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in DMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) CALL DEALLOC_LRB(THELRB,KEEP8) ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE DMUMPS_BLR_FREE_CB_LRB SUBROUTINE DMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE DMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if((trim(mode).EQ."memory_save").OR.(trim(mode).EQ."save")) then call DMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(trim(mode).EQ."memory_save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL DMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL DMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call DMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_BLR SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_STRUC_T PARAMETER (NBVARIABLES_BLR_STRUC_T = 15) CHARACTER(len=30), dimension(NBVARIABLES_BLR_STRUC_T):: & VARIABLES_BLR_STRUC_T CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords,Local_NbRecords INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 VARIABLES_BLR_STRUC_T(1)="IsSYM" VARIABLES_BLR_STRUC_T(2)="IsT2" VARIABLES_BLR_STRUC_T(3)="IsSLAVE" VARIABLES_BLR_STRUC_T(4)="PANELS_L" VARIABLES_BLR_STRUC_T(5)="PANELS_U" VARIABLES_BLR_STRUC_T(6)="CB_LRB" VARIABLES_BLR_STRUC_T(7)="BEGS_BLR_STATIC" VARIABLES_BLR_STRUC_T(8)="BEGS_BLR_DYNAMIC" VARIABLES_BLR_STRUC_T(9)="BEGS_BLR_L" VARIABLES_BLR_STRUC_T(10)="BEGS_BLR_COL" VARIABLES_BLR_STRUC_T(11)="NB_ACCESSES_INIT" VARIABLES_BLR_STRUC_T(12)="NB_PANELS" VARIABLES_BLR_STRUC_T(13)="DIAG_BLOCKS" VARIABLES_BLR_STRUC_T(14)="NFS4FATHER" VARIABLES_BLR_STRUC_T(15)="M_ARRAY" SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T TMP_STRING = VARIABLES_BLR_STRUC_T(i1) SELECT CASE(TMP_STRING) CASE("IsSYM") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsT2") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsSLAVE") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_STATIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_DYNAMIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_L") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_COL") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_ACCESSES_INIT") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_PANELS") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("PANELS_L") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE("PANELS_U") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE("CB_LRB") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"memory_save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"restore" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE("DIAG_BLOCKS") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL DMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL DMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE("NFS4FATHER") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("M_ARRAY") if(trim(mode).EQ."restore") then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE DMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_LRB_TYPE PARAMETER (NBVARIABLES_LRB_TYPE = 6) CHARACTER(len=30), dimension(NBVARIABLES_LRB_TYPE):: & VARIABLES_LRB_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_LRB_TYPE(1)="Q" VARIABLES_LRB_TYPE(2)="R" VARIABLES_LRB_TYPE(3)="K" VARIABLES_LRB_TYPE(4)="M" VARIABLES_LRB_TYPE(5)="N" VARIABLES_LRB_TYPE(6)="ISLR" SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE TMP_STRING = VARIABLES_LRB_TYPE(i1) SELECT CASE(TMP_STRING) CASE("Q") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("R") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("K") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("M") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("N") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("ISLR") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_LRB SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_PANEL_TYPE PARAMETER (NBVARIABLES_BLR_PANEL_TYPE = 2) CHARACTER(len=30), dimension(NBVARIABLES_BLR_PANEL_TYPE):: & VARIABLES_BLR_PANEL_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords,Local_NbRecords INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL VARIABLES_BLR_PANEL_TYPE(1)="NB_ACCESSES_LEFT" VARIABLES_BLR_PANEL_TYPE(2)="LRB_PANEL" SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE TMP_STRING = VARIABLES_BLR_PANEL_TYPE(i1) SELECT CASE(TMP_STRING) CASE("NB_ACCESSES_LEFT") NbRecords_BLR_PANEL_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE("LRB_PANEL") if(trim(mode).EQ."memory_save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL DMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE DMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_DIAG_BLOCK_TYPE PARAMETER (NBVARIABLES_DIAG_BLOCK_TYPE = 1) CHARACTER(len=30), dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & VARIABLES_DIAG_BLOCK_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_DIAG_BLOCK_TYPE(1)="DIAG_BLOCK" SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE TMP_STRING = VARIABLES_DIAG_BLOCK_TYPE(i1) SELECT CASE(TMP_STRING) CASE("DIAG_BLOCK") NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(trim(mode).EQ."restore") then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_DIAG_BLOCK END MODULE DMUMPS_LR_DATA_M MUMPS_5.4.1/src/dana_lr.F0000664000175000017500000020104414102210523015213 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_ANA_LR USE DMUMPS_LR_CORE USE DMUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) NBGROUPS_KWAY = MAX(NINT(dble(NV)/dble(GROUP_SIZE2)),1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB (NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR DOUBLE PRECISION :: COMPRESS_RATIO #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) COMPRESS_RATIO= dble(NVEXPANDED)/dble(NV) NBGROUPS_KWAY = MAX(NINT(dble(NVEXPANDED)/dble(GROUP_SIZE2)),1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN INTEGER :: PARTS(:) INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBGROUPS) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO NBGROUPS = NBGROUPS + NPARTS !$OMP END CRITICAL(lrgrouping_cri) SEP = NEWSEP DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(dble(IPE(N+1)-1_8)/dble(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE DMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, MAXFRONT INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL DMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE DMUMPS_LR_GROUPING SUBROUTINE DMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL DMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE DMUMPS_LR_GROUPING_NEW SUBROUTINE DMUMPS_AB_LR_GROUPING(N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, MYID, COMM) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, COMM TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 501 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP ATOMIC WRITE IERROR = 3*N ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IF (MAPCOL(NODE).NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = dble(NVEXPANDED)/dble(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(dble(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE DMUMPS_AB_LR_GROUPING SUBROUTINE DMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, & COMM, MYID, NPROCS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 501 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = dble(NVEXPANDED)/dble(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(dble(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO 498 CONTINUE !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE DMUMPS_AB_LR_MPI_GROUPING END MODULE DMUMPS_ANA_LR MUMPS_5.4.1/src/dmumps_gpu.c0000664000175000017500000000117314102210474016036 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "dmumps_gpu.h" void MUMPS_CALL dmumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.4.1/src/ssol_bwd.F0000664000175000017500000001473114102210521015432 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE SMUMPS_STATIC_PTR_M, ONLY : SMUMPS_SET_STATIC_PTR, & SMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS REAL A(LA), W(LWC) REAL W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) REAL RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine SMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) BLOQ = ( III .EQ. IIPOOL ) CALL SMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 CALL SMUMPS_SET_STATIC_PTR(A) CALL SMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL SMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .EQ. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE SMUMPS_SOL_S MUMPS_5.4.1/src/zana_aux_par.F0000664000175000017500000030335414102210525016274 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_PARALLEL_ANALYSIS USE ZMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS INCLUDE 'mpif.h' PUBLIC ZMUMPS_ANA_F_PAR INTERFACE ZMUMPS_ANA_F_PAR MODULE PROCEDURE ZMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, COMM_NODES, NPROCS, NSLAVES, MYID INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER :: N, COMM INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK CONTAINS SUBROUTINE ZMUMPS_ANA_F_PAR(id, WORK1, WORK2, NFSIZ, FILS, & FRERE) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER :: NFSIZ(:), FILS(:), FRERE(:) TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: IPE(:), NV(:), & NE(:), NA(:), NODE(:), & ND(:), SUBORD(:), NAMALG(:), & IPS(:), CUMUL(:), & SAVEIRN(:), SAVEJCN(:) INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG LOGICAL :: SPLITROOT INTEGER(8), PARAMETER :: K79REF=12000000_8 INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) DOUBLE PRECISION :: TIMEB nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) ord%PERMTAB => WORK1(1 : id%N) ord%PERITAB => WORK1(id%N+1 : 2*id%N) ord%TREETAB => WORK1(2*id%N+1 : 3*id%N) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_SET_PAR_ORD(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) CALL ZMUMPS_DO_PAR_ORD(id, ord, WORK2) IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(*,'(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(id%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL ZMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:id%N) NE => WORK1(id%N+1 : 2*id%N) NA => WORK1(2*id%N+1 : 3*id%N) NODE => WORK2(1 : id%N ) ND => WORK2(id%N+1 : 2*id%N) SUBORD => WORK2(2*id%N+1 : 3*id%N) NAMALG => WORK2(3*id%N+1 : 4*id%N) CALL MUMPS_REALLOC(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL ZMUMPS_ANA_LNEW(id%N, IPE(1), NV(1), IPS(1), NE(1), & NA(1), NFSIZ(1), NODE(1), id%INFOG(6), FILS(1), FRERE(1), & ND(1), NEMIN, SUBORD(1), id%KEEP(60), id%KEEP(20), & id%KEEP(38), NAMALG(1), id%KEEP(104), CUMUL(1), & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%NSLAVES, & id%KEEP(250).EQ.1, .FALSE., IDUMMY, LIDUMMY) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL ZMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(id%N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL ZMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2)) & id%KEEP(210)=0 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0)) & id%KEEP(210)=1 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0)) & id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN IDUMMY(1) = -1 CALL ZMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), SPLITROOT, & MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = (((id%ICNTL(13).GT.0) .AND. & (id%NSLAVES.GT.id%ICNTL(13))) .OR. & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL ZMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF END IF RETURN END SUBROUTINE ZMUMPS_ANA_F_PAR SUBROUTINE ZMUMPS_SET_PAR_ORD(id, ord) TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29) CALL MPI_BCAST( id%KEEP(245), 1, & MPI_INTEGER, 0, id%COMM, IERR ) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(245) .EQ. 0) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) id%KEEP(245) = 1 IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, & ord%COMM_NODES, IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to ParMETIS.")') id%KEEP(245) = 2 RETURN #endif id%INFO(1) = -38 id%INFOG(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP, & '("No parallel ordering tools available.")') WRITE(LP, & '("Please install PT-SCOTCH or ParMETIS.")') END IF RETURN ELSE IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, ord%COMM_NODES, & IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF END SUBROUTINE ZMUMPS_SET_PAR_ORD SUBROUTINE ZMUMPS_DO_PAR_ORD(id, ord, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) CALL ZMUMPS_PTSCOTCH_ORD(id, ord, WORK) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) CALL ZMUMPS_PARMETIS_ORD(id, ord, WORK) if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_NODES, IERR) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF RETURN END SUBROUTINE ZMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_PARMETIS_ORD(id, ord, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IERR=0 IF(size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL ZMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:id%N) CALL MUMPS_REALLOC(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_BUILD_TREE(ord) ord%N = id%N ord%COMM = id%COMM RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE ZMUMPS_PARMETIS_ORD #endif #if defined(ptscotch) SUBROUTINE ZMUMPS_PTSCOTCH_ORD(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF (size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside ZMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) BASE = id%NPROCS-id%NSLAVES BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL ZMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL ZMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 CALL MUMPS_REALLOC(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) END IF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = id%N ord%COMM = id%COMM CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) RETURN 11 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE ZMUMPS_PTSCOTCH_ORD #endif FUNCTION ZMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: ZMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(ZMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF ZMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN ZMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN ZMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = id%N END IF DO I=1, ANODE WEIGHT = ord%NW(LIST(I)) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT END DO I = ord%SON(BIG) DO WEIGHT = ord%NW(I) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT IF(ord%BROTHER(I) .EQ. -1) EXIT I = ord%BROTHER(I) END DO TOPROWS = ord%TOPNODES(2)+ord%RANGTAB(BIG+1)-ord%RANGTAB(BIG) SUBMEM = 7 *id%N HOSTMEM = 12*id%N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/id%N) IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN ZMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE ZMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION ZMUMPS_STOP_DESCENT FUNCTION ZMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: ZMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR ZMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE ZMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN ZMUMPS_CNT_KIDS = ZMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION ZMUMPS_CNT_KIDS SUBROUTINE ZMUMPS_GET_SUBTREES(ord, id) IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(ZMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok LOGICAL :: SD NNODES = ord%NSLAVES CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. ZMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL ZMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL ZMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = ZMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = ZMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL ZMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL ZMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL ZMUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL ZMUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(46) .EQ. 1) THEN BASE = 0 ELSE ord%FIRST(1) = 0 ord%LAST(1) = -1 BASE = 1 END IF DO I=1, ANODE CURR = LIST(I) ND = CURR IF(ord%SON(ND) .NE. -1) THEN ND = ord%SON(ND) DO IF((ord%SON(ND) .EQ. -1) .AND. & (ord%BROTHER(ND).EQ.-1)) THEN EXIT ELSE IF(ord%BROTHER(ND) .EQ. -1) THEN ND = ord%SON(ND) ELSE ND = ord%BROTHER(ND) END IF END DO END IF ord%FIRST(BASE+I) = ord%RANGTAB(ND) ord%LAST(BASE+I) = ord%RANGTAB(CURR+1)-1 END DO DO I=ANODE+1, id%NSLAVES ord%FIRST(BASE+I) = id%N+1 ord%LAST(BASE+I) = id%N END DO DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE ZMUMPS_GET_SUBTREES SUBROUTINE ZMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(size(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in ZMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : id%N) ELEN => WORK( id%N+1 : 2*id%N) LENG => WORK(2*id%N+1 : 3*id%N) PERM => WORK(3*id%N+1 : 4*id%N) END IF CALL ZMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1 : 2*id%N) CALL ZMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = id%N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(dble(TMP)*1.10D0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), & HIDX, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, id%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(id%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, id%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, id%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL ZMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL ZMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & id%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & id%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & id%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & id%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, id%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, id%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE ZMUMPS_PARSYMFACT SUBROUTINE ZMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE ZMUMPS_MAKE_LOC_IDX SUBROUTINE ZMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE ZMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in ZMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE ZMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), SDISPL(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : id%N) LENG => WORK(id%N+1 : 2*id%N) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*id%N id%KEEP8(126) = id%KEEP8(127)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END DO CALL ZMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, id%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(id%N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL ZMUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL ZMUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE ZMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE ZMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & SDISPL(:), HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : id%N) HALO_MAP => WORK(id%N+1 : 2*id%N) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) I = ceiling(dble(MAXS)*1.20D0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(dble(NROWS_LOC+1)*1.20D0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END IF END DO CALL ZMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, id%N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, id%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE ZMUMPS_BUILD_LOC_GRAPH SUBROUTINE ZMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in ZMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in ZMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in ZMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in ZMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in ZMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE ZMUMPS_SEND_BUF SUBROUTINE ZMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE ZMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE ZMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE ZMUMPS_BUILD_TREE SUBROUTINE ZMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, TYPE) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(id%N/ord%NSLAVES,8) DO I=1, ord%NSLAVES FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NSLAVES) = MAX(LAST(BASE+ord%NSLAVES), id%N) DO I = ord%NSLAVES+1, id%NSLAVES+1 FIRST(BASE+I) = id%N+1 LAST (BASE+I) = id%N END DO ELSE IF (TYPE.EQ.2) THEN TMP => WORK(1:id%N) NZ_ROW => WORK(id%N+1:2*id%N) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MPI_ALLREDUCE(TMP(1), NZ_ROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NSLAVES,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, id%N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((id%N-I).EQ.(ord%NSLAVES-P-1)) .OR. & (I.EQ.id%N) & ) THEN P = P+1 IF(P.EQ.ord%NSLAVES) THEN FIRST(BASE+P) = F LAST(BASE+P) = id%N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = id%N+1 LAST(BASE+J) = id%N END DO END IF RETURN END SUBROUTINE ZMUMPS_GRAPH_DIST #endif SUBROUTINE ZMUMPS_MERGESWAP(N, L, A1, A2) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A1(:), A2(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A1(LP) A1(LP) = A1(I) A1(I) = ISWAP ISWAP = A2(LP) A2(LP) = A2(I) A2(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE ZMUMPS_MERGESWAP #if defined(DETERMINISTIC_PARALLEL_GRAPH) SUBROUTINE ZMUMPS_MERGESWAP1(N, L, A) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A(LP) A(LP) = A(I) A(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE ZMUMPS_MERGESWAP1 #endif SUBROUTINE ZMUMPS_MERGESORT(N, K, L) INTEGER :: N INTEGER :: K(:), L(0:) INTEGER :: P, Q, S, T CONTINUE L(0) = 1 T = N + 1 DO P = 1,N - 1 IF (K(P) <= K(P+1)) THEN L(P) = P + 1 ELSE L(T) = - (P+1) T = P END IF END DO L(T) = 0 L(N) = 0 IF (L(N+1) == 0) THEN RETURN ELSE L(N+1) = iabs(L(N+1)) END IF 200 CONTINUE S = 0 T = N+1 P = L(S) Q = L(T) IF(Q .EQ. 0) RETURN 300 CONTINUE IF(K(P) .GT. K(Q)) GOTO 600 CONTINUE L(S) = sign(P,L(S)) S = P P = L(P) IF (P .GT. 0) GOTO 300 CONTINUE L(S) = Q S = T DO T = Q Q = L(Q) IF (Q .LE. 0) EXIT END DO GOTO 800 600 CONTINUE L(S) = sign(Q, L(S)) S = Q Q = L(Q) IF (Q .GT. 0) GOTO 300 CONTINUE L(S) = P S = T DO T = P P = L(P) IF (P .LE. 0) EXIT END DO 800 CONTINUE P = -P Q = -Q IF(Q.EQ.0) THEN L(S) = sign(P, L(S)) L(T) = 0 GOTO 200 END IF GOTO 300 END SUBROUTINE ZMUMPS_MERGESORT FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:) #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8) IF (id%KEEP(10).EQ.1) THEN CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(ZMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) BASEVAL_I8 = int(BASEVAL,8) VERTLOCNBR_I8 = int(VERTLOCNBR,8) ENDIF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.4.1/src/smumps_iXamax.F0000664000175000017500000000131314102210521016441 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION SMUMPS_IXAMAX(N,X,INCX,GRAIN) IMPLICIT NONE REAL, intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN INTEGER isamax SMUMPS_IXAMAX = isamax(N,X,INCX) RETURN END FUNCTION SMUMPS_IXAMAX MUMPS_5.4.1/src/sfac_sol_pool.F0000664000175000017500000004420014102210521016432 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_INIT_POOL_LAST3(IPOOL, LPOOL, LEAF) USE SMUMPS_LOAD IMPLICIT NONE INTEGER LPOOL, LEAF INTEGER IPOOL(LPOOL) IPOOL(LPOOL-2) = 0 IPOOL(LPOOL-1) = 0 IPOOL(LPOOL) = LEAF-1 RETURN END SUBROUTINE SMUMPS_INIT_POOL_LAST3 SUBROUTINE SMUMPS_INSERT_POOL_N & (N, POOL, LPOOL, PROCNODE, SLAVEF, KEEP199, & K28, K76, K80, K47, STEP, INODE) USE SMUMPS_LOAD IMPLICIT NONE INTEGER N, INODE, LPOOL, K28, SLAVEF, K76, K80, K47, KEEP199 INTEGER STEP(N), POOL(LPOOL), PROCNODE(K28) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR, ATM_CURRENT_NODE INTEGER NBINSUBTREE, NBTOP, INODE_EFF,POS_TO_INSERT INTEGER IPOS1, IPOS2, ISWAP INTEGER NODE,J,I ATM_CURRENT_NODE = ( K76 == 2 .OR. K76 ==3 .OR. & K76==4 .OR. K76==5) NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF (INODE > N ) THEN INODE_EFF = INODE - N ELSE IF (INODE < 0) THEN INODE_EFF = - INODE ELSE INODE_EFF = INODE ENDIF IF(((INODE.GT.0).AND.(INODE.LE.N)).AND.(.NOT. & MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199)) & ) THEN IF ((K80 == 1 .AND. K47 .GE. 1) .OR. & (( K80 == 2 .OR. K80==3 ) .AND. & ( K47 == 4 ))) THEN CALL SMUMPS_REMOVE_NODE(INODE,1) ENDIF ENDIF IF ( MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE_EFF)), & KEEP199) ) THEN POOL(NBINSUBTREE + 1 ) = INODE NBINSUBTREE = NBINSUBTREE + 1 ELSE POS_TO_INSERT=NBTOP+1 IF((K76.EQ.4).OR.(K76.EQ.5).OR.(K76.EQ.6))THEN IF((INODE.GT.N).OR.(INODE.LE.0))THEN DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0) & .AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 333 ENDIF IF ( POOL(LPOOL-2-J) < 0 ) THEN NODE=-POOL(LPOOL-2-J) ELSE IF ( POOL(LPOOL-2-J) > N ) THEN NODE = POOL(LPOOL-2-J) - N ELSE NODE = POOL(LPOOL-2-J) ENDIF IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 333 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(J.EQ.0) J=1 333 CONTINUE DO I=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-I-1)=POOL(LPOOL-2-I) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF DO J=NBTOP,1,-1 IF((POOL(LPOOL-2-J).GT.0).AND.(POOL(LPOOL-2-J).LE.N))THEN GOTO 888 ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO 888 CONTINUE DO I=J,1,-1 NODE=POOL(LPOOL-2-I) IF((K76.EQ.4).OR.(K76.EQ.6))THEN IF(DEPTH_FIRST_LOAD(STEP(NODE)).GE. & DEPTH_FIRST_LOAD(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF IF(K76.EQ.5)THEN IF(COST_TRAV(STEP(NODE)).LE. & COST_TRAV(STEP(INODE_EFF)))THEN GOTO 999 ENDIF ENDIF POS_TO_INSERT=POS_TO_INSERT-1 ENDDO IF(I.EQ.0) I=1 999 CONTINUE DO J=NBTOP,POS_TO_INSERT,-1 POOL(LPOOL-2-J-1)=POOL(LPOOL-2-J) ENDDO POOL(LPOOL-2-POS_TO_INSERT)=INODE NBTOP = NBTOP + 1 GOTO 20 ENDIF POOL( LPOOL - 2 - ( NBTOP + 1 ) ) = INODE NBTOP = NBTOP + 1 IPOS1 = LPOOL - 2 - NBTOP IPOS2 = LPOOL - 2 - NBTOP + 1 10 CONTINUE IF ( IPOS2 == LPOOL - 2 ) GOTO 20 IF ( POOL(IPOS1) < 0 ) GOTO 20 IF ( POOL(IPOS2) < 0 ) GOTO 30 IF ( ATM_CURRENT_NODE ) THEN IF ( POOL(IPOS1) > N ) GOTO 20 IF ( POOL(IPOS2) > N ) GOTO 30 END IF GOTO 20 30 CONTINUE ISWAP = POOL(IPOS1) POOL(IPOS1) = POOL(IPOS2) POOL(IPOS2) = ISWAP IPOS1 = IPOS1 + 1 IPOS2 = IPOS2 + 1 GOTO 10 20 CONTINUE ENDIF POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP RETURN END SUBROUTINE SMUMPS_INSERT_POOL_N LOGICAL FUNCTION SMUMPS_POOL_EMPTY(POOL, LPOOL) IMPLICIT NONE INTEGER LPOOL INTEGER POOL(LPOOL) INTEGER NBINSUBTREE, NBTOP NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) SMUMPS_POOL_EMPTY = (NBINSUBTREE + NBTOP == 0) RETURN END FUNCTION SMUMPS_POOL_EMPTY SUBROUTINE SMUMPS_EXTRACT_POOL( N, POOL, LPOOL, PROCNODE, SLAVEF, & STEP, INODE, KEEP,KEEP8, MYID, ND, & FORCE_EXTRACT_TOP_SBTR ) USE SMUMPS_LOAD IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N), POOL(LPOOL), PROCNODE(KEEP(28)), & ND(KEEP(28)) EXTERNAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, SMUMPS_POOL_EMPTY LOGICAL MUMPS_INSSARBR, MUMPS_ROOTSSARBR, SMUMPS_POOL_EMPTY EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER NBINSUBTREE, NBTOP, INSUBTREE, INODE_EFF, MYID LOGICAL LEFT, ATOMIC_SUBTREE,UPPER,FLAG_MEM,SBTR_FLAG,PROC_FLAG LOGICAL FORCE_EXTRACT_TOP_SBTR INTEGER NODE_TO_EXTRACT,I,J,MIN_PROC NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF ( KEEP(76) > 6 .OR. KEEP(76) < 0 ) THEN WRITE(*,*) "Error 2 in SMUMPS_EXTRACT_POOL: unknown strategy" CALL MUMPS_ABORT() ENDIF ATOMIC_SUBTREE = ( KEEP(76) == 1 .OR. KEEP(76) == 3) IF ( SMUMPS_POOL_EMPTY(POOL, LPOOL) ) THEN WRITE(*,*) "Error 1 in SMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF IF ( .NOT. ATOMIC_SUBTREE ) THEN LEFT = (NBTOP == 0) IF(.NOT.LEFT)THEN IF((KEEP(76).EQ.4).OR.(KEEP(76).EQ.5))THEN IF(NBINSUBTREE.EQ.0)THEN LEFT=.FALSE. ELSE IF ( POOL(NBINSUBTREE) < 0 ) THEN I = -POOL(NBINSUBTREE) ELSE IF ( POOL(NBINSUBTREE) > N ) THEN I = POOL(NBINSUBTREE) - N ELSE I = POOL(NBINSUBTREE) ENDIF IF ( POOL(LPOOL-2-NBTOP) < 0 ) THEN J = -POOL(LPOOL-2-NBTOP) ELSE IF ( POOL(LPOOL-2-NBTOP) > N ) THEN J = POOL(LPOOL-2-NBTOP) - N ELSE J = POOL(LPOOL-2-NBTOP) ENDIF IF(KEEP(76).EQ.4)THEN IF(DEPTH_FIRST_LOAD(STEP(J)).GE. & DEPTH_FIRST_LOAD(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF IF(KEEP(76).EQ.5)THEN IF(COST_TRAV(STEP(J)).LE. & COST_TRAV(STEP(I)))THEN LEFT=.TRUE. ELSE LEFT=.FALSE. ENDIF ENDIF ENDIF ENDIF ENDIF ELSE IF ( INSUBTREE == 1 ) THEN IF (NBINSUBTREE == 0) THEN WRITE(*,*) "Error 3 in SMUMPS_EXTRACT_POOL" CALL MUMPS_ABORT() ENDIF LEFT = .TRUE. ELSE LEFT = ( NBTOP == 0) ENDIF ENDIF 222 CONTINUE IF ( LEFT ) THEN INODE = POOL( NBINSUBTREE ) IF(KEEP(81).EQ.2)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8,PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN WRITE(*,*)MYID,': ca a change pour moi' LEFT=.FALSE. GOTO 222 ENDIF ENDIF ELSEIF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL SMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(.NOT.SBTR_FLAG)THEN LEFT=.FALSE. WRITE(*,*)MYID,': ca a change pour moi (2)' GOTO 222 ENDIF ENDIF ENDIF ENDIF NBINSUBTREE = NBINSUBTREE - 1 IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199)) ) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.0))THEN CALL SMUMPS_LOAD_SET_SBTR_MEM(.TRUE.) ENDIF INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE_EFF)), & KEEP(199))) THEN IF((KEEP(47).GE.2.AND.KEEP(81).EQ.1).AND. & (INSUBTREE.EQ.1))THEN CALL SMUMPS_LOAD_SET_SBTR_MEM(.FALSE.) ENDIF INSUBTREE = 0 END IF ELSE IF (NBTOP < 1 ) THEN WRITE(*,*) "Error 5 in SMUMPS_EXTRACT_POOL", NBTOP CALL MUMPS_ABORT() ENDIF INODE = POOL( LPOOL - 2 - NBTOP ) IF(KEEP(81).EQ.1)THEN CALL SMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IF(UPPER)THEN GOTO 666 ELSE NBINSUBTREE=NBINSUBTREE-1 IF ( MUMPS_INSSARBR( PROCNODE(STEP(INODE)), & KEEP(199)) ) THEN INSUBTREE = 1 ELSE IF ( MUMPS_ROOTSSARBR( PROCNODE(STEP(INODE)), & KEEP(199))) THEN INSUBTREE = 0 ENDIF GOTO 777 ENDIF ENDIF IF(KEEP(81).EQ.2)THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (3)' GOTO 222 ENDIF ELSE IF(KEEP(81).EQ.3)THEN IF((INODE.GE.0).AND.(INODE.LE.N))THEN NODE_TO_EXTRACT=INODE FLAG_MEM=.FALSE. CALL SMUMPS_LOAD_CHK_MEMCST_POOL(FLAG_MEM) IF(FLAG_MEM)THEN CALL SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N, & STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG, & PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN LEFT=.TRUE. WRITE(*,*)MYID,': ca a change pour moi (4)' GOTO 222 ENDIF ELSE CALL SMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF ENDIF ENDIF 666 CONTINUE NBTOP = NBTOP - 1 IF((INODE.GT.0).AND.(INODE.LE.N))THEN IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 ))) THEN CALL SMUMPS_REMOVE_NODE(INODE,2) ENDIF ENDIF IF ( INODE < 0 ) THEN INODE_EFF = -INODE ELSE IF ( INODE > N ) THEN INODE_EFF = INODE - N ELSE INODE_EFF = INODE ENDIF END IF 777 CONTINUE POOL(LPOOL) = NBINSUBTREE POOL(LPOOL - 1) = NBTOP POOL(LPOOL - 2) = INSUBTREE RETURN END SUBROUTINE SMUMPS_EXTRACT_POOL SUBROUTINE SMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR,FLAG_SAME_PROC,MIN_PROC) USE SMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,MYID,SLAVEF,PROC,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),STEP(N),PROCNODE(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LOGICAL SBTR,FLAG_SAME_PROC INTEGER POS_TO_EXTRACT,NODE_TO_EXTRACT,NBTOP,I,INSUBTREE, & NBINSUBTREE DOUBLE PRECISION MIN_COST, TMP_COST NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) MIN_COST=huge(MIN_COST) TMP_COST=huge(TMP_COST) FLAG_SAME_PROC=.FALSE. SBTR=.FALSE. MIN_PROC=-9999 IF((INODE.GT.0).AND.(INODE.LE.N))THEN POS_TO_EXTRACT=-1 NODE_TO_EXTRACT=-1 DO I=NBTOP,1,-1 IF(NODE_TO_EXTRACT.LT.0)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) CALL SMUMPS_LOAD_COMP_MAXMEM_POOL(NODE_TO_EXTRACT, & TMP_COST,PROC) MIN_COST=TMP_COST MIN_PROC=PROC ELSE CALL SMUMPS_LOAD_COMP_MAXMEM_POOL(POOL(LPOOL-2-I), & TMP_COST,PROC) IF((PROC.NE.MIN_PROC).OR.(TMP_COST.NE.MIN_COST))THEN FLAG_SAME_PROC=.TRUE. ENDIF IF(TMP_COST.GT.MIN_COST)THEN POS_TO_EXTRACT=I NODE_TO_EXTRACT=POOL(LPOOL-2-I) MIN_COST=TMP_COST MIN_PROC=PROC ENDIF ENDIF ENDDO IF((KEEP(47).EQ.4).AND.(NBINSUBTREE.NE.0))THEN CALL SMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IF(SBTR)THEN WRITE(*,*)MYID,': selecting from subtree' RETURN ENDIF ENDIF IF((.NOT.SBTR).AND.(.NOT.FLAG_SAME_PROC))THEN WRITE(*,*)MYID,': I must search for a task & to save My friend' RETURN ENDIF INODE = NODE_TO_EXTRACT DO I=POS_TO_EXTRACT,NBTOP IF(I.NE.NBTOP)THEN POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDIF ENDDO POOL(LPOOL-2-NBTOP)=INODE CALL SMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ELSE ENDIF END SUBROUTINE SMUMPS_MEM_CONS_MNG SUBROUTINE SMUMPS_MEM_NODE_SELECT(INODE,POOL,LPOOL,N,STEP, & KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) USE SMUMPS_LOAD IMPLICIT NONE INTEGER INODE,LPOOL,N,SLAVEF,MYID,MIN_PROC INTEGER POOL(LPOOL),KEEP(500),PROCNODE(KEEP(28)),STEP(N) INTEGER(8) KEEP8(150) LOGICAL SBTR_FLAG,PROC_FLAG EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR INTEGER NODE_TO_EXTRACT,I,POS_TO_EXTRACT,NBTOP,NBINSUBTREE NBTOP= POOL(LPOOL - 1) NBINSUBTREE = POOL(LPOOL) IF(NBTOP.GT.0)THEN WRITE(*,*)MYID,': NBTOP=',NBTOP ENDIF SBTR_FLAG=.FALSE. PROC_FLAG=.FALSE. CALL SMUMPS_MEM_CONS_MNG(INODE,POOL,LPOOL,N,STEP,KEEP,KEEP8, & PROCNODE,SLAVEF,MYID,SBTR_FLAG,PROC_FLAG,MIN_PROC) IF(SBTR_FLAG)THEN RETURN ENDIF IF(MIN_PROC.EQ.-9999)THEN IF((INODE.GT.0).AND.(INODE.LT.N))THEN SBTR_FLAG=(NBINSUBTREE.NE.0) ENDIF RETURN ENDIF IF(.NOT.PROC_FLAG)THEN NODE_TO_EXTRACT=INODE IF((INODE.GE.0).AND.(INODE.LE.N))THEN CALL SMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*)MYID,': Extracting from a subtree & for helping',MIN_PROC SBTR_FLAG=.TRUE. RETURN ELSE IF(NODE_TO_EXTRACT.NE.INODE)THEN WRITE(*,*)MYID,': Extracting from top & inode=',INODE,'for helping',MIN_PROC ENDIF CALL SMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) ENDIF ENDIF DO I=1,NBTOP IF (POOL(LPOOL-2-I).EQ.INODE)THEN GOTO 452 ENDIF ENDDO 452 CONTINUE POS_TO_EXTRACT=I DO I=POS_TO_EXTRACT,NBTOP-1 POOL(LPOOL-2-I)=POOL(LPOOL-2-I-1) ENDDO POOL(LPOOL-2-NBTOP)=INODE ENDIF END SUBROUTINE SMUMPS_MEM_NODE_SELECT SUBROUTINE SMUMPS_GET_INODE_FROM_POOL & ( IPOOL, LPOOL, III, LEAF, & INODE, STRATEGIE ) IMPLICIT NONE INTEGER, INTENT(IN) :: STRATEGIE, LPOOL INTEGER IPOOL (LPOOL) INTEGER III,LEAF INTEGER, INTENT(OUT) :: INODE LEAF = LEAF - 1 INODE = IPOOL( LEAF ) RETURN END SUBROUTINE SMUMPS_GET_INODE_FROM_POOL MUMPS_5.4.1/src/ana_set_ordering.F0000664000175000017500000000515514102210475017131 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SET_ORDERING(N, KEEP, SYM, NPROCS, IORD, & NBQD, AvgDens, & PROK, MP) IMPLICIT NONE INTEGER, intent(in) :: N, KEEP(500), NPROCS, SYM INTEGER, intent(in) :: NBQD, AvgDens, MP LOGICAL, intent(in) :: PROK INTEGER, intent(inout) :: IORD INTEGER MAXQD PARAMETER (MAXQD=2) INTEGER SMALLSYM, SMALLUNS PARAMETER (SMALLUNS=5000, SMALLSYM=10000) #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF ( IORD .EQ. 5 ) THEN IF (PROK) WRITE(MP,*) & 'WARNING: METIS not available. Ordering set to default.' IORD = 7 END IF #endif #if ! defined(pord) IF ( IORD .EQ. 4 ) THEN IF (PROK) WRITE(MP,*) & 'WARNING: PORD not available. Ordering set to default.' IORD = 7 END IF #endif #if ! defined(scotch) && ! defined(ptscotch) IF ( IORD .EQ. 3 ) THEN IF (PROK) WRITE(MP,*) & 'WARNING: SCOTCH not available. Ordering set to default.' IORD = 7 END IF #endif IF (IORD.EQ.7) THEN IF (SYM.NE.0) THEN IF ( N.LE.SMALLSYM ) THEN IF (NBQD.GE.MAXQD) THEN IORD = 6 ELSE IORD = 2 ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else # if defined(scotch) || defined(ptscotch) IORD = 3 # else # if defined(pord) IORD = 4 # else IORD = 6 # endif # endif #endif ENDIF ELSE IF ( N.LE.SMALLUNS ) THEN IF (NBQD.GE.MAXQD) THEN IORD = 6 ELSE IORD = 2 ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else # if defined(scotch) || defined(ptscotch) IORD = 3 # else # if defined(pord) IORD = 4 # else IORD = 6 # endif # endif #endif ENDIF ENDIF ENDIF RETURN END SUBROUTINE MUMPS_SET_ORDERING MUMPS_5.4.1/src/ssol_fwd_aux.F0000664000175000017500000011647614102210521016324 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) USE SMUMPS_OOC USE SMUMPS_SOL_LR, ONLY: SMUMPS_SOL_SLAVE_LR_U USE SMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) REAL WCB( LWCB ), A( LA ) REAL RHSCOMP( LRHSCOMP, NRHS ) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSCOMP INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG !$ LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_REAL, COMM, IERR ) DO I = 1, LONG IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(IWCB(I))) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 SMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_REAL, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_REAL, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL SMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL SMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in SMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE SMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE SMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE SMUMPS_SOL_LR USE SMUMPS_OOC USE SMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS REAL WCB( LWCB ), A( LA ) INTEGER(8) :: LRHS_ROOT REAL RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP REAL RHSCOMP(LRHSCOMP, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL sgemv, strsv, sgemm, strsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE REAL ALPHA,ONE,ZERO PARAMETER (ZERO=0.0E0, ONE = 1.0E0, ALPHA=-1.0E0) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSCOMPLASTFSDYN !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) ERROR_WAS_BROADCASTED = .FALSE. DUMMY(1)=1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL SMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN LDADIAG = NPIV ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IFR_ini8 = IFR8 !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(IFR8,JJ) IF(OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in SMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = SMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL SMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP(1, JBDEB), LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL SMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL strsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL strsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL strsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL strsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL sgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL SMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE CALL SMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( KEEP(50) .eq. 0 ) THEN APOS1 = APOS + int(NPIV,8) * int(LIELL,8) ELSE APOS1 = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL SMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN CALL SMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSCOMPLASTFSDYN = 0 ELSE IPOSINRHSCOMPLASTFSDYN = & abs(POSINRHSCOMP_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSCOMP_FWD( IW(J3+I) )) .GT. & IPOSINRHSCOMPLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN IF (.NOT. CBINITZERO) THEN WRITE(*,*) ' Internal error 3 in SMUMPS_SOLVE_NODE_FWD', & CBINITZERO, INODE, NUPDATE, NUPDATE_NONCRITICAL CALL MUMPS_ABORT() ENDIF DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) !$OMP CRITICAL(SMUMPS_RHSCOMP_CRI) DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO !$OMP END CRITICAL(SMUMPS_RHSCOMP_CRI) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL SMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL SMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL SMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE SMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE SMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) REAL WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSCOMP, POSINRHSCOMP_FWD(N) REAL RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL SMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE SMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE SMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP, LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSCOMP, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSCOMP_FWD( N ), IW( LIW ) REAL, INTENT( INOUT ) :: RHSCOMP( LRHSCOMP, NRHS_B ) REAL, INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) REAL :: DKEEP(150) INTEGER, PARAMETER :: ZERO = 0.0E0 INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSCOMP INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' !$ LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP(IPOSINRHSCOMP,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( CBINITZERO ) THEN !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) !$OMP PARALLEL DO COLLAPSE(2) IF ( OMP_FLAG ) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_RHSCOMP_TO_WCB MUMPS_5.4.1/src/domp_tps_m.F0000664000175000017500000000101714102210522015751 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE DMUMPS_TPS_M_RETURN MUMPS_5.4.1/src/sfac_asm_ELT.F0000664000175000017500000002357614102210521016105 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) REAL :: A(LA) REAL :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL SMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE SMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) REAL, intent(inout) :: A(LA) REAL, intent(in) :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: INTARR(LINTARR) REAL, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS REAL ZERO PARAMETER( ZERO = 0.0E0 ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE SMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.4.1/src/slr_stats.F0000664000175000017500000006042514102210521015635 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_LR_STATS USE SMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: MRY_CB_FR, & MRY_CB_LRGAIN, & MRY_LU_FR, & MRY_LU_LRGAIN, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_LRGAIN, & FLOP_FACTO_FR, & FLOP_FACTO_LR, & FLOP_PANEL, & FLOP_TRSM, & FLOP_TRSM_FR, & FLOP_TRSM_LR, & FLOP_UPDATE_FR, & FLOP_UPDATE_LR, & FLOP_UPDATE_LRLR1, & FLOP_UPDATE_LRLR2, & FLOP_UPDATE_LRLR3, & FLOP_UPDATE_FRLR, & FLOP_UPDATE_FRFR DOUBLE PRECISION :: FLOP_COMPRESS, & FLOP_CB_COMPRESS, & FLOP_MIDBLK_COMPRESS, & FLOP_FRSWAP_COMPRESS, & FLOP_ACCUM_COMPRESS, & FLOP_DECOMPRESS, & FLOP_CB_DECOMPRESS, & FLOP_FRFRONTS, & FLOP_SOLFWD_FR, & FLOP_SOLFWD_LR DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: TIME_UPDATE DOUBLE PRECISION :: TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TIME_UPDATE_FRLR DOUBLE PRECISION :: TIME_UPDATE_FRFR DOUBLE PRECISION :: TIME_COMPRESS DOUBLE PRECISION :: TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TIME_CB_COMPRESS DOUBLE PRECISION :: TIME_LR_MODULE DOUBLE PRECISION :: TIME_UPD_NELIM DOUBLE PRECISION :: TIME_LRTRSM DOUBLE PRECISION :: TIME_FRTRSM DOUBLE PRECISION :: TIME_PANEL DOUBLE PRECISION :: TIME_FAC_I DOUBLE PRECISION :: TIME_FAC_MQ DOUBLE PRECISION :: TIME_FAC_SQ DOUBLE PRECISION :: TIME_FRFRONTS DOUBLE PRECISION :: TIME_DIAGCOPY DOUBLE PRECISION :: TIME_DECOMP DOUBLE PRECISION :: TIME_DECOMP_UCFS DOUBLE PRECISION :: TIME_DECOMP_ASM1 DOUBLE PRECISION :: TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TIME_DECOMP_ASMS2M DOUBLE PRECISION :: TIME_LRANA_LRGROUPING DOUBLE PRECISION :: TIME_LRANA_SEPGROUPING DOUBLE PRECISION :: TIME_LRANA_GETHALO DOUBLE PRECISION :: TIME_LRANA_KWAY DOUBLE PRECISION :: TIME_LRANA_GNEW DOUBLE PRECISION :: AVG_FLOP_FACTO_LR DOUBLE PRECISION :: MIN_FLOP_FACTO_LR DOUBLE PRECISION :: MAX_FLOP_FACTO_LR INTEGER :: TOTAL_NBLOCKS_ASS, TOTAL_NBLOCKS_CB INTEGER :: MIN_BLOCKSIZE_ASS, MAX_BLOCKSIZE_ASS INTEGER :: MIN_BLOCKSIZE_CB, MAX_BLOCKSIZE_CB DOUBLE PRECISION :: AVG_BLOCKSIZE_ASS, AVG_BLOCKSIZE_CB CONTAINS SUBROUTINE COLLECT_BLOCKSIZES(CUT,NPARTSASS,NPARTSCB) INTEGER, INTENT(IN) :: NPARTSASS, NPARTSCB INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: LOC_MIN_ASS, LOC_MIN_CB, LOC_MAX_ASS, LOC_MAX_CB, & LOC_TOT_ASS, LOC_TOT_CB DOUBLE PRECISION :: LOC_AVG_ASS, LOC_AVG_CB INTEGER :: I LOC_TOT_ASS = 0 LOC_TOT_CB = 0 LOC_AVG_ASS = 0.D0 LOC_AVG_CB = 0.D0 LOC_MIN_ASS = 100000 LOC_MIN_CB = 100000 LOC_MAX_ASS = 0 LOC_MAX_CB = 0 DO I = 1,NPARTSASS LOC_AVG_ASS = ( LOC_TOT_ASS * LOC_AVG_ASS & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_ASS + 1) LOC_TOT_ASS = LOC_TOT_ASS + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_ASS) THEN LOC_MIN_ASS = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_ASS) THEN LOC_MAX_ASS = CUT(I+1) - CUT(I) END IF END DO DO I = NPARTSASS+1,NPARTSASS+NPARTSCB LOC_AVG_CB = ( LOC_TOT_CB * LOC_AVG_CB & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_CB + 1) LOC_TOT_CB = LOC_TOT_CB + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_CB) THEN LOC_MIN_CB = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_CB) THEN LOC_MAX_CB = CUT(I+1) - CUT(I) END IF END DO AVG_BLOCKSIZE_ASS = (TOTAL_NBLOCKS_ASS*AVG_BLOCKSIZE_ASS & + LOC_TOT_ASS*LOC_AVG_ASS) / (TOTAL_NBLOCKS_ASS+LOC_TOT_ASS) AVG_BLOCKSIZE_CB = (TOTAL_NBLOCKS_CB*AVG_BLOCKSIZE_CB & + LOC_TOT_CB*LOC_AVG_CB) / (TOTAL_NBLOCKS_CB+LOC_TOT_CB) TOTAL_NBLOCKS_ASS = TOTAL_NBLOCKS_ASS + LOC_TOT_ASS TOTAL_NBLOCKS_CB = TOTAL_NBLOCKS_CB + LOC_TOT_CB MIN_BLOCKSIZE_ASS = min(MIN_BLOCKSIZE_ASS,LOC_MIN_ASS) MIN_BLOCKSIZE_CB = min(MIN_BLOCKSIZE_CB,LOC_MIN_CB) MAX_BLOCKSIZE_ASS = max(MAX_BLOCKSIZE_ASS,LOC_MAX_ASS) MAX_BLOCKSIZE_CB = max(MAX_BLOCKSIZE_CB,LOC_MAX_CB) END SUBROUTINE COLLECT_BLOCKSIZES SUBROUTINE UPD_FLOP_DECOMPRESS(F, CB) DOUBLE PRECISION, INTENT(IN) :: F LOGICAL, INTENT(IN) :: CB !$OMP ATOMIC UPDATE FLOP_DECOMPRESS = FLOP_DECOMPRESS + F !$OMP END ATOMIC IF (CB) THEN !$OMP ATOMIC UPDATE FLOP_CB_DECOMPRESS = FLOP_CB_DECOMPRESS + F !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE UPD_FLOP_DECOMPRESS SUBROUTINE UPD_FLOP_COMPRESS(LR_B, REC_ACC, & CB_COMPRESS, FRSWAP) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST,BUILDQ_COST, & HR_AND_BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC, CB_COMPRESS, FRSWAP M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(K*K*K/3_8 + 4_8*K*M*N - (2_8*M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(2_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF HR_AND_BUILDQ_COST = HR_COST + BUILDQ_COST !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + HR_AND_BUILDQ_COST !$OMP END ATOMIC IF (present(REC_ACC)) THEN IF (REC_ACC) THEN !$OMP ATOMIC UPDATE FLOP_ACCUM_COMPRESS = FLOP_ACCUM_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(CB_COMPRESS)) THEN IF (CB_COMPRESS) THEN !$OMP ATOMIC UPDATE FLOP_CB_COMPRESS = FLOP_CB_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(FRSWAP)) THEN IF (FRSWAP) THEN !$OMP ATOMIC UPDATE FLOP_FRSWAP_COMPRESS = FLOP_FRSWAP_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE UPD_FLOP_COMPRESS SUBROUTINE UPD_FLOP_TRSM(LRB, LorU) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: LorU DOUBLE PRECISION :: LR_COST, FR_COST, LR_GAIN IF (LorU.EQ.0) THEN FR_COST = dble(LRB%M*LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%K*LRB%N*LRB%N) ELSE LR_COST = FR_COST ENDIF ELSE FR_COST = dble(LRB%M-1)*dble(LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%N-1)*dble(LRB%N*LRB%K) ELSE LR_COST = FR_COST ENDIF ENDIF LR_GAIN = FR_COST - LR_COST !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_TRSM SUBROUTINE UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS, RANK_IN, BUILDQ, & IS_SYMDIAG, LUA_ACTIVATED, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 LOGICAL, INTENT(IN) :: BUILDQ, IS_SYMDIAG, LUA_ACTIVATED INTEGER, INTENT(IN) :: RANK_IN, MIDBLK_COMPRESS LOGICAL, INTENT(IN), OPTIONAL :: REC_ACC DOUBLE PRECISION :: COST_FR, COST_LR, COST_LRLR1, COST_LRLR2, & COST_LRLR3, COST_FRLR, COST_FRFR, & COST_COMPRESS, COST_LR_AND_COMPRESS, LR_GAIN DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK LOGICAL :: REC_ACC_LOC M1 = dble(LRB1%M) N1 = dble(LRB1%N) K1 = dble(LRB1%K) M2 = dble(LRB2%M) N2 = dble(LRB2%N) K2 = dble(LRB2%K) RANK = dble(RANK_IN) COST_LRLR1 = 0.0D0 COST_LRLR2 = 0.0D0 COST_LRLR3 = 0.0D0 COST_FRLR = 0.0D0 COST_FRFR = 0.0D0 COST_COMPRESS = 0.0D0 IF (present(REC_ACC)) THEN REC_ACC_LOC = REC_ACC ELSE REC_ACC_LOC = .FALSE. ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN COST_FRFR = 2.0D0*M1*M2*N1 COST_LR = 2.0D0*M1*M2*N1 COST_FR = 2.0D0*M1*M2*N1 ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN COST_FRLR = 2.0D0*K1*M2*N1 COST_LRLR3 = 2.0D0*M1*M2*K1 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN COST_FRLR = 2.0D0*M1*K2*N1 COST_LRLR3 = 2.0D0*M1*M2*K2 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSE IF (MIDBLK_COMPRESS.GE.1) THEN COST_COMPRESS = RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & (2.0D0*K1+K2)*RANK*RANK IF (BUILDQ) THEN COST_COMPRESS = COST_COMPRESS + 4.0D0*RANK*RANK*K1 & - RANK*RANK*RANK ENDIF ENDIF COST_LRLR1 = 2.0D0*K1*K2*N1 IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN COST_LRLR2 = 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK COST_LRLR3 = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN COST_LRLR2 = 2.0D0*K1*M1*K2 COST_LRLR3 = 2.0D0*M1*M2*K2 ELSE COST_LRLR2 = 2.0D0*K1*M2*K2 COST_LRLR3 = 2.0D0*M1*M2*K1 ENDIF ENDIF COST_LR = COST_LRLR1 + COST_LRLR2 + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ENDIF IF (IS_SYMDIAG) THEN COST_FR = COST_FR/2.0D0 COST_LRLR3 = COST_LRLR3/2.0D0 COST_FRFR = COST_FRFR/2.0D0 COST_LR = COST_LR - COST_LRLR3 - COST_FRFR ENDIF IF (LUA_ACTIVATED) THEN COST_LR = COST_LR - COST_LRLR3 COST_LRLR3 = 0.0D0 IF (REC_ACC_LOC) THEN COST_LR_AND_COMPRESS = COST_LR + COST_COMPRESS !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_LR_AND_COMPRESS !$OMP END ATOMIC ENDIF ENDIF IF (.NOT.REC_ACC_LOC) THEN !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_COMPRESS !$OMP END ATOMIC LR_GAIN = COST_FR - COST_LR !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC ENDIF END SUBROUTINE UPD_FLOP_UPDATE SUBROUTINE UPD_FLOP_UPDATE_LRLR3(LRB, NIV) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV DOUBLE PRECISION :: FLOP_COST FLOP_COST = 2.0D0*dble(LRB%M)*dble(LRB%N)*dble(LRB%K) !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN - FLOP_COST !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_UPDATE_LRLR3 SUBROUTINE UPD_FLOP_ROOT(KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + COST_PER_PROC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_ROOT SUBROUTINE INIT_STATS_GLOBAL(id) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id MRY_LU_FR = 0.D0 MRY_LU_LRGAIN = 0.D0 MRY_CB_FR = 0.D0 MRY_CB_LRGAIN = 0.D0 FLOP_FACTO_FR = 0.D0 FLOP_FACTO_LR = 0.D0 FLOP_LRGAIN = 0.D0 FLOP_CB_COMPRESS = 0.D0 FLOP_CB_DECOMPRESS = 0.D0 FLOP_DECOMPRESS = 0.D0 FLOP_UPDATE_FR = 0.D0 FLOP_UPDATE_LR = 0.D0 FLOP_UPDATE_LRLR1 = 0.D0 FLOP_UPDATE_LRLR2 = 0.D0 FLOP_UPDATE_LRLR3 = 0.D0 FLOP_UPDATE_FRLR = 0.D0 FLOP_UPDATE_FRFR = 0.D0 FLOP_MIDBLK_COMPRESS = 0.D0 FLOP_TRSM_FR = 0.D0 FLOP_TRSM_LR = 0.D0 FLOP_COMPRESS = 0.D0 FLOP_ACCUM_COMPRESS = 0.D0 FLOP_FRSWAP_COMPRESS = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 FLOP_FRFRONTS = 0.D0 FLOP_SOLFWD_FR = 0.D0 FLOP_SOLFWD_LR = 0.D0 TOTAL_NBLOCKS_ASS = 0 TOTAL_NBLOCKS_CB = 0 AVG_BLOCKSIZE_ASS = 0.D0 AVG_BLOCKSIZE_CB = 0.D0 MIN_BLOCKSIZE_ASS = huge(1) MAX_BLOCKSIZE_ASS = 0 MIN_BLOCKSIZE_CB = huge(1) MAX_BLOCKSIZE_CB = 0 CNT_NODES = 0 TIME_UPDATE = 0.D0 TIME_MIDBLK_COMPRESS = 0.D0 TIME_UPDATE_LRLR1 = 0.D0 TIME_UPDATE_LRLR2 = 0.D0 TIME_UPDATE_LRLR3 = 0.D0 TIME_UPDATE_FRLR = 0.D0 TIME_UPDATE_FRFR = 0.D0 TIME_COMPRESS = 0.D0 TIME_CB_COMPRESS = 0.D0 TIME_LR_MODULE = 0.D0 TIME_UPD_NELIM = 0.D0 TIME_LRTRSM = 0.D0 TIME_FRTRSM = 0.D0 TIME_PANEL = 0.D0 TIME_FAC_I = 0.D0 TIME_FAC_MQ = 0.D0 TIME_FAC_SQ = 0.D0 TIME_FRFRONTS = 0.D0 TIME_DIAGCOPY = 0.D0 TIME_FRSWAP_COMPRESS = 0.D0 TIME_DECOMP = 0.D0 TIME_DECOMP_UCFS = 0.D0 TIME_DECOMP_ASM1 = 0.D0 TIME_DECOMP_LOCASM2 = 0.D0 TIME_DECOMP_MAPLIG1 = 0.D0 TIME_DECOMP_ASMS2S = 0.D0 TIME_DECOMP_ASMS2M = 0.D0 END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE UPD_MRY_LU_FR(NASS, NCB, SYM, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, NELIM DOUBLE PRECISION :: MRY INTEGER :: NPIV NPIV = NASS - NELIM IF (SYM .GT. 0) THEN MRY = dble(NPIV)*(dble(NPIV)+1.D0)/2.D0 & + dble(NPIV)*dble(NCB+NELIM) ELSE MRY = dble(NPIV)*dble(NPIV) & + 2.0D0*dble(NPIV)*dble(NCB+NELIM) END IF !$OMP ATOMIC UPDATE MRY_LU_FR = MRY_LU_FR + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_FR SUBROUTINE UPD_MRY_CB(NROWS, NCOLS, & SYM, NIV, LRGAIN) INTEGER,INTENT(IN) :: NROWS, NCOLS, SYM, NIV, LRGAIN DOUBLE PRECISION :: MRY, LRGAIND IF (SYM.EQ.0) THEN MRY = dble(NCOLS)*dble(NROWS) ELSE MRY = dble(NCOLS-NROWS)*dble(NROWS) + & dble(NROWS)*dble(NROWS+1)/2.D0 ENDIF !$OMP ATOMIC UPDATE MRY_CB_FR = MRY_CB_FR + MRY !$OMP END ATOMIC LRGAIND=dble(LRGAIN) !$OMP ATOMIC UPDATE MRY_CB_LRGAIN = MRY_CB_LRGAIN + LRGAIND !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_CB SUBROUTINE UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_INASM, & NB_INCB, DIR) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR DOUBLE PRECISION :: FLOPFR, FLOPLR, MRY INTEGER :: I FLOPFR = 0.0D0 FLOPLR = 0.0D0 MRY = 0.0D0 IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN FLOPFR = FLOPFR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) FLOPLR = FLOPLR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) ENDIF DO I = 1, NB_INASM+NB_INCB IF (DIR .EQ. 'V') THEN FLOPFR = FLOPFR + & 2.0D0*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN FLOPLR = FLOPLR + & 2.0D0*dble((BLR_PANEL(I)%M+BLR_PANEL(I)%N) & *BLR_PANEL(I)%K) ELSE FLOPLR = FLOPLR + & 2.0D0*dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N) ENDIF ENDIF IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ENDIF ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE UPD_FLOP_FACTO_FR( NFRONT, NASS, NPIV, SYM, NIV) INTEGER,INTENT(IN) :: NFRONT, SYM, NASS, NPIV, NIV DOUBLE PRECISION :: FLOP CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP) !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC END SUBROUTINE UPD_FLOP_FACTO_FR SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2( NROW1, NCOL1, & NASS1, KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FAC CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FAC) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP_FAC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONTS SUBROUTINE UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NB_ENTRIES_FACTOR_withLR, & PROKG, MPG) INTEGER(8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: MPG LOGICAL, INTENT(IN) :: PROKG REAL, INTENT(IN) :: FLOP_NUMBER INTEGER(8), INTENT(OUT) :: & NB_ENTRIES_FACTOR_withLR IF (NB_ENTRIES_FACTOR < 0) THEN IF (PROKG.AND.MPG.GT.0) THEN WRITE(MPG,*) "NEGATIVE NUMBER OF ENTRIES IN FACTOR" WRITE(MPG,*) "===> OVERFLOW ?" END IF END IF IF (MRY_LU_FR .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & MRY_LU_LRGAIN/MRY_LU_FR ENDIF IF (MRY_CB_FR .EQ. 0) THEN MRY_CB_FR = 100.0D0 END IF NB_ENTRIES_FACTOR_withLR = NB_ENTRIES_FACTOR - & int(MRY_LU_LRGAIN,8) IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & MRY_LU_FR/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*MRY_LU_LRGAIN/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN + FLOP_COMPRESS & + FLOP_DECOMPRESS RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & ICNTL36, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, & K8110, K849, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,DEPTH, N, & ICNTL36, BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, & K472, K475, K478, K480, K481, K483, K484, & SYM, NPROCS INTEGER(8), INTENT(IN) :: K8110, K849 LOGICAL, INTENT(IN) :: PROKG REAL :: DKEEP(230) LOGICAL PROK PROK = (PROKG.AND.(MPG.GE.0)) IF (PROK) THEN WRITE(MPG,'(/A,A)') & '-------------- Beginning of BLR statistics -------------------', & '--------------' WRITE(MPG,'(A,I2)') & ' ICNTL(36) BLR variant = ', ICNTL36 WRITE(MPG,'(A,ES8.1)') & ' CNTL(7) Dropping parameter controlling accuracy = ', & DKEEP(8) WRITE(MPG,'(A)') & ' Statistics after BLR factorization :' WRITE(MPG,'(A,I8)') & ' Number of BLR fronts = ', & CNT_NODES ENDIF IF (PROK) WRITE(MPG,'(A,F8.1,A)') & ' Fraction of factors in BLR fronts =', & FACTOR_PROCESSED_FRACTION,'% ' IF (PROK) THEN WRITE(MPG,'(A)') & ' Statistics on the number of entries in factors :' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(29) Theoretical nb of entries in factors =' & ,real(K8110),' (100.0%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(35) Effective nb of entries (% of INFOG(29)) =' & ,real(K849),' (' & ,real(100)*(real(K849)/real(max(K8110,1_8))) & ,'%)' ENDIF IF (PROK) WRITE(MPG,'(A)') & ' Statistics on operation counts (OPC):' TOTAL_FLOP = MAX(TOTAL_FLOP,EPSILON(1.0D0)) DKEEP(55)=real(TOTAL_FLOP) DKEEP(60)=real(100) DKEEP(56)=real(FLOP_FACTO_LR+FLOP_FRFRONTS) DKEEP(61)=real(100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(3) Total theoretical operations counts =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(14) Total effective OPC (% of RINFOG(3)) =' & ,FLOP_FACTO_LR+FLOP_FRFRONTS,' (' &,100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP &,'%)' ENDIF IF (PROK) WRITE(MPG,'(A,A)') & '-------------- End of BLR statistics -------------------------', & '--------------' RETURN END SUBROUTINE SAVEandWRITE_GAINS END MODULE SMUMPS_LR_STATS MUMPS_5.4.1/src/dfac_process_contrib_type3.F0000664000175000017500000002515314102210522021116 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE DMUMPS_LOAD USE DMUMPS_OOC USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC ) :: root INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF DOUBLE PRECISION A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW INCLUDE 'mpif.h' INTEGER IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI INTEGER(8) :: LREQA, POS_ROOT INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF INTEGER NSUPCOL_EFF INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NSUPROW, NSUPCOL, BBPCBP INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISON, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPCOL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BBPCBP, 1, MPI_INTEGER, & COMM, IERR ) IF (BBPCBP .EQ. 1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF IROOT = KEEP( 38 ) IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR. & PTLUST( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL DMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in DMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_PRECISION, COMM, IERR ) OPASSW = OPASSW + LREQA CALL DMUMPS_ASS_ROOT( root, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in DMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL DMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_DOUBLE_PRECISION, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL DMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL DMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & root%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.4.1/src/mumps_io_basic.c0000664000175000017500000007334214102210474016656 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_io_basic.h" #include "mumps_io_err.h" #include "mumps_c_types.h" /* Exported global variables */ #if ! defined (MUMPS_WIN32) # if defined(WITH_PFUNC) && ! defined (WITHOUT_PTHREAD) # include pthread_mutex_t mumps_io_pwrite_mutex; # endif /* int* mumps_io_pfile_pointer_array; */ /* int* mumps_io_current_file; */ /* #else /\*MUMPS_WIN32*\/ */ /* FILE** mumps_io_current_file; */ /* FILE** mumps_io_pfile_pointer_array; */ #endif /* MUMPS_WIN32 */ /* mumps_file_struct* mumps_io_pfile_pointer_array; mumps_file_struct* mumps_io_current_file; */ mumps_file_type* mumps_files = NULL; /* int mumps_io_current_file_number; */ char* mumps_ooc_file_prefix = NULL; /* char** mumps_io_pfile_name; */ /* int mumps_io_current_file_position; */ /* int mumps_io_write_pos; */ /* int mumps_io_last_file_opened; */ MUMPS_INT mumps_elementary_data_size; MUMPS_INT mumps_io_is_init_called; MUMPS_INT mumps_io_myid; MUMPS_INT mumps_io_max_file_size; /* int mumps_io_nb_file; */ MUMPS_INT mumps_io_flag_async; MUMPS_INT mumps_io_k211; /* int mumps_flag_open;*/ MUMPS_INT mumps_directio_flag; MUMPS_INT mumps_io_nb_file_type; /* Functions */ MUMPS_INT mumps_set_file(MUMPS_INT type,MUMPS_INT file_number_arg){ /* Defines the pattern for the file name. The last 6 'X' will be replaced so as to name were unique */ char name[351]; #if ! defined(_WIN32) MUMPS_INT fd; char buf[64]; /* for error message */ #endif mumps_file_struct *mumps_io_pfile_pointer_array; if (file_number_arg > ((mumps_files+type)->mumps_io_nb_file)-1){ /* mumps_io_nb_file was initialized to the estimated number of files inside mumps_io_init_file_struct; this block is entered in case of a too small estimation of the required number of files. */ /* We increase the number of files needed and then realloc. */ ((mumps_files+type)->mumps_io_nb_file)++; (mumps_files+type)->mumps_io_pfile_pointer_array=(mumps_file_struct*)realloc((void *)(mumps_files+type)->mumps_io_pfile_pointer_array,((mumps_files+type)->mumps_io_nb_file)*sizeof(mumps_file_struct)); /* Check for reallocation problem */ if((mumps_files+type)->mumps_io_pfile_pointer_array==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } /* initialize "is_opened", as in mumps_io_init_file_struct */ ((mumps_files+type)->mumps_io_pfile_pointer_array+((mumps_files+type)->mumps_io_nb_file)-1)->is_opened = 0; } mumps_io_pfile_pointer_array=(mumps_files+type)->mumps_io_pfile_pointer_array; /* Do change the current file Careful: both mumps_io_current_file_number and mumps_io_current_file must be changed */ ((mumps_files+type)->mumps_io_current_file_number)=file_number_arg; ((mumps_files+type)->mumps_io_current_file)=mumps_io_pfile_pointer_array+file_number_arg; if((mumps_io_pfile_pointer_array+file_number_arg)->is_opened!=0){ /* The file already exists and is open. The i/o will be performed in the current file (which may not be the last one. */ return 0; } /*********************/ /* CREATE A NEW FILE */ /*********************/ /* #if ! defined( MUMPS_WIN32 )*/ /* MinGW does not have a mkstemp function and MinGW defines _WIN32, * so we also go in the else branch below with MinGW */ #if ! defined(_WIN32) strcpy(name,mumps_ooc_file_prefix); fd=mkstemp(name); /* Note that a file name is built by mkstemp and that the file is opened. fd hold the file descriptor to access it. We want to close the file that will be opened later and might be removed before the end of the processus. */ if(fd < 0) { sprintf(buf,"File creation failure"); return mumps_io_sys_error(-90,buf); } else { close(fd); } #else sprintf(name,"%s_%d_%d",mumps_ooc_file_prefix,((mumps_files+type)->mumps_io_current_file_number)+1,type); #endif /* *(mumps_io_pfile_pointer_array+mumps_io_current_file_number)=fopen(name,"w+"); */ /* *(mumps_io_pfile_name+mumps_io_current_file_number)=(char *)malloc((strlen(name)+1)*sizeof(char)); */ /* if(*(mumps_io_pfile_name+mumps_io_current_file_number)==NULL){ */ /* sprintf(error_str,"Allocation problem in low-level OOC layer\n"); */ /* return -13; */ /* } */ strcpy((mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number)->name,name); /* See mumps_io_basic.h for comments on the I/O flags passed to open */ #if ! defined( MUMPS_WIN32 ) (mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number)->file=open(name,(mumps_files+type)->mumps_flag_open,0666); /* CPA: for LU factor file: (mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number)->file= open(name, O_WRONLY | O_CREAT | O_TRUNC, 0666); */ if((mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number)->file==-1){ return mumps_io_sys_error(-90,"Unable to open OOC file"); } #else (mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number)->file=fopen(name,(mumps_files+type)->mumps_flag_open); if((mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number)->file==NULL){ return mumps_io_error(-90,"Problem while opening OOC file"); } #endif (mumps_files+type)->mumps_io_current_file=(mumps_io_pfile_pointer_array+(mumps_files+type)->mumps_io_current_file_number); ((mumps_files+type)->mumps_io_nb_file_opened)++; if((mumps_files+type)->mumps_io_current_file_number>(mumps_files+type)->mumps_io_last_file_opened){ (mumps_files+type)->mumps_io_last_file_opened=(mumps_files+type)->mumps_io_current_file_number; } /* if(*(mumps_io_pfile_pointer_array+mumps_io_current_file_number)==NULL) */ ((mumps_files+type)->mumps_io_current_file)->write_pos=0; ((mumps_files+type)->mumps_io_current_file)->is_opened=1; /* printf("new file created -> num = %d \n", ((mumps_files+type)->mumps_io_last_file_opened));*/ /* printf("new file created %d\n",mumps_io_current_file_number);*/ return 0; } void mumps_update_current_file_position(mumps_file_struct* file_arg){ file_arg->current_pos=file_arg->write_pos; /* mumps_io_current_file_position=mumps_io_write_pos; */ } MUMPS_INT mumps_compute_where_to_write(const double to_be_written,const MUMPS_INT type,long long vaddr,size_t already_written){ /* Check if the current file has enough memory to receive the whole block*/ MUMPS_INT ret_code; MUMPS_INT file; mumps_file_struct *current_file; long long vaddr_loc; MUMPS_INT pos; /* Virtual address based file management scheme */ vaddr_loc=vaddr*(long long)mumps_elementary_data_size+(long long)already_written; mumps_gen_file_info(vaddr_loc,&pos,&file); ret_code=mumps_set_file(type,file); if(ret_code<0){ return ret_code; } current_file=(mumps_files+type)->mumps_io_current_file; current_file->write_pos=pos; mumps_update_current_file_position(current_file); return 0; } MUMPS_INT mumps_prepare_pointers_for_write(double to_be_written,MUMPS_INT * pos_in_file, MUMPS_INT * file_number,const MUMPS_INT type,long long vaddr,size_t already_written){ MUMPS_INT ret_code; ret_code=mumps_compute_where_to_write(to_be_written,type,vaddr,already_written); if(ret_code<0){ return ret_code; } *pos_in_file=((mumps_files+type)->mumps_io_current_file)->current_pos; /* should be modified to take into account the file arg */ *file_number=(mumps_files+type)->mumps_io_current_file_number; return 0; } MUMPS_INLINE MUMPS_INT mumps_gen_file_info(long long vaddr, MUMPS_INT * pos, MUMPS_INT * file){ *file=(MUMPS_INT)(vaddr/(long long)mumps_io_max_file_size); *pos=(MUMPS_INT)(vaddr%(long long)mumps_io_max_file_size); return 0; } MUMPS_INT mumps_compute_nb_concerned_files(long long block_size, MUMPS_INT * nb_concerned_files,long long vaddr){ MUMPS_INT file,pos,available_size; long long vaddr_loc; vaddr_loc=vaddr*(long long)mumps_elementary_data_size; mumps_gen_file_info(vaddr_loc,&pos,&file); available_size=mumps_io_max_file_size-pos+1; *nb_concerned_files=(MUMPS_INT)my_ceil((double)(my_max(0,((block_size)*(double)(mumps_elementary_data_size))-available_size))/(double)mumps_io_max_file_size)+1; return 0; } MUMPS_INT mumps_io_do_write_block(void * address_block, long long block_size, MUMPS_INT * type_arg, long long vaddr, MUMPS_INT * ierr){ /* Type of fwrite : size_t fwrite(const void *ptr, size_t size, *size_t nmemb, FILE *stream); */ size_t write_size; MUMPS_INT i; MUMPS_INT nb_concerned_files=0; MUMPS_INT ret_code,file_number_loc,pos_in_file_loc; double to_be_written; #if ! defined( MUMPS_WIN32 ) MUMPS_INT* file; #else FILE** file; #endif MUMPS_INT where; void* loc_addr; MUMPS_INT type; size_t already_written=0; char buf[64]; type=*type_arg; loc_addr=address_block; mumps_compute_nb_concerned_files(block_size,&nb_concerned_files,vaddr); to_be_written=((double)mumps_elementary_data_size)*((double)(block_size)); /* printf("nb_concerned -> %d | %lf \n",nb_concerned_files,to_be_written); */ for(i=0;imumps_io_current_file)->write_pos)>to_be_written){ write_size=(size_t)to_be_written; already_written=(size_t)to_be_written; }else{ write_size=(size_t)((double)(mumps_io_max_file_size-((mumps_files+type)->mumps_io_current_file)->write_pos)); already_written=already_written+(size_t)write_size; } #if defined( MUMPS_WIN32 ) write_size=(size_t)(MUMPS_INT)((write_size)/mumps_elementary_data_size); #endif file=&(((mumps_files+type)->mumps_io_current_file)->file); where=((mumps_files+type)->mumps_io_current_file)->write_pos; #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC if(mumps_io_flag_async==IO_ASYNC_TH){ mumps_io_unprotect_pointers(); } # endif #endif ret_code=mumps_io_write__(file,loc_addr,write_size,where,type); if(ret_code<0){ return ret_code; } #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC if(mumps_io_flag_async==IO_ASYNC_TH){ mumps_io_protect_pointers(); } # endif #endif #if ! defined( MUMPS_WIN32 ) ((mumps_files+type)->mumps_io_current_file)->write_pos=((mumps_files+type)->mumps_io_current_file)->write_pos+((MUMPS_INT)write_size); to_be_written=to_be_written-((MUMPS_INT)write_size); loc_addr=(void*)((size_t)loc_addr+write_size); /* mumps_io_write_pos=mumps_io_write_pos+((MUMPS_INT)write_size); */ /* to_be_written=to_be_written-((MUMPS_INT)write_size); */ /* loc_addr=(void*)((size_t)loc_addr+write_size); */ #else /* fread and write */ ((mumps_files+type)->mumps_io_current_file)->write_pos=((mumps_files+type)->mumps_io_current_file)->write_pos+((MUMPS_INT)write_size*mumps_elementary_data_size); to_be_written=to_be_written-((MUMPS_INT)write_size*mumps_elementary_data_size); loc_addr=(void*)((size_t)loc_addr+(size_t)((MUMPS_INT)write_size*mumps_elementary_data_size)); /* mumps_io_write_pos=mumps_io_write_pos+((MUMPS_INT)write_size*mumps_elementary_data_size); */ /* to_be_written=to_be_written-((MUMPS_INT)write_size*mumps_elementary_data_size); */ /* loc_addr=(void*)((size_t)loc_addr+(size_t)((MUMPS_INT)write_size*mumps_elementary_data_size)); */ #endif #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC if(mumps_io_flag_async==IO_ASYNC_TH){ mumps_io_unprotect_pointers(); } # endif #endif } if(to_be_written!=0){ *ierr = -90; sprintf(buf,"Internal (1) error in low-level I/O operation %lf",to_be_written); return mumps_io_error(*ierr,buf); } /* printf("write ok -> %d \n");*/ return 0; } MUMPS_INT mumps_io_do_read_block(void * address_block, long long block_size, MUMPS_INT * type_arg, long long vaddr, MUMPS_INT * ierr){ size_t size; #if ! defined( MUMPS_WIN32 ) MUMPS_INT* file; #else FILE** file; #endif double read_size; MUMPS_INT local_fnum,local_offset; void *loc_addr; long long vaddr_loc; MUMPS_INT type; type=*type_arg; /* if(((double)(*block_size))*((double)(mumps_elementary_data_size))>(double)mumps_io_max_file_size){ sprintf(error_str,"Internal error in low-level I/O operation (requested size too big for file system) \n"); return -90; }*/ if(block_size==0){ return 0; } read_size=(double)mumps_elementary_data_size*(double)(block_size); /* if((*file_number<0)&&(read_size<(double)mumps_io_max_file_size)){ sprintf(error_str,"Internal error (1) in low level read op\n"); return -90; }*/ loc_addr=address_block; vaddr_loc=vaddr*(long long)mumps_elementary_data_size; while(read_size>0){ /* Virtual addressing based management stuff */ local_fnum=(MUMPS_INT)(vaddr_loc/(long long)mumps_io_max_file_size); local_offset=(MUMPS_INT)(vaddr_loc%(long long)mumps_io_max_file_size); file=&((((mumps_files+type)->mumps_io_pfile_pointer_array)+local_fnum)->file); /* printf("1 read | file -> %d | fnum -> %d | vaddr -> %d \n",*file,local_fnum,(MUMPS_INT)vaddr_loc); */ #if ! defined( MUMPS_WIN32 ) if(read_size+(double)local_offset>(double)mumps_io_max_file_size){ size=(size_t)mumps_io_max_file_size-(size_t)local_offset; }else{ size=(size_t)read_size; } #else if(read_size+(double)local_offset>(double)mumps_io_max_file_size){ size=((size_t)mumps_io_max_file_size-(size_t)local_offset)/(size_t)mumps_elementary_data_size; }else{ size=(size_t)(read_size/mumps_elementary_data_size); } #endif *ierr=mumps_io_read__(file,loc_addr,size,local_offset,type); if(*ierr<0){ return *ierr; } #if defined( MUMPS_WIN32 ) size=size*mumps_elementary_data_size; #endif vaddr_loc=vaddr_loc+(long long)size; read_size=read_size-(double)size; loc_addr=(void*)((size_t)loc_addr+size); local_fnum++; local_offset=0; if(local_fnum>(mumps_files+type)->mumps_io_nb_file){ *ierr = -90; return mumps_io_error(*ierr,"Internal error (2) in low level read op\n"); } } return 0; } MUMPS_INT mumps_free_file_pointers(MUMPS_INT *step){ MUMPS_INT i,j,bound,ierr; /* Free prefix only for facto */ if (*step == 0) free(mumps_ooc_file_prefix); if(mumps_files == NULL ) return 0; #if ! defined( MUMPS_WIN32 ) #endif bound=mumps_io_nb_file_type; /* if(*step==0){ */ /* /\* factorization *\/ */ /* bound=NB_FILE_TYPE_FACTO; */ /* }else{ */ /* /\* solve *\/ */ /* bound=NB_FILE_TYPE_SOLVE; */ /* } */ for(j=0;jmumps_io_nb_file_opened;i++){ #if ! defined( MUMPS_WIN32 ) ierr=close((((mumps_files+j)->mumps_io_pfile_pointer_array)+i)->file); if(ierr==-1){ return mumps_io_sys_error(-90,"Problem while closing OOC file"); } #else ierr=fclose((((mumps_files+j)->mumps_io_pfile_pointer_array)+i)->file); if(ierr==-1){ return mumps_io_error(-90,"Problem while closing OOC file\n"); } #endif /* free(*(mumps_io_pfile_name+i)); */ } free((mumps_files+j)->mumps_io_pfile_pointer_array); } /* free(mumps_io_pfile_name); */ free(mumps_files); #if ! defined( MUMPS_WIN32 ) #endif return 0; } /* Initialize the mumps_file_type structure at th position in mumps_files. It only set values with no allocation to avoid any errors. */ void mumps_io_init_file_struct(MUMPS_INT* nb,MUMPS_INT which) { (mumps_files+which)->mumps_io_current_file_number = -1; (mumps_files+which)->mumps_io_last_file_opened = -1; (mumps_files+which)->mumps_io_nb_file_opened = 0; (mumps_files+which)->mumps_io_nb_file=*nb; (mumps_files+which)->mumps_io_pfile_pointer_array = NULL; (mumps_files+which)->mumps_io_current_file=NULL; } /* Allocate the file structures for factor files and initialize the is_opened filed to 0 */ MUMPS_INT mumps_io_alloc_file_struct(MUMPS_INT* nb,MUMPS_INT which) { MUMPS_INT i; (mumps_files+which)->mumps_io_pfile_pointer_array=(mumps_file_struct *)malloc((*nb)*sizeof(mumps_file_struct)); if((mumps_files+which)->mumps_io_pfile_pointer_array==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } for(i=0;i<*nb;i++){ (((mumps_files+which)->mumps_io_pfile_pointer_array)+i)->is_opened=0; } return 0; } MUMPS_INT mumps_init_file_structure(MUMPS_INT* _myid, long long *total_size_io,MUMPS_INT *size_element,MUMPS_INT *nb_file_type,MUMPS_INT *flag_tab) { /* Computes the number of files needed. Uses ceil value. */ MUMPS_INT ierr; #if ! defined( MUMPS_WIN32 ) MUMPS_INT mumps_flag_open; #endif MUMPS_INT i,nb; MUMPS_INT mumps_io_nb_file; mumps_io_max_file_size=MAX_FILE_SIZE; mumps_io_nb_file_type=*nb_file_type; mumps_io_nb_file=(MUMPS_INT)((((double)(*total_size_io)*1000000)*((double)(*size_element)))/(double)mumps_io_max_file_size)+1; mumps_directio_flag=0; #if ! defined( MUMPS_WIN32 ) mumps_flag_open=0; #endif mumps_io_myid=*_myid; mumps_elementary_data_size=*size_element; /* Allocates the memory necessary to handle the file pointer array.*/ mumps_files=(mumps_file_type *)malloc(mumps_io_nb_file_type*sizeof(mumps_file_type)); if(mumps_files==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } /* Safe initialization of the mumps_file_type elements */ for(i=0;imumps_flag_open=mumps_flag_open|O_WRONLY|O_CREAT|O_TRUNC; # if defined(__MINGW32__) /* O_BINARY necessary */ (mumps_files+i)->mumps_flag_open=(mumps_files+i)->mumps_flag_open|O_BINARY; # endif #else strcpy((mumps_files+i)->mumps_flag_open,"wb"); #endif break; case 1: #if ! defined( MUMPS_WIN32 ) (mumps_files+i)->mumps_flag_open=mumps_flag_open|O_RDONLY|O_CREAT|O_TRUNC; # if defined(__MINGW32__) /* O_BINARY necessary */ (mumps_files+i)->mumps_flag_open=(mumps_files+i)->mumps_flag_open|O_BINARY; # endif #else strcpy((mumps_files+i)->mumps_flag_open,"rb"); #endif break; case 2: #if ! defined( MUMPS_WIN32 ) (mumps_files+i)->mumps_flag_open=mumps_flag_open|O_RDWR|O_CREAT|O_TRUNC; # if defined(__MINGW32__) /* O_BINARY necessary */ (mumps_files+i)->mumps_flag_open=(mumps_files+i)->mumps_flag_open|O_BINARY; # endif #else strcpy((mumps_files+i)->mumps_flag_open,"rwb"); #endif break; default: return mumps_io_error(-90,"unknown value of flag_open\n"); } ierr=mumps_io_alloc_file_struct(&nb,i); if(ierr<0){ return ierr; } ierr=mumps_set_file(i,0); if(ierr<0){ return ierr; } } /* Init the current file.*/ return 0; } MUMPS_INT mumps_init_file_name(char* mumps_dir,char* mumps_file, MUMPS_INT* mumps_dim_dir,MUMPS_INT* mumps_dim_file,MUMPS_INT* _myid){ MUMPS_INT i; char *tmp_dir,*tmp_fname; char base_name[20]; MUMPS_INT dir_flag=0,file_flag=0; char mumps_base[10]="mumps_"; tmp_dir=(char *)malloc(((*mumps_dim_dir)+1)*sizeof(char)); if(tmp_dir==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } tmp_fname=(char *)malloc(((*mumps_dim_file)+1)*sizeof(char)); if(tmp_fname==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } for(i=0;i<*mumps_dim_dir;i++){ tmp_dir[i]=mumps_dir[i]; } tmp_dir[i]=0; for(i=0;i<*mumps_dim_file;i++){ tmp_fname[i]=mumps_file[i]; } tmp_fname[i]=0; if(strcmp(tmp_dir,UNITIALIZED)==0){ dir_flag=1; free(tmp_dir); tmp_dir=getenv("MUMPS_OOC_TMPDIR"); if(tmp_dir==NULL){ #ifdef _AIX # ifndef CINES_ tmp_dir=getenv("TMPDIR"); if(tmp_dir==NULL){ tmp_dir=MUMPS_OOC_DEFAULT_DIR; } # else tmp_dir=MUMPS_OOC_DEFAULT_DIR; # endif #else tmp_dir=MUMPS_OOC_DEFAULT_DIR; #endif } } if(strcmp(tmp_fname,UNITIALIZED)==0){ free(tmp_fname); tmp_fname=getenv("MUMPS_OOC_PREFIX"); file_flag=1; } if(tmp_fname!=NULL){ #if ! defined( MUMPS_WIN32 ) sprintf(base_name,"_%s%d_XXXXXX",mumps_base,(int)*_myid); #else sprintf(base_name,"_%s%d",mumps_base,*_myid); #endif mumps_ooc_file_prefix=(char *)malloc((strlen(SEPARATOR)+strlen(tmp_dir)+strlen(tmp_fname)+strlen(base_name)+1+1)*sizeof(char)); if(mumps_ooc_file_prefix==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } sprintf(mumps_ooc_file_prefix,"%s%s%s%s",tmp_dir,SEPARATOR,tmp_fname,base_name); }else{ #if ! defined( MUMPS_WIN32 ) sprintf(base_name,"%s%s%d_XXXXXX",SEPARATOR,mumps_base,(int)*_myid); #else sprintf(base_name,"%s%s%d",SEPARATOR,mumps_base,*_myid); #endif mumps_ooc_file_prefix=(char *)malloc((strlen(SEPARATOR)+strlen(tmp_dir)+strlen(base_name)+1)*sizeof(char)); if(mumps_ooc_file_prefix==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } sprintf(mumps_ooc_file_prefix,"%s%s%s",tmp_dir,SEPARATOR,base_name); } if(!dir_flag){ free(tmp_dir); } if(!file_flag){ free(tmp_fname); } return 0; } MUMPS_INT mumps_io_get_nb_files(MUMPS_INT* nb_files, const MUMPS_INT* type){ *nb_files=((mumps_files+*type)->mumps_io_last_file_opened)+1; return 0; } MUMPS_INT mumps_io_get_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type){ MUMPS_INT i; i=(*indice)-1; strcpy(name,(((mumps_files+*type)->mumps_io_pfile_pointer_array)+i)->name); *length=(MUMPS_INT)strlen(name)+1; return 0; } MUMPS_INT mumps_io_alloc_pointers(MUMPS_INT* nb_file_type,MUMPS_INT * dim){ MUMPS_INT ierr; MUMPS_INT i; /* This is called by solve step, we have only one type of files */ mumps_io_nb_file_type=*nb_file_type; mumps_files=(mumps_file_type *)malloc(mumps_io_nb_file_type*sizeof(mumps_file_type)); if(mumps_files==NULL){ return mumps_io_error(-13,"Allocation problem in low-level OOC layer\n"); } for(i=0;imumps_flag_open=mumps_flag_open|O_RDONLY; #else strcpy((mumps_files+i)->mumps_flag_open,"rb"); #endif } mumps_io_myid=*myid_arg; mumps_elementary_data_size=*size_element; mumps_io_flag_async=*async_arg; return 0; } MUMPS_INT mumps_io_set_file_name(MUMPS_INT* indice,char* name,MUMPS_INT* length,MUMPS_INT* type){ MUMPS_INT i; i=(*indice)-1; /* *(mumps_io_pfile_name+i)=(char *) malloc((*length)*strlen(name)); */ /* if(*(mumps_io_pfile_name+i)==NULL){ */ /* sprintf(error_str,"Allocation problem in low-level OOC layer"); */ /* return -13; */ /* } */ strcpy((((mumps_files+*type)->mumps_io_pfile_pointer_array)+i)->name,name); return 0; } MUMPS_INT mumps_io_open_files_for_read(){ MUMPS_INT i,j; mumps_file_struct *mumps_io_pfile_pointer_array; #if defined (sgi) || defined (__sgi) struct dioattr dio; #endif for(j=0;jmumps_io_pfile_pointer_array; for(i=0;i<(mumps_files+j)->mumps_io_nb_file;i++){ #if ! defined( MUMPS_WIN32 ) (mumps_io_pfile_pointer_array+i)->file=open((mumps_io_pfile_pointer_array+i)->name,(mumps_files+j)->mumps_flag_open); if((mumps_io_pfile_pointer_array+i)->file==-1){ return mumps_io_sys_error(-90,"Problem while opening OOC file"); } #else (mumps_io_pfile_pointer_array+i)->file=fopen((mumps_io_pfile_pointer_array+i)->name,(mumps_files+j)->mumps_flag_open); if((mumps_io_pfile_pointer_array+i)->file==NULL){ return mumps_io_error(-90,"Problem while opening OOC file"); } (mumps_io_pfile_pointer_array+i)->is_opened=1; #endif } } return 0; } MUMPS_INT mumps_io_set_last_file(MUMPS_INT* dim,MUMPS_INT* type){ (mumps_files+*type)->mumps_io_last_file_opened=*dim-1; (mumps_files+*type)->mumps_io_nb_file_opened=*dim; return 0; } #if ! defined( MUMPS_WIN32 ) && ! defined (WITHOUT_PTHREAD) # ifdef WITH_PFUNC MUMPS_INT mumps_io_protect_pointers(){ pthread_mutex_lock(&mumps_io_pwrite_mutex); return 0; } MUMPS_INT mumps_io_unprotect_pointers(){ pthread_mutex_unlock(&mumps_io_pwrite_mutex); return 0; } MUMPS_INT mumps_io_init_pointers_lock(){ pthread_mutex_init(&mumps_io_pwrite_mutex,NULL); return 0; } MUMPS_INT mumps_io_destroy_pointers_lock(){ pthread_mutex_destroy(&mumps_io_pwrite_mutex); return 0; } # endif /*WITH_PFUNC*/ #endif /* _WIN32 && WITHOUT_PTHREAD */ MUMPS_INT mumps_io_read__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset,MUMPS_INT type){ MUMPS_INT ret_code; #if ! defined( MUMPS_WIN32 ) if(!mumps_directio_flag){ ret_code=mumps_io_read_os_buff__(file,loc_addr, size,local_offset); if(ret_code<0){ return ret_code; } } #else ret_code=mumps_io_read_win32__(file,loc_addr, size,local_offset); if(ret_code<0){ return ret_code; } #endif return 0; } #if ! defined( MUMPS_WIN32 ) MUMPS_INT mumps_io_read_os_buff__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset){ size_t ret_code; /* printf("Read with buff %d %d %d\n",(MUMPS_INT) size, local_offset,*((MUMPS_INT *)file)); */ # ifdef WITH_PFUNC ret_code=pread(*(MUMPS_INT *)file,loc_addr,size,local_offset); # else lseek(*(MUMPS_INT *)file,(long) local_offset,SEEK_SET); ret_code=read(*(MUMPS_INT *)file,loc_addr,size); # endif if((MUMPS_INT) ret_code==-1){ return mumps_io_sys_error(-90,"Problem with low level read"); } return 0; } #endif #if defined( MUMPS_WIN32 ) MUMPS_INT mumps_io_read_win32__(void * file,void * loc_addr,size_t size,MUMPS_INT local_offset){ size_t ret_code; fseek(*(FILE **)file,(long) local_offset,SEEK_SET); ret_code=fread(loc_addr,mumps_elementary_data_size,size,*(FILE **)file); if((ret_code!=size)||(ferror(*(FILE**)file))){ return mumps_io_error(-90,"Problem with I/O operation\n"); } return 0; } #endif MUMPS_INT mumps_io_write__(void *file, void *loc_addr, size_t write_size, MUMPS_INT where,MUMPS_INT type){ MUMPS_INT ret_code; #if ! defined( MUMPS_WIN32 ) if(!mumps_directio_flag){ ret_code=mumps_io_write_os_buff__(file,loc_addr, write_size,where); if(ret_code<0){ return ret_code; } } #else ret_code=mumps_io_write_win32__(file,loc_addr, write_size,where); if(ret_code<0){ return ret_code; } #endif return 0; } #if ! defined( MUMPS_WIN32 ) MUMPS_INT mumps_io_write_os_buff__(void *file, void *loc_addr, size_t write_size, MUMPS_INT where){ size_t ret_code; /* printf("write with buff %d %d %d\n",(MUMPS_INT) write_size, where,*((MUMPS_INT *)file)); */ # ifdef WITH_PFUNC ret_code=pwrite(*(MUMPS_INT *)file,loc_addr,write_size,where); # else /*in this case all the I/O's are made by the I/O thread => we don't need to protect the file pointer.*/ lseek(*(MUMPS_INT *)file,(long)where,SEEK_SET); ret_code=write(*(MUMPS_INT *)file,loc_addr,write_size); # endif if((MUMPS_INT)ret_code==-1){ return mumps_io_sys_error(-90,"Problem with low level write"); } else if(ret_code!=write_size){ return mumps_io_error(-90,"Error not enough space on disk \n"); } return 0; } #endif #if defined( MUMPS_WIN32 ) MUMPS_INT mumps_io_write_win32__(void *file, void *loc_addr, size_t write_size, MUMPS_INT where){ size_t ret_code; fseek(*(FILE **)file,(long)where,SEEK_SET); ret_code=fwrite(loc_addr,mumps_elementary_data_size, write_size,*(FILE**)file); if((ret_code!=write_size)||(ferror(*(FILE**)file))){ return mumps_io_error(-90,"Problem with I/O operation\n"); } return 0; } #endif MUMPS_INT mumps_compute_file_size(void *file,size_t *size){ /* Compute the size of the file pointed by file and return it in size */ #if defined(MUMPS_WIN32) /* This works well as soon as we don't use threads under WIN32 */ MUMPS_INT ret_code; long pos=0; /* Get the current position */ pos=ftell(*(FILE **)file); /* Move the file pointer to the end of the file */ fseek(*(FILE **)file,0,SEEK_END); /* Get the current position which is in fact the size */ *size=(size_t)ftell(*(FILE **)file); /* Restore the old position */ fseek(*(FILE **)file,pos,SEEK_SET); #else struct stat file_info; /* fstat does everything :-) */ fstat(*(MUMPS_INT *)file, &file_info); *size = (size_t)file_info.st_size; #endif return 0; } MUMPS_5.4.1/src/csol_distrhs.F0000664000175000017500000005410014102210523016312 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSCOMP, LD_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE CMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size COMPLEX, INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSCOMP, LD_RHSCOMP INTEGER, INTENT(IN) :: POSINRHSCOMP_FWD(N) COMPLEX, INTENT(OUT) :: RHSCOMP(LD_RHSCOMP, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV COMPLEX, PARAMETER :: ZERO = (0.0E0, 0.0E0) !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ENDIF NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL CMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSCOMP), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in CMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSCOMP ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSCOMP,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSCOMP TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL CMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL CMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL CMUMPS_DR_TRY_RECV() CALL CMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL CMUMPS_DR_TRY_RECV() CALL CMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL CMUMPS_DR_TRY_FREE_SEND() ENDDO CALL CMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE CMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE CMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE CMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_COMPLEX, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL CMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE CMUMPS_DR_TRY_RECV SUBROUTINE CMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) COMPLEX, INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in CMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSCOMP=POSINRHSCOMP_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSCOMP IF ( .NOT. TOUCHED(IRHSCOMP) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSCOMP=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS IRHSCOMP=BUFRECI_ARG(I) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K) + & BUFRECR_ARG(I,K) ENDDO ENDDO !$OMP END PARALLEL DO DO I = 1, NBRECORDS IRHSCOMP = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE CMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE CMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSCOMP INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in CMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT)* & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE CMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE CMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DR_GET_NEW_BUF SUBROUTINE CMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DR_TRY_FREE_SEND SUBROUTINE CMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in CMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in CMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL CMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) * & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_COMPLEX, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_DR_TRY_SEND SUBROUTINE CMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSCOMP ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSCOMP > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSCOMP IF ( .NOT. TOUCHED(IFS) ) THEN RHSCOMP( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE CMUMPS_DR_EMPTY_ROWS END SUBROUTINE CMUMPS_SCATTER_DIST_RHS SUBROUTINE CMUMPS_SOL_INIT_IRHS_loc(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in CMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%ICNTL(20).EQ.10) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_BUILD_IRHS_loc(id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE CMUMPS_SOL_INIT_IRHS_loc MUMPS_5.4.1/src/fac_maprow_data_m.F0000664000175000017500000002445114102210475017251 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FAC_MAPROW_DATA_M IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) C ========================================= C The MUMPS_FAC_MAPROW_DATA_M module stores C the MAPROW messages that arrive too early. C It is based on the MUMPS_FRONT_DATA_MGT_M C module. C C An array of structures that contain MAPROW C information is used as a global variable in C this module. It is indexed by an "IWHANDLER" C (stored in the main IW array) that is C managed by the MUMPS_FRONT_DATA_MGT_M module. C C The same handler can be used for other data C stored for active type 2 fronts (DESCBAND C information, typically) C ======================================== C PRIVATE PUBLIC :: MAPROW_STRUC_T, MUMPS_FMRD_INIT, MUMPS_FMRD_END, & MUMPS_FMRD_SAVE_MAPROW, MUMPS_FMRD_IS_MAPROW_STORED, & MUMPS_FMRD_RETRIEVE_MAPROW, & MUMPS_FMRD_FREE_MAPROW_STRUC TYPE MAPROW_STRUC_T INTEGER :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER INTEGER,POINTER, DIMENSION(:) :: SLAVES_PERE !size NSLAVES_PERE INTEGER,POINTER, DIMENSION(:) :: TROW !size LMAP END TYPE MAPROW_STRUC_T TYPE (MAPROW_STRUC_T), POINTER, DIMENSION(:), SAVE :: FMRD_ARRAY CONTAINS FUNCTION MUMPS_FMRD_IS_MAPROW_STORED( IWHANDLER ) LOGICAL :: MUMPS_FMRD_IS_MAPROW_STORED INTEGER, INTENT(IN) :: IWHANDLER IF (IWHANDLER .LT. 0 .OR. IWHANDLER .GT. size(FMRD_ARRAY)) THEN MUMPS_FMRD_IS_MAPROW_STORED = .FALSE. ELSE MUMPS_FMRD_IS_MAPROW_STORED = & (FMRD_ARRAY(IWHANDLER)%INODE .GE. 0 ) IF (FMRD_ARRAY(IWHANDLER)%INODE .EQ.0) THEN WRITE(*,*) " Internal error 1 in MUMPS_FMRD_IS_MAPROW_STORED" CALL MUMPS_ABORT() ENDIF ENDIF RETURN END FUNCTION MUMPS_FMRD_IS_MAPROW_STORED C SUBROUTINE MUMPS_FMRD_INIT( INITIAL_SIZE, INFO ) C C Purpose: C ======= C C Module initialization C C Arguments C ========= C INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables C =============== C INTEGER :: I, IERR C ALLOCATE(FMRD_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE FMRD_ARRAY(I)%INODE=-9999 NULLIFY(FMRD_ARRAY(I)%SLAVES_PERE) NULLIFY(FMRD_ARRAY(I)%TROW) ENDDO RETURN END SUBROUTINE MUMPS_FMRD_INIT C SUBROUTINE MUMPS_FMRD_SAVE_MAPROW( & IWHANDLER, & INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE, !size NSLAVES_PERE & TROW, !size LMAP & INFO) C C Arguments: C ========= C INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER INTEGER, INTENT(IN) :: SLAVES_PERE (max(1,NSLAVES_PERE)) INTEGER, INTENT(IN) :: TROW( LMAP) INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) C C Local variables: C =============== C TYPE(MAPROW_STRUC_T) :: MAPROW_STRUC C CALL MUMPS_FMRD_FILL_MAPROW( MAPROW_STRUC, & INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE, !size NSLAVES_PERE & TROW, !size LMAP & INFO) IF (INFO(1) .LT. 0) RETURN CALL MUMPS_FMRD_STORE_MAPROW(IWHANDLER, MAPROW_STRUC, INFO) RETURN END SUBROUTINE MUMPS_FMRD_SAVE_MAPROW C SUBROUTINE MUMPS_FMRD_STORE_MAPROW(IWHANDLER, MAPROW_STRUC, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX C C Purpose: C ======= C C Given an IWHANDLER and a MAPROW structure, store the MAPROW C structure into the main array of the module. C C If IWHANDLER is larger than the current array size, the C array is reallocated. C C Arguments: C ========= C INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) TYPE(MAPROW_STRUC_T), INTENT(IN) :: MAPROW_STRUC C C Local variables: C =============== C TYPE(MAPROW_STRUC_T), POINTER, DIMENSION(:) :: FMRD_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR C CALL MUMPS_FDM_START_IDX('A', 'MAPROW', IWHANDLER, INFO) IF (INFO(1) .LT. 0) RETURN IF (IWHANDLER > size(FMRD_ARRAY)) THEN C Reallocate in a bigger array OLD_SIZE = size(FMRD_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) C ALLOCATE(FMRD_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE RETURN ENDIF DO I=1, OLD_SIZE FMRD_ARRAY_TMP(I)=FMRD_ARRAY(I) ENDDO C Similar to code in MUMPS_FMRD_INIT: DO I=OLD_SIZE+1, NEW_SIZE FMRD_ARRAY_TMP(I)%INODE = -9999 NULLIFY(FMRD_ARRAY_TMP(I)%SLAVES_PERE) NULLIFY(FMRD_ARRAY_TMP(I)%TROW) ENDDO DEALLOCATE(FMRD_ARRAY) FMRD_ARRAY=>FMRD_ARRAY_TMP NULLIFY(FMRD_ARRAY_TMP) ENDIF FMRD_ARRAY(IWHANDLER) = MAPROW_STRUC RETURN END SUBROUTINE MUMPS_FMRD_STORE_MAPROW SUBROUTINE MUMPS_FMRD_FILL_MAPROW(MAPROW_STRUC, & INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE, !size NSLAVES_PERE & TROW, !size LMAP & INFO) C C Purpose: C ======= C Fill the MAPROW_STRUC into C C Arguments: C ========= C INTEGER, INTENT(IN) :: INODE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER INTEGER, INTENT(IN) :: SLAVES_PERE(max(1,NSLAVES_PERE)) INTEGER, INTENT(IN) :: TROW( LMAP) TYPE (MAPROW_STRUC_T), INTENT(OUT) :: MAPROW_STRUC INTEGER, INTENT(INOUT) :: INFO(2) C C Local variables: C =============== C INTEGER :: IERR, I C MAPROW_STRUC%INODE = INODE MAPROW_STRUC%ISON = ISON MAPROW_STRUC%NSLAVES_PERE = NSLAVES_PERE MAPROW_STRUC%NFRONT_PERE = NFRONT_PERE MAPROW_STRUC%NASS_PERE = NASS_PERE MAPROW_STRUC%LMAP = LMAP MAPROW_STRUC%NFS4FATHER = NFS4FATHER ALLOCATE(MAPROW_STRUC%SLAVES_PERE(max(1,NSLAVES_PERE)), & MAPROW_STRUC%TROW(LMAP), stat=IERR) IF (IERR .GT.0) THEN INFO(1) = -13 INFO(2) = NSLAVES_PERE + LMAP RETURN ENDIF DO I=1, NSLAVES_PERE MAPROW_STRUC%SLAVES_PERE(I) = SLAVES_PERE(I) ENDDO DO I=1, LMAP MAPROW_STRUC%TROW(I) = TROW(I) ENDDO RETURN END SUBROUTINE MUMPS_FMRD_FILL_MAPROW C SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX C C Purpose: C ======= C C Free internal arrays of MAPROW_STRUC. C Typically used after a MAPROW_STRUC has been retrieved C from the module and late-received message has finally C been processed. C C MAPROW_STRUC normally corresponds to a local variable C of the calling routine and will not be reused. C C Arguments: C ========= C INTEGER, INTENT(INOUT) :: IWHANDLER C C Local variables: C =============== C TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC C MAPROW_STRUC => FMRD_ARRAY(IWHANDLER) MAPROW_STRUC%INODE = -7777 ! Special value: negative means unused DEALLOCATE(MAPROW_STRUC%SLAVES_PERE, MAPROW_STRUC%TROW) NULLIFY (MAPROW_STRUC%SLAVES_PERE, MAPROW_STRUC%TROW) C Release handler IWHANDLER and store it C in a new free position for future reuse CALL MUMPS_FDM_END_IDX('A', 'MAPROW', IWHANDLER) RETURN END SUBROUTINE MUMPS_FMRD_FREE_MAPROW_STRUC C SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW(IWHANDLER, MAPROW_STRUC) C C Purpose: C ======= C C Given an IWHANDLER, return a pointer to a MAPROW structure, C containing information on a previously received MAPROW message. C C Arguments: C ========= C INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) TYPE (MAPROW_STRUC_T), POINTER, INTENT(OUT) :: MAPROW_STRUC #else TYPE (MAPROW_STRUC_T), POINTER :: MAPROW_STRUC #endif MAPROW_STRUC => FMRD_ARRAY(IWHANDLER) RETURN END SUBROUTINE MUMPS_FMRD_RETRIEVE_MAPROW C SUBROUTINE MUMPS_FMRD_END(INFO1) C C Purpose: C ======= C Module final termination. C C Arguments: C ========= C INTEGER, INTENT(IN) :: INFO1 C Local variables: C =============== INTEGER :: I, IWHANDLER C IF (.NOT. associated(FMRD_ARRAY)) THEN WRITE(*,*) "Internal error 1 in MUMPS_FAC_FMRD_END" CALL MUMPS_ABORT() ENDIF DO I=1, size(FMRD_ARRAY) IF (FMRD_ARRAY(I)%INODE .GE. 0) THEN C Node is not free: possible only in C case of fatal error (INFO1 < 0) IF (INFO1 .GE.0) THEN C Should have been freed earlier while consuming MAPLIG WRITE(*,*) "Internal error 2 in MUMPS_FAC_FMRD_END",I CALL MUMPS_ABORT() ELSE C May happen in case an error has forced finishing C factorization before all MAPROW msgs were processed. C We copy the loop index I in the local variable IWHANDLER C because there would otherwise be a risk for the loop index C I to be modified by MUMPS_FMRD_FREE_MAPROW_STRUC IWHANDLER=I CALL MUMPS_FMRD_FREE_MAPROW_STRUC(IWHANDLER) ENDIF ENDIF ENDDO DEALLOCATE(FMRD_ARRAY) RETURN END SUBROUTINE MUMPS_FMRD_END #endif END MODULE MUMPS_FAC_MAPROW_DATA_M MUMPS_5.4.1/src/dsol_matvec.F0000664000175000017500000002411614102210525016120 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) DOUBLE PRECISION A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION TEMP DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE DMUMPS_MV_ELT SUBROUTINE DMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) DOUBLE PRECISION A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE DMUMPS_LOC_MV8 SUBROUTINE DMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) DOUBLE PRECISION ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: PX DOUBLE PRECISION ZERO INTEGER :: allocok PARAMETER( ZERO = 0.0D0 ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE DMUMPS_MV8 C C SUBROUTINE DMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) DOUBLE PRECISION A_loc( NZ_loc8 ), X( N ) DOUBLE PRECISION Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: RZERO=0.0D0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE DMUMPS_LOC_OMEGA1 MUMPS_5.4.1/src/cfac_process_contrib_type3.F0000664000175000017500000002506214102210523021115 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE3(BUFR,LBUFR, & LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND,PROCNODE_STEPS, SLAVEF, OPASSW ) USE CMUMPS_LOAD USE CMUMPS_OOC USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC ) :: root INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER LBUFR, LBUFR_BYTES, N, LIW, & IWPOS, IWPOSCB, COMP, COMM, COMM_LOAD, IFLAG, & IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LEAF ) INTEGER PTRIST(KEEP(28)) INTEGER PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), ITLOC( N+KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER BUFR( LBUFR_BYTES ) INTEGER IW( LIW ) INTEGER ND(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER SLAVEF COMPLEX A( LA ) INTEGER MYID INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) COMPLEX DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW INCLUDE 'mpif.h' INTEGER IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER POSITION, LOCAL_M, LOCAL_N, LREQI INTEGER(8) :: LREQA, POS_ROOT INTEGER NSUBSET_ROW, NSUBSET_COL, IROOT, ISON, NSUBSET_COL_EFF INTEGER NSUPCOL_EFF INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NSUPROW, NSUPCOL, BBPCBP INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISON, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_ROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPROW, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUBSET_COL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSUPCOL, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BBPCBP, 1, MPI_INTEGER, & COMM, IERR ) IF (BBPCBP .EQ. 1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF IROOT = KEEP( 38 ) IF ( PTRIST( STEP(IROOT) ) .NE. 0 .OR. & PTLUST( STEP(IROOT)) .NE. 0 ) THEN IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NSUBSET_ROW & - NSUPROW .OR. NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSEIF (KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), & KEEP(80), KEEP(47), & STEP, IROOT + N) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF ELSE IF (NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. & NSUBSET_ROW - NSUPROW .OR. & NSUBSET_ROW - NSUPROW.EQ.0 .OR. & NSUBSET_COL_EFF .EQ. 0)THEN KEEP(121)=-1 ENDIF CALL CMUMPS_ROOT_ALLOC_STATIC( root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) IF ( IFLAG .LT. 0 ) RETURN END IF IF (KEEP(60) .EQ.0) THEN IF ( PTRIST(STEP(IROOT)) .GE. 0 ) THEN IF ( PTRIST(STEP(IROOT)) .NE. 0 ) THEN LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) POS_ROOT = PAMASTER(STEP( IROOT )) ELSE LOCAL_N = IW( PTLUST(STEP( IROOT ) ) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST(STEP( IROOT ) ) + 2 + KEEP(IXSZ)) POS_ROOT = PTRFAC(IW(PTLUST(STEP(IROOT))+4+ & KEEP(IXSZ))) END IF ENDIF ELSE LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC ENDIF IF ( (BBPCBP.EQ.1).AND. (NBROWS_ALREADY_SENT.EQ.0).AND. & (min(NSUPROW, NSUPCOL) .GT. 0) & ) THEN LREQI = NSUPROW+NSUPCOL LREQA = int(NSUPROW,8) * int(NSUPCOL,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in CMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA CALL CMUMPS_ASS_ROOT( root, KEEP(50), NSUPROW, NSUPCOL, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NSUPROW + 1 ), NSUPCOL, & A( IPTRLU + 1_8 ), & A( 1 ), & LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 1) IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF LREQI = NBROWS_PACKET + NSUBSET_COL_EFF LREQA = int(NBROWS_PACKET,8) * int(NSUBSET_COL_EFF,8) IF ( (LREQA.NE.0_8) .AND. & (PTRIST(STEP(IROOT)).LT.0).AND. & KEEP(60)==0) THEN WRITE(*,*) ' Error in CMUMPS_PROCESS_CONTRIB_TYPE3' CALL MUMPS_ABORT() ENDIF IF (LREQA.NE.0_8) THEN CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & LREQI, LREQA, -1234, S_NOTFREE, .FALSE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 1 ), LREQI, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( IPTRLU + 1_8 ), int(LREQA), & MPI_COMPLEX, COMM, IERR ) OPASSW = OPASSW + LREQA IF (KEEP(60).EQ.0) THEN CALL CMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & A( POS_ROOT ), LOCAL_M, LOCAL_N, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ELSE CALL CMUMPS_ASS_ROOT( root, KEEP(50), & NBROWS_PACKET, NSUBSET_COL_EFF, & IW( IWPOSCB + 1 ), & IW( IWPOSCB + NBROWS_PACKET + 1 ), & NSUPCOL_EFF, & A( IPTRLU + 1_8 ), & root%SCHUR_POINTER(1), & root%SCHUR_LLD , root%SCHUR_NLOC, & root%RHS_ROOT(1,1), root%RHS_NLOC, & 0) ENDIF IWPOSCB = IWPOSCB + LREQI IPTRLU = IPTRLU + LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_CONTRIB_TYPE3 MUMPS_5.4.1/src/smumps_gpu.h0000664000175000017500000000114314102210474016057 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef SMUMPS_GPU_H #define SMUMPS_GPU_H #include "mumps_compat.h" #include "mumps_common.h" void MUMPS_CALL smumps_gpu_return(); #endif /* SMUMPS_GPU_H */ MUMPS_5.4.1/src/sfac_omp_m.F0000664000175000017500000000076214102210522015721 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_OMP_M END MODULE SMUMPS_FAC_OMP_M MUMPS_5.4.1/src/csol_c.F0000664000175000017500000023532114102210523015062 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOL_C(root, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, POSINRHSCOMP_BWD, & NZ_RHS, NBCOL_INBLOC, NRHS_ORIG, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS & ) USE CMUMPS_OOC USE CMUMPS_SOL_ES USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( CMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) REAL, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSCOMP, NB_FS_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT COMPLEX A(LA), W(LWC), & W2(KEEP(133)) COMPLEX :: RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP_FWD(N), & POSINRHSCOMP_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT COMPLEX RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IERR INTEGER(8) :: IAPOS INTEGER IOLDPS, & LOCAL_M, & LOCAL_N #if defined(V_T) INTEGER soln_c_class, forw_soln, back_soln, root_soln #endif LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL SWITCH_OFF_ES LOGICAL DUMMY_BOOL INTEGER :: IDUMMY COMPLEX, PARAMETER :: ZERO = (0.0E0,0.0E0) INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS INTEGER nb_nodes_RHS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER nb_prun_roots, JAM1 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in CMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. SWITCH_OFF_ES = .FALSE. IF ( KEEP(111).NE.0 .OR. KEEP(252).NE.0 ) THEN DOFORWARD = .FALSE. ENDIF IF (KEEP(221).eq.1) DOBACKWARD = .FALSE. IF (KEEP(221).eq.2) DOFORWARD = .FALSE. IF ( KEEP(60).EQ.0 .AND. & ( & (KEEP(38).NE.0 .AND. root%yes) & .OR. & (KEEP(20).NE.0 .AND. MYID_NODES.EQ.MASTER_ROOT) & ) & .AND. KEEP(252).EQ.0 & ) &THEN DOROOT = .TRUE. ELSE DOROOT = .FALSE. ENDIF DOROOT_BWD_PANEL = DOROOT .AND. MTYPE.NE.1 .AND. KEEP(50).EQ.0 & .AND. KEEP(201).EQ.1 DOROOT_FWD_OOC = DOROOT .AND. .NOT.DOROOT_BWD_PANEL AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN = (Exploit_Sparsity.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity = .FALSE. DO_PRUN = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in CMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF IF ( DO_PRUN ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN ) THEN nb_prun_nodes = 0 nb_prun_roots = 0 Pruned_SONS(:) = -1 IF ( Exploit_Sparsity ) THEN nb_nodes_RHS = 0 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ELSE IF ( AM1 ) THEN nb_nodes_RHS = 0 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF CALL CMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) CALL CMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL CMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity) MODE_RHS_BOUNDS = 2 CALL CMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL CMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL CMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) SWITCH_OFF_ES = .TRUE. ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF CALL CMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) IF (DO_PRUN) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM CMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=real(TIME_FWD) + DKEEP(117) ENDIF IF (DO_PRUN.AND.SWITCH_OFF_ES) THEN DO_PRUN = .FALSE. Exploit_Sparsity = .FALSE. IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF IF ( DOBACKWARD .AND. DO_PRUN ) THEN nb_prun_leaves = 0 IF ( Exploit_Sparsity .AND. (KEEP(111).EQ.0) ) THEN nb_nodes_RHS = nb_prun_roots ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nodes_RHS(1:nb_prun_roots)=Pruned_Roots(1:nb_prun_roots) DEALLOCATE(Pruned_Roots) ELSE nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF IF ( Exploit_Sparsity ) THEN CALL CMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) CALL CMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL CMUMPS_TREE_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), & KEEP8(31), & STEP, & Pruned_List, & nb_prun_nodes, OOC_FCT_TYPE_TMP) ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL CMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after CMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL CMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after CMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=real(TIME_SpecialRoot) + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity.AND.(KEEP(111).EQ.0) ) & .OR. AM1 ) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN OOC_STATE_NODE(STEP(KEEP(38)))=-4 ENDIF ENDIF IF (Exploit_Sparsity.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = AM1 IF ( AM1 ) THEN CALL CMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL CMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL CMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL CMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL CMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL CMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL CMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSCOMP_F.NE.NB_FS_IN_RHSCOMP_TOT)) THEN DO I =1, N II = POSINRHSCOMP_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSCOMP_F)) THEN DO K=1,NRHS RHSCOMP(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( DO_PRUN & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF CALL CMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & ) CALL CMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=real(TIME_BWD)+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSCOMP,1).GT.0) & WRITE (MP,99993) (RHSCOMP(I,1),I=1,K) IF (size(RHSCOMP,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (Exploit_Sparsity.OR.AM1.OR.SWITCH_OFF_ES) THEN IF ( allocated(nodes_RHS)) DEALLOCATE (nodes_RHS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5E14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5E14.6)) 99992 FORMAT (//' LEAVING SOLVE (CMUMPS_SOL_C) WITH') END SUBROUTINE CMUMPS_SOL_C SUBROUTINE CMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSCOMP COMPLEX RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSCOMP, POSINRHSCOMP(LPOS_N) COMPLEX, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER :: JCOL_RHS INTEGER :: K242 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in CMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in CMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL CMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL CMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL CMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_COMPLEX, & COMM, IERR) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO ENDIF ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE CMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: LOCAL_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN LOCAL_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LOCAL_LSCAL) THEN RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSCOMP= POSINRHSCOMP(IW(J1)) DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL CMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE CMUMPS_NPIV_BLOCK_ADD SUBROUTINE CMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE CMUMPS_NPIV_BLOCK_SEND END SUBROUTINE CMUMPS_GATHER_SOLUTION SUBROUTINE CMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSCOMP, LRHSCOMP, NRHSCOMP_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, & LSCAL, SCALING, LSCALING, & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSCOMP, LPOS_ROW, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSCOMP, NRHSCOMP_COL COMPLEX, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSCOMP INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP(LPOS_ROW) COMPLEX :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSCOMP INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in CMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(II) IF (IPOSINRHSCOMP.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL CMUMPS_AM1_BLOCK_ADD ( .TRUE. ) IRHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & I RHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & RHS_SPARSE_COPY(IZ) K = K+1 ELSE CALL CMUMPS_AM1_BLOCK_ADD ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL CMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_COMPLEX, & COMM, IERR) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE CMUMPS_AM1_BLOCK_ADD ( SCALE_ONLY ) LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN III = I IF (KEEP(23).NE.0) III = UNS_PERM_INV(I) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS_SPARSE_COPY(IZ)*SCALING(III) ENDIF RETURN ENDIF CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL CMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE CMUMPS_AM1_BLOCK_ADD SUBROUTINE CMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE CMUMPS_AM1_BLOCK_SEND END SUBROUTINE CMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE CMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, scaling_data, LSCAL & , IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) LOGICAL LSCAL LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_DISTSOL_INDICES SUBROUTINE CMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSCOMP, LRHSCOMP, NBRHS_EFF, & POSINRHSCOMP, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t TYPE (scaling_data_t) :: scaling_data LOGICAL LSCAL INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSCOMP INTEGER POSINRHSCOMP(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS COMPLEX SOL_LOC( LSOL_LOC, NRHS ) COMPLEX RHSCOMP( LRHSCOMP, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSCOMP, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: ROOT !$ LOGICAL :: OMP_FLAG COMPLEX, PARAMETER :: ZERO = (0.0E0,0.0E0) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN ROOT=.false. IF (KEEP(38).ne.0) ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) ROOT = STEP(KEEP(20))==ISTEP IF ( ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSCOMP) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE CMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSCOMP, NCOL_RHSCOMP INTEGER ICNTL(60), INFO(80) COMPLEX, intent(in) :: RHS (LRHS, NCOL_RHS) COMPLEX, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), NB_FS_IN_RHSCOMP_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL CMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL CMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE CMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSCOMP( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE CMUMPS_GET_BUF_INDX_RHS END SUBROUTINE CMUMPS_SCATTER_RHS SUBROUTINE CMUMPS_BUILD_POSINRHSCOMP & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & NBENT_RHSCOMP, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP, NB_FS_IN_RHSCOMP INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 ENDDO IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) = IPOSINRHSCOMP+JJ-JCOL ENDDO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO NB_FS_IN_RHSCOMP = IPOSINRHSCOMP -1 IF (POSINRHSCOMP_COL_ALLOC) IPOSINRHSCOMP_COL=IPOSINRHSCOMP IF (IPOSINRHSCOMP.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(J1+JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN POSINRHSCOMP_COL(IW(JCOL+JJ)) = - IPOSINRHSCOMP_COL IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSCOMP = IPOSINRHSCOMP - 1 IF (POSINRHSCOMP_COL_ALLOC) & NBENT_RHSCOMP = max(NBENT_RHSCOMP, IPOSINRHSCOMP_COL-1) RETURN END SUBROUTINE CMUMPS_BUILD_POSINRHSCOMP SUBROUTINE CMUMPS_BUILD_POSINRHSCOMP_AM1 & (NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, SIZE_UNS_PERM_INV & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW, & SIZE_UNS_PERM_INV INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP INTEGER, intent(out):: NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER I, JAM1 INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSCOMP_ROW, IPOSINRHSCOMP_COL INTEGER NBENT_RHSCOMP_ROW, NBENT_RHSCOMP_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF(KEEP(237).EQ.0) THEN WRITE(*,*)'BUILD_POSINRHSCOMP_SPARSE available for A-1 only !' CALL MUMPS_ABORT() END IF POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP_ROW = 0 IPOSINRHSCOMP_COL = 0 DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_ROW(IW(J1)).EQ.0) THEN DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) & = IPOSINRHSCOMP_ROW + JJ - J1 + 1 ENDDO IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + NPIV IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) & = - N - (IPOSINRHSCOMP_COL + JJ - JCOL + 1) ENDDO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ENDIF ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO NB_FS_IN_RHSCOMP_FWD = IPOSINRHSCOMP_ROW IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_COL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ))) = & IPOSINRHSCOMP_COL+JJ-JCOL+1 END DO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ELSE IF (POSINRHSCOMP_COL(ABSJCOL).LT.-N) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ)))= & -(N+POSINRHSCOMP_COL(abs(IW(JJ)))) END DO ELSE IF ((POSINRHSCOMP_COL(ABSJCOL).LT.0).AND. & (POSINRHSCOMP_COL(ABSJCOL).GE.-N))THEN WRITE(*,*)'Internal error 7 in BUILD...SPARSE' CALL MUMPS_ABORT() ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSCOMP_TOT = IPOSINRHSCOMP_COL IF (NSLAVES.NE.1) THEN DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + 1 POSINRHSCOMP_ROW(IW(JJ+J1)) & = -IPOSINRHSCOMP_ROW END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = -IPOSINRHSCOMP_COL ELSE IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).LT.-N) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = POSINRHSCOMP_COL(IW(JCOL+JJ)) + N END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSCOMP_ROW = IPOSINRHSCOMP_ROW NBENT_RHSCOMP_COL = IPOSINRHSCOMP_COL NBENT_RHSCOMP = max(NBENT_RHSCOMP_ROW,NBENT_RHSCOMP_COL) RETURN END SUBROUTINE CMUMPS_BUILD_POSINRHSCOMP_AM1 MUMPS_5.4.1/src/cmumps_gpu.c0000664000175000017500000000117314102210474016035 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "cmumps_gpu.h" void MUMPS_CALL cmumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.4.1/src/mumps_save_restore_C.c0000664000175000017500000000261514102210474020044 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "mumps_save_restore_C.h" #include "mumps_common.h" /* Functions */ void MUMPS_CALL MUMPS_GET_SAVE_DIR_C(MUMPS_INT *len_save_dir, char* save_dir, mumps_ftnlen l1) { char *tmp_save_dir; tmp_save_dir = getenv ("MUMPS_SAVE_DIR"); if (tmp_save_dir==NULL) { tmp_save_dir = "NAME_NOT_INITIALIZED"; } *len_save_dir = strlen(tmp_save_dir); save_dir = strncpy(save_dir, tmp_save_dir, l1); } void MUMPS_CALL MUMPS_GET_SAVE_PREFIX_C(MUMPS_INT *len_save_prefix, char* save_prefix, mumps_ftnlen l1) { char *tmp_save_prefix; tmp_save_prefix = getenv ("MUMPS_SAVE_PREFIX"); if (tmp_save_prefix==NULL) { tmp_save_prefix = "NAME_NOT_INITIALIZED"; } *len_save_prefix = strlen(tmp_save_prefix); save_prefix = strncpy(save_prefix, tmp_save_prefix, l1); } void MUMPS_CALL MUMPS_SAVE_RESTORE_RETURN_C() { /* Save/restore feature will be available in the future */ } MUMPS_5.4.1/src/srank_revealing.F0000664000175000017500000001072314102210521016765 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 RETURN END SUBROUTINE SMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE SMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE SMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE SMUMPS_RR_INIT_POINTERS(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) id NULLIFY(id%root%QR_TAU) NULLIFY(id%root%SVD_U) NULLIFY(id%root%SVD_VT) NULLIFY(id%root%SINGULAR_VALUES) RETURN END SUBROUTINE SMUMPS_RR_INIT_POINTERS SUBROUTINE SMUMPS_RR_FREE_POINTERS(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) id IF (associated(id%root%QR_TAU)) THEN DEALLOCATE(id%root%QR_TAU) NULLIFY(id%root%QR_TAU) ENDIF IF (associated(id%root%SVD_U)) THEN DEALLOCATE(id%root%SVD_U) NULLIFY(id%root%SVD_U) ENDIF IF (associated(id%root%SVD_VT)) THEN DEALLOCATE(id%root%SVD_VT) NULLIFY(id%root%SVD_VT) ENDIF IF (associated(id%root%SINGULAR_VALUES)) THEN DEALLOCATE(id%root%SINGULAR_VALUES) NULLIFY(id%root%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE SMUMPS_RR_FREE_POINTERS MUMPS_5.4.1/src/cfac_root_parallel.F0000664000175000017500000001704414102210523017433 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FACTO_ROOT( & MPA, MYID, MASTER_OF_ROOT, & root, N, IROOT, & COMM, IW, LIW, IFREE, & A, LA, PTRAST, PTLUST_S, PTRFAC, & STEP, INFO, LDLT, QR, & WK, LWK, KEEP,KEEP8,DKEEP,OPELIW, & DET_EXP, DET_MANT, DET_SIGN & ) USE CMUMPS_LR_STATS, ONLY: UPD_FLOP_ROOT USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE ( CMUMPS_ROOT_STRUC ) :: root INTEGER, INTENT(IN) :: MPA INTEGER N, IROOT, COMM, LIW, MYID, IFREE, MASTER_OF_ROOT INTEGER(8) :: LA INTEGER(8) :: LWK COMPLEX WK( LWK ) INTEGER KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTLUST_S(KEEP(28)), STEP(N), IW( LIW ) INTEGER INFO( 2 ), LDLT, QR COMPLEX A( LA ) DOUBLE PRECISION, intent(inout) :: OPELIW INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX, INTENT(INOUT) :: DET_MANT INTEGER IOLDPS INTEGER(8) :: IAPOS DOUBLE PRECISION :: FLOPS_ROOT INTEGER(8) :: ENTRIES_ROOT INTEGER LOCAL_M, LOCAL_N, LPIV, IERR, allocok INTEGER FWD_LOCAL_N_RHS, FWD_MTYPE INCLUDE 'mumps_headers.h' EXTERNAL numroc INTEGER numroc IF ( .NOT. root%yes ) RETURN IF ( KEEP(60) .NE. 0 ) THEN IF ((LDLT == 1 .OR. LDLT == 2) .AND. KEEP(60) == 3 ) THEN CALL CMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_NLOC, & root%TOT_ROOT_SIZE, MYID, COMM ) ENDIF RETURN ENDIF IF (MPA.GT.0) THEN IF (MYID.EQ.MASTER_OF_ROOT) THEN CALL MUMPS_GET_FLOPS_COST & (root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & LDLT, 3, FLOPS_ROOT) WRITE(MPA,'(A, A, 1PD10.3)') & " ... Start processing the root node with ScaLAPACK, ", & " remaining flops = ", FLOPS_ROOT ENDIF ENDIF IOLDPS = PTLUST_S(STEP(IROOT))+KEEP(IXSZ) IAPOS = PTRAST(STEP(IROOT)) LOCAL_M = IW( IOLDPS + 2 ) LOCAL_N = IW( IOLDPS + 1 ) IAPOS = PTRFAC(IW ( IOLDPS + 4 )) IF ( LDLT.EQ.0 .OR. LDLT.EQ.2 .OR. QR.ne.0 ) THEN LPIV = LOCAL_M + root%MBLOCK ELSE LPIV = 1 END IF IF (associated( root%IPIV )) DEALLOCATE(root%IPIV) root%LPIV = LPIV ALLOCATE( root%IPIV( LPIV ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1) = -13 INFO(2) = LPIV WRITE(*,*) MYID,': problem allocating IPIV(',LPIV,') in root' CALL MUMPS_ABORT() END IF CALL DESCINIT( root%DESCRIPTOR(1), root%TOT_ROOT_SIZE, & root%TOT_ROOT_SIZE, root%MBLOCK, root%NBLOCK, & 0, 0, root%CNTXT_BLACS, LOCAL_M, IERR ) IF ( LDLT.EQ.2 ) THEN IF(root%MBLOCK.NE.root%NBLOCK) THEN WRITE(*,*) ' Error: symmetrization only works for' WRITE(*,*) ' square block sizes, MBLOCK/NBLOCK=', & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() END IF IF ( LWK .LT. min( & int(root%MBLOCK,8) * int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)* int(root%TOT_ROOT_SIZE,8 ) & )) THEN WRITE(*,*) 'Not enough workspace for symmetrization.' CALL MUMPS_ABORT() END IF CALL CMUMPS_SYMMETRIZE( WK, root%MBLOCK, & root%MYROW, root%MYCOL, root%NPROW, root%NPCOL, & A( IAPOS ), LOCAL_M, LOCAL_N, & root%TOT_ROOT_SIZE, MYID, COMM ) END IF IF (LDLT.EQ.0.OR.LDLT.EQ.2) THEN CALL pcgetrf( root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & A( IAPOS ), & 1, 1, root%DESCRIPTOR(1), root%IPIV(1), IERR ) IF ( IERR .GT. 0 ) THEN INFO(1)=-10 INFO(2)=IERR-1 END IF ELSE CALL pcpotrf('L',root%TOT_ROOT_SIZE,A(IAPOS), & 1,1,root%DESCRIPTOR(1),IERR) IF ( IERR .GT. 0 ) THEN INFO(1)=-40 INFO(2)=IERR-1 END IF END IF IF (IERR .GT. 0) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, INFO(2), & root%NPROW, root%NPCOL, MYID ) ENDIF ELSE CALL MUMPS_UPDATE_FLOPS_ROOT( OPELIW, LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) IF (KEEP(486) .GT. 0) THEN CALL UPD_FLOP_ROOT( LDLT, & root%TOT_ROOT_SIZE, root%TOT_ROOT_SIZE, & root%NPROW, root%NPCOL, MYID ) ENDIF ENDIF IF ( LDLT .EQ. 0 ) THEN ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE,8) ELSE ENTRIES_ROOT = int(root%TOT_ROOT_SIZE,8) & * int(root%TOT_ROOT_SIZE+1,8)/2_8 ENDIF KEEP8(10)=KEEP8(10) + ENTRIES_ROOT / & int(root%NPROW * root%NPCOL,8) IF (MYID .eq. MASTER_OF_ROOT) THEN KEEP8(10)=KEEP8(10) + & mod(ENTRIES_ROOT, int(root%NPROW*root%NPCOL,8)) ENDIF CALL CMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DKEEP, KEEP, LDLT) IF (KEEP(258).NE.0) THEN IF (root%MBLOCK.NE.root%NBLOCK) THEN write(*,*) "Internal error in CMUMPS_FACTO_ROOT:", & "Block size different for rows and columns", & root%MBLOCK, root%NBLOCK CALL MUMPS_ABORT() ENDIF CALL CMUMPS_GETDETER2D(root%MBLOCK, root%IPIV(1),root%MYROW, & root%MYCOL, root%NPROW, root%NPCOL, A(IAPOS), LOCAL_M, & LOCAL_N, root%TOT_ROOT_SIZE, MYID, DET_MANT, DET_EXP, & LDLT) ENDIF IF (KEEP(252) .NE. 0) THEN FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) FWD_MTYPE = 1 CALL CMUMPS_SOLVE_2D_BCYCLIC( & root%TOT_ROOT_SIZE, & KEEP(253), & FWD_MTYPE, & A(IAPOS), & root%DESCRIPTOR(1), & LOCAL_M, LOCAL_N, FWD_LOCAL_N_RHS, & root%IPIV(1), LPIV, & root%RHS_ROOT(1,1), LDLT, & root%MBLOCK, root%NBLOCK, & root%CNTXT_BLACS, IERR) ENDIF RETURN END SUBROUTINE CMUMPS_FACTO_ROOT MUMPS_5.4.1/src/mumps_thread_affinity.h0000664000175000017500000000132614102210474020244 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_THREAD_AFFINITY_H #define MUMPS_THREAD_AFFINITY_H #include "mumps_common.h" #define MUMPS_THREAD_AFFINITY_RETURN \ F_SYMBOL(thread_affinity_return,THREAD_AFFINITY_RETURN) void MUMPS_CALL MUMPS_THREAD_AFFINITY_RETURN(); #endif /* MUMPS_THREAD_AFFINITY_H */ MUMPS_5.4.1/src/dlr_type.F0000664000175000017500000000501414102210523015434 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE DOUBLE PRECISION,POINTER,DIMENSION(:,:) :: Q => null() DOUBLE PRECISION,POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: MEM IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) IF(associated(LRB_OUT%R)) MEM = MEM + size(LRB_OUT%R) ELSE IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) ENDIF !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - int(MEM,8) !$OMP END ATOMIC IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE DMUMPS_LR_TYPE MUMPS_5.4.1/src/zfac_mem_stack.F0000664000175000017500000005507014102210524016570 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) DOUBLE PRECISION DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) COMPLEX(kind=8) A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR, MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR, & MUMPS_ROOTSSARBR LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 INPLACE = .FALSE. MIN_SPACE_IN_PLACE = 0_8 IOLDPS = PTLUST_S(STEP(INODE)) INTSIZ = IW(IOLDPS+XXI) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS + 1+KEEP(IXSZ)) NMAXNPIV = max(NPIV, NMAXNPIV) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in ZMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL ZMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL ZMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL ZMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL ZMUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL ZMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL ZMUMPS_PROCESS_RTNELIND( root, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL ZMUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL ZMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL ZMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & ZMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & ZMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL ZMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL ZMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL ZMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL ZMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL ZMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I = 1, NCBROW_PREVIOUSLY_MOVED*NPIV A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) CALL ZMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL ZMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_STACK MUMPS_5.4.1/src/cana_aux.F0000664000175000017500000041151614102210523015401 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE CMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) REAL :: CNTL4 REAL, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif REAL, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED, WEIGHTREQUESTED LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB EXTERNAL MUMPS_ANA_H, CMUMPS_ANA_J, & CMUMPS_ANA_K, CMUMPS_ANA_GNEW, & CMUMPS_ANA_LNEW, CMUMPS_ANA_M #if defined(OLDDFS) EXTERNAL CMUMPS_ANA_L #endif EXTERNAL CMUMPS_GNEW_SCHUR EXTERNAL CMUMPS_LDLT_COMPRESS, CMUMPS_EXPAND_PERMUTATION, & CMUMPS_SET_CONSTRAINTS IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF ( (LIWALLOC.EQ.0_8).AND.(.not.GCOMP_PROVIDED)) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.2) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL CMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: CMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0E0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF IF (PROK) & WRITE(MP,*) 'Setting static pivoting ON, COMPRESS =', & COMPRESS ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL CMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL CMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, & WEIGHTUSED, WEIGHTREQUESTED) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL CMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL CMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL CMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL CMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.3) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL CMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF (KEEP(106).EQ.3.AND.KEEP(60).EQ.0) THEN ELSE ALLOCATE( WTEMP ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF ELSE CALL CMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL CMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) IF (KEEP(60) .EQ. 0) THEN IF (KEEP(60) .EQ. 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF ENDIF ENDIF #if defined(OLDDFS) CALL CMUMPS_ANA_L & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ, INFO(6), FILS(1), FRERE(1), PTRAR(1,3), & NEMIN, KEEP(60)) #else IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (present(SIZEOFBLOCKS)) THEN CALL CMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .TRUE. , SIZEOFBLOCKS, N & ) ELSE CALL CMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .FALSE., IDUMMY, LIDUMMY ) ENDIF DEALLOCATE(WTEMP) #endif IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL CMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL CMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) THEN KEEP(210)=0 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) THEN KEEP(210)=1 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) THEN KEEP(210)=2 ENDIF IF (KEEP(210).EQ.2) THEN KEEP8(79)=huge(KEEP8(79)) ENDIF IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL CMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 INFO(1) = -4 INFO(2) = K GOTO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE CMUMPS_ANA_F SUBROUTINE CMUMPS_ANA_N_DIST( id, PTRAR ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(CMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER(8), POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => PTRAR(id%N+1:id%N+id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N) IWORK2 => PTRAR(id%N+1:id%N+id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1_8 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1_8 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1_8 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1_8 END IF ENDIF ENDIF 70 CONTINUE END IF IF (id%KEEP(54) .EQ. 3) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(id%N+1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR(1), 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE CMUMPS_ANA_N_DIST SUBROUTINE CMUMPS_ANA_O( N, NZ, MTRANS, PERM, IKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN COMPLEX, POINTER, DIMENSION(:) :: idA REAL, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER, TARGET :: IKEEPALLOC(3*N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW REAL, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) REAL CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT REAL THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK REAL ZERO,TWO,ONE PARAMETER(ZERO = 0.0E0,TWO = 2.0E0,ONE = 1.0E0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) ) THEN MTRANS = 0 KEEP(95) =1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS=0 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(N+1:2*N) CALL CMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*KEEP(10) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8*N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8*N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. real(0.0E0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(real(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2*N+1:3*N) IF(MTRANSLOC.NE.1) THEN CALL CMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL CMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL CMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) GO TO 400 IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC(N+1:2*N) FLAG => IKEEPALLOC(2*N+1:3*N) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL CMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in CMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in CMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE CMUMPS_ANA_O END MODULE CMUMPS_ANA_AUX_M SUBROUTINE CMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL CMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_K SUBROUTINE CMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max0(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM CMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE CMUMPS_ANA_J SUBROUTINE CMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE CMUMPS_ANA_D #if defined(OLDDFS) SUBROUTINE CMUMPS_ANA_L(N, IPE, NV, IPS, NE, NA, NFSIZ, & NSTEPS, & FILS, FRERE,NDD,NEMIN, KEEP60) INTEGER N,NSTEPS INTEGER NDD(N) INTEGER FILS(N), FRERE(N) INTEGER IPS(N), NE(N), NA(N), NFSIZ(N) INTEGER IPE(N), NV(N) INTEGER NEMIN, KEEP60 INTEGER I,IF,IS,NR,NR1,INS,INL,INB,INF,INFS,INSW INTEGER K,L,ISON,IN,INP,IFSON,INC,INO INTEGER INOS,IB,IL DO 10 I=1,N IPS(I) = 0 NE(I) = 0 10 CONTINUE DO 20 I=1,N IF (NV(I).GT.0) GO TO 20 IF = -IPE(I) IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I 20 CONTINUE NR = N + 1 DO 50 I=1,N IF (NV(I).LE.0) GO TO 50 IF = -IPE(I) IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF 50 CONTINUE DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (IPE(INS).LT.0) THEN INS = -IPE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (IPE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = IPE(INS) IF (NV(INB).EQ.0) THEN INS = INB GO TO 1070 ENDIF IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = IPE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB IPE(INS) = IPE(INB) IPE(INB) = INS INS = INB GO TO 1070 ENDIF INSW = INFS 1100 INFS = IPE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF IPE(INS) = IPE(INB) IPE(INB) = INS IPE(INSW)= INB INS =INB GO TO 1070 1151 CONTINUE DO 51 I=1,N FRERE(I) = IPE(I) FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IL = 0 DO 160 K=1,N IF (I.GT.0) GO TO 60 I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 60 DO 70 L=1,N IF (IPS(I).GE.0) GO TO 80 ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE 80 IPS(I) = K NE(IS) = NE(IS) + 1 IF (NV(I).GT.0) GO TO 89 IN = I 81 IN = FRERE(IN) IF (IN.GT.0) GO TO 81 IF = -IN IN = IF 82 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 82 IFSON = -IN FILS(INL) = I IN = I 83 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 83 IF (IFSON .EQ. I) GO TO 86 FILS(INP) = -IFSON IN = IFSON 84 INC =IN IN = FRERE(IN) IF (IN.NE.I) GO TO 84 FRERE(INC) = FRERE(I) GO TO 120 86 IF (FRERE(I).LT.0) FILS(INP) = 0 IF (FRERE(I).GT.0) FILS(INP) = -FRERE(I) GO TO 120 89 IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) NDD(IS) = NV(I) NFSIZ(I) = NV(I) IF (NA(IS).LT.1) GO TO 110 IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.NDD(IS)) ) GOTO 110 IF (NDD(IS-1)-NE(IS-1).EQ.NDD(IS)) GO TO 100 IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(NDD(IS)-NDD(IS-1)+NE(IS-1)).GE. & ((NDD(IS)+NE(IS-1))* & (NDD(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 NDD(IS-1) = NDD(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 IN=I 101 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 101 IFSON = -IN IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 FILS(INL) = INO NFSIZ(I) = NDD(IS-1) IN = INO 103 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 103 INOS = -IN IF (IFSON.EQ.INO) GO TO 107 IN = IFSON FILS(INP) = -IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) FRERE(INS) = -I IF (INOS.NE.0) FRERE(INS) = INOS IF (INOS.EQ.0) GO TO 109 107 IN = INOS IF (IN.EQ.0) GO TO 109 108 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -I 109 CONTINUE GO TO 120 110 IS = IS + 1 120 IB = IPE(I) IF (IB.LT.0) GOTO 150 IF (IB.EQ.0) GOTO 140 NA(IL) = 0 140 I = IB GO TO 160 150 I = -IB IL = IL + 1 160 CONTINUE NSTEPS = IS - 1 DO 170 I=1,N K = FILS(I) IF (K.GT.0) THEN FRERE(K) = N + 1 NFSIZ(K) = 0 ENDIF 170 CONTINUE RETURN END SUBROUTINE CMUMPS_ANA_L #else SUBROUTINE CMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 ENDIF DO 70 L=1,N IF (IPS(I).GE.0) EXIT ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE #if ! defined(NOAMALGTOFATHER) DADI = -IPE(I) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF IF ( (NV(I).GT. 50*NV(DADI)).AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. 0.2 ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & NODE(I) * 900 .LE. NV(DADI) - NAMALG(DADI)) THEN IF ( NAMALG(DADI) < (NV(DADI)-NAMALG(DADI))/50 ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ANA_LNEW #endif SUBROUTINE CMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE CMUMPS_ANA_M SUBROUTINE CMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ANA_R SUBROUTINE CMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(80), ICNTL(60), INFOG(80) INTEGER(8) KEEP8(150) REAL RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN WRITE(MPG, 99992) INFO(1), INFO(2), & KEEP8(109), KEEP8(111), INFOG(4), & INFOG(5), KEEP(28), INFOG(32), INFOG(7), KEEP(23), & ICNTL(7), KEEP(12), & ICNTL(18), & KEEP(56), KEEP(61), RINFOG(1) IF (KEEP(95).GT.1) & WRITE(MPG, 99993) KEEP(95) IF (KEEP(54).GT.0) WRITE(MPG, 99994) KEEP(54) IF (KEEP(60).GT.0) WRITE(MPG, 99995) KEEP(60) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' Number of level 2 nodes =',I16/ & ' Number of split nodes =',I16/ & ' RINFOG(1) Operations during elimination (estim)=', & 1PD10.3) 99993 FORMAT(' Ordering compressed/constrained (ICNTL(12)) =',I16) 99994 FORMAT(' Distributed matrix entry format (ICNTL(18)) =',I16) 99995 FORMAT(' Effective Schur option (ICNTL(19)) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) END SUBROUTINE CMUMPS_DIAG_ANA SUBROUTINE CMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER NFRONT, K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( real( NSLAVES - 1 ) ) & / log(2.0E0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) INODE = abs(IPOOL(1)) NFRONT = NFSIZ( INODE ) K79 = max( & int(NFRONT,8)*int(NFRONT,8)/(int(K82+1,8)*int(K82+1,8)), & 9_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL CMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE CMUMPS_CUTNODES RECURSIVE SUBROUTINE CMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM REAL WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( real(NSLAVESMAX-NSLAVESMIN)/real(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667E0 * & real(NPIV)*real(NPIV)*real(NPIV) + & real(NPIV)*real(NPIV)*real(NCB) WK_SLAVE = real( NPIV ) * real( NCB ) * & ( 2.0E0 * real(NFRONT) - real(NPIV) ) & / real(NSLAVES_ESTIM) ELSE WK_MASTER = real(NPIV)*real(NPIV)*real(NPIV) / real(3) WK_SLAVE = & (real(NPIV)*real(NCB)*real(NFRONT)) & / real(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( real( 100 + STRAT ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ELSE IF ( real( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / real(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(real(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL CMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL CMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE CMUMPS_SPLIT_1NODE SUBROUTINE CMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0E0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE CMUMPS_ANA_GNEW SUBROUTINE CMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE CMUMPS_SET_K821_SURFACE SUBROUTINE CMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) REAL :: A(LA) REAL :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K REAL :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0E+00,ONE=1.0E+0) EXTERNAL CMUMPS_MTRANSZ,CMUMPS_MTRANSB,CMUMPS_MTRANSR, & CMUMPS_MTRANSS,CMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/real(2*N) RINF3 = 0.0E0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = int(4*N + M,8) IF (JOB.EQ.2) K = int(N + 2*M,8) IF (JOB.EQ.3) K = int(8*N + 2*M + NE,8) IF (JOB.EQ.4) K = int(N + M,8) IF (JOB.EQ.5) K = int(3*N + 2*M,8) IF (JOB.EQ.6) K = int(3*N + 2*M + NE,8) IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int( M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = int( 2*M,8) IF (JOB.EQ.5) K = int(N + 2*M,8) IF (JOB.EQ.6) K = int(N + 3*M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL CMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL CMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(N+1),IW(N+M+1),DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL CMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL CMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1), & IW(NE+N+1),IW(NE+2*N+1),IW(NE+3*N+1),IW(NE+4*N+1), & IW(NE+5*N+1),IW(NE+5*N+M+1),FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(M+N+N), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 INFOMUMPS(2) = M+N+N GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL CMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3*N+2*M+K) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2*M+N+I) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2*M+N+I)) THEN DW(2*M+N+I) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2*M+N+I).NE.ZERO) THEN DW(2*M+N+I) = 1.0E0/DW(2*M+N+I) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2*M+N+I) * A(K) 65 CONTINUE 66 CONTINUE CALL CMUMPS_MTRANSR(N,NE,IP,IW(3*N+2*M+1),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL CMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL CMUMPS_MTRANSW(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2*M+N+I).NE.0.0E0) THEN DW(I) = DW(I) + log(DW(2*M+N+I)) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2*M+J).NE.ZERO) THEN DW(M+J) = DW(M+J) - log(DW(2*M+J)) ELSE DW(M+J) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5E0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(M+J),J=1,min(10,N)) ENDIF ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,M) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,M) WRITE(ICNTL(3),9034) (DW(M+J),J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in CMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from CMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for CMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for CMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE CMUMPS_MTRANS_DRIVER SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) REAL, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE CMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE CMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE CMUMPS_SORT_PERM SUBROUTINE CMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, LRGROUPS_OLD, LRGROUPS_NEW, & K20, K38 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(NBLK) INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(N) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20, K38 INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_EXPAND_TREE_STEPS SUBROUTINE CMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) REAL PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE CMUMPS_DIST_AVOID_COPIES SUBROUTINE CMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE CMUMPS_SET_PROCNODE MUMPS_5.4.1/src/mumps_metis64.c0000664000175000017500000001435214102210474016375 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include /* For NULL constant (stddef.h) and debug printings */ #include "mumps_metis64.h" #if defined(parmetis) || defined(parmetis3) /*PARMETIS*/ #if defined(parmetis3) /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void ParMETIS_V3_NodeND(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT8 *order, MUMPS_INT8 *sizes, MPI_Comm *Ccomm); #else #include "metis.h" #include "parmetis.h" /* Prototypes from parmetis.h will be used */ #endif void MUMPS_CALL MUMPS_PARMETIS_64(MUMPS_INT8 *first, MUMPS_INT8 *vertloctab, MUMPS_INT8 *edgeloctab, #if defined(parmetis3) MUMPS_INT *numflag, MUMPS_INT *options, #else MUMPS_INT8 *numflag, MUMPS_INT8 *options, #endif MUMPS_INT8 *order, MUMPS_INT8 *sizes, MUMPS_INT *comm, MUMPS_INT *ierr) { MPI_Comm int_comm; #if defined(parmetis) # if (IDXTYPEWIDTH == 64) int iierr; #endif #endif int_comm = MPI_Comm_f2c(*comm); #if defined(parmetis3) /* Prototype may not match with 32-bit integers and Parmetis3 */ ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); #elif defined(parmetis) # if (IDXTYPEWIDTH == 64) *ierr=0; iierr=ParMETIS_V3_NodeND(first, vertloctab, edgeloctab, numflag, options, order, sizes, &int_comm); if(iierr != METIS_OK) *ierr=1; # else /* SHOULD NEVER BE CALLED */ printf("** Error: ParMETIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_PARMETIS_64 was called\n"); *ierr=1; # endif #endif return; } #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #if defined(metis4) || defined(parmetis3) /* parmetis3 comes with metis4 */ /* Provide prototype by hand. This is because we are not sure * at compilation/preprocessing time whether we use a 32-bit * or a 64-bit metis */ void METIS_PartGraphKway(int *, MUMPS_INT8 *, MUMPS_INT8 *, MUMPS_INT8 *, MUMPS_INT8 *, int *, int *, int *, int *, int *, MUMPS_INT8 *); #else /* Prototype properly defined in metis.h * One can rely on IDXTYPEWIDTH to know at compilation/preprocessing * time whether we use a 32-bit or a 64-bit metis */ #include "metis.h" #endif /* Interface for metis k-way partitioning with 64-bit ints */ void MUMPS_CALL MUMPS_METIS_KWAY_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to */ /* SELECTIVE I8 FIXME: add an argument *ierr, check it on exit */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; MUMPS_INT kINT, nINT; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* n and k are MUMPS_INT */ nINT=(MUMPS_INT)(*n); kINT=(MUMPS_INT)(*k); /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(&nINT, iptr, jcn, NULL, NULL, &wgtflag, &numflag, &kINT, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 64) MUMPS_INT8 ncon, edgecut, options[40]; ierr=METIS_SetDefaultOptions(options); options[0] = 0; /* Use 1-based fortran numbering */ options[17] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, NULL, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_METIS_KWAY_64 was called\n"); ierr=1; # endif #endif return; } /* Interface for metis k-way partitioning with 64-bit ints and weights on vertices*/ void MUMPS_CALL MUMPS_METIS_KWAY_AB_64(MUMPS_INT8 *n, MUMPS_INT8 *iptr, MUMPS_INT8 *jcn, MUMPS_INT8 *k, MUMPS_INT8 *part, MUMPS_INT8 *vwgt ) /* n -- the size of the graph to be partitioned iptr -- pointer to the beginning of each node's adjacency list jcn -- jcn[iptr[i]:iptr[i+1]-1] contains the list of neighbors of node i k -- the number of parts part -- part[i] is the part node i belongs to */ /* SELECTIVE I8 FIXME: add an argument *ierr, check it on exit */ { #if defined(metis4) || defined(parmetis3) MUMPS_INT numflag, edgecut, wgtflag, options[8]; MUMPS_INT kINT, nINT; options[0] = 0; /* unweighted partitioning */ wgtflag = 0; /* Use 1-based fortran numbering */ numflag = 1; /* n and k are MUMPS_INT */ nINT=(MUMPS_INT)(*n); kINT=(MUMPS_INT)(*k); /* void METIS_PartGraphKway(int *, idxtype *, idxtype *, idxtype *, idxtype *, int *, int *, int *, int *, int *, idxtype *); */ METIS_PartGraphKway(&nINT, iptr, jcn, vwgt, NULL, &wgtflag, &numflag, &kINT, options, &edgecut, part); #else /* METIS >= 5 */ int ierr; # if (IDXTYPEWIDTH == 64) MUMPS_INT8 ncon, edgecut, options[40]; ierr=METIS_SetDefaultOptions(options); options[0] = 0; /* Use 1-based fortran numbering */ options[17] = 1; ncon = 1; ierr = METIS_PartGraphKway(n, &ncon, iptr, jcn, vwgt, NULL, NULL, k, NULL, NULL, options, &edgecut, part); # else printf("** Error: METIS version >= 4, IDXTYPE WIDTH !=64, but MUMPS_METIS_KWAY_AB_64 was called\n"); ierr=1; # endif #endif return; } #endif MUMPS_5.4.1/src/cmumps_load.F0000664000175000017500000066467714102210524016150 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_LOAD implicit none PUBLIC :: CMUMPS_LOAD_SET_INICOST, CMUMPS_LOAD_INIT, & CMUMPS_LOAD_SET_SLAVES, CMUMPS_LOAD_UPDATE, & CMUMPS_LOAD_END, CMUMPS_LOAD_PROCESS_MESSAGE, & CMUMPS_LOAD_LESS, CMUMPS_LOAD_LESS_CAND, & CMUMPS_LOAD_SET_SLAVES_CAND, CMUMPS_LOAD_MASTER_2_ALL, & CMUMPS_LOAD_RECV_MSGS, CMUMPS_LOAD_MEM_UPDATE, & CMUMPS_LOAD_SET_PARTITION, & CMUMPS_SPLIT_PREP_PARTITION, CMUMPS_SPLIT_POST_PARTITION, & CMUMPS_SPLIT_PROPAGATE_PARTI, CMUMPS_LOAD_POOL_UPD_NEW_POOL, & CMUMPS_LOAD_SBTR_UPD_NEW_POOL, CMUMPS_LOAD_POOL_CHECK_MEM, & CMUMPS_LOAD_SET_SBTR_MEM, & CMUMPS_REMOVE_NODE, CMUMPS_UPPER_PREDICT & ,CMUMPS_LOAD_SEND_MD_INFO, & CMUMPS_LOAD_CLEAN_MEMINFO_POOL, CMUMPS_LOAD_COMP_MAXMEM_POOL, & CMUMPS_LOAD_CHK_MEMCST_POOL, CMUMPS_CHECK_SBTR_COST, & CMUMPS_FIND_BEST_NODE_FOR_MEM, & CMUMPS_LOAD_INIT_SBTR_STRUCT DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE, PRIVATE :: LOAD_FLOPS INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: BUF_LOAD_RECV INTEGER, SAVE, PRIVATE :: LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES INTEGER, SAVE, PRIVATE :: K50, K69, K35 INTEGER(8), SAVE, PRIVATE :: MAX_SURF_MASTER LOGICAL, SAVE, PRIVATE :: BDC_MEM, BDC_POOL, BDC_SBTR, & BDC_POOL_MNG, & BDC_M2_MEM,BDC_M2_FLOPS,BDC_MD,REMOVE_NODE_FLAG, & REMOVE_NODE_FLAG_MEM DOUBLE PRECISION, SAVE, PRIVATE :: REMOVE_NODE_COST, & REMOVE_NODE_COST_MEM INTEGER, SAVE, PRIVATE :: SBTR_WHICH_M DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, TARGET, SAVE, PRIVATE :: WLOAD DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM LOGICAL, SAVE, PRIVATE :: IS_MUMPS_LOAD_ENABLED PUBLIC:: MUMPS_LOAD_ENABLE, MUMPS_LOAD_DISABLE INTEGER(8), SAVE, PRIVATE :: CHECK_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, TARGET, PRIVATE :: & IDWLOAD DOUBLE PRECISION, SAVE, PRIVATE :: COST_SUBTREE DOUBLE PRECISION, SAVE, PRIVATE :: ALPHA DOUBLE PRECISION, SAVE, PRIVATE :: BETA INTEGER, SAVE, PRIVATE :: MYID, NPROCS, COMM_LD INTEGER, SAVE, PRIVATE :: COMM_NODES DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE :: POOL_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, PRIVATE, & SAVE :: SBTR_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: SBTR_CUR INTEGER, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: NB_SON DOUBLE PRECISION, & PRIVATE, SAVE :: SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: PEAK_SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: MAX_PEAK_STK DOUBLE PRECISION, SAVE, & PRIVATE :: POOL_LAST_COST_SENT DOUBLE PRECISION, SAVE, & PRIVATE :: MIN_DIFF INTEGER, SAVE :: POS_ID,POS_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: CB_COST_ID INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE & :: CB_COST_MEM PUBLIC :: CB_COST_ID, CB_COST_MEM,POS_MEM,POS_ID DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: LU_USAGE INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE::MD_MEM, TAB_MAXS DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE ::MEM_SUBTREE INTEGER :: NB_SUBTREES,NIV1_FLAG INTEGER, PRIVATE :: INDICE_SBTR,INDICE_SBTR_ARRAY INTEGER :: POOL_NIV2_SIZE INTEGER,SAVE :: INSIDE_SUBTREE PUBLIC :: NB_SUBTREES,MEM_SUBTREE,INSIDE_SUBTREE,NIV1_FLAG DOUBLE PRECISION, SAVE, PRIVATE :: DM_SUMLU, & DM_THRES_MEM DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE , PRIVATE:: DM_MEM INTEGER, SAVE, PRIVATE :: POOL_SIZE,ID_MAX_M2 DOUBLE PRECISION, SAVE, PRIVATE :: MAX_M2,TMP_M2 INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, PRIVATE:: POOL_NIV2 DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE :: POOL_NIV2_COST, NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: CHK_LD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: & PROCNODE_LOAD, STEP_TO_NIV2_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: KEEP_LOAD INTEGER, SAVE, PRIVATE :: N_LOAD INTEGER(8), DIMENSION(:), POINTER, SAVE, PRIVATE:: KEEP8_LOAD INTEGER, DIMENSION(:),POINTER, SAVE :: & FILS_LOAD, STEP_LOAD, & FRERE_LOAD, ND_LOAD, & NE_LOAD,DAD_LOAD INTEGER, DIMENSION(:,:),POINTER, SAVE, PRIVATE :: CAND_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, & PRIVATE :: MY_FIRST_LEAF,MY_NB_LEAF, MY_ROOT_SBTR INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_FIRST_POS_IN_POOL DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_PEAK_ARRAY, & SBTR_CUR_ARRAY DOUBLE PRECISION,DIMENSION(:),POINTER, SAVE :: COST_TRAV INTEGER, DIMENSION(:),POINTER, SAVE :: DEPTH_FIRST_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD PUBLIC :: DEPTH_FIRST_LOAD,COST_TRAV, FILS_LOAD,STEP_LOAD, & FRERE_LOAD, ND_LOAD,NE_LOAD,DAD_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD INTEGER, SAVE :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST PUBLIC :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST CONTAINS SUBROUTINE MUMPS_LOAD_ENABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .TRUE. RETURN END SUBROUTINE MUMPS_LOAD_ENABLE SUBROUTINE MUMPS_LOAD_DISABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .FALSE. RETURN END SUBROUTINE MUMPS_LOAD_DISABLE SUBROUTINE CMUMPS_LOAD_SET_INICOST( COST_SUBTREE_ARG, K64, DK15, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K375 REAL, INTENT(IN) :: DK15 INTEGER(8)::MAXS DOUBLE PRECISION :: T64, T66 LOGICAL :: AVOID_LOAD_MESSAGES T64 = max ( dble(K64), dble(1) ) T64 = min ( T64, dble(1000) ) T66 = max (dble(DK15), dble(100)) MIN_DIFF = ( T64 / dble(1000) )* & T66 * dble(1000000) DM_THRES_MEM = dble(MAXS/300_8) COST_SUBTREE = COST_SUBTREE_ARG AVOID_LOAD_MESSAGES = .FALSE. IF (K375.EQ.1) THEN AVOID_LOAD_MESSAGES = .TRUE. ENDIF IF (AVOID_LOAD_MESSAGES) THEN MIN_DIFF = MIN_DIFF * 1000.D0 DM_THRES_MEM = DM_THRES_MEM * 1000_8 ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_SET_INICOST SUBROUTINE CMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND, ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, SLAVES_LIST, & SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SIZE_SLAVES_LIST, SLAVEF, & KEEP(500) INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), CAND(SLAVEF+1), & FILS(N) INTEGER, intent(out) :: NBSPLIT, NUMORG_SPLIT INTEGER, intent(inout) :: SLAVES_LIST(SIZE_SLAVES_LIST), & COPY_CAND(SLAVEF+1) INTEGER :: IN, LP, II INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT = NBSPLIT + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG_SPLIT = NUMORG_SPLIT + 1 II = FILS(II) ENDDO END DO SLAVES_LIST(1:NBSPLIT) = CAND(1:NBSPLIT) COPY_CAND(1:SIZE_SLAVES_LIST-NBSPLIT) = & CAND(1+NBSPLIT:SIZE_SLAVES_LIST) COPY_CAND(SIZE_SLAVES_LIST-NBSPLIT+1:SLAVEF) = -1 COPY_CAND(SLAVEF+1) = SIZE_SLAVES_LIST-NBSPLIT RETURN END SUBROUTINE CMUMPS_SPLIT_PREP_PARTITION SUBROUTINE CMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & TAB_POS, NSLAVES_NODE & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SLAVEF, NCB, & KEEP(500), NBSPLIT INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N) INTEGER, intent(inout) :: TAB_POS ( SLAVEF+2 ), NSLAVES_NODE INTEGER :: IN, LP, II, NUMORG, NBSPLIT_LOC, I INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT DO I= NSLAVES_NODE+1, 1, -1 TAB_POS(I+NBSPLIT) = TAB_POS(I) END DO LP = ICNTL(1) IN = INODE NBSPLIT_LOC = 0 NUMORG = 0 TAB_POS(1) = 1 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT_LOC = NBSPLIT_LOC + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG = NUMORG + 1 II = FILS(II) ENDDO TAB_POS(NBSPLIT_LOC+1) = NUMORG + 1 END DO DO I = NBSPLIT+2, NBSPLIT+NSLAVES_NODE+1 TAB_POS(I) = TAB_POS(I) + NUMORG ENDDO NSLAVES_NODE = NSLAVES_NODE + NBSPLIT TAB_POS (NSLAVES_NODE+2:SLAVEF+1) = -9999 TAB_POS ( SLAVEF+2 ) = NSLAVES_NODE RETURN END SUBROUTINE CMUMPS_SPLIT_POST_PARTITION SUBROUTINE CMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND, SIZE_CAND, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES_NODE, & SLAVES_LIST, SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, TYPESPLIT, IFSON, N, SLAVEF, & KEEP(500), & NSLSON, SIZE_SLAVES_LIST, SIZE_CAND INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N), INIV2, & SON_SLAVE_LIST (NSLSON), & ISTEP_TO_INIV2(KEEP(71)), & CAND(SIZE_CAND) INTEGER, intent(out) :: NSLAVES_NODE INTEGER, intent(inout) :: & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(out) :: SLAVES_LIST (SIZE_SLAVES_LIST) INTEGER :: IN, LP, I, NSLAVES_SONS, & INIV2_FILS, ISHIFT LP = ICNTL(1) IN = INODE INIV2_FILS = ISTEP_TO_INIV2( STEP( IFSON )) NSLAVES_SONS = TAB_POS_IN_PERE (SLAVEF+2, INIV2_FILS) TAB_POS_IN_PERE (1,INIV2) = 1 ISHIFT = TAB_POS_IN_PERE (2, INIV2_FILS) -1 DO I = 2, NSLAVES_SONS TAB_POS_IN_PERE (I,INIV2) = & TAB_POS_IN_PERE (I+1,INIV2_FILS) - ISHIFT SLAVES_LIST(I-1) = SON_SLAVE_LIST (I) END DO TAB_POS_IN_PERE(NSLAVES_SONS+1:SLAVEF+1,INIV2) = -9999 NSLAVES_NODE = NSLAVES_SONS - 1 TAB_POS_IN_PERE (SLAVEF+2, INIV2) = NSLAVES_NODE RETURN END SUBROUTINE CMUMPS_SPLIT_PROPAGATE_PARTI SUBROUTINE CMUMPS_LOAD_SET_PARTITION( & NCBSON_MAX, SLAVEF, & KEEP,KEEP8,ICNTL, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,INODE &) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: SLAVEF, NFRONT INTEGER, intent (inout) ::NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER i INTEGER LP,MP INTEGER(8) DUMMY1 INTEGER DUMMY2 INTEGER TMP_ARRAY(2) LP=ICNTL(4) MP=ICNTL(2) IF ( KEEP(48) == 0 .OR. KEEP(48) .EQ. 3 ) THEN CALL CMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) ELSE IF ( KEEP(48) == 4 ) THEN CALL CMUMPS_SET_PARTI_ACTV_MEM( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'probleme de partition dans &CMUMPS_LOAD_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN IF (KEEP(375).EQ.1) THEN GOTO 458 ENDIF CALL CMUMPS_SET_PARTI_FLOP_IRR( & NCBSON_MAX, & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & MP,LP) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'problem with partition in &CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO GOTO 457 458 CONTINUE IF ( KEEP(375).EQ.1 )THEN TMP_ARRAY(1)=0 TMP_ARRAY(2)=0 ENDIF CALL CMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS,TMP_ARRAY,DUMMY1,DUMMY2 & ) ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF 457 CONTINUE RETURN END SUBROUTINE CMUMPS_LOAD_SET_PARTITION SUBROUTINE CMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER ITEMP, NMB_OF_CAND, NSLAVES_LESS DOUBLE PRECISION MSG_SIZE LOGICAL FORCE_CAND INTEGER MUMPS_REG_GET_NSLAVES EXTERNAL MUMPS_REG_GET_NSLAVES IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in CMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in CMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF MSG_SIZE = dble( NFRONT - NCB ) * dble(NCB) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF (FORCE_CAND) THEN ITEMP=CMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=CMUMPS_LOAD_LESS(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_REG_GET_NSLAVES(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND, & KEEP(375), KEEP(119)) CALL MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL CMUMPS_LOAD_SET_SLAVES_CAND(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL CMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_PARTI_REGULAR SUBROUTINE CMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) USE CMUMPS_BUF USE CMUMPS_STRUC_DEF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC INTEGER(8) :: I8SIZE INTEGER allocok, IERR, IERR_MPI, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_DBLE(2) INTEGER WHAT INTEGER(8) MEMORY_MD, LA CALL MUMPS_LOAD_ENABLE() STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP8_LOAD=>id%KEEP8 FILS_LOAD=>id%FILS FRERE_LOAD=>id%FRERE_STEPS DAD_LOAD=>id%DAD_STEPS PROCNODE_LOAD=>id%PROCNODE_STEPS STEP_LOAD=>id%STEP NE_LOAD=>id%NE_STEPS N_LOAD=id%N ROOT_CURRENT_SUBTREE=-9999 MEMORY_MD=MEMORY_MD_ARG LA=MAXS MAX_SURF_MASTER=id%MAX_SURF_MASTER+ & (int(id%KEEP(12),8)*int(id%MAX_SURF_MASTER,8)/int(100,8)) COMM_LD = id%COMM_LOAD COMM_NODES = id%COMM_NODES MAX_PEAK_STK = 0.0D0 K69 = id%KEEP(69) IF ( id%KEEP(47) .le. 0 .OR. id%KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in CMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( id%KEEP(47) >= 2 ) BDC_POOL = ( id%KEEP(47) >= 3 ) BDC_SBTR = ( id%KEEP(47) >= 4 ) BDC_M2_MEM = ( ( id%KEEP(80) == 2 .OR. id%KEEP(80) == 3 ) & .AND. id%KEEP(47) == 4 ) BDC_M2_FLOPS = ( id%KEEP(80) == 1 & .AND. id%KEEP(47) .GE. 1 ) BDC_MD = (id%KEEP(86)==1) SBTR_WHICH_M = id%KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (id%KEEP(80) .LT. 0 .OR. id%KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((id%KEEP(80) == 2 .OR. id%KEEP(80)==3).AND. id%KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in CMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF IF (id%KEEP(81) == 1 .AND. id%KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in CMUMPS_LOAD_INIT" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((id%KEEP(81) == 1).AND.(id%KEEP(47) >= 2)) IF(id%KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(id%KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(id%KEEP(76).EQ.6)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST DEPTH_FIRST_SEQ_LOAD=>id%DEPTH_FIRST_SEQ SBTR_ID_LOAD=>id%SBTR_ID ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN POOL_NIV2_SIZE=max(1,min(id%NBSA+id%KEEP(262),id%NA(1))) ALLOCATE(NIV2(id%NSLAVES), NB_SON(id%KEEP(28)), & POOL_NIV2(POOL_NIV2_SIZE), & POOL_NIV2_COST(POOL_NIV2_SIZE), & stat=allocok) DO i = 1, id%KEEP(28) NB_SON(i)=id%NE_STEPS(i) ENDDO NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + id%KEEP(28) + 200 RETURN ENDIF ENDIF K50 = id%KEEP(50) CALL MPI_COMM_RANK( COMM_LD, MYID, IERR_MPI ) NPROCS = id%NSLAVES DM_SUMLU=ZERO POOL_SIZE=0 IF(BDC_MD)THEN IF ( allocated(MD_MEM) ) DEALLOCATE(MD_MEM) ALLOCATE( MD_MEM( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(TAB_MAXS) ) DEALLOCATE(TAB_MAXS) ALLOCATE( TAB_MAXS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF TAB_MAXS=0_8 IF ( allocated(LU_USAGE) ) DEALLOCATE(LU_USAGE) ALLOCATE( LU_USAGE( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((id%KEEP(81).EQ.2).OR.(id%KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_MEM=int(0,8) ALLOCATE(CB_COST_ID(2000*3), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_ID=0 POS_MEM=1 POS_ID=1 ENDIF ALLOCATE(FUTURE_NIV2(NPROCS), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN ENDIF DO i = 1, NPROCS FUTURE_NIV2(i) = id%FUTURE_NIV2(i) IF(BDC_MD)THEN IF(FUTURE_NIV2(i).EQ.0)THEN MD_MEM(i-1)=999999999_8 ENDIF ENDIF ENDDO DELTA_MEM=ZERO DELTA_LOAD=ZERO CHECK_MEM=0_8 IF(BDC_SBTR.OR.BDC_POOL_MNG)THEN NB_SUBTREES=id%NBSA_LOCAL IF (allocated(MEM_SUBTREE)) DEALLOCATE(MEM_SUBTREE) ALLOCATE(MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF DO i=1,id%NBSA_LOCAL MEM_SUBTREE(i)=id%MEM_SUBTREE(i) ENDDO MY_FIRST_LEAF=>id%MY_FIRST_LEAF MY_NB_LEAF=>id%MY_NB_LEAF MY_ROOT_SBTR=>id%MY_ROOT_SBTR IF (allocated(SBTR_FIRST_POS_IN_POOL)) & DEALLOCATE(SBTR_FIRST_POS_IN_POOL) ALLOCATE(SBTR_FIRST_POS_IN_POOL(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF INSIDE_SUBTREE=0 PEAK_SBTR_CUR_LOCAL = dble(0) SBTR_CUR_LOCAL = dble(0) IF (allocated(SBTR_PEAK_ARRAY)) DEALLOCATE(SBTR_PEAK_ARRAY) ALLOCATE(SBTR_PEAK_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_CUR_ARRAY=dble(0) INDICE_SBTR_ARRAY=1 NIV1_FLAG=0 INDICE_SBTR=1 ENDIF IF ( allocated(LOAD_FLOPS) ) DEALLOCATE( LOAD_FLOPS ) ALLOCATE( LOAD_FLOPS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(WLOAD) ) DEALLOCATE( WLOAD ) ALLOCATE( WLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(IDWLOAD) ) DEALLOCATE( IDWLOAD ) ALLOCATE( IDWLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( BDC_MEM ) THEN IF ( allocated(DM_MEM) ) DEALLOCATE( DM_MEM ) ALLOCATE( DM_MEM( 0:NPROCS-1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF END IF IF ( BDC_POOL ) THEN IF ( allocated(POOL_MEM) ) DEALLOCATE(POOL_MEM) ALLOCATE( POOL_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF POOL_MEM = dble(0) POOL_LAST_COST_SENT = dble(0) END IF IF ( BDC_SBTR ) THEN IF ( allocated(SBTR_MEM) ) DEALLOCATE(SBTR_MEM) ALLOCATE( SBTR_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(SBTR_CUR) ) DEALLOCATE(SBTR_CUR) ALLOCATE( SBTR_CUR(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF K34_LOC=id%KEEP(34) CALL MUMPS_SIZE_C(SIZE_DBLE(1),SIZE_DBLE(2),I8SIZE) K35 = int(I8SIZE) BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35 + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 ENDIF LBUF_LOAD_RECV = (BUF_LOAD_SIZE+K34_LOC)/K34_LOC LBUF_LOAD_RECV_BYTES = LBUF_LOAD_RECV * K34_LOC IF ( allocated(BUF_LOAD_RECV) ) DEALLOCATE(BUF_LOAD_RECV) ALLOCATE( BUF_LOAD_RECV( LBUF_LOAD_RECV), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL CMUMPS_BUF_ALLOC_LOAD_BUFFER( BUF_LOAD_SIZE, IERR ) IF ( IERR .LT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = BUF_LOAD_SIZE RETURN END IF DO i = 0, NPROCS - 1 LOAD_FLOPS( i ) = ZERO END DO IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO ENDIF CALL CMUMPS_INIT_ALPHA_BETA(id%KEEP(69)) IF(BDC_MD)THEN MAX_SBTR=0.0D0 IF(BDC_SBTR)THEN DO i=1,id%NBSA_LOCAL MAX_SBTR=max(id%MEM_SUBTREE(i),MAX_SBTR) ENDDO ENDIF MD_MEM(MYID)=MEMORY_MD WHAT=8 CALL CMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & dble(MEMORY_MD),dble(0) ,MYID, id%KEEP, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * & dble(max(id%KEEP(5),id%KEEP(6))) * dble(id%KEEP(127))) IF (id%KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(id%KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF IF (id%KEEP(375).EQ.1) THEN MEMORY_SENT=dble(LA) ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL CMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & MEMORY_SENT, & dble(0),MYID, id%KEEP, IERR ) ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_INIT SUBROUTINE CMUMPS_LOAD_UPDATE( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG INTEGER CHECK_FLOPS INTEGER IERR DOUBLE PRECISION ZERO, SEND_MEM, SEND_LOAD,SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN IF (INC_LOAD == 0.0D0) THEN IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN ENDIF IF((CHECK_FLOPS.NE.0).AND. & (CHECK_FLOPS.NE.1).AND.(CHECK_FLOPS.NE.2))THEN WRITE(*,*)MYID,': Bad value for CHECK_FLOPS' CALL MUMPS_ABORT() ENDIF IF(CHECK_FLOPS.EQ.1)THEN CHK_LD=CHK_LD+INC_LOAD ELSE IF(CHECK_FLOPS.EQ.2)THEN RETURN ENDIF ENDIF IF ( PROCESS_BANDE ) THEN RETURN ENDIF LOAD_FLOPS( MYID ) = max( LOAD_FLOPS( MYID ) + INC_LOAD, ZERO) IF(BDC_M2_FLOPS.AND.REMOVE_NODE_FLAG)THEN IF(INC_LOAD.NE.REMOVE_NODE_COST)THEN IF(INC_LOAD.GT.REMOVE_NODE_COST)THEN DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 ELSE DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_LOAD = DELTA_LOAD + INC_LOAD 888 CONTINUE IF ( DELTA_LOAD > MIN_DIFF .OR. DELTA_LOAD < -MIN_DIFF) THEN SEND_LOAD = DELTA_LOAD IF (BDC_MEM) THEN SEND_MEM = DELTA_MEM ELSE SEND_MEM = ZERO END IF IF(BDC_SBTR)THEN SBTR_TMP=SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF 111 CONTINUE CALL CMUMPS_BUF_SEND_UPDATE_LOAD( BDC_SBTR,BDC_MEM, & BDC_MD,COMM_LD, NPROCS, & SEND_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_UPDATE SUBROUTINE CMUMPS_LOAD_MEM_UPDATE( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLUS) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLUS LOGICAL, INTENT(IN) :: PROCESS_BANDE_ARG, SSARBR INTEGER IERR, KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION ZERO, SEND_MEM, SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs INTEGER(8) :: INC_MEM LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG IF ( PROCESS_BANDE .AND. NEW_LU .NE. 0_8) THEN WRITE(*,*) " Internal Error in CMUMPS_LOAD_MEM_UPDATE." WRITE(*,*) " NEW_LU must be zero if called from PROCESS_BANDE" CALL MUMPS_ABORT() ENDIF DM_SUMLU = DM_SUMLU + dble(NEW_LU) IF(KEEP_LOAD(201).EQ.0)THEN CHECK_MEM = CHECK_MEM + INC_MEM ELSE CHECK_MEM = CHECK_MEM + INC_MEM - NEW_LU ENDIF IF ( MEM_VALUE .NE. CHECK_MEM ) THEN WRITE(*,*)MYID, & ':Problem with increments in CMUMPS_LOAD_MEM_UPDATE', & CHECK_MEM, MEM_VALUE, INC_MEM,NEW_LU CALL MUMPS_ABORT() ENDIF IF (PROCESS_BANDE) THEN RETURN ENDIF IF(BDC_POOL_MNG) THEN IF(SBTR_WHICH_M.EQ.0)THEN IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM-NEW_LU) ELSE IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM) ENDIF ENDIF IF ( .NOT. BDC_MEM ) THEN RETURN ENDIF IF (BDC_SBTR .AND. SSARBR) THEN IF((SBTR_WHICH_M.EQ.0).AND.(KEEP(201).NE.0))THEN SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM-NEW_LU) ELSE SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM) ENDIF SBTR_TMP = SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF IF ( NEW_LU > 0_8 ) THEN INC_MEM = INC_MEM - NEW_LU ENDIF DM_MEM( MYID ) = DM_MEM(MYID) + dble(INC_MEM) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MYID)) IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(dble(INC_MEM).NE.REMOVE_NODE_COST_MEM)THEN IF(dble(INC_MEM).GT.REMOVE_NODE_COST_MEM)THEN DELTA_MEM = DELTA_MEM + & (dble(INC_MEM)-REMOVE_NODE_COST_MEM) GOTO 888 ELSE DELTA_MEM = DELTA_MEM - & (REMOVE_NODE_COST_MEM-dble(INC_MEM)) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_MEM = DELTA_MEM + dble(INC_MEM) 888 CONTINUE IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND.(abs(DELTA_MEM) & .GE.0.2d0*dble(LRLUS))))THEN IF ( abs(DELTA_MEM) > DM_THRES_MEM ) THEN SEND_MEM = DELTA_MEM 111 CONTINUE CALL CMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, & DELTA_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO DELTA_MEM = ZERO ENDIF ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG_MEM)THEN REMOVE_NODE_FLAG_MEM=.FALSE. ENDIF END SUBROUTINE CMUMPS_LOAD_MEM_UPDATE INTEGER FUNCTION CMUMPS_LOAD_LESS( K69, MEM_DISTRIB,MSG_SIZE ) IMPLICIT NONE INTEGER i, NLESS, K69 INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION LREF DOUBLE PRECISION MSG_SIZE NLESS = 0 DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO WLOAD(1:NPROCS) = LOAD_FLOPS(0:NPROCS-1) IF(BDC_M2_FLOPS)THEN DO i=1,NPROCS WLOAD(i)=WLOAD(i)+NIV2(i) ENDDO ENDIF IF(K69 .gt. 1) THEN CALL CMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,IDWLOAD,NPROCS) ENDIF LREF = LOAD_FLOPS(MYID) DO i=1, NPROCS IF (WLOAD(i).LT.LREF) NLESS=NLESS+1 ENDDO CMUMPS_LOAD_LESS = NLESS RETURN END FUNCTION CMUMPS_LOAD_LESS SUBROUTINE CMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB,MSG_SIZE,DEST, & NSLAVES) IMPLICIT NONE INTEGER NSLAVES INTEGER DEST(NSLAVES) INTEGER, DIMENSION(0:NPROCS - 1) :: MEM_DISTRIB INTEGER i,J,NBDEST DOUBLE PRECISION MSG_SIZE IF ( NSLAVES.eq.NPROCS-1 ) THEN J = MYID+1 DO i=1,NSLAVES J=J+1 IF (J.GT.NPROCS) J=1 DEST(i) = J - 1 ENDDO ELSE DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO CALL MUMPS_SORT_DOUBLES(NPROCS, WLOAD, IDWLOAD) NBDEST = 0 DO i=1, NSLAVES J = IDWLOAD(i) IF (J.NE.MYID) THEN NBDEST = NBDEST+1 DEST(NBDEST) = J ENDIF ENDDO IF (NBDEST.NE.NSLAVES) THEN DEST(NSLAVES) = IDWLOAD(NSLAVES+1) ENDIF IF(BDC_MD)THEN J=NSLAVES+1 do i=NSLAVES+1,NPROCS IF(IDWLOAD(i).NE.MYID)THEN DEST(J)= IDWLOAD(i) J=J+1 ENDIF end do ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_SET_SLAVES SUBROUTINE CMUMPS_LOAD_END( INFO1, NSLAVES, IERR ) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT(IN) :: INFO1 INTEGER, INTENT(IN) :: NSLAVES INTEGER, INTENT(OUT) :: IERR INTEGER :: DUMMY_COMMUNICATOR IERR=0 DUMMY_COMMUNICATOR = -999 CALL CMUMPS_CLEAN_PENDING( INFO1, KEEP_LOAD(1), BUF_LOAD_RECV(1), & LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES, DUMMY_COMMUNICATOR, COMM_LD, & NSLAVES, & .FALSE., & .TRUE. & ) DEALLOCATE( LOAD_FLOPS ) DEALLOCATE( WLOAD ) DEALLOCATE( IDWLOAD ) DEALLOCATE(FUTURE_NIV2) IF(BDC_MD)THEN DEALLOCATE(MD_MEM) DEALLOCATE(LU_USAGE) DEALLOCATE(TAB_MAXS) ENDIF IF ( BDC_MEM ) DEALLOCATE( DM_MEM ) IF ( BDC_POOL) DEALLOCATE( POOL_MEM ) IF ( BDC_SBTR) THEN DEALLOCATE( SBTR_MEM ) DEALLOCATE( SBTR_CUR ) DEALLOCATE(SBTR_FIRST_POS_IN_POOL) NULLIFY(MY_FIRST_LEAF) NULLIFY(MY_NB_LEAF) NULLIFY(MY_ROOT_SBTR) ENDIF IF(KEEP_LOAD(76).EQ.4)THEN NULLIFY(DEPTH_FIRST_LOAD) ENDIF IF(KEEP_LOAD(76).EQ.5)THEN NULLIFY(COST_TRAV) ENDIF IF((KEEP_LOAD(76).EQ.4).OR.(KEEP_LOAD(76).EQ.6))THEN NULLIFY(DEPTH_FIRST_LOAD) NULLIFY(DEPTH_FIRST_SEQ_LOAD) NULLIFY(SBTR_ID_LOAD) ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN DEALLOCATE(NB_SON,POOL_NIV2,POOL_NIV2_COST, NIV2) END IF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN DEALLOCATE(CB_COST_MEM) DEALLOCATE(CB_COST_ID) ENDIF NULLIFY(ND_LOAD) NULLIFY(KEEP_LOAD) NULLIFY(KEEP8_LOAD) NULLIFY(FILS_LOAD) NULLIFY(FRERE_LOAD) NULLIFY(PROCNODE_LOAD) NULLIFY(STEP_LOAD) NULLIFY(NE_LOAD) NULLIFY(CAND_LOAD) NULLIFY(STEP_TO_NIV2_LOAD) NULLIFY(DAD_LOAD) IF (BDC_SBTR.OR.BDC_POOL_MNG) THEN DEALLOCATE(MEM_SUBTREE) DEALLOCATE(SBTR_PEAK_ARRAY) DEALLOCATE(SBTR_CUR_ARRAY) ENDIF CALL CMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) DEALLOCATE(BUF_LOAD_RECV) RETURN END SUBROUTINE CMUMPS_LOAD_END RECURSIVE SUBROUTINE CMUMPS_LOAD_RECV_MSGS(COMM) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGLEN, MSGSOU,COMM INTEGER IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR_MPI ) IF (FLAG) THEN KEEP_LOAD(65)=KEEP_LOAD(65)+1 KEEP_LOAD(267)=KEEP_LOAD(267)-1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in CMUMPS_LOAD_RECV_MSGS", & MSGTAG CALL MUMPS_ABORT() ENDIF CALL MPI_GET_COUNT(STATUS, MPI_PACKED, MSGLEN, IERR_MPI) IF ( MSGLEN > LBUF_LOAD_RECV_BYTES ) THEN write(*,*) "Internal error 2 in CMUMPS_LOAD_RECV_MSGS", & MSGLEN, LBUF_LOAD_RECV_BYTES CALL MUMPS_ABORT() ENDIF CALL MPI_RECV( BUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES, & MPI_PACKED, MSGSOU, MSGTAG, COMM_LD, STATUS, IERR_MPI) CALL CMUMPS_LOAD_PROCESS_MESSAGE( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_RECV_MSGS RECURSIVE SUBROUTINE CMUMPS_LOAD_PROCESS_MESSAGE & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, WHAT, NSLAVES, i INTEGER IERR_MPI DOUBLE PRECISION LOAD_RECEIVED INTEGER INODE_RECEIVED,NCB_RECEIVED DOUBLE PRECISION SURF INTEGER, POINTER, DIMENSION (:) :: LIST_SLAVES DOUBLE PRECISION, POINTER, DIMENSION (:) :: LOAD_INCR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WHAT, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) IF ( WHAT == 0 ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MSGSOU)) END IF IF(BDC_SBTR)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_CUR(MSGSOU)=LOAD_RECEIVED ENDIF IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(KEEP_LOAD(201).EQ.0)THEN LU_USAGE(MSGSOU)=LOAD_RECEIVED ENDIF ENDIF ELSEIF (( WHAT == 1).OR.(WHAT.EQ.19)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) + & LOAD_INCR(i) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(LIST_SLAVES(i))) END DO END IF IF(WHAT.EQ.19)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) CALL CMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE_RECEIVED) CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES WRITE(*,*)MYID,':',LIST_SLAVES(i),'->',LOAD_INCR(i) CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(LOAD_INCR(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF NULLIFY( LIST_SLAVES ) NULLIFY( LOAD_INCR ) ELSE IF (WHAT == 2 ) THEN IF ( .not. BDC_POOL ) THEN WRITE(*,*) "Internal error 2 in CMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) POOL_MEM(MSGSOU)=LOAD_RECEIVED ELSE IF ( WHAT == 3 ) THEN IF ( .NOT. BDC_SBTR) THEN WRITE(*,*) "Internal error 3 in CMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED ELSE IF (WHAT == 4) THEN FUTURE_NIV2(MSGSOU+1)=0 IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SURF, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF IF(BDC_M2_MEM.OR.BDC_M2_FLOPS)THEN ENDIF ELSE IF (WHAT == 5) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 7 in CMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN CALL CMUMPS_PROCESS_NIV2_MEM_MSG(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL CMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE_RECEIVED) ENDIF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & KEEP_LOAD(199)).EQ.1 & )THEN CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MSGSOU,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB_RECEIVED,8)* & int(NCB_RECEIVED,8) POS_MEM=POS_MEM+1 ENDIF ENDIF ELSE IF ( WHAT == 6 ) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 8 in CMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSEIF(WHAT == 17)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_MD)THEN DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED ELSEIF(BDC_POOL)THEN POOL_MEM(MSGSOU)=LOAD_RECEIVED ENDIF ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED ENDIF ELSEIF ( WHAT == 7 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 4 &in CMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF END DO ELSEIF ( WHAT == 8 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 5 &in CMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF ELSEIF ( WHAT == 9 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 6 &in CMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) TAB_MAXS(MSGSOU)=int(LOAD_RECEIVED,8) ELSE WRITE(*,*) "Internal error 1 in CMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE CMUMPS_LOAD_PROCESS_MESSAGE integer function CMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB,CAND, & K69, & SLAVEF,MSG_SIZE, & NMB_OF_CAND ) implicit none integer, intent(in) :: K69, SLAVEF INTEGER, intent(in) :: CAND(SLAVEF+1) INTEGER, DIMENSION(0:NPROCS - 1), intent(in) :: MEM_DISTRIB INTEGER, intent(out) :: NMB_OF_CAND integer i,nless DOUBLE PRECISION lref DOUBLE PRECISION MSG_SIZE nless = 0 NMB_OF_CAND=CAND(SLAVEF+1) do i=1,NMB_OF_CAND WLOAD(i)=LOAD_FLOPS(CAND(i)) IF(BDC_M2_FLOPS)THEN WLOAD(i)=WLOAD(i)+NIV2(CAND(i)+1) ENDIF end do IF(K69 .gt. 1) THEN CALL CMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE, & CAND,NMB_OF_CAND) ENDIF lref = LOAD_FLOPS(MYID) do i=1, NMB_OF_CAND if (WLOAD(i).lt.lref) nless=nless+1 end do CMUMPS_LOAD_LESS_CAND = nless return end function CMUMPS_LOAD_LESS_CAND subroutine CMUMPS_LOAD_SET_SLAVES_CAND & (MEM_DISTRIB,CAND, & & SLAVEF, & nslaves_inode, DEST) implicit none integer, intent(in) :: nslaves_inode, SLAVEF integer, intent(in) :: CAND(SLAVEF+1) integer, dimension(0:NPROCS - 1), intent(in) :: MEM_DISTRIB integer, intent(out) :: DEST(CAND(SLAVEF+1)) integer i,j,NMB_OF_CAND external MUMPS_SORT_DOUBLES NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in CMUMPS_LOAD_SET_SLAVES_CAND', & nslaves_inode, NPROCS, NMB_OF_CAND CALL MUMPS_ABORT() end if if (nslaves_inode.eq.NPROCS-1) then j=MYID+1 do i=1,nslaves_inode if(j.ge.NPROCS) j=0 DEST(i)=j j=j+1 end do else do i=1,NMB_OF_CAND IDWLOAD(i)=i end do call MUMPS_SORT_DOUBLES(NMB_OF_CAND, & WLOAD(1),IDWLOAD(1) ) do i=1,nslaves_inode DEST(i)= CAND(IDWLOAD(i)) end do IF(BDC_MD)THEN do i=nslaves_inode+1,NMB_OF_CAND DEST(i)= CAND(IDWLOAD(i)) end do ENDIF end if return end subroutine CMUMPS_LOAD_SET_SLAVES_CAND SUBROUTINE CMUMPS_INIT_ALPHA_BETA(K69) IMPLICIT NONE INTEGER K69 IF (K69 .LE. 4) THEN ALPHA = 0.0d0 BETA = 0.0d0 RETURN ENDIF IF (K69 .EQ. 5) THEN ALPHA = 0.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 6) THEN ALPHA = 0.5d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 7) THEN ALPHA = 0.5d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 8) THEN ALPHA = 1.0d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 9) THEN ALPHA = 1.0d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 10) THEN ALPHA = 1.0d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 11) THEN ALPHA = 1.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 12) THEN ALPHA = 1.5d0 BETA = 100000.0d0 RETURN ENDIF ALPHA = 1.5d0 BETA = 150000.0d0 RETURN END SUBROUTINE CMUMPS_INIT_ALPHA_BETA SUBROUTINE CMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,ARRAY_ADM,LEN) IMPLICIT NONE INTEGER i,LEN INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION MSG_SIZE,FORBIGMSG INTEGER ARRAY_ADM(LEN) DOUBLE PRECISION MY_LOAD FORBIGMSG = 1.0d0 IF (K69 .lt.2) THEN RETURN ENDIF IF(BDC_M2_FLOPS)THEN MY_LOAD=LOAD_FLOPS(MYID)+NIV2(MYID+1) ELSE MY_LOAD=LOAD_FLOPS(MYID) ENDIF IF((MSG_SIZE * dble(K35) ) .gt. 3200000.0d0) THEN FORBIGMSG = 2.0d0 ENDIF IF (K69 .le. 4) THEN DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i)/MY_LOAD ELSE IF ( MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1 ) THEN WLOAD(i) = WLOAD(i) * & dble(MEM_DISTRIB(ARRAY_ADM(i))) & * FORBIGMSG & + dble(2) ENDIF ENDIF ENDDO RETURN ENDIF DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i) / MY_LOAD ELSE IF(MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1) THEN WLOAD(i) = (WLOAD(i) + & ALPHA * MSG_SIZE * dble(K35) + & BETA) * FORBIGMSG ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ARCHGENWLOAD SUBROUTINE CMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: MYID, SLAVEF, COMM, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES( NSLAVES ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER NCB, NFRONT, NBROWS_SLAVE INTEGER i, IERR,WHAT,INODE, allocok LOGICAL :: EXIT_FLAG DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: FLOPS_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: CB_BAND ALLOCATE(MEM_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of MEM_INCREMENT ' & // 'in routine CMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(FLOPS_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of FLOPS_INCREMENT ' & // 'in routine CMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(CB_BAND(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of CB_BAND ' & // 'in routine CMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in CMUMPS_LOAD_MASTER_2_ALL" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL CMUMPS_BUF_SEND_NOT_MSTR(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),KEEP,IERR) IF (IERR == -1 ) THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in CMUMPS_LOAD_MASTER_2_ALL", & NSLAVES, TAB_POS(SLAVEF+2) CALL MUMPS_ABORT() ENDIF NCB = TAB_POS(NSLAVES+1) - 1 NFRONT = NCB + NASS DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) IF ( KEEP(50) == 0 ) THEN FLOPS_INCREMENT( i ) = (dble(NBROWS_SLAVE)*dble( NASS ))+ & dble(NBROWS_SLAVE) * dble(NASS) * & dble(2*NFRONT-NASS-1) ELSE FLOPS_INCREMENT( i ) = dble(NBROWS_SLAVE) * dble(NASS ) * & dble( 2 * ( NASS + TAB_POS(i+1) - 1 ) & - NBROWS_SLAVE - NASS + 1 ) ENDIF IF ( BDC_MEM ) THEN IF ( KEEP(50) == 0 ) THEN MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT) ELSE MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble( NASS + TAB_POS(i+1) - 1 ) END IF ENDIF IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN CB_BAND(i)=dble(-999999) ELSE IF ( KEEP(50) == 0 ) THEN CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT-NASS) ELSE CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(TAB_POS(i+1)-1) END IF ENDIF END DO IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(CB_BAND(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF 111 CONTINUE CALL CMUMPS_BUF_BCAST_ARRAY(BDC_MEM, COMM, MYID, SLAVEF, & FUTURE_NIV2, & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = LOAD_FLOPS(LIST_SLAVES(i)) & + FLOPS_INCREMENT(i) IF ( BDC_MEM ) THEN DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) & + MEM_INCREMENT(i) END IF ENDDO ENDIF 100 CONTINUE DEALLOCATE(MEM_INCREMENT,FLOPS_INCREMENT,CB_BAND) RETURN END SUBROUTINE CMUMPS_LOAD_MASTER_2_ALL SUBROUTINE CMUMPS_LOAD_POOL_UPD_NEW_POOL( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL, SLAVEF, COMM, MYID INTEGER N, KEEP(500) INTEGER(8) KEEP8(150) INTEGER POOL( LPOOL ), PROCNODE( KEEP(28) ), STEP( N ) INTEGER ND( KEEP(28) ), FILS( N ) INTEGER i, INODE, NELIM, NFR, LEVEL, IERR, WHAT DOUBLE PRECISION COST LOGICAL :: EXIT_FLAG INTEGER NBINSUBTREE,NBTOP,INSUBTREE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF(BDC_MD)THEN RETURN ENDIF IF((KEEP(76).EQ.0).OR.(KEEP(76).EQ.2))THEN IF(NBTOP.NE.0)THEN DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE IF(KEEP(76).EQ.1)THEN IF(INSUBTREE.EQ.1)THEN DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE WRITE(*,*) & 'Internal error: Unknown pool management strategy' CALL MUMPS_ABORT() ENDIF ENDIF 20 CONTINUE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS(i) GOTO 10 ENDIF NFR = ND( STEP(INODE) ) LEVEL = MUMPS_TYPENODE( PROCNODE(STEP(INODE)), KEEP(199) ) IF (LEVEL .EQ. 1) THEN COST = dble( NFR ) * dble( NFR ) ELSE IF ( KEEP(50) == 0 ) THEN COST = dble( NFR ) * dble( NELIM ) ELSE COST = dble( NELIM ) * dble( NELIM ) ENDIF ENDIF 30 CONTINUE IF ( abs(POOL_LAST_COST_SENT-COST).GT.DM_THRES_MEM ) THEN WHAT = 2 111 CONTINUE CALL CMUMPS_BUF_BROADCAST( WHAT, & COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_POOL_UPD_NEW_POOL SUBROUTINE CMUMPS_LOAD_SBTR_UPD_NEW_POOL( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL,MYID,SLAVEF,COMM,INODE INTEGER POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER WHAT,IERR LOGICAL OK DOUBLE PRECISION COST LOGICAL FLAG, EXIT_FLAG EXTERNAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_LOAD(STEP_LOAD(INODE)), KEEP(199)) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)))THEN IF(NE_LOAD(STEP_LOAD(INODE)).EQ.0)THEN RETURN ENDIF ENDIF FLAG=.FALSE. IF(INDICE_SBTR.LE.NB_SUBTREES)THEN IF(INODE.EQ.MY_FIRST_LEAF(INDICE_SBTR))THEN FLAG=.TRUE. ENDIF ENDIF IF(FLAG)THEN SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY)=MEM_SUBTREE(INDICE_SBTR) SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY)=SBTR_CUR(MYID) INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY+1 WHAT = 3 IF(dble(MEM_SUBTREE(INDICE_SBTR)).GE.DM_THRES_MEM)THEN 111 CONTINUE CALL CMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in CMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF SBTR_MEM(MYID)=SBTR_MEM(MYID)+ & dble(MEM_SUBTREE(INDICE_SBTR)) INDICE_SBTR=INDICE_SBTR+1 IF(INSIDE_SUBTREE.EQ.0)THEN INSIDE_SUBTREE=1 ENDIF ELSE IF(INODE.EQ.MY_ROOT_SBTR(INDICE_SBTR-1))THEN WHAT = 3 COST=-SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY-1) IF(abs(COST).GE.DM_THRES_MEM)THEN 112 CONTINUE CALL CMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in CMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY-1 SBTR_MEM(MYID)=SBTR_MEM(MYID)- & SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY) SBTR_CUR(MYID)=SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY) IF(INDICE_SBTR_ARRAY.EQ.1)THEN SBTR_CUR(MYID)=dble(0) INSIDE_SUBTREE=0 ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_LOAD_SBTR_UPD_NEW_POOL SUBROUTINE CMUMPS_SET_PARTI_ACTV_MEM & (SLAVEF,KEEP,KEEP8,PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47, K48, K50 INTEGER(8) :: K821 DOUBLE PRECISION DK821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS INTEGER(8)::TOTAL_MEM LOGICAL FORCE_CAND DOUBLE PRECISION TEMP(SLAVEF),PEAK INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME IF (KEEP8(21) .GT. 0_8) THEN write(*,*)MYID, & ": Internal Error 1 in CMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF K821=abs(KEEP8(21)) DK821=dble(K821) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF(K48.NE.4)THEN WRITE(*,*)'CMUMPS_COMPUTE_PARTI_ACTV_MEM_K821 & should be called with KEEP(48) different from 4' CALL MUMPS_ABORT() ENDIF KMIN=1 KMAX=int(K821/int(NFRONT,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=DM_MEM(PROCS(i)) IDWLOAD(i)=PROCS(i) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = DM_MEM(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) TOTAL_MEM=int(NCB,8)*int(NFRONT,8) SOMME=dble(0) J=1 PEAK=dble(0) DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN PEAK=max(PEAK,WLOAD(i)) TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_SBTR)THEN TEMP(J)=TEMP(J)+SBTR_MEM(IDWLOAD(i))- & SBTR_CUR(IDWLOAD(i)) ENDIF IF(BDC_POOL)THEN TEMP(J)=TEMP(J)+POOL_MEM(TEMP_ID(J)) ENDIF IF(BDC_M2_MEM)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) IF(K50.EQ.0)THEN PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT)*dble(NFRONT-NCB)) ELSE PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT-NCB)*dble(NFRONT-NCB)) ENDIF PEAK=max(PEAK,TEMP(OTHERS)) SOMME=dble(0) DO i=1,NUMBER_OF_PROCS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(SOMME.LE.dble(TOTAL_MEM)) THEN GOTO 096 ENDIF 096 CONTINUE SOMME=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(dble(TOTAL_MEM).GE.SOMME) THEN AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,OTHERS IF(K50.EQ.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC IF(X.LE.0) THEN WRITE(*,*)"Internal Error 2 in & CMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 111 IF(NCB.EQ.ACC) GOTO 111 ENDDO 111 CONTINUE IF((ACC.GT.NCB))THEN X=0 DO i=1,OTHERS X=X+NB_ROWS(i) ENDDO WRITE(*,*)'NCB=',NCB,',SOMME=',X WRITE(*,*)MYID, & ": Internal Error 3 in CMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF IF((NCB.NE.ACC))THEN IF(K50.NE.0)THEN IF(CHOSEN.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+ADDITIONNAL_ROWS ELSE TMP_SUM=dble(TOTAL_MEM)/dble(NUMBER_OF_PROCS) CHOSEN=0 ACC=0 DO i=1,OTHERS X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 002 IF(NCB.EQ.ACC) GOTO 002 ENDDO 002 CONTINUE IF(ACC.LT.NCB)THEN NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+(NCB-ACC) ENDIF ENDIF GOTO 333 ENDIF ADDITIONNAL_ROWS=NCB-ACC DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 222 ENDIF ENDDO 222 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 333 CONTINUE IF(NB_ROWS(CHOSEN).EQ.0) CHOSEN=CHOSEN-1 GOTO 889 ELSE DO i=OTHERS,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(dble(TOTAL_MEM).GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i DO J=1,i IF(TEMP(J).EQ.TEMP(i)) THEN SMALL_SET=J GOTO 123 ENDIF ENDDO 123 CONTINUE IF(i.EQ.1)THEN NB_ROWS(i)=NCB CHOSEN=1 GOTO 666 ENDIF 323 CONTINUE AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 4 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 5 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ':Internal error 6 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LT.OTHERS)THEN SMALL_SET=REF+1 REF=SMALL_SET GOTO 323 ELSE NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+NCB-ACC GOTO 666 ENDIF ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 X=int(ADDITIONNAL_ROWS/(i-1)) IF((X.EQ.0).AND.(ADDITIONNAL_ROWS.NE.0))THEN DO WHILE ((J.LT.i).AND.(ADDITIONNAL_ROWS.GT.0)) NB_ROWS(J)=NB_ROWS(J)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 J=J+1 ENDDO IF(ADDITIONNAL_ROWS.NE.0)THEN WRITE(*,*)MYID, & ':Internal error 7 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF GOTO 047 ENDIF IF((TEMP(1)+dble((NB_ROWS(1)+X)*NFRONT)).LE. & TEMP(i))THEN DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=X IF((AFFECTED+NB_ROWS(J)).GT. & KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED J=J+1 ENDDO ELSE DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))*dble(NFRONT)))) & /dble(NFRONT)) IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO ENDIF i=i+1 ENDDO 047 CONTINUE IF((ADDITIONNAL_ROWS.EQ.0).AND. & (i.LT.NUMBER_OF_PROCS))THEN CHOSEN=i-1 ELSE CHOSEN=i-2 ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))* & dble(NFRONT))))/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO i=i+1 ENDDO CHOSEN=i-2 ENDIF CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN IF(K50.NE.0) THEN IF((TEMP(i)+dble(NB_ROWS(i)) & *dble(X+NB_ROWS(i)+NFRONT-NCB)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF IF(K50.EQ.0) THEN IF((TEMP(i)+dble(NB_ROWS(i))*dble(NFRONT)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO ENDIF 889 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN IF(X.EQ.1)THEN WRITE(*,*)MYID, & ':Internal error 12 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 DO i=1,CHOSEN SLAVES_LIST(i)=TEMP_ID(i) TAB_POS(i)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*) & 'Internal error 14 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*) & 'Internal error 15 in CMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF END SUBROUTINE CMUMPS_SET_PARTI_ACTV_MEM SUBROUTINE CMUMPS_SET_PARTI_FLOP_IRR & (NCBSON_MAX,SLAVEF,KEEP,KEEP8, & PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID,INODE,MP,LP) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: MP,LP INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47,K48, K50,K83,K69 INTEGER(8) :: K821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM,DELTA,A,B,C,MASTER_WORK INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS,NELIM INTEGER(8) X8 LOGICAL FORCE_CAND,SMP DOUBLE PRECISION BANDE_K821 INTEGER NB_SAT,NB_ZERO DOUBLE PRECISION TEMP(SLAVEF),TOTAL_COST, MAX_MEM_ALLOW INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) INTEGER NSLAVES_REF,NCB_FILS EXTERNAL MPI_WTIME,MUMPS_GETKMIN INTEGER MUMPS_GETKMIN INTEGER POS_MIN_LOAD,SIZE_MY_SMP,WHAT,ADDITIONNAL_ROWS_SPECIAL LOGICAL HAVE_TYPE1_SON DOUBLE PRECISION MIN_LOAD,MAX_LOAD,TEMP_MAX_LOAD DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION BUF_SIZE,NELIM_MEM_SIZE DOUBLE PRECISION MEM_SIZE_STRONG(SLAVEF),MEM_SIZE_WEAK(SLAVEF) K821=abs(KEEP8(21)) TEMP_MAX_LOAD=dble(0) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) K83=KEEP(83) K69=0 NCB_FILS=NCBSON_MAX IF(int(NCB_FILS,8)*int(min(NCB,NCB_FILS),8).GT.K821)THEN HAVE_TYPE1_SON=.TRUE. ELSE HAVE_TYPE1_SON=.FALSE. ENDIF SMP=(K69.NE.0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF NELIM=NFRONT-NCB KMAX=int(K821/int(NCB,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=LOAD_FLOPS(PROCS(i)) IDWLOAD(i)=PROCS(i) WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = LOAD_FLOPS(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Negative load ', & WLOAD(i) ENDIF ENDIF WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF KMAX=int(NCB/OTHERS) KMIN=MUMPS_GETKMIN(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) IF(K50.EQ.0)THEN TOTAL_COST=dble( NELIM ) * dble ( NCB ) + & dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE TOTAL_COST=dble(NELIM) * dble ( NCB ) * & dble(NFRONT+1) ENDIF CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM,K50, & 2,MASTER_WORK) SOMME=dble(0) J=1 IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.GT.K83))THEN MASTER_WORK=dble(KEEP(88))*MASTER_WORK/dble(100) ENDIF IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.LE.K83))THEN MASTER_WORK=dble(KEEP(87))*MASTER_WORK/dble(100) ENDIF IF(MASTER_WORK.LT.dble(1))THEN MASTER_WORK=dble(1) ENDIF NSLAVES_REF=int(TOTAL_COST/MASTER_WORK)+1 IF(FORCE_CAND)THEN NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS) ELSE NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS-1) ENDIF DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_M2_FLOPS)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) SOMME=dble(0) TMP_SUM=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) TMP_SUM=TMP_SUM+TEMP(i) ENDDO TMP_SUM=(TMP_SUM/dble(OTHERS))+ & (TOTAL_COST/dble(OTHERS)) SIZE_MY_SMP=OTHERS MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 IF(.NOT.SMP) MAX_LOAD=TEMP(OTHERS) IF(SMP)THEN J=1 DO i=1,OTHERS IF(MEM_DISTRIB(TEMP_ID(i)).EQ.1)THEN IF(TEMP(i).LE.TMP_SUM)THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ELSE ENDIF ENDIF ENDDO MAX_LOAD=WLOAD(J-1) SIZE_MY_SMP=J-1 DO i=1,OTHERS IF((MEM_DISTRIB(TEMP_ID(i)).NE.1).OR. & ((MEM_DISTRIB(TEMP_ID(i)).EQ.1).AND. & (TEMP(i).GE.TMP_SUM)))THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ENDIF ENDDO TEMP=WLOAD TEMP_ID=IDWLOAD ENDIF IF(BDC_MD)THEN BUF_SIZE=dble(K821) IF (KEEP(201).EQ.2) THEN A=dble(int((dble(KEEP(100))/dble(2))/dble(NELIM))) IF(K50.EQ.0)THEN BUF_SIZE=min(BUF_SIZE,A*dble(NCB)) ELSE BUF_SIZE=min(BUF_SIZE,A*A) ENDIF ENDIF BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS A=dble(MD_MEM(TEMP_ID(i)))/ & dble(NELIM) A=A*dble(NFRONT) IF(K50.EQ.0)THEN B=dble(int(dble(NCB)/dble(NUMBER_OF_PROCS))+1)* & dble(NFRONT) ELSE WHAT = 5 CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) B=dble(X8)+(dble(J)*dble(NELIM)) ENDIF NELIM_MEM_SIZE=A+B MEM_SIZE_WEAK(i)=NELIM_MEM_SIZE IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF IF(min(MEM_SIZE_STRONG(i),MEM_SIZE_WEAK(i)).LT.dble(0))THEN IF(MEM_SIZE_STRONG(i).LT.0.0d0)THEN MEM_SIZE_STRONG(i)=dble(0) ELSE MEM_SIZE_WEAK(i)=dble(0) ENDIF ENDIF ENDDO ELSE BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF MEM_SIZE_STRONG(i)=max(dble(0),MEM_SIZE_STRONG(i)) MEM_SIZE_WEAK(i)=huge(MEM_SIZE_WEAK(i)) ENDDO ENDIF IF((((NUMBER_OF_PROCS.LE.K83).AND.FORCE_CAND).AND. & (TOTAL_COST.GE.SOMME)).OR. & (.NOT.FORCE_CAND).OR. & (((NUMBER_OF_PROCS+1).GT.K83).AND.FORCE_CAND))THEN REF=NSLAVES_REF SMALL_SET=NSLAVES_REF IF(.NOT.SMP)THEN DO i=NSLAVES_REF,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(TOTAL_COST.GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) 450 CONTINUE SOMME=dble(0) DO J=1,X SOMME=SOMME+(TEMP(X)-TEMP(J)) ENDDO IF(SOMME.GT.TOTAL_COST)THEN X=X-1 GOTO 450 ELSE IF(X.LT.SIZE_MY_SMP) THEN REF=X SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) J=X+1 MAX_LOAD=TEMP(X) TMP_SUM=MAX_LOAD DO i=X+1,OTHERS IF(TEMP(i).GT.MAX_LOAD)THEN SOMME=SOMME+(dble(i-1)*(TEMP(i)-MAX_LOAD)) TMP_SUM=MAX_LOAD MAX_LOAD=TEMP(i) ELSE SOMME=SOMME+(MAX_LOAD-TEMP(i)) ENDIF IF(i.EQ.NSLAVES_REF)THEN SMALL_SET=NSLAVES_REF REF=SMALL_SET GOTO 323 ENDIF IF(SOMME.GT.TOTAL_COST)THEN REF=i-1 SMALL_SET=i-1 MAX_LOAD=TMP_SUM GOTO 323 ENDIF ENDDO ENDIF ENDIF ENDIF 323 CONTINUE MAX_LOAD=dble(0) DO i=1,SMALL_SET MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO TEMP_MAX_LOAD=MAX_LOAD NB_ROWS=0 TMP_SUM=dble(0) CHOSEN=0 ACC=0 NB_SAT=0 NB_ZERO=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) X=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 1 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF TMP_SUM=MAX_LOAD IF(K50.EQ.0)THEN MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM)* & dble(2*NFRONT-NELIM-1)))) ELSE MAX_LOAD=max(MAX_LOAD, & TEMP(i)+(dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ACC)-NB_ROWS(i) & -NELIM+1)) ENDIF IF(TMP_SUM.LT.MAX_LOAD)THEN ENDIF IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 2 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ': Internal error 3 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LE.OTHERS)THEN IF((NB_SAT.EQ.SMALL_SET).AND.(SMALL_SET.LT. & NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ADDITIONNAL_ROWS_SPECIAL=NCB-ACC DO i=1,SMALL_SET MAX_LOAD=TEMP_MAX_LOAD ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS-NELIM & +1) SOMME=SOMME/dble(SMALL_SET-NB_SAT) NB_ROWS=0 NB_ZERO=0 ACC=0 CHOSEN=0 NB_SAT=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO J=1,SMALL_SET A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=(dble(NELIM)*dble(NELIM+2*ACC+1)) C=-(MAX_LOAD-TEMP(J)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) X=X+1 IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 4 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE NB_ZERO=NB_ZERO+1 X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN NB_ZERO=NB_ZERO+1 X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X TMP_SUM=MAX_LOAD TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(J)+(dble(NELIM) * & dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(NCB.EQ.ACC) GOTO 666 ENDDO IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF(NB_ZERO.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF((NB_SAT+NB_ZERO).EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF ENDDO 434 CONTINUE ADDITIONNAL_ROWS=NCB-ACC IF(ADDITIONNAL_ROWS.NE.0)THEN IF(ADDITIONNAL_ROWS.LT.KMIN)THEN i=CHOSEN J=ACC 436 CONTINUE IF(NB_ROWS(i).NE.0)THEN J=J-NB_ROWS(i) A=dble(1) B=dble(J+2) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(J+2+NELIM) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(J+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(NB_ROWS(i).NE.KMAX)THEN IF(NCB-J.LE.KMAX)THEN NB_ROWS(i)=+NCB-J ADDITIONNAL_ROWS=0 ENDIF ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(i)+ & (dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(i) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF ELSE i=i-1 IF(i.NE.0)GOTO 436 ENDIF IF(ADDITIONNAL_ROWS.NE.0)THEN i=CHOSEN IF(i.NE.SMALL_SET)THEN i=i+1 IF(NB_ROWS(i).NE.0)THEN WRITE(*,*)MYID, & ': Internal error 5 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF CHOSEN=i ENDIF ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X ACC=ACC+X ADDITIONNAL_ROWS=NCB-ACC ELSE IF((TEMP(i).GT.MAX_LOAD))THEN MAX_LOAD=TEMP(i) NB_SAT=0 ACC=0 NB_ROWS=0 DO J=1,i A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(J)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 6 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF ACC=ACC+X MAX_LOAD=max(MAX_LOAD, & TEMP(J)+ & (dble(NELIM)*dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(NCB.EQ.ACC) GOTO 741 IF(NCB-ACC.LT.KMIN) GOTO 210 ENDDO 210 CONTINUE ENDIF 741 CONTINUE i=i+1 ADDITIONNAL_ROWS=NCB-ACC ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)*dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 7 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=min(KMAX,KMIN) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 488 ENDDO 488 CONTINUE ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 8 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=KMIN ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 477 ENDDO 477 CONTINUE IF(ACC.NE.NCB)THEN NB_SAT=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN NB_SAT=NB_SAT+1 ENDIF ACC=ACC+NB_ROWS(i) IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 834 ENDDO 834 CONTINUE ENDIF IF(ACC.NE.NCB)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS-NB_SAT) ACC=0 DO i=1,CHOSEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN GOTO 102 ENDIF A=dble(NELIM) B=dble(NELIM)* & dble(NELIM+2*(ACC+NB_ROWS(i))+1) C=-(SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(1) B=dble(ACC+NELIM) C=dble(-BANDE_K821) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 9 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC+X+NB_ROWS(i)).GT.NCB)THEN IF((NCB-ACC).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NCB-ACC ENDIF ELSE IF((NB_ROWS(i)+X).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+X ENDIF ENDIF 102 CONTINUE ACC=ACC+NB_ROWS(i) IF(NCB.EQ.ACC) THEN CHOSEN=i GOTO 666 ENDIF IF(NCB-ACC.LT.KMIN) THEN CHOSEN=i GOTO 007 ENDIF ENDDO 007 CONTINUE DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ACC=ACC+1 IF(ACC.EQ.NCB)GOTO 666 ENDDO IF(ACC.LT.NCB)THEN IF(SMP)THEN NB_ROWS(1)=NB_ROWS(1)+NCB-ACC ELSE NB_ROWS(POS_MIN_LOAD)= & NB_ROWS(POS_MIN_LOAD)+NCB-ACC ENDIF ENDIF ENDIF GOTO 666 ENDIF ENDIF GOTO 666 ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 IF(NB_SAT.EQ.SMALL_SET) GOTO 777 DO i=1,SMALL_SET IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & (dble(NFRONT+1))) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF WLOAD(i)=MAX_MEM_ALLOW ENDDO CALL MUMPS_SORT_DOUBLES(SMALL_SET, WLOAD, IDWLOAD) NB_ZERO=0 IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LT.NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LE.NUMBER_OF_PROCS))GOTO 777 AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) DO i=1,SMALL_SET KMAX=int(WLOAD(i)/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN GOTO 912 ENDIF IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GT.KMAX)THEN IF(NB_ROWS(IDWLOAD(i)).GT.KMAX)THEN ENDIF ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX NB_SAT=NB_SAT+1 IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.NE.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM) * & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))* & dble(NELIM))* & dble(2*NFRONT-NELIM-1))) GOTO 777 ENDIF ENDIF AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) ELSE IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GE.KMIN)THEN X=min(AFFECTED,ADDITIONNAL_ROWS) NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE X=int((MAX_LOAD-TEMP(IDWLOAD(i)))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X+AFFECTED.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ELSE X=AFFECTED+X ENDIF IF(X.GE.KMIN)THEN NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & X ELSE NB_ZERO=NB_ZERO+1 ENDIF ENDIF ENDIF 912 CONTINUE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM)* & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(SMALL_SET.LT.NUMBER_OF_PROCS)THEN IF(MAX_LOAD.GT.TEMP(SMALL_SET+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(SMALL_SET.EQ.NB_SAT)GOTO 777 IF(ADDITIONNAL_ROWS.EQ.0)THEN CHOSEN=SMALL_SET GOTO 049 ENDIF ENDDO 777 CONTINUE IF((NB_ZERO.NE.0).AND.(ADDITIONNAL_ROWS.GE.KMIN))THEN J=NB_ZERO 732 CONTINUE X=int(ADDITIONNAL_ROWS/(J)) IF(X.LT.KMIN)THEN J=J-1 GOTO 732 ENDIF IF(X*J.LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,SMALL_SET AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(i).EQ.0)THEN IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(X.GT.KMAX)THEN X=KMAX ENDIF IF(X.GT.KMIN)THEN NB_ROWS(i)=X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) ENDIF ENDIF ENDDO ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) AFFECTED=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF ELSE IF((TEMP(i).GT.MAX_LOAD))THEN IF(NB_SAT.EQ.i-1) GOTO 218 X=(ADDITIONNAL_ROWS/(i-1-NB_SAT)) ACC=1 DO J=1,i-1 TMP_SUM=((dble(NELIM) * dble(NB_ROWS(J)+X)) & +(dble(NB_ROWS(J)+X)*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) IF((TEMP(J)+TMP_SUM).GT.MAX_LOAD)THEN ACC=0 ENDIF ENDDO IF(ACC.EQ.1)THEN MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ELSE MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF TMP_SUM=((dble(NELIM)* dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 10 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ENDIF ENDIF 218 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN IF(NB_ROWS(i)+1.GE.KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 ENDIF MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((ADDITIONNAL_ROWS.NE.0))THEN IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN i=CHOSEN+1 ELSE IF(CHOSEN.NE.NUMBER_OF_PROCS)THEN WRITE(*,*)MYID, & ': Internal error 11 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF i=CHOSEN ENDIF DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(TEMP(i).LE.MAX_LOAD)THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) AFFECTED=X IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 12 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF IF(i.NE.NUMBER_OF_PROCS) GOTO 624 ELSE IF((TEMP(i).GT.MAX_LOAD))THEN X=int(ADDITIONNAL_ROWS/i-1) X=max(X,1) IF((MAX_LOAD+((dble(NELIM)* & dble(X))+(dble( & X)*dble(NELIM))*dble( & (2*NFRONT-NELIM-1)))).LE.TEMP(i))THEN AFFECTED=X POS=1 ELSE POS=0 ENDIF MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) MAX_MEM_ALLOW=BANDE_K821 IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(POS.EQ.0)THEN TMP_SUM=((dble(NELIM) * & dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((TEMP(i)-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT- & NELIM))) ELSE X=int(TMP_SUM) ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((X+NB_ROWS(J)).GT.KMAX)THEN X=KMAX-NB_ROWS(J) ELSE IF((NB_ROWS(J)+X).LT. & KMIN)THEN X=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF J=J+1 ENDDO ENDIF 624 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ACC=0 DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 13 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((X+NB_ROWS(i)).GE.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF((X+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ACC=ACC+1 ELSE ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN CHOSEN=CHOSEN+1 ENDIF IF(ACC.EQ.0)THEN ACC=1 ENDIF X=int(ADDITIONNAL_ROWS/ACC) X=max(X,1) ACC=0 DO i=1,CHOSEN J=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(J)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN J=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(J)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) J=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).LT.KMAX)THEN IF((min(X,J)+NB_ROWS(i)).GE.KMAX)THEN IF((KMAX-NB_ROWS(i)).GT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ENDIF ELSE IF((min(X,J)+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+min(X,J) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & min(X,J) ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(ACC.GT.0)THEN DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT. & ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF(NB_ROWS(i).EQ.0)THEN IF(min(KMIN,KMAX).LT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=min(KMIN,KMAX) ADDITIONNAL_ROWS= & ADDITIONNAL_ROWS- & min(KMIN,KMAX) ENDIF ELSE NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO ENDIF DO i=1,CHOSEN IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-dble(NB_ROWS(i)*NFRONT)) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 049 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO i=1,CHOSEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(i)=NB_ROWS(i)+X IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 049 CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO GOTO 890 ELSE IF((KEEP(83).GE.NUMBER_OF_PROCS).AND.FORCE_CAND)THEN MAX_LOAD=dble(0) DO i=1,OTHERS MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO ACC=0 CHOSEN=0 X=1 DO i=1,OTHERS ENDDO DO i=2,OTHERS IF(TEMP(i).EQ.TEMP(1))THEN X=X+1 ELSE GOTO 329 ENDIF ENDDO 329 CONTINUE TMP_SUM=TOTAL_COST/dble(X) TEMP_MAX_LOAD=dble(0) DO i=1,OTHERS IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i))) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN SOMME=MAX_LOAD-TEMP(i) ELSE SOMME=TMP_SUM ENDIF X=int(SOMME/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GT.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=min(KMIN,KMAX) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN C=-(MAX_LOAD-TEMP(i)) ELSE C=-TMP_SUM ENDIF DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 14 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GT.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LE.min(KMIN,KMAX))THEN IF(KMAX.LT.KMIN)THEN X=0 ELSE X=min(KMIN,KMAX) ENDIF ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD,TEMP(i)) NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(ACC.EQ.NCB) GOTO 541 ENDDO 541 CONTINUE IF(ACC.LT.NCB)THEN IF(K50.EQ.0)THEN ADDITIONNAL_ROWS=NCB-ACC DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)).LT.KMAX)THEN IF(ADDITIONNAL_ROWS.GT.(KMAX-NB_ROWS(J)))THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(J)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)+X).GT.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(J)=NB_ROWS(J)+X ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,NUMBER_OF_PROCS IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-(dble(NB_ROWS(i))* & dble(NFRONT))) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 889 ENDDO GOTO 994 ELSE ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC ENDIF ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC 994 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(OTHERS)) IF((X*OTHERS).LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,OTHERS NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X IF(ADDITIONNAL_ROWS.LT.X)X=ADDITIONNAL_ROWS ENDDO CHOSEN=OTHERS ENDIF ENDIF 889 CONTINUE MAX_LOAD=TEMP_MAX_LOAD 890 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*)MYID, & ': Internal error 15 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 X=1 DO i=1,J IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(X)=TEMP_ID(i) TAB_POS(X)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*)MYID, & ': Internal error 16 in CMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in CMUMPS_SET_PARTI_FLOP_IRR', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE CMUMPS_SET_PARTI_FLOP_IRR SUBROUTINE CMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(KEEP(28)), POOL(LPOOL), PROCNODE(KEEP(28)) LOGICAL UPPER INTEGER J DOUBLE PRECISION MEM_COST INTEGER NBINSUBTREE,i,NBTOP EXTERNAL CMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR LOGICAL CMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'CMUMPS_LOAD_POOL_CHECK_MEM must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=CMUMPS_LOAD_GET_MEM(INODE) IF((DM_MEM(MYID)+dble(MEM_COST)+ PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL) & .GT.MAX_PEAK_STK)THEN DO i=NBTOP-1,1,-1 INODE = POOL( LPOOL - 2 - i) MEM_COST=CMUMPS_LOAD_GET_MEM(INODE) IF((INODE.LT.0).OR.(INODE.GT.N)) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF IF((DM_MEM(MYID)+dble(MEM_COST)+PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL).LE. & MAX_PEAK_STK) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF ENDDO IF(NBINSUBTREE.NE.0)THEN INODE = POOL( NBINSUBTREE ) IF(.NOT.MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*) & 'Internal error 1 in CMUMPS_LOAD_POOL_CHECK_MEM' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE CMUMPS_LOAD_POOL_CHECK_MEM SUBROUTINE CMUMPS_LOAD_SET_SBTR_MEM(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'CMUMPS_LOAD_SET_SBTR_MEM & should be called when K81>0 and K47>2' ENDIF IF(WHAT)THEN PEAK_SBTR_CUR_LOCAL=PEAK_SBTR_CUR_LOCAL+ & dble(MEM_SUBTREE(INDICE_SBTR)) IF(.NOT.BDC_SBTR) INDICE_SBTR=INDICE_SBTR+1 ELSE PEAK_SBTR_CUR_LOCAL=dble(0) SBTR_CUR_LOCAL=dble(0) ENDIF END SUBROUTINE CMUMPS_LOAD_SET_SBTR_MEM DOUBLE PRECISION FUNCTION CMUMPS_LOAD_GET_MEM( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFR = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) IF (LEVEL .EQ. 1) THEN COST = dble(NFR) * dble(NFR) ELSE IF ( K50 == 0 ) THEN COST = dble(NFR) * dble(NELIM) ELSE COST = dble(NELIM) * dble(NELIM) ENDIF ENDIF CMUMPS_LOAD_GET_MEM=COST RETURN END FUNCTION CMUMPS_LOAD_GET_MEM RECURSIVE SUBROUTINE CMUMPS_NEXT_NODE(FLAG,COST,COMM) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG, EXIT_FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF(FLAG)THEN WHAT=17 IF(BDC_M2_FLOPS)THEN TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) ELSE IF(BDC_M2_MEM)THEN IF(BDC_POOL.AND.(.NOT.BDC_MD))THEN TO_BE_SENT=max(TMP_M2,POOL_LAST_COST_SENT) POOL_LAST_COST_SENT=TO_BE_SENT ELSE IF(BDC_MD)THEN DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM ELSE TO_BE_SENT=dble(0) ENDIF ENDIF ELSE WHAT=6 TO_BE_SENT=dble(0) ENDIF 111 CONTINUE CALL CMUMPS_BUF_BROADCAST( WHAT, & COMM, NPROCS, & FUTURE_NIV2, & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 100 CONTINUE RETURN END SUBROUTINE CMUMPS_NEXT_NODE SUBROUTINE CMUMPS_UPPER_PREDICT(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE CMUMPS_BUF IMPLICIT NONE INTEGER INODE,NSTEPS,MYID,SLAVEF,COMM,N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE(NSTEPS),NE(NSTEPS),STEP(N),PROCNODE(NSTEPS) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_PROCNODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER i,NCB,NELIM INTEGER MUMPS_PROCNODE INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE LOGICAL :: EXIT_FLAG IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in CMUMPS_UPPER_PREDICT' CALL MUMPS_ABORT() ENDIF IF((INODE.LT.0).OR.(INODE.GT.N)) THEN RETURN ENDIF i=INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NCB=ND_LOAD(STEP_LOAD(INODE))-NELIM + KEEP_LOAD(253) WHAT=5 FATHER_NODE=DAD_LOAD(STEP_LOAD(INODE)) IF (FATHER_NODE.EQ.0) THEN RETURN ENDIF IF((FRERE(STEP(FATHER_NODE)).EQ.0).AND. & ((FATHER_NODE.EQ.KEEP(38)).OR. & (FATHER_NODE.EQ.KEEP(20))))THEN RETURN ENDIF IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(FATHER_NODE)), & KEEP(199))) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),KEEP(199)) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL CMUMPS_PROCESS_NIV2_MEM_MSG(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL CMUMPS_PROCESS_NIV2_FLOPS_MSG(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)).EQ.1)THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MYID,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB,8)*int(NCB,8) POS_MEM=POS_MEM+1 ENDIF ENDIF GOTO 666 ENDIF 111 CONTINUE CALL CMUMPS_BUF_SEND_FILS(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP,MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 666 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in CMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE RETURN END SUBROUTINE CMUMPS_UPPER_PREDICT SUBROUTINE CMUMPS_REMOVE_NODE(INODE,NUM_CALL) IMPLICIT NONE DOUBLE PRECISION MAXI INTEGER i,J,IND_MAXI INTEGER INODE,NUM_CALL IF(BDC_M2_MEM)THEN IF(((NUM_CALL.EQ.1).AND.(BDC_MD)).OR. & ((NUM_CALL.EQ.2).AND.(.NOT.BDC_MD)))THEN RETURN ENDIF ENDIF IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0).AND. & ((INODE.EQ.KEEP_LOAD(38)).OR. & (INODE.EQ.KEEP_LOAD(20)))) THEN RETURN ENDIF DO i=POOL_SIZE,1,-1 IF(POOL_NIV2(i).EQ.INODE) GOTO 666 ENDDO NB_SON(STEP_LOAD(INODE))=-1 RETURN 666 CONTINUE IF(BDC_M2_MEM)THEN IF(POOL_NIV2_COST(i).EQ.MAX_M2)THEN TMP_M2=MAX_M2 MAXI=dble(0) IND_MAXI=-9999 DO J=POOL_SIZE,1,-1 IF(J.NE.i) THEN IF(POOL_NIV2_COST(J).GT.MAXI)THEN MAXI=POOL_NIV2_COST(J) IND_MAXI=J ENDIF ENDIF ENDDO MAX_M2=MAXI J=IND_MAXI REMOVE_NODE_FLAG_MEM=.TRUE. REMOVE_NODE_COST_MEM=TMP_M2 CALL CMUMPS_NEXT_NODE(REMOVE_NODE_FLAG,MAX_M2,COMM_LD) NIV2(MYID+1)=MAX_M2 ENDIF ELSEIF(BDC_M2_FLOPS)THEN REMOVE_NODE_COST=POOL_NIV2_COST(i) REMOVE_NODE_FLAG=.TRUE. CALL CMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & -POOL_NIV2_COST(i),COMM_LD) NIV2(MYID+1)=NIV2(MYID+1)-POOL_NIV2_COST(i) ENDIF DO J=i+1,POOL_SIZE POOL_NIV2(J-1)=POOL_NIV2(J) POOL_NIV2_COST(J-1)=POOL_NIV2_COST(J) ENDDO POOL_SIZE=POOL_SIZE-1 END SUBROUTINE CMUMPS_REMOVE_NODE RECURSIVE SUBROUTINE CMUMPS_PROCESS_NIV2_MEM_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in CMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &CMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & CMUMPS_LOAD_GET_MEM(INODE) POOL_SIZE=POOL_SIZE+1 IF(POOL_NIV2_COST(POOL_SIZE).GT.MAX_M2)THEN MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL CMUMPS_NEXT_NODE(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_NIV2_MEM_MSG RECURSIVE SUBROUTINE CMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in CMUMPS_PROCESS_NIV2_FLOPS_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &CMUMPS_PROCESS_NIV2_FLOPS_MSG',POOL_NIV2_SIZE, & POOL_SIZE CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & CMUMPS_LOAD_GET_FLOPS_COST(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL CMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & POOL_NIV2_COST(POOL_SIZE), & COMM_LD) NIV2(MYID+1)=POOL_NIV2_COST(POOL_SIZE)+NIV2(MYID+1) ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_NIV2_FLOPS_MSG DOUBLE PRECISION FUNCTION CMUMPS_LOAD_GET_FLOPS_COST(INODE) USE MUMPS_FUTURE_NIV2 INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION COST i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFRONT = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) COST=dble(0) CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) CMUMPS_LOAD_GET_FLOPS_COST=COST RETURN END FUNCTION CMUMPS_LOAD_GET_FLOPS_COST INTEGER FUNCTION CMUMPS_LOAD_GET_CB_FREED( INODE ) IMPLICIT NONE INTEGER INODE,NELIM,NFR,SON,IN,i INTEGER COST_CB COST_CB=0 i = INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i DO i=1, NE_LOAD(STEP_LOAD(INODE)) NFR = ND_LOAD( STEP_LOAD(SON) ) + KEEP_LOAD(253) IN=SON NELIM = 0 20 CONTINUE IF ( IN > 0 ) THEN NELIM = NELIM + 1 IN = FILS_LOAD(IN) GOTO 20 ENDIF COST_CB=COST_CB+((NFR-NELIM)*(NFR-NELIM)) SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO CMUMPS_LOAD_GET_CB_FREED=COST_CB RETURN END FUNCTION CMUMPS_LOAD_GET_CB_FREED SUBROUTINE CMUMPS_LOAD_SEND_MD_INFO(SLAVEF,NMB_OF_CAND, & LIST_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE CMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_OF_CAND(NMB_OF_CAND) INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES(NSLAVES) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: DELTA_MD INTEGER, DIMENSION(:), ALLOCATABLE :: IPROC2POSINDELTAMD INTEGER, DIMENSION(:), ALLOCATABLE :: P_TO_UPDATE INTEGER NBROWS_SLAVE,i,WHAT,IERR INTEGER :: NP_TO_UPDATE, K LOGICAL FORCE_CAND LOGICAL :: EXIT_FLAG MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF CALL CMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NMB_OF_CAND,NASS) ALLOCATE(IPROC2POSINDELTAMD(0:SLAVEF-1), & DELTA_MD(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & P_TO_UPDATE(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) "PB ALLOC IN CMUMPS_LOAD_SEND_MD_INFO", & SLAVEF, NMB_OF_CAND, NSLAVES CALL MUMPS_ABORT() ENDIF IPROC2POSINDELTAMD = -99 NP_TO_UPDATE = 0 DO i = 1, NSLAVES NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_SLAVES(i)) = NP_TO_UPDATE NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD(NP_TO_UPDATE)=-dble(NBROWS_SLAVE)* & dble(NASS) P_TO_UPDATE(NP_TO_UPDATE) = LIST_SLAVES(i) ENDDO DO i = 1, NMB_OF_CAND K = IPROC2POSINDELTAMD(LIST_OF_CAND(i)) IF ( K > 0 ) THEN DELTA_MD(K)=DELTA_MD(K)+FCT_COST ELSE NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_OF_CAND(i)) = NP_TO_UPDATE DELTA_MD (NP_TO_UPDATE) = FCT_COST P_TO_UPDATE(NP_TO_UPDATE) = LIST_OF_CAND(i) ENDIF ENDDO WHAT=7 111 CONTINUE CALL CMUMPS_BUF_BCAST_ARRAY(.FALSE., COMM_LD, MYID, SLAVEF, & FUTURE_NIV2, & NP_TO_UPDATE, P_TO_UPDATE,0, & DELTA_MD, & DELTA_MD, & DELTA_MD, & WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL CMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in CMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF ENDDO ENDIF 100 CONTINUE DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) RETURN END SUBROUTINE CMUMPS_LOAD_SEND_MD_INFO SUBROUTINE CMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NSLAVES,NELIM) IMPLICIT NONE INTEGER INODE,NSLAVES,NFR,NELIM,IN DOUBLE PRECISION MEM_COST,FCT_COST NFR=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) IN = INODE FCT_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NELIM) MEM_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NFR) END SUBROUTINE CMUMPS_LOAD_GET_ESTIM_MEM_COST SUBROUTINE CMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN RETURN ENDIF IF(POS_ID.GT.1)THEN i=INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i IF(POS_ID.LT.NE_LOAD(STEP_LOAD(INODE))*3)THEN i=1 ENDIF DO i=1, NE_LOAD(STEP_LOAD(INODE)) J=1 DO WHILE (J.LT.POS_ID) IF(CB_COST_ID(J).EQ.SON)GOTO 295 J=J+3 ENDDO 295 CONTINUE IF(J.GE.POS_ID)THEN IF ( MUMPS_PROCNODE( & PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) .EQ. MYID ) THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 ENDIF ELSE GOTO 666 ENDIF ENDIF NSLAVES_TEMP=CB_COST_ID(J+1) POS_TEMP=CB_COST_ID(J+2) DO K=J,POS_ID-1 CB_COST_ID(K)=CB_COST_ID(K+3) ENDDO K=POS_TEMP DO WHILE (K.LE.POS_MEM-1) CB_COST_MEM(K)=CB_COST_MEM(K+2*NSLAVES_TEMP) K=K+1 ENDDO POS_MEM=POS_MEM-2*NSLAVES_TEMP POS_ID=POS_ID-3 IF((POS_MEM.LT.1).OR.(POS_ID.LT.1))THEN WRITE(*,*)MYID,': negative pos_mem or pos_id' CALL MUMPS_ABORT() ENDIF 666 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO ENDIF END SUBROUTINE CMUMPS_LOAD_CLEAN_MEMINFO_POOL SUBROUTINE CMUMPS_LOAD_CHK_MEMCST_POOL(FLAG) IMPLICIT NONE LOGICAL FLAG INTEGER i DOUBLE PRECISION MEM FLAG=.FALSE. DO i=0,NPROCS-1 MEM=DM_MEM(i)+LU_USAGE(i) IF(BDC_SBTR)THEN MEM=MEM+SBTR_MEM(i)-SBTR_CUR(i) ENDIF IF((MEM/dble(TAB_MAXS(i))).GT.0.8d0)THEN FLAG=.TRUE. GOTO 666 ENDIF ENDDO 666 CONTINUE END SUBROUTINE CMUMPS_LOAD_CHK_MEMCST_POOL SUBROUTINE CMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IMPLICIT NONE INTEGER NBINSUBTREE,INSUBTREE,NBTOP DOUBLE PRECISION MIN_COST LOGICAL SBTR INTEGER i DOUBLE PRECISION TMP_COST,TMP_MIN TMP_MIN=huge(TMP_MIN) DO i=0,NPROCS-1 IF(i.NE.MYID)THEN IF(BDC_SBTR)THEN TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i))-(SBTR_MEM(i)-SBTR_CUR(i))) ELSE TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))- & (DM_MEM(i)+LU_USAGE(i))) ENDIF ENDIF ENDDO IF(NBINSUBTREE.GT.0)THEN IF(INSUBTREE.EQ.1)THEN TMP_COST=dble(TAB_MAXS(MYID))-(DM_MEM(MYID)+ & LU_USAGE(MYID)) & -(SBTR_MEM(MYID)-SBTR_CUR(MYID)) ELSE SBTR=.FALSE. GOTO 777 ENDIF ENDIF TMP_MIN=min(TMP_COST,TMP_MIN) IF(TMP_MIN.GT.MIN_COST) SBTR=.TRUE. 777 CONTINUE END SUBROUTINE CMUMPS_CHECK_SBTR_COST SUBROUTINE CMUMPS_LOAD_COMP_MAXMEM_POOL(INODE,MAX_MEM,PROC) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION MAX_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_ON_PROCS, & RECV_BUF LOGICAL, DIMENSION(:), ALLOCATABLE :: CONCERNED DOUBLE PRECISION MAX_SENT_MSG IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF ALLOCATE( MEM_ON_PROCS(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in CMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF RECV_BUF=dble(0) MAX_SENT_MSG=dble(0) i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i NFRONT=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) NCB=NFRONT-NELIM IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN NCAND=CAND_LOAD(NPROCS+1, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) ENDIF DO i=0,NPROCS-1 IF(i.EQ.MYID)THEN MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i)+ & CMUMPS_LOAD_GET_MEM(INODE)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF CONCERNED(i)=.TRUE. ELSE MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF IF(BDC_M2_MEM)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-NIV2(i+1) ENDIF ENDIF IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN IF(BDC_MD.AND.(KEEP_LOAD(48).EQ.5))THEN DO J=1,NCAND IF(CAND_LOAD(J, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) & .EQ.i)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)- & ((dble(NFRONT)*dble(NCB))/dble(NCAND)) CONCERNED(i)=.TRUE. GOTO 666 ENDIF ENDDO ENDIF ENDIF 666 CONTINUE ENDDO DO K=1, NE_LOAD(STEP_LOAD(INODE)) i=1 DO WHILE (i.LE.POS_ID) IF(CB_COST_ID(i).EQ.SON)GOTO 295 i=i+3 ENDDO 295 CONTINUE IF(i.GE.POS_ID)THEN IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': ',SON,'has not been found & in CMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF GOTO 777 ENDIF NSLAVES=CB_COST_ID(i+1) POS=CB_COST_ID(i+2) DO i=1,NSLAVES SLAVE=int(CB_COST_MEM(POS)) IF(.NOT.CONCERNED(SLAVE))THEN MEM_ON_PROCS(SLAVE)=MEM_ON_PROCS(SLAVE)+ & dble(CB_COST_MEM(POS+1)) ENDIF DO J=0,NPROCS-1 IF(CONCERNED(J))THEN IF(SLAVE.NE.J)THEN RECV_BUF(J)=max(RECV_BUF(J), & dble(CB_COST_MEM(POS+1))) ENDIF ENDIF ENDDO POS=POS+2 ENDDO 777 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO MAX_MEM=huge(MAX_MEM) WRITE(*,*)'NPROCS=',NPROCS,MAX_MEM DO i=0,NPROCS-1 IF(MAX_MEM.GT.MEM_ON_PROCS(i))THEN PROC=i ENDIF MAX_MEM=min(MEM_ON_PROCS(i),MAX_MEM) ENDDO DEALLOCATE(MEM_ON_PROCS) DEALLOCATE(CONCERNED) DEALLOCATE(RECV_BUF) END SUBROUTINE CMUMPS_LOAD_COMP_MAXMEM_POOL SUBROUTINE CMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER i,NBTOP,INSUBTREE,NBINSUBTREE,NODE,FATHER,SON,J INTEGER SBTR_NB_LEAF,POS,K,allocok,L INTEGER, ALLOCATABLE, DIMENSION (:) :: TMP_SBTR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF((KEEP_LOAD(47).EQ.4).AND. & ((NBINSUBTREE.NE.0)))THEN DO J=INDICE_SBTR,NB_SUBTREES NODE=MY_ROOT_SBTR(J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 110 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 110 ENDIF SON=-i i=SON 120 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN SBTR_NB_LEAF=MY_NB_LEAF(J) POS=SBTR_FIRST_POS_IN_POOL(J) IF(POOL(POS+SBTR_NB_LEAF).NE.MY_FIRST_LEAF(J))THEN WRITE(*,*)MYID,': The first leaf is not ok' CALL MUMPS_ABORT() ENDIF ALLOCATE (TMP_SBTR(SBTR_NB_LEAF), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*)MYID,': Not enough space & for allocation' CALL MUMPS_ABORT() ENDIF POS=SBTR_FIRST_POS_IN_POOL(J) DO K=1,SBTR_NB_LEAF TMP_SBTR(K)=POOL(POS+K-1) ENDDO DO K=POS+1,NBINSUBTREE-SBTR_NB_LEAF POOL(K)=POOL(K+SBTR_NB_LEAF) ENDDO POS=1 DO K=NBINSUBTREE-SBTR_NB_LEAF+1,NBINSUBTREE POOL(K)=TMP_SBTR(POS) POS=POS+1 ENDDO DO K=INDICE_SBTR,J SBTR_FIRST_POS_IN_POOL(K)=SBTR_FIRST_POS_IN_POOL(K) & -SBTR_FIRST_POS_IN_POOL(J) ENDDO SBTR_FIRST_POS_IN_POOL(J)=NBINSUBTREE-SBTR_NB_LEAF POS=MY_FIRST_LEAF(J) L=MY_NB_LEAF(J) DO K=INDICE_SBTR,J MY_FIRST_LEAF(J)=MY_FIRST_LEAF(J+1) MY_NB_LEAF(J)=MY_NB_LEAF(J+1) ENDDO MY_FIRST_LEAF(INDICE_SBTR)=POS MY_NB_LEAF(INDICE_SBTR)=L INODE=POOL(NBINSUBTREE) DEALLOCATE(TMP_SBTR) RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 120 ENDIF ENDDO ENDIF DO J=NBTOP,1,-1 NODE=POOL(LPOOL-2-J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 11 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 11 ENDIF SON=-i i=SON 12 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN INODE=NODE RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 12 ENDIF ENDDO END SUBROUTINE CMUMPS_FIND_BEST_NODE_FOR_MEM SUBROUTINE CMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_ROOTSSARBR LOGICAL MUMPS_ROOTSSARBR IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_ROOTSSARBR( & PROCNODE_LOAD(STEP_LOAD(POOL(POS+1))), & KEEP(199))) POS=POS+1 ENDDO SBTR_FIRST_POS_IN_POOL(i)=POS+1 POS=POS+MY_NB_LEAF(i) ENDDO END SUBROUTINE CMUMPS_LOAD_INIT_SBTR_STRUCT END MODULE CMUMPS_LOAD SUBROUTINE CMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & PROCS, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1) INTEGER, intent(in) :: SUP_PROC_ARG(2) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX INTEGER(8), intent(out):: MAX_SURF LOGICAL :: FORCE_LDLTRegular_NIV2 INTEGER NSLAVES,ACC INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1)) INTEGER TMP_NROW,X,K LOGICAL SUP,MEM_CSTR DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA, & LOAD_CORR INTEGER IDWLOAD(SLAVEF) INTEGER(8) MEM_CONSTRAINT(2) K50=KEEP(50) FORCE_LDLTRegular_NIV2 = .FALSE. MAX_SURF=0 NB_ROW_MAX=0 NELIM=NFRONT-NCB NB_SUP=0 TOTAL_LOAD=0.0D0 SUP=.FALSE. IF(SUP_PROC_ARG(1).NE. & 0)THEN MEM_CONSTRAINT(1)=TAB_MAXS_ARG(PROCS(1)) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(1))/100.0D0 NB_SUP=NB_SUP+1 ENDIF IF(SUP_PROC_ARG(2).NE. & 0)THEN MEM_CONSTRAINT(2)=TAB_MAXS_ARG(PROCS(PROCS(SLAVEF+1))) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(2))/100.0D0 NB_SUP=NB_SUP+1 ENDIF TOTAL_LOAD=TOTAL_LOAD+(PROCS(SLAVEF+1)-NB_SUP) IF(K50.EQ.0)THEN MAX_LOAD=dble( NELIM ) * dble ( NCB ) + * dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE MAX_LOAD=dble(NELIM) * dble ( NCB ) * * dble(NFRONT+1) ENDIF TMP=min(MAX_LOAD,MAX_LOAD/TOTAL_LOAD) J=1 DO i=1,PROCS(SLAVEF+1) IF((NB_SUP.GT.0).AND.(i.EQ.1))THEN CYCLE ELSEIF((NB_SUP.EQ.2).AND.(i.EQ.PROCS(SLAVEF+1)))THEN CYCLE ENDIF IDWLOAD(J)=PROCS(i) J=J+1 ENDDO DO i=1,NB_SUP IF(i.EQ.1)THEN IDWLOAD(J)=PROCS(1) ELSE IDWLOAD(J)=PROCS(PROCS(SLAVEF+1)) ENDIF J=J+1 ENDDO IF ((K50.EQ.0).OR.FORCE_LDLTRegular_NIV2) THEN ACC=0 J=PROCS(SLAVEF+1)-NB_SUP+1 DO i=1,NB_SUP VAR=dble(SUP_PROC_ARG(i))/100.0D0 TMP_NROW=int(dble(MEM_CONSTRAINT(i))/dble(NFRONT)) NB_ROWS(J)=int(max((VAR*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM)), & dble(1))) IF(NB_ROWS(J).GT.TMP_NROW)THEN NB_ROWS(J)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(J)) THEN NB_ROWS(J)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(J) J=J+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF DO i=1,PROCS(SLAVEF+1)-NB_SUP VAR=1.0D0 TMP_NROW=int((dble(TAB_MAXS_ARG(IDWLOAD(i))))/dble(NFRONT)) NB_ROWS(i)=int((dble(VAR)*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(i)) THEN NB_ROWS(i)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE TMP_NROW=(NCB-ACC)/(PROCS(SLAVEF+1)-NB_SUP)+1 DO i=1,PROCS(SLAVEF+1)-NB_SUP NB_ROWS(i)=NB_ROWS(i)+TMP_NROW ACC=ACC+TMP_NROW IF(ACC.GT.NCB) THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+ & (NCB-(ACC-TMP_NROW)) EXIT ENDIF ENDDO ENDIF ENDIF ELSE ACC=0 i=PROCS(SLAVEF+1)-NB_SUP+1 X=NCB LOAD_CORR=0.0D0 MEM_CSTR=.FALSE. DO J=1,NB_SUP VAR=DBLE(SUP_PROC_ARG(J))/DBLE(100) A=1.0D0 B=dble(X+NELIM) C=-dble(max(MEM_CONSTRAINT(J),0_8)) DELTA=((B*B)-(4*A*C)) TMP_NROW=int((-B+sqrt(DELTA))/(2*A)) A=dble(-NELIM) B=dble(NELIM)*(dble(-NELIM)+dble(2*(X+NELIM)+1)) C=-(VAR*TMP) DELTA=(B*B-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW MEM_CSTR=.TRUE. ENDIF IF(ACC+NB_ROWS(i).GT.NCB)THEN NB_ROWS(i)=NCB-ACC ACC=NCB X=0 EXIT ENDIF X=X-NB_ROWS(i) ACC=ACC+NB_ROWS(i) LOAD_CORR=LOAD_CORR+(dble(NELIM) * dble (NB_ROWS(i)) * * dble(2*(X+NELIM) - NELIM - NB_ROWS(i) + 1)) i=i+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF IF((PROCS(SLAVEF+1).NE.NB_SUP).AND.MEM_CSTR)THEN TMP=(MAX_LOAD-LOAD_CORR)/(PROCS(SLAVEF+1)-NB_SUP) ENDIF X=ACC ACC=0 DO i=1,PROCS(SLAVEF+1)-NB_SUP IF (KEEP(375) .EQ. 1) THEN VAR=1.0D0 A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(VAR*TMP) ELSE A=1.0D0 B=dble(ACC+NELIM) C=-TMP ENDIF DELTA=((B*B)-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NCB-ACC-X.LT.NB_ROWS(i))THEN NB_ROWS(i)=NCB-ACC-X ACC=NCB-X EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO ACC=ACC+X IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE NB_ROWS(PROCS(SLAVEF+1)-NB_SUP)= & NB_ROWS(PROCS(SLAVEF+1) & -NB_SUP)+NCB-ACC ENDIF ENDIF ENDIF 777 CONTINUE NSLAVES=0 ACC=1 J=1 K=1 DO i=1,PROCS(SLAVEF+1) IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(J)=IDWLOAD(i) TAB_POS(J)=ACC ACC=ACC+NB_ROWS(i) NB_ROW_MAX=max(NB_ROW_MAX,NB_ROWS(i)) IF(K50.EQ.0)THEN MAX_SURF=max(int(NB_ROWS(i),8)*int(NCB,8),int(0,8)) ELSE MAX_SURF=max(int(NB_ROWS(i),8)*int(ACC,8),int(0,8)) ENDIF NSLAVES=NSLAVES+1 J=J+1 ELSE SLAVES_LIST(PROCS(SLAVEF+1)-K+1)=IDWLOAD(i) K=K+1 ENDIF ENDDO TAB_POS(SLAVEF+2) = NSLAVES TAB_POS(NSLAVES+1)= NCB+1 NSLAVES_NODE=NSLAVES END SUBROUTINE CMUMPS_SET_PARTI_REGULAR MUMPS_5.4.1/src/cfac_par_m.F0000664000175000017500000010326314102210524015672 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_PAR_M CONTAINS SUBROUTINE CMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND, FILS, STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, & NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, & DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS ) !$ USE OMP_LIB USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_CBSTATIC2DYNAMIC, & CMUMPS_DM_FREEALLDYNAMICCB USE CMUMPS_LOAD USE CMUMPS_OOC USE CMUMPS_FAC_ASM_MASTER_M USE CMUMPS_FAC_ASM_MASTER_ELT_M USE CMUMPS_FAC1_LDLT_M USE CMUMPS_FAC2_LDLT_M USE CMUMPS_FAC1_LU_M USE CMUMPS_FAC2_LU_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX, TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER LRGROUPS(N) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS, NASS, HF, XSIZE INTEGER(8) NFRONT8 INTEGER(8) :: POSELT INTEGER IPOSROOT, IPOSROOTROWINDICES INTEGER GLOBK109 INTEGER(8) :: LBUFRX COMPLEX, POINTER, DIMENSION(:) :: BUFRX LOGICAL :: IS_BUFRX_ALLOCATED DOUBLE PRECISION FLOP1 INTEGER TYPE LOGICAL SON_LEVEL2, SET_IRECV, BLOCKING, & MESSAGE_RECEIVED LOGICAL AVOID_DELAYED LOGICAL LAST_CALL INTEGER MASTER_ROOT INTEGER LOCAL_M, LOCAL_N INTEGER LRHS_CNTR_MASTER_ROOT, FWD_LOCAL_N_RHS LOGICAL ROOT_OWNER EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR LOGICAL CMUMPS_POOL_EMPTY EXTERNAL CMUMPS_POOL_EMPTY, CMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER numroc EXTERNAL numroc INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 STACK_RIGHT_AUTHORIZED = .TRUE. CALL CMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL CMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF KEEP(429)=0 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL CMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. CMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL CMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL CMUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL CMUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL CMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL CMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL CMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL_LDLT_NIV2, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL CMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL CMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSE JOBASS = 0 CALL CMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL CMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in CMUMPS_FAC_PAR", POSELT CALL MUMPS_ABORT() ENDIF CALL CMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(STEP(INODE)) XSIZE = KEEP(IXSZ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF (KEEP(50).EQ.0) THEN CALL CMUMPS_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL CMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL CMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL CMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in CMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' Stop END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL CMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in CMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in CMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL CMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL CMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL CMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL CMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL CMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL CMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU IS_BUFRX_ALLOCATED = .FALSE. ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -9 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before CMUMPS_FACTO_ROOT', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL CMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (root%yes.AND.KEEP(60).EQ.0) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL CMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in CMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (root%yes. AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (MYID_NODES .EQ. MASTER_ROOT) THEN LRHS_CNTR_MASTER_ROOT = root%TOT_ROOT_SIZE*KEEP(253) ELSE LRHS_CNTR_MASTER_ROOT = 1 ENDIF ALLOCATE(root%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before CMUMPS_FACTO_ROOT', & LRHS_CNTR_MASTER_ROOT CALL MUMPS_ABORT() ENDIF FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL CMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & root%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & root%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) & ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF RETURN END SUBROUTINE CMUMPS_FAC_PAR SUBROUTINE CMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE CMUMPS_CHANGE_HEADER END MODULE CMUMPS_FAC_PAR_M MUMPS_5.4.1/src/mumps_io_thread.h0000664000175000017500000000634014102210474017043 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_IO_THREAD_H #define MUMPS_IO_THREAD_H #include "mumps_compat.h" #include "mumps_c_types.h" #if ! defined (MUMPS_WIN32) && ! defined (WITHOUT_PTHREAD) # include # include # include # include # include # define MAX_IO 20 # define MAX_FINISH_REQ 40 # define IO_FLAG_STOP 1 # define IO_FLAG_RUN 0 # define IO_READ 1 # define IO_WRITE 0 struct request_io{ MUMPS_INT inode; MUMPS_INT req_num; /*request number*/ void* addr; /*memory address (either source or dest)*/ long long size; /* size of the requested io (unit=size of elementary mumps data)*/ long long vaddr; /* virtual address for file management */ MUMPS_INT io_type; /*read or write*/ MUMPS_INT file_type; /* cb or lu or ... */ pthread_cond_t local_cond; MUMPS_INT int_local_cond; }; /* Exported global variables */ extern MUMPS_INT io_flag_stop,current_req_num; extern pthread_t io_thread,main_thread; extern pthread_mutex_t io_mutex; extern pthread_cond_t cond_io,cond_nb_free_finished_requests,cond_nb_free_active_requests,cond_stop; extern pthread_mutex_t io_mutex_cond; extern MUMPS_INT int_sem_io,int_sem_nb_free_finished_requests,int_sem_nb_free_active_requests,int_sem_stop; extern MUMPS_INT with_sem; extern struct request_io *io_queue; extern MUMPS_INT first_active,last_active,nb_active; extern MUMPS_INT *finished_requests_inode,*finished_requests_id,first_finished_requests, last_finished_requests,nb_finished_requests,smallest_request_id; extern MUMPS_INT mumps_owns_mutex; extern MUMPS_INT test_request_called_from_mumps; /* Exported functions */ void* mumps_async_thread_function_with_sem (void* arg); MUMPS_INT mumps_is_there_finished_request_th(MUMPS_INT* flag); MUMPS_INT mumps_clean_request_th(MUMPS_INT* request_id); MUMPS_INT mumps_wait_req_sem_th(MUMPS_INT *request_id); MUMPS_INT mumps_test_request_th(MUMPS_INT* request_id,MUMPS_INT *flag); MUMPS_INT mumps_wait_request_th(MUMPS_INT *request_id); MUMPS_INT mumps_low_level_init_ooc_c_th(MUMPS_INT* async, MUMPS_INT* ierr); MUMPS_INT mumps_async_write_th(const MUMPS_INT * strat_IO,void * address_block,long long block_size, MUMPS_INT * inode,MUMPS_INT * request_arg,MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_async_read_th(const MUMPS_INT * strat_IO,void * address_block,long long block_size,MUMPS_INT * inode,MUMPS_INT * request_arg, MUMPS_INT * type,long long vaddr,MUMPS_INT * ierr); MUMPS_INT mumps_clean_io_data_c_th(MUMPS_INT *myid); MUMPS_INT mumps_get_sem(void *arg,MUMPS_INT *value); MUMPS_INT mumps_wait_sem(void *arg,pthread_cond_t *cond); MUMPS_INT mumps_post_sem(void *arg,pthread_cond_t *cond); MUMPS_INT mumps_clean_finished_queue_th(); #endif /*_WIN32 && WITHOUT_PTHREAD*/ #endif /* MUMPS_IO_THREAD_H */ MUMPS_5.4.1/src/smumps_ooc.F0000664000175000017500000036116214102210521016005 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_OOC USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ DOUBLE PRECISION,SAVE :: MAX_OOC_FILE_SIZE INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER SMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: SMUMPS_OOC_INIT_FACTO,SMUMPS_NEW_FACTOR, & SMUMPS_READ_OOC, & SMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & SMUMPS_IS_THERE_FREE_SPACE, & SMUMPS_OOC_END_SOLVE, & SMUMPS_SOLVE_INIT_OOC_FWD,SMUMPS_SOLVE_INIT_OOC_BWD, & SMUMPS_INITIATE_READ_OPS,SMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC SMUMPS_OOC_IO_LU_PANEL, & SMUMPS_OOC_PANEL_SIZE PRIVATE SMUMPS_OOC_STORE_LorU, & SMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE SMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_STRAT_IO_FLAGS FUNCTION SMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL SMUMPS_IS_THERE_FREE_SPACE SMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION SMUMPS_IS_THERE_FREE_SPACE SUBROUTINE SMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE SMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE SMUMPS_OOC_INIT_FACTO(id, MAXS) USE SMUMPS_STRUC_DEF USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER TMPDIR_MAX_LENGTH, PREFIX_MAX_LENGTH PARAMETER (TMPDIR_MAX_LENGTH=255, PREFIX_MAX_LENGTH=63) INTEGER(8), intent(in) :: MAXS TYPE(SMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER allocok INTEGER ASYNC CHARACTER(len=1):: TMP_DIR(TMPDIR_MAX_LENGTH), & TMP_PREFIX(PREFIX_MAX_LENGTH) INTEGER DIM_DIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER K211_LOC ICNTL1=id%ICNTL(1) MAX_SIZE_FACTOR_OOC=0_8 N_OOC=id%N ASYNC=0 SOLVE=.FALSE. IERR=0 IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) IF (id%KEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS MYID_OOC=id%MYID SLAVEF_OOC=id%NSLAVES KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_VADDR=>id%OOC_VADDR IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(19),int(dble(MAXS)* & 0.9d0*0.2d0,8)) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF SMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(id%OOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF id%OOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL SMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(99), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO ) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 MAX_NB_NODES_FOR_ZONE=0 OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL SMUMPS_INIT_OOC_BUF(id%INFO(1),id%INFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ENDIF DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) DIM_DIR=len(trim(id%OOC_TMPDIR)) DIM_PREFIX=len(trim(id%OOC_PREFIX)) CALL SMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL SMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_PREFIX(1), & id%OOC_PREFIX, PREFIX_MAX_LENGTH, DIM_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, TMP_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_DIR, TMP_DIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(id%KEEP8(11)/1000000_8)+1 IF((id%KEEP(201).EQ.1).AND.(id%KEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & id%KEEP(35),LOW_LEVEL_STRAT_IO,K211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0 ) THEN WRITE(ICNTL1,*)MYID_OOC,': PB in MUMPS_LOW_LEVEL_INIT_OOC_C' WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) ENDIF id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_GET_MAX_FILE_SIZE_C(MAX_OOC_FILE_SIZE) DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE SMUMPS_OOC_INIT_FACTO SUBROUTINE SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE REAL A(LA) INTEGER IERR,NODE,ASYNC,REQUEST LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL SMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL SMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF NODE=-9999 PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_NEW_FACTOR SUBROUTINE SMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE REAL DEST INTEGER ASYNC LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN GOTO 555 ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_READ_OOC SUBROUTINE SMUMPS_OOC_CLEAN_PENDING(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL SMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE SMUMPS_OOC_CLEAN_PENDING SUBROUTINE SMUMPS_OOC_END_FACTO(id,IERR) USE SMUMPS_OOC_BUFFER USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF(WITH_BUF)THEN CALL SMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF id%OOC_MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DO I=1,OOC_NB_FILE_TYPE id%OOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF id%KEEP8(20)=MAX_SIZE_FACTOR_OOC CALL SMUMPS_STRUC_STORE_FILE_NAME(id,IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_OOC_END_FACTO SUBROUTINE SMUMPS_OOC_CLEAN_FILES(id,IERR) USE SMUMPS_STRUC_DEF IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(SMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(350) IERR=0 K=1 IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0)THEN WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE SMUMPS_OOC_CLEAN_FILES SUBROUTINE SMUMPS_CLEAN_OOC_DATA(id,IERR) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL SMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE SMUMPS_CLEAN_OOC_DATA SUBROUTINE SMUMPS_OOC_INIT_SOLVE(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(SMUMPS_STRUC), TARGET :: id INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=id%ICNTL(1) SOLVE=.TRUE. N_OOC=id%N IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL SMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) IF(id%INFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS SLAVEF_OOC=id%NSLAVES MYID_OOC=id%MYID KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE OOC_VADDR=>id%OOC_VADDR ALLOCATE(IO_REQ(id%KEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF SMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) MAX_NB_NODES_FOR_ZONE=id%OOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>id%OOC_TOTAL_NB_NODES CALL SMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(20) SIZE_ZONE_SOLVE=int((real(FACT_AREA_SIZE)- & real(SIZE_SOLVE_EMM))/real(id%KEEP(107)),8) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) ENDIF ELSE SIZE_ZONE_SOLVE=FACT_AREA_SIZE SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF IF(SIZE_SOLVE_EMM.LT.id%KEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in SMUMPS_OOC_INIT_SOLVE' id%INFO(1) = -11 CALL MUMPS_SET_IERROR(id%KEEP8(20), id%INFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,id%COMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(id%KEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. id%root%yes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE SMUMPS_OOC_INIT_SOLVE SUBROUTINE SMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_INITIATE_READ_OPS SUBROUTINE SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL SMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL SMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE SMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE SMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES REAL DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL SMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL SMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE SMUMPS_READ_SOLVE_BLOCK SUBROUTINE SMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE SMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE SMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL SMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' SMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' SMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' SMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE SMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE SMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR REAL A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J, FREE_HOLE_FLAG INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in SMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL SMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE FREE_HOLE_FLAG=0 IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL SMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3E0*real(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL SMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION SMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR REAL A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER SMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL SMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL SMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE SMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION SMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE SMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE SMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE SMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL SMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE SMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE SMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE SMUMPS_SOLVE_FIND_ZONE SUBROUTINE SMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE SMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE SMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE SMUMPS_SOLVE_SELECT_ZONE SUBROUTINE SMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(SMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE SMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS REAL A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' SMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' SMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' SMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE SMUMPS_GET_TOP_AREA_SPACE SUBROUTINE SMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) REAL A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' SMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' SMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' SMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'SMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE SMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) REAL A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' SMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE SMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE SMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) REAL A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in SMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' SMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL SMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE SMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' SMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE SMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE SMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE SMUMPS_SEARCH_SOLVE FUNCTION SMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL SMUMPS_SOLVE_IS_END_REACHED SMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN SMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN SMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION SMUMPS_SOLVE_IS_END_REACHED SUBROUTINE SMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(SMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(SMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(SMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL SMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL SMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL SMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL SMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE SMUMPS_SOLVE_ZONE_READ SUBROUTINE SMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(SMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' SMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL SMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE SMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE SMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE SMUMPS_OOC_END_SOLVE SUBROUTINE SMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA REAL :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL SMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL SMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN CALL SMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to SMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_PREPARE_PREF SUBROUTINE SMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL SMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL SMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL SMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE SMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR REAL A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL SMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL SMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL SMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & SMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL SMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL SMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL SMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE SMUMPS_STRUC_STORE_FILE_NAME(id,IERR) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(350) EXTERNAL MUMPS_OOC_GET_NB_FILES_C, MUMPS_OOC_GET_FILE_NAME_C IERR=0 SIZE=0 DO J=1,OOC_NB_FILE_TYPE TMP=J-1 CALL MUMPS_OOC_GET_NB_FILES_C(TMP,I) id%OOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF ALLOCATE(id%OOC_FILE_NAMES(SIZE,350),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(id%INFO(1).GE.0)THEN id%INFO(1) = -13 id%INFO(2) = SIZE*350 RETURN ENDIF ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(id%OOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in SMUMPS_STRUC_STORE_FILE_NAME' ENDIF id%INFO(1) = -13 id%INFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,id%OOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 id%OOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO id%OOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO END SUBROUTINE SMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE SMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC), TARGET :: id CHARACTER(len=1):: TMP_NAME(350) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES INTEGER K211 ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in SMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=id%OOC_NB_FILES I=id%MYID K=id%KEEP(35) L=mod(id%KEEP(204),3) K211=id%KEEP(211) CALL MUMPS_OOC_ALLOC_POINTERS_C(OOC_NB_FILE_TYPE,NB_FILES,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,K211,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=id%OOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO TMP=I1-1 CALL MUMPS_OOC_SET_FILE_NAME_C(TMP,I,DIM,IERR,TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=K+1 ENDDO ENDDO CALL MUMPS_OOC_START_LOW_LEVEL(IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE SMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE SMUMPS_CONVERT_STR_TO_CHR_ARRAY(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB):: SRC CHARACTER(len=1):: DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE SMUMPS_CONVERT_STR_TO_CHR_ARRAY SUBROUTINE SMUMPS_FORCE_WRITE_BUF(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE SMUMPS_FORCE_WRITE_BUF SUBROUTINE SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL SMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE SMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE SMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE SMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL SMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL SMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE RETURN END SUBROUTINE SMUMPS_OOC_IO_LU_PANEL SUBROUTINE SMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR, ILAST INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = SMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = SMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = SMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in SMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in SMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in SMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in SMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL SMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in SMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE ILAST = ICUR IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in SMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE SMUMPS_OOC_STORE_LorU SUBROUTINE SMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE SMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL SMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE SMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION SMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE SMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION SMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION SMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER SMUMPS_OOC_GET_PANEL_SIZE SMUMPS_OOC_PANEL_SIZE=SMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION SMUMPS_OOC_PANEL_SIZE SUBROUTINE SMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.SMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE SMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_OOC_SET_STATES_ES END MODULE SMUMPS_OOC MUMPS_5.4.1/src/sbcast_int.F0000664000175000017500000000307714102210521015750 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE SMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL SMUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to SMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE SMUMPS_MCAST2 SUBROUTINE SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL SMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE SMUMPS_BDC_ERROR MUMPS_5.4.1/src/sfac_process_contrib_type1.F0000664000175000017500000001161714102210521021132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL SMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_REAL, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_REAL, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_NODE MUMPS_5.4.1/src/zfac_asm.F0000664000175000017500000010124214102210524015376 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON ) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON, IWPOSCB INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), STEP(N), PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)), ROWLIST(NBROWS) COMPLEX(kind=8) A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW LOGICAL, INTENT(IN) :: IS_ofType5or6 INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER HF,HS, NSLAVES, NFRONT, NASS1, & IOLDPS, ISTCHK, LSTK, NSLSON,NELIM, & NPIVS,NCOLS,J1,JJ,JJ1,NROWS, & LDAFS_PERE, IBEG, DIAG INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (KEEP(50).EQ.0) THEN LDAFS_PERE = NFRONT ELSE IF ( NSLAVES .eq. 0 ) THEN LDAFS_PERE = NFRONT ELSE LDAFS_PERE = NASS1 ENDIF ENDIF HF = 6 + NSLAVES + KEEP(IXSZ) POSEL1 = POSELT - int(LDAFS_PERE,8) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) OPASSW = OPASSW + dble(NBROWS*NBCOLS) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DO JJ = 1, NBROWS DO JJ1 = 1, NBCOLS JJ2 = APOS + int(JJ1-1,8) A(JJ2)=A(JJ2)+VALSON(JJ1,JJ) ENDDO APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO 170 JJ = 1, NBROWS APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO 160 JJ1 = 1, NBCOLS JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 160 CONTINUE 170 CONTINUE ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DIAG = ROWLIST(1) DO JJ = 1, NBROWS DO JJ1 = 1, DIAG JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO DIAG = DIAG+1 APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO JJ = 1, NBROWS IF (ROWLIST(JJ).LE.NASS1.and..NOT.IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(JJ) - 1,8) DO JJ1 = 1, NELIM JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO IBEG = NELIM+1 ELSE IBEG = 1 ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, NBCOLS IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_MASTER SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) COMPLEX(kind=8) :: A(LA) INTEGER :: INTARR(KEEP8(27)) COMPLEX(kind=8) :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) COMPLEX(kind=8) A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG COMPLEX(kind=8), POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8)) + & VALSON(1:NBCOLS-IDIAG,I) APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE ZMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX(kind=8) A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO IPOSCB = IPOSCB + 1_8 ENDDO ENDIF ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE ZMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX(kind=8) A( LA ) COMPLEX(kind=8) SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 DO I = 1, NELIM POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) IF (.NOT. CB_IS_COMPRESSED) THEN IPOSCB = 1_8 + int( I - 1, 8 ) * int(NCOLS,8) ENDIF DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_LDLT_ASM_NIV12 SUBROUTINE ZMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_RESTORE_INDICES SUBROUTINE ZMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) USE ZMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON,IWPOSCB INTEGER NBCOLS INTEGER IW(LIW), STEP(N), & PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)) COMPLEX(kind=8) A(LA) DOUBLE PRECISION VALSON(NBCOLS) DOUBLE PRECISION OPASSW INTEGER HF,HS, NSLAVES, NASS1, & IOLDPS, ISTCHK, & LSTK, NSLSON,NELIM,NPIVS,NCOLS, J1, & JJ1,NROWS INTEGER(8) POSELT, APOS, JJ2 INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(dble(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_MAX SUBROUTINE ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: RHS_MUMPS(KEEP(255)) COMPLEX(kind=8), intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(N), PTRARW(N) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: J18, J28, JJ8, JK8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE DO WHILE (IN.GT.0) AINPUT8 = PTRARW(IN) JK8 = PTRAIW(IN) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: ZMUMPS_IS_TRSM_LARGE_ENOUGH, & ZMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF NCB = NFRONT-NASS1 IF (PARPIV_T1.EQ.-2) THEN IF ( & ( ZMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( ZMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF RETURN END SUBROUTINE ZMUMPS_SET_PARPIVT1 LOGICAL FUNCTION ZMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) ZMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION ZMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION ZMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) ZMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION ZMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE ZMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253 ) & IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 COMPLEX(kind=8), intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB COMPLEX(kind=8) :: ZERO DOUBLE PRECISION :: RMAX PARAMETER( ZERO = (0.0D0,0.0D0) ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = dble(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = dble(A(APOSMAX+int(I,8)-1_8)) DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = cmplx(RMAX,kind=kind(A)) APOS = APOS+NFRONT_8 ENDDO ENDIF CALL ZMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1) RETURN END SUBROUTINE ZMUMPS_PARPIVT1_SET_MAX SUBROUTINE ZMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) COMPLEX(kind=8), intent(inout):: PARPIV(LPARPIV) INTEGER :: I DOUBLE PRECISION :: EPS, RMIN, RZERO, RTMP LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0D0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) DO I = 1, LPARPIV RTMP = dble(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN EPS = sqrt(epsilon(RZERO)) RMIN = min(RMIN, EPS) DO I = 1, LPARPIV RTMP = dble(PARPIV(I)) IF (dble(PARPIV(I)).EQ.RZERO) THEN PARPIV(I) = cmplx(-RMIN, kind=kind(PARPIV)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE ZMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY: ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1 INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL ZMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253 ) ENDIF RETURN END SUBROUTINE ZMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX MUMPS_5.4.1/src/build_mumps_int_def.c0000664000175000017500000000130514102210474017663 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include int main() { printf("#if ! defined(MUMPS_INT_H)\n"); printf("# define MUMPS_INT_H\n"); #if defined(INTSIZE64) printf("# define MUMPS_INTSIZE64\n"); #else printf("# define MUMPS_INTSIZE32\n"); #endif printf("#endif\n"); return 0; } MUMPS_5.4.1/src/cana_aux_ELT.F0000664000175000017500000010761014102210523016102 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES, LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,L1,L2,NCMPA,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL CMUMPS_ANA_G11_ELT, CMUMPS_ANA_G12_ELT, & CMUMPS_ANA_G1_ELT, CMUMPS_ANA_G2_ELT, & CMUMPS_ANA_G2_ELTNEW, & CMUMPS_ANA_J1_ELT, CMUMPS_ANA_J2_ELT, & CMUMPS_ANA_K, & CMUMPS_ANA_LNEW, CMUMPS_ANA_M, & MUMPS_AMD_ELT #if defined(OLDDFS) EXTERNAL CMUMPS_ANA_L #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 4*N GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min0(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min0(10,ELTPTR(NELT+1)-1) IF (LDIAG.EQ.4) K = ELTPTR(NELT+1)-1 IF (K.GT.0) WRITE (MP,99995) (ELTVAR(I),I=1,K) K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP(I,1),I=1,K) ENDIF 10 L1 = 1 L2 = L1 + N IF (LIW .LT. 3*N) THEN INFO(1) = -2002 INFO(2) = LIW ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL CMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL CMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL CMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4*N+4, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL CMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL CMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in CMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL CMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL CMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+K) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+IKEEP(K,1)).EQ.1) THEN GOTO 40 ELSE IW(L1+IKEEP(K,1)) = 1 ENDIF ENDDO CALL CMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL CMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in CMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL CMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF #if defined(OLDDFS) CALL CMUMPS_ANA_L(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, KEEP(60)) #else CALL CMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+N),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY) #endif DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL CMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL CMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) KEEP(210)=0 IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) KEEP(210)=1 IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL CMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE CMUMPS_ANA_F_ELT SUBROUTINE CMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine CMUMPS_NODEL ***') END SUBROUTINE CMUMPS_NODEL SUBROUTINE CMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G1_ELT SUBROUTINE CMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G2_ELTNEW SUBROUTINE CMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G2_ELT SUBROUTINE CMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_J1_ELT SUBROUTINE CMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE CMUMPS_ANA_J2_ELT SUBROUTINE CMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE CMUMPS_ANA_DIST_ELEMENTS SUBROUTINE CMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ELTPROC SUBROUTINE CMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine CMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine CMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine CMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE CMUMPS_FRTELT SUBROUTINE CMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD,LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL CMUMPS_SUPVAR LP = 6 CALL CMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3*N+3+1),3*N+3,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from CMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3*N+3+1+I) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(N+1:2*N) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(N+J).NE.I)) THEN IW(N+J) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G11_ELT SUBROUTINE CMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_ANA_G12_ELT SUBROUTINE CMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LIW,LP,N,NELT,NSUP,NZ INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER FLAG,NEW,VARS EXTERNAL CMUMPS_SUPVARB INFO(1) = 0 INFO(2) = 0 INFO(3) = 0 INFO(4) = 0 IF (N.LT.1) GO TO 10 IF (NELT.LT.1) GO TO 20 IF (NZ.LT.ELTPTR(NELT+1)-1) GO TO 30 IF (LIW.LT.6) THEN INFO(4) = 3*N + 3 GO TO 40 END IF NEW = 1 VARS = NEW + LIW/3 FLAG = VARS + LIW/3 CALL CMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP,LIW/3-1, & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = 3*N + 3 GO TO 40 ELSE INFO(4) = 3*NSUP + 3 END IF GO TO 50 10 INFO(1) = -1 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 20 INFO(1) = -2 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 30 INFO(1) = -3 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 40 INFO(1) = -4 IF (LP.GT.0) THEN WRITE (LP,FMT=9000) INFO(1) WRITE (LP,FMT=9010) INFO(4) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from CMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE CMUMPS_SUPVAR SUBROUTINE CMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE CMUMPS_SUPVARB MUMPS_5.4.1/src/cana_mtrans.F0000664000175000017500000007651214102210526016116 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE CMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) REAL CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0E0 CNTL(2) = 0.0E0 DO 20 I = 3,NCNTL CNTL(I) = 0.0E0 20 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSI SUBROUTINE CMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) REAL :: A(NE) REAL :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 REAL CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX REAL ZERO,MINONE,ONE PARAMETER (ZERO=0.0E0,MINONE=-1.0E0,ONE=1.0E0) INTRINSIC abs,min EXTERNAL CMUMPS_MTRANSD, CMUMPS_MTRANSE, & CMUMPS_MTRANSF, CMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL CMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL CMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL CMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL CMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSB SUBROUTINE CMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE CMUMPS_MTRANSD SUBROUTINE CMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) REAL DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE CMUMPS_MTRANSE SUBROUTINE CMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) REAL D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) REAL DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE CMUMPS_MTRANSF SUBROUTINE CMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) REAL :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) REAL SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE CMUMPS_MTRANSQ SUBROUTINE CMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) REAL, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S REAL :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSR SUBROUTINE CMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) REAL A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 REAL :: BVAL,BMIN,BMAX EXTERNAL CMUMPS_MTRANSQ,CMUMPS_MTRANSU,CMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL CMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0E0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001E0 * BMAX ENDIF BVAL = 0.0E0 BMIN = 0.0E0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL CMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL CMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL CMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSS C SUBROUTINE CMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSU C SUBROUTINE CMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) REAL A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP REAL :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD REAL :: ZERO, ONE PARAMETER (ZERO=0.0E0,ONE=1.0E0) EXTERNAL CMUMPS_MTRANSD, CMUMPS_MTRANSE, & CMUMPS_MTRANSF, CMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL CMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL CMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL CMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL CMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSW SUBROUTINE CMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 EXTERNAL CMUMPS_MTRANSX DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 1000 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL CMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE CMUMPS_MTRANSZ SUBROUTINE CMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K DO 10 J = 1,N CW(J) = 0 10 CONTINUE K = 0 DO 20 I = 1,M IF (IPERM(I).EQ.0) THEN K = K + 1 RW(K) = I ELSE J = IPERM(I) CW(J) = I ENDIF 20 CONTINUE K = 0 DO 30 J = 1,N IF (CW(J).NE.0) GO TO 30 K = K + 1 I = RW(K) IPERM(I) = -J 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = -J 40 CONTINUE RETURN END SUBROUTINE CMUMPS_MTRANSX MUMPS_5.4.1/src/dfac_par_m.F0000664000175000017500000010340414102210523015667 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_PAR_M CONTAINS SUBROUTINE DMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND, FILS, STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, & NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, & DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS ) !$ USE OMP_LIB USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_CBSTATIC2DYNAMIC, & DMUMPS_DM_FREEALLDYNAMICCB USE DMUMPS_LOAD USE DMUMPS_OOC USE DMUMPS_FAC_ASM_MASTER_M USE DMUMPS_FAC_ASM_MASTER_ELT_M USE DMUMPS_FAC1_LDLT_M USE DMUMPS_FAC2_LDLT_M USE DMUMPS_FAC1_LU_M USE DMUMPS_FAC2_LU_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP DOUBLE PRECISION, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA DOUBLE PRECISION, TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(N) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS, NASS, HF, XSIZE INTEGER(8) NFRONT8 INTEGER(8) :: POSELT INTEGER IPOSROOT, IPOSROOTROWINDICES INTEGER GLOBK109 INTEGER(8) :: LBUFRX DOUBLE PRECISION, POINTER, DIMENSION(:) :: BUFRX LOGICAL :: IS_BUFRX_ALLOCATED DOUBLE PRECISION FLOP1 INTEGER TYPE LOGICAL SON_LEVEL2, SET_IRECV, BLOCKING, & MESSAGE_RECEIVED LOGICAL AVOID_DELAYED LOGICAL LAST_CALL INTEGER MASTER_ROOT INTEGER LOCAL_M, LOCAL_N INTEGER LRHS_CNTR_MASTER_ROOT, FWD_LOCAL_N_RHS LOGICAL ROOT_OWNER EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR LOGICAL DMUMPS_POOL_EMPTY EXTERNAL DMUMPS_POOL_EMPTY, DMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER numroc EXTERNAL numroc INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 STACK_RIGHT_AUTHORIZED = .TRUE. CALL DMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL DMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF KEEP(429)=0 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL DMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. DMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL DMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL DMUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL DMUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL DMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL DMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL_LDLT_NIV2, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL DMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL DMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSE JOBASS = 0 CALL DMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL DMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in DMUMPS_FAC_PAR", POSELT CALL MUMPS_ABORT() ENDIF CALL DMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(STEP(INODE)) XSIZE = KEEP(IXSZ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF (KEEP(50).EQ.0) THEN CALL DMUMPS_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL DMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL DMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL DMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in DMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' Stop END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in DMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in DMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL DMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL DMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL DMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL DMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL DMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL DMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL DMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU IS_BUFRX_ALLOCATED = .FALSE. ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -9 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before DMUMPS_FACTO_ROOT', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL DMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (root%yes.AND.KEEP(60).EQ.0) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL DMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in DMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (root%yes. AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (MYID_NODES .EQ. MASTER_ROOT) THEN LRHS_CNTR_MASTER_ROOT = root%TOT_ROOT_SIZE*KEEP(253) ELSE LRHS_CNTR_MASTER_ROOT = 1 ENDIF ALLOCATE(root%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before DMUMPS_FACTO_ROOT', & LRHS_CNTR_MASTER_ROOT CALL MUMPS_ABORT() ENDIF FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL DMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & root%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & root%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) & ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF RETURN END SUBROUTINE DMUMPS_FAC_PAR SUBROUTINE DMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE DMUMPS_CHANGE_HEADER END MODULE DMUMPS_FAC_PAR_M MUMPS_5.4.1/src/zsol_matvec.F0000664000175000017500000002413514102210526016150 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) COMPLEX(kind=8) A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 COMPLEX(kind=8) TEMP COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_MV_ELT SUBROUTINE ZMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX(kind=8) A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE ZMUMPS_LOC_MV8 SUBROUTINE ZMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) COMPLEX(kind=8) ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: PX COMPLEX(kind=8) ZERO INTEGER :: allocok PARAMETER( ZERO = (0.0D0,0.0D0) ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE ZMUMPS_MV8 C C SUBROUTINE ZMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) COMPLEX(kind=8) A_loc( NZ_loc8 ), X( N ) DOUBLE PRECISION Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: RZERO=0.0D0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE ZMUMPS_LOC_OMEGA1 MUMPS_5.4.1/src/sfac_process_blocfacto.F0000664000175000017500000007757014102210521020316 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE SMUMPS_LOAD USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_FAC_LR USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_HAVE_SET_K117 INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL, KEEP_BEGS_BLR_L LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: INFO_TMP(2) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL,ALLOCATABLE,DIMENSION(:) :: RWORK REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL REAL, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER :: allocok INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 NULLIFY(BEGS_BLR_U) I_HAVE_SET_K117 = .FALSE. DYNAMIC_ALLOC = .FALSE. FPERE = -1 POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) ENDIF CALL SMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_REAL, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_REAL, & COMM, IERR ) LD_BLOCFACTO = NCOL ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 IF (DYNAMIC_ALLOC) THEN DO I = 1, NPIV IF (DYN_PIVINFO(I).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+DYN_PIVINFO(I)) IW(ICT11+DYN_PIVINFO(I)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + DYN_PIVINFO(I) - 1,8) CALL sswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ELSE DO I = 1, NPIV IF (IW(IPIV+I-1).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1)) IW(ICT11+IW(IPIV+I-1)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8) CALL sswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNAMIC_ALLOC) THEN CALL strsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A_PTR(LPOS2), NCOL1) ELSE CALL strsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_L = NPARTSCB IF (IPANEL.EQ.1) THEN BEGS_BLR_COL=>BEGS_BLR_U ELSE ALLOCATE(BEGS_BLR_COL(size(BEGS_BLR_U)+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = size(BEGS_BLR_U)+IPANEL-1 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF BEGS_BLR_COL(1:IPANEL-1) = 1 DO I=1,size(BEGS_BLR_U) BEGS_BLR_COL(IPANEL+I-1) = BEGS_BLR_U(I) ENDDO ENDIF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IPANEL.NE.1) THEN DEALLOCATE(BEGS_BLR_COL) ENDIF IF (IFLAG.LT.0) GOTO 700 ELSE CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U) IF (LASTBL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL SMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ELSE CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL SMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN UPOS = 1_8+int(NPIV,8) IF (DYNAMIC_ALLOC) THEN CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE IF (DYNAMIC_ALLOC) THEN UPOS = int(NPIV+1,8) CALL sgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,DYN_BLOCFACTO(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL sgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF ENDIF IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV IF (LASTBL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) ) ENDIF IF ( .not. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8) DEALLOCATE(BLR_U) IF (KEEP(486).EQ.3) THEN CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8) DEALLOCATE(BLR_L) ELSE CALL UPD_MRY_LU_LRGAIN(BLR_L, 0, NPARTSCB, 'V') ENDIF ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV ENDIF FLOP1 = dble( NPIV1*NROW1 ) + & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1) & - & dble((NPIV1+NPIV)*NROW1 ) - & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1) CALL SMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 IF (NPIV.EQ.0) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) IF (COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_COL+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during SMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL SMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1) & ) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF CALL SMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_PROCESS_BLOCFACTO SUBROUTINE SMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE SMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE SMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_REAL, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_REAL, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_REAL, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_MPI_UNPACK_LR MUMPS_5.4.1/src/dstatic_ptr_m.F0000664000175000017500000000212114102210522016441 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_STATIC_PTR_M PUBLIC :: DMUMPS_TMP_PTR, DMUMPS_GET_TMP_PTR DOUBLE PRECISION, DIMENSION(:), POINTER, SAVE :: DMUMPS_TMP_PTR CONTAINS SUBROUTINE DMUMPS_SET_STATIC_PTR(ARRAY) DOUBLE PRECISION, DIMENSION(:), TARGET :: ARRAY DMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE DMUMPS_SET_STATIC_PTR SUBROUTINE DMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_F2003) DOUBLE PRECISION, DIMENSION(:), POINTER, INTENT(OUT) :: PTR #else DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR #endif PTR => DMUMPS_TMP_PTR RETURN END SUBROUTINE DMUMPS_GET_TMP_PTR END MODULE DMUMPS_STATIC_PTR_M MUMPS_5.4.1/src/mumps_mpitoomp_m.F0000664000175000017500000000103114102210475017214 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_MPITOOMP_M_RETURN() RETURN END SUBROUTINE MUMPS_MPITOOMP_M_RETURN MUMPS_5.4.1/src/zmumps_struc_def.F0000664000175000017500000000102414102210525017202 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_STRUC_DEF INCLUDE 'zmumps_struc.h' END MODULE ZMUMPS_STRUC_DEF MUMPS_5.4.1/src/double_linked_list.F0000664000175000017500000010343414102210475017460 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_IDLL IMPLICIT NONE TYPE IDLL_NODE_T TYPE ( IDLL_NODE_T ), POINTER :: NEXT, PREV INTEGER ELMT END TYPE IDLL_NODE_T TYPE IDLL_T TYPE ( IDLL_NODE_T ), POINTER :: FRONT, BACK END TYPE IDLL_T CONTAINS FUNCTION IDLL_CREATE(DLL) INTEGER :: IDLL_CREATE #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( OUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER IERR ALLOCATE ( DLL, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_CREATE = -2 RETURN END IF NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) IDLL_CREATE = 0 RETURN END FUNCTION IDLL_CREATE FUNCTION IDLL_DESTROY(DLL) INTEGER :: IDLL_DESTROY #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( OUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif TYPE ( IDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN IDLL_DESTROY = -1 RETURN END IF DO WHILE ( associated ( DLL%FRONT ) ) AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT DEALLOCATE( AUX ) END DO DEALLOCATE( DLL ) IDLL_DESTROY = 0 END FUNCTION IDLL_DESTROY FUNCTION IDLL_PUSH_FRONT(DLL, ELMT) INTEGER :: IDLL_PUSH_FRONT #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN IDLL_PUSH_FRONT = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_PUSH_FRONT = -2 RETURN END IF NODE%ELMT = ELMT NODE%NEXT => DLL%FRONT NULLIFY ( NODE%PREV ) IF ( associated ( DLL%FRONT ) ) THEN DLL%FRONT%PREV => NODE END IF DLL%FRONT => NODE IF ( .NOT. associated ( DLL%BACK ) ) THEN DLL%BACK => NODE END IF IDLL_PUSH_FRONT = 0 END FUNCTION IDLL_PUSH_FRONT FUNCTION IDLL_POP_FRONT(DLL, ELMT) INTEGER :: IDLL_POP_FRONT #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN IDLL_POP_FRONT = -1 RETURN END IF IF ( .NOT. associated ( DLL%FRONT ) ) THEN IDLL_POP_FRONT = -3 RETURN END IF ELMT = DLL%FRONT%ELMT AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT IF ( associated ( DLL%FRONT ) ) THEN NULLIFY ( DLL%FRONT%PREV ) END IF IF ( associated ( DLL%BACK, AUX ) ) THEN NULLIFY ( DLL%BACK ) END IF DEALLOCATE ( AUX ) IDLL_POP_FRONT = 0 END FUNCTION IDLL_POP_FRONT FUNCTION IDLL_PUSH_BACK(DLL, ELMT) INTEGER :: IDLL_PUSH_BACK #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN IDLL_PUSH_BACK = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_PUSH_BACK = -2 RETURN END IF NODE%ELMT = ELMT NULLIFY ( NODE%NEXT ) NODE%PREV => DLL%BACK IF ( associated ( DLL%BACK ) ) THEN DLL%BACK%NEXT => NODE END IF DLL%BACK => NODE IF ( .NOT. associated ( DLL%FRONT ) ) THEN DLL%FRONT => NODE END IF IDLL_PUSH_BACK = 0 END FUNCTION IDLL_PUSH_BACK FUNCTION IDLL_POP_BACK(DLL, ELMT) INTEGER :: IDLL_POP_BACK #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN IDLL_POP_BACK = -1 RETURN END IF IF ( .NOT. associated ( DLL%BACK ) ) THEN IDLL_POP_BACK = -3 RETURN END IF ELMT = DLL%BACK%ELMT AUX => DLL%BACK DLL%BACK => DLL%BACK%PREV IF ( associated ( DLL%BACK ) ) THEN NULLIFY ( DLL%BACK%NEXT ) END IF IF ( associated ( DLL%FRONT, AUX ) ) THEN NULLIFY ( DLL%FRONT ) END IF DEALLOCATE ( AUX ) IDLL_POP_BACK = 0 END FUNCTION IDLL_POP_BACK FUNCTION IDLL_INSERT(DLL, POS, ELMT) INTEGER :: IDLL_INSERT #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: POS, ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE TYPE ( IDLL_NODE_T ), POINTER :: NEW_PTR, OLD_PTR INTEGER :: IERR, CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_INSERT = -1 RETURN END IF IF ( POS .LE. 0 ) THEN IDLL_INSERT = -4 RETURN END IF CPT = 1 NEW_PTR => DLL%FRONT NULLIFY ( OLD_PTR ) DO WHILE ( ( CPT .LT. POS ) .AND. & ( associated ( NEW_PTR ) ) ) OLD_PTR => NEW_PTR NEW_PTR => NEW_PTR%NEXT CPT = CPT + 1 END DO ALLOCATE ( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_INSERT = -2 RETURN END IF NODE%ELMT = ELMT IF ( .NOT. associated ( OLD_PTR ) ) THEN IF ( .NOT. associated ( NEW_PTR ) ) THEN NULLIFY ( NODE%PREV ) NULLIFY ( NODE%NEXT ) DLL%FRONT => NODE DLL%BACK => NODE ELSE NULLIFY ( NODE%PREV ) NODE%NEXT => NEW_PTR NEW_PTR%PREV => NODE DLL%FRONT => NODE END IF ELSE IF ( .NOT. associated ( NEW_PTR ) ) THEN NODE%PREV => OLD_PTR NULLIFY ( NODE%NEXT ) OLD_PTR%NEXT => NODE DLL%BACK => NODE ELSE NODE%PREV => OLD_PTR NODE%NEXT => NEW_PTR OLD_PTR%NEXT => NODE NEW_PTR%PREV => NODE END IF END IF IDLL_INSERT = 0 END FUNCTION IDLL_INSERT FUNCTION IDLL_INSERT_BEFORE(DLL, NODE_AFTER, ELMT) INTEGER :: IDLL_INSERT_BEFORE #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_AFTER #else TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: NODE_AFTER #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE_BEFORE INTEGER :: IERR ALLOCATE ( NODE_BEFORE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_INSERT_BEFORE = -2 RETURN END IF NODE_BEFORE%ELMT = ELMT IF ( .NOT. associated ( NODE_AFTER%PREV ) ) THEN NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%NEXT => NODE_AFTER NULLIFY ( NODE_BEFORE%PREV ) DLL%FRONT => NODE_BEFORE ELSE NODE_BEFORE%NEXT => NODE_AFTER NODE_BEFORE%PREV => NODE_AFTER%PREV NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%PREV%NEXT => NODE_BEFORE END IF IDLL_INSERT_BEFORE = 0 END FUNCTION IDLL_INSERT_BEFORE FUNCTION IDLL_INSERT_AFTER(DLL, NODE_BEFORE, ELMT) INTEGER :: IDLL_INSERT_AFTER #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_BEFORE #else TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: NODE_BEFORE #endif INTEGER, INTENT ( IN ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: NODE_AFTER INTEGER :: IERR ALLOCATE ( NODE_AFTER, STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_INSERT_AFTER = -2 RETURN END IF NODE_AFTER%ELMT = ELMT IF ( .NOT. associated ( NODE_BEFORE%NEXT ) ) THEN NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%PREV => NODE_BEFORE NULLIFY ( NODE_AFTER%NEXT ) DLL%BACK => NODE_AFTER ELSE NODE_AFTER%PREV => NODE_BEFORE NODE_AFTER%NEXT => NODE_BEFORE%NEXT NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%NEXT%PREV => NODE_AFTER END IF IDLL_INSERT_AFTER = 0 END FUNCTION IDLL_INSERT_AFTER FUNCTION IDLL_LOOKUP (DLL, POS, ELMT) INTEGER :: IDLL_LOOKUP #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: POS INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_LOOKUP = -1 RETURN END IF IF ( POS .LE. 0 ) THEN IDLL_LOOKUP = -4 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( CPT .LT. POS ) .AND. ( associated ( AUX ) ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( .NOT. associated ( AUX ) ) THEN IDLL_LOOKUP = -3 RETURN END IF ELMT = AUX%ELMT IDLL_LOOKUP = 0 END FUNCTION IDLL_LOOKUP FUNCTION IDLL_REMOVE_POS(DLL, POS, ELMT) INTEGER :: IDLL_REMOVE_POS #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: POS INTEGER, INTENT ( OUT ) :: ELMT TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_REMOVE_POS = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( CPT .LT. POS ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF ELMT = AUX%ELMT DEALLOCATE ( AUX ) ELSE IDLL_REMOVE_POS = -3 RETURN END IF IDLL_REMOVE_POS = 0 END FUNCTION IDLL_REMOVE_POS FUNCTION IDLL_REMOVE_ELMT(DLL, ELMT, POS) INTEGER :: IDLL_REMOVE_ELMT #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: ELMT INTEGER, INTENT ( OUT ) :: POS TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN IDLL_REMOVE_ELMT = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( AUX%ELMT .NE. ELMT ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF POS = CPT DEALLOCATE ( AUX ) ELSE IDLL_REMOVE_ELMT = -3 RETURN END IF IDLL_REMOVE_ELMT = 0 END FUNCTION IDLL_REMOVE_ELMT FUNCTION IDLL_LENGTH(DLL) INTEGER :: IDLL_LENGTH #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif INTEGER :: LENGTH TYPE ( IDLL_NODE_T ), POINTER :: AUX LENGTH = 0 IF ( .NOT. associated ( DLL ) ) THEN IDLL_LENGTH = -1 RETURN END IF AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) LENGTH = LENGTH + 1 AUX => AUX%NEXT END DO IDLL_LENGTH = LENGTH END FUNCTION IDLL_LENGTH FUNCTION IDLL_ITERATOR_BEGIN(DLL, PTR) INTEGER :: IDLL_ITERATOR_BEGIN #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #else TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN IDLL_ITERATOR_BEGIN = -1 RETURN END IF PTR => DLL%FRONT IDLL_ITERATOR_BEGIN = 0 END FUNCTION IDLL_ITERATOR_BEGIN FUNCTION IDLL_ITERATOR_END(DLL, PTR) INTEGER :: IDLL_ITERATOR_END #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( IDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #else TYPE ( IDLL_T ), POINTER :: DLL TYPE ( IDLL_NODE_T ), POINTER :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN IDLL_ITERATOR_END = -1 RETURN END IF PTR => DLL%BACK IDLL_ITERATOR_END = 0 END FUNCTION IDLL_ITERATOR_END FUNCTION IDLL_IS_EMPTY(DLL) LOGICAL :: IDLL_IS_EMPTY #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL #else TYPE ( IDLL_T ), POINTER :: DLL #endif IDLL_IS_EMPTY = ( associated ( DLL%FRONT ) ) END FUNCTION IDLL_IS_EMPTY FUNCTION IDLL_2_ARRAY(DLL, ARRAY, LENGTH) INTEGER :: IDLL_2_ARRAY #if defined(MUMPS_F2003) TYPE ( IDLL_T ), POINTER, INTENT ( IN ) :: DLL INTEGER, POINTER, DIMENSION (:), INTENT ( OUT ) :: ARRAY #else TYPE ( IDLL_T ), POINTER :: DLL INTEGER, POINTER, DIMENSION (:) :: ARRAY #endif INTEGER, INTENT ( OUT ) :: LENGTH TYPE ( IDLL_NODE_T ), POINTER :: AUX INTEGER :: I, IERR IF ( .NOT. associated ( DLL ) ) THEN IDLL_2_ARRAY = -1 RETURN END IF LENGTH = IDLL_LENGTH(DLL) ALLOCATE ( ARRAY ( max(1,LENGTH) ), STAT=IERR ) IF ( IERR .NE. 0 ) THEN IDLL_2_ARRAY = -2 RETURN END IF I = 1 AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) ARRAY ( I ) = AUX%ELMT I = I + 1 AUX => AUX%NEXT END DO IDLL_2_ARRAY = 0 END FUNCTION IDLL_2_ARRAY END MODULE MUMPS_IDLL MODULE MUMPS_DDLL IMPLICIT NONE TYPE DDLL_NODE_T TYPE ( DDLL_NODE_T ), POINTER :: NEXT, PREV DOUBLE PRECISION :: ELMT END TYPE DDLL_NODE_T TYPE DDLL_T TYPE ( DDLL_NODE_T ), POINTER :: FRONT, BACK END TYPE DDLL_T CONTAINS FUNCTION DDLL_CREATE(DLL) INTEGER :: DDLL_CREATE #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( OUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif INTEGER IERR ALLOCATE ( DLL, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_CREATE = -2 RETURN END IF NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) DDLL_CREATE = 0 RETURN END FUNCTION DDLL_CREATE FUNCTION DDLL_DESTROY(DLL) INTEGER :: DDLL_DESTROY #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_DESTROY = -1 RETURN END IF DO WHILE ( associated ( DLL%FRONT ) ) AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT DEALLOCATE( AUX ) END DO DEALLOCATE( DLL ) DDLL_DESTROY = 0 END FUNCTION DDLL_DESTROY FUNCTION DDLL_PUSH_FRONT(DLL, ELMT) INTEGER :: DDLL_PUSH_FRONT #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN DDLL_PUSH_FRONT = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_PUSH_FRONT = -2 RETURN END IF NODE%ELMT = ELMT NODE%NEXT => DLL%FRONT NULLIFY ( NODE%PREV ) IF ( associated ( DLL%FRONT ) ) THEN DLL%FRONT%PREV => NODE END IF DLL%FRONT => NODE IF ( .NOT. associated ( DLL%BACK ) ) THEN DLL%BACK => NODE END IF DDLL_PUSH_FRONT = 0 END FUNCTION DDLL_PUSH_FRONT FUNCTION DDLL_POP_FRONT(DLL, ELMT) INTEGER :: DDLL_POP_FRONT #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_POP_FRONT = -1 RETURN END IF IF ( .NOT. associated ( DLL%FRONT ) ) THEN DDLL_POP_FRONT = -3 RETURN END IF ELMT = DLL%FRONT%ELMT AUX => DLL%FRONT DLL%FRONT => DLL%FRONT%NEXT IF ( associated ( DLL%FRONT ) ) THEN NULLIFY ( DLL%FRONT%PREV ) END IF IF ( associated ( DLL%BACK, AUX ) ) THEN NULLIFY ( DLL%BACK ) END IF DEALLOCATE ( AUX ) DDLL_POP_FRONT = 0 END FUNCTION DDLL_POP_FRONT FUNCTION DDLL_PUSH_BACK(DLL, ELMT) INTEGER :: DDLL_PUSH_BACK #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE INTEGER IERR IF ( .NOT. associated ( DLL ) ) THEN DDLL_PUSH_BACK = -1 RETURN END IF ALLOCATE( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_PUSH_BACK = -2 RETURN END IF NODE%ELMT = ELMT NULLIFY ( NODE%NEXT ) NODE%PREV => DLL%BACK IF ( associated ( DLL%BACK ) ) THEN DLL%BACK%NEXT => NODE END IF DLL%BACK => NODE IF ( .NOT. associated ( DLL%FRONT ) ) THEN DLL%FRONT => NODE END IF DDLL_PUSH_BACK = 0 END FUNCTION DDLL_PUSH_BACK FUNCTION DDLL_POP_BACK(DLL, ELMT) INTEGER :: DDLL_POP_BACK #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_POP_BACK = -1 RETURN END IF IF ( .NOT. associated ( DLL%BACK ) ) THEN DDLL_POP_BACK = -3 RETURN END IF ELMT = DLL%BACK%ELMT AUX => DLL%BACK DLL%BACK => DLL%BACK%PREV IF ( associated ( DLL%BACK ) ) THEN NULLIFY ( DLL%BACK%NEXT ) END IF IF ( associated ( DLL%FRONT, AUX ) ) THEN NULLIFY ( DLL%FRONT ) END IF DEALLOCATE ( AUX ) DDLL_POP_BACK = 0 END FUNCTION DDLL_POP_BACK FUNCTION DDLL_INSERT(DLL, POS, ELMT) INTEGER :: DDLL_INSERT #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: POS DOUBLE PRECISION , INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE TYPE ( DDLL_NODE_T ), POINTER :: NEW_PTR, OLD_PTR INTEGER :: IERR, CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_INSERT = -1 RETURN END IF IF ( POS .LE. 0 ) THEN DDLL_INSERT = -4 RETURN END IF CPT = 1 NEW_PTR => DLL%FRONT NULLIFY ( OLD_PTR ) DO WHILE ( ( CPT .LT. POS ) .AND. & ( associated ( NEW_PTR ) ) ) OLD_PTR => NEW_PTR NEW_PTR => NEW_PTR%NEXT CPT = CPT + 1 END DO ALLOCATE ( NODE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_INSERT = -2 RETURN END IF NODE%ELMT = ELMT IF ( .NOT. associated ( OLD_PTR ) ) THEN IF ( .NOT. associated ( NEW_PTR ) ) THEN NULLIFY ( NODE%PREV ) NULLIFY ( NODE%NEXT ) DLL%FRONT => NODE DLL%BACK => NODE ELSE NULLIFY ( NODE%PREV ) NODE%NEXT => NEW_PTR NEW_PTR%PREV => NODE DLL%FRONT => NODE END IF ELSE IF ( .NOT. associated ( NEW_PTR ) ) THEN NODE%PREV => OLD_PTR NULLIFY ( NODE%NEXT ) OLD_PTR%NEXT => NODE DLL%BACK => NODE ELSE NODE%PREV => OLD_PTR NODE%NEXT => NEW_PTR OLD_PTR%NEXT => NODE NEW_PTR%PREV => NODE END IF END IF DDLL_INSERT = 0 END FUNCTION DDLL_INSERT FUNCTION DDLL_INSERT_BEFORE(DLL, NODE_AFTER, ELMT) INTEGER :: DDLL_INSERT_BEFORE #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_AFTER #else TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: NODE_AFTER #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE_BEFORE INTEGER :: IERR ALLOCATE ( NODE_BEFORE, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_INSERT_BEFORE = -2 RETURN END IF NODE_BEFORE%ELMT = ELMT IF ( .NOT. associated ( NODE_AFTER%PREV ) ) THEN NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%NEXT => NODE_AFTER NULLIFY ( NODE_BEFORE%PREV ) DLL%FRONT => NODE_BEFORE ELSE NODE_BEFORE%NEXT => NODE_AFTER NODE_BEFORE%PREV => NODE_AFTER%PREV NODE_AFTER%PREV => NODE_BEFORE NODE_BEFORE%PREV%NEXT => NODE_BEFORE END IF DDLL_INSERT_BEFORE = 0 END FUNCTION DDLL_INSERT_BEFORE FUNCTION DDLL_INSERT_AFTER(DLL, NODE_BEFORE, ELMT) INTEGER :: DDLL_INSERT_AFTER #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( IN ) :: NODE_BEFORE #else TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: NODE_BEFORE #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: NODE_AFTER INTEGER :: IERR ALLOCATE ( NODE_AFTER, STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_INSERT_AFTER = -2 RETURN END IF NODE_AFTER%ELMT = ELMT IF ( .NOT. associated ( NODE_BEFORE%NEXT ) ) THEN NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%PREV => NODE_BEFORE NULLIFY ( NODE_AFTER%NEXT ) DLL%BACK => NODE_AFTER ELSE NODE_AFTER%PREV => NODE_BEFORE NODE_AFTER%NEXT => NODE_BEFORE%NEXT NODE_BEFORE%NEXT => NODE_AFTER NODE_AFTER%NEXT%PREV => NODE_AFTER END IF DDLL_INSERT_AFTER = 0 END FUNCTION DDLL_INSERT_AFTER FUNCTION DDLL_LOOKUP (DLL, POS, ELMT) INTEGER :: DDLL_LOOKUP #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: POS DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_LOOKUP = -1 RETURN END IF IF ( POS .LE. 0 ) THEN DDLL_LOOKUP = -4 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( CPT .LT. POS ) .AND. ( associated ( AUX ) ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( .NOT. associated ( AUX ) ) THEN DDLL_LOOKUP = -3 RETURN END IF ELMT = AUX%ELMT DDLL_LOOKUP = 0 END FUNCTION DDLL_LOOKUP FUNCTION DDLL_REMOVE_POS(DLL, POS, ELMT) INTEGER :: DDLL_REMOVE_POS #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif INTEGER, INTENT ( IN ) :: POS DOUBLE PRECISION, INTENT ( OUT ) :: ELMT TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_REMOVE_POS = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( CPT .LT. POS ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF ELMT = AUX%ELMT DEALLOCATE ( AUX ) ELSE DDLL_REMOVE_POS = -3 RETURN END IF DDLL_REMOVE_POS = 0 END FUNCTION DDLL_REMOVE_POS FUNCTION DDLL_REMOVE_ELMT(DLL, ELMT, POS) INTEGER :: DDLL_REMOVE_ELMT #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( INOUT ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif DOUBLE PRECISION, INTENT ( IN ) :: ELMT INTEGER, INTENT ( OUT ) :: POS TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: CPT IF ( .NOT. associated ( DLL ) ) THEN DDLL_REMOVE_ELMT = -1 RETURN END IF CPT = 1 AUX => DLL%FRONT DO WHILE ( ( associated ( AUX ) ) .AND. & ( AUX%ELMT .NE. ELMT ) ) CPT = CPT + 1 AUX => AUX%NEXT END DO IF ( associated ( AUX ) ) THEN IF ( .NOT. associated ( AUX%PREV ) ) THEN IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( DLL%FRONT ) NULLIFY ( DLL%BACK ) ELSE NULLIFY ( AUX%NEXT%PREV ) DLL%FRONT => AUX%NEXT END IF ELSE IF ( .NOT. associated ( AUX%NEXT ) ) THEN NULLIFY ( AUX%PREV%NEXT ) DLL%BACK => AUX%PREV ELSE AUX%PREV%NEXT => AUX%NEXT AUX%NEXT%PREV => AUX%PREV END IF END IF POS = CPT DEALLOCATE ( AUX ) ELSE DDLL_REMOVE_ELMT = -3 RETURN END IF DDLL_REMOVE_ELMT = 0 END FUNCTION DDLL_REMOVE_ELMT FUNCTION DDLL_LENGTH(DLL) INTEGER :: DDLL_LENGTH #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif INTEGER :: LENGTH TYPE ( DDLL_NODE_T ), POINTER :: AUX IF ( .NOT. associated ( DLL ) ) THEN DDLL_LENGTH = -1 RETURN END IF LENGTH = 0 AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) LENGTH = LENGTH + 1 AUX => AUX%NEXT END DO DDLL_LENGTH = LENGTH END FUNCTION DDLL_LENGTH FUNCTION DDLL_ITERATOR_BEGIN(DLL, PTR) INTEGER :: DDLL_ITERATOR_BEGIN #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #else TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN DDLL_ITERATOR_BEGIN = -1 RETURN END IF PTR => DLL%FRONT DDLL_ITERATOR_BEGIN = 0 END FUNCTION DDLL_ITERATOR_BEGIN FUNCTION DDLL_ITERATOR_END(DLL, PTR) INTEGER :: DDLL_ITERATOR_END #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL TYPE ( DDLL_NODE_T ), POINTER, INTENT ( OUT ) :: PTR #else TYPE ( DDLL_T ), POINTER :: DLL TYPE ( DDLL_NODE_T ), POINTER :: PTR #endif IF ( .NOT. associated ( DLL ) ) THEN DDLL_ITERATOR_END = -1 RETURN END IF PTR => DLL%BACK DDLL_ITERATOR_END = 0 END FUNCTION DDLL_ITERATOR_END FUNCTION DDLL_IS_EMPTY(DLL) LOGICAL :: DDLL_IS_EMPTY #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL #else TYPE ( DDLL_T ), POINTER :: DLL #endif DDLL_IS_EMPTY = ( associated ( DLL%FRONT ) ) END FUNCTION DDLL_IS_EMPTY FUNCTION DDLL_2_ARRAY(DLL, ARRAY, LENGTH) INTEGER :: DDLL_2_ARRAY #if defined(MUMPS_F2003) TYPE ( DDLL_T ), POINTER, INTENT ( IN ) :: DLL DOUBLE PRECISION, POINTER, DIMENSION(:), INTENT(OUT) :: ARRAY #else TYPE ( DDLL_T ), POINTER :: DLL DOUBLE PRECISION, POINTER, DIMENSION(:) :: ARRAY #endif INTEGER, INTENT ( OUT ) :: LENGTH TYPE ( DDLL_NODE_T ), POINTER :: AUX INTEGER :: I, IERR IF ( .NOT. associated ( DLL ) ) THEN DDLL_2_ARRAY = -1 RETURN END IF LENGTH = DDLL_LENGTH(DLL) ALLOCATE ( ARRAY ( max(1,LENGTH) ), STAT=IERR ) IF ( IERR .NE. 0 ) THEN DDLL_2_ARRAY = -2 RETURN END IF I = 1 AUX => DLL%FRONT DO WHILE ( associated ( AUX ) ) ARRAY ( I ) = AUX%ELMT I = I + 1 AUX => AUX%NEXT END DO DDLL_2_ARRAY = 0 END FUNCTION DDLL_2_ARRAY END MODULE MUMPS_DDLL MUMPS_5.4.1/src/zana_dist_m.F0000664000175000017500000015512314102210524016112 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE ZMUMPS_ANA_LR, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) DOUBLE PRECISION UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) DOUBLE PRECISION OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR DOUBLE PRECISION OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB INTEGER(8):: MAXTEMPCB_LR INTEGER :: NB_BLR LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER NBouter_MIN INCLUDE 'mumps_headers.h' INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int, real INTEGER ZMUMPS_OOC_GET_PANEL_SIZE EXTERNAL ZMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0D0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(488)) IF (KEEP(66).NE.0.AND.SLAVEF.GT.1) THEN IF ( KEEP(50).EQ.0 ) THEN NBouter_MIN = ceiling & ( & (dble(KEEP(59))*dble(KEEP(108))*dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ELSE NBouter_MIN = ceiling & ( & ( max (dble(KEEP(108))*dble(KEEP(108)), & dble(KEEP(59))*dble(KEEP(108)/2) & ) & *dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ENDIF NBouter_MIN = max (NBouter_MIN, 4) LKJIB_FR = min(KEEP(108)/NBouter_MIN, 4321) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXTEMPCB_LR = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in ZMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF CALL COMPUTE_BLR_VCS(KEEP(472), NB_BLR, KEEP(488), NELIM) IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = ZMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0_8 ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NBCOLFAC=NFR ELSE NBCOLFAC=NELIM ENDIF PANEL_SIZE = ZMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU_CURRENT = int(NBCOLFAC,8)*int(NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0 ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max0(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF (KEEP(50).NE.0.AND.UPDATE.AND.LEVEL.EQ.1) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + & int(NELIM,8)*int(NCB,8) ENDIF IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR+ & NRLADU_CURRENT_MISSING) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+MAXTEMPCB_LR) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in ZMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in ZMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPSA_LOC, KEEP(50), NFR, & NFR, ROOT_NPROW, ROOT_NPCOL, MYID ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + dble(OPS_NODE) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (UPDATE .AND. LEVEL.EQ.2 .AND. .NOT. MASTER) THEN NRLNEC = & max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & 2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXTEMPCB_LR = max(MAXTEMPCB_LR,LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in ZMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in ZMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max0(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) SBUF_RECOLD = max(int(SBUFR_FR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = dble(OPS_SBTR_LOC) OPSA = dble(OPSA_LOC) RETURN END SUBROUTINE ZMUMPS_ANA_DISTM MUMPS_5.4.1/src/dsol_omp_m.F0000664000175000017500000000076614102210523015753 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SOL_L0OMP_M END MODULE DMUMPS_SOL_L0OMP_M MUMPS_5.4.1/src/dmumps_load.F0000664000175000017500000066471314102210522016136 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_LOAD implicit none PUBLIC :: DMUMPS_LOAD_SET_INICOST, DMUMPS_LOAD_INIT, & DMUMPS_LOAD_SET_SLAVES, DMUMPS_LOAD_UPDATE, & DMUMPS_LOAD_END, DMUMPS_LOAD_PROCESS_MESSAGE, & DMUMPS_LOAD_LESS, DMUMPS_LOAD_LESS_CAND, & DMUMPS_LOAD_SET_SLAVES_CAND, DMUMPS_LOAD_MASTER_2_ALL, & DMUMPS_LOAD_RECV_MSGS, DMUMPS_LOAD_MEM_UPDATE, & DMUMPS_LOAD_SET_PARTITION, & DMUMPS_SPLIT_PREP_PARTITION, DMUMPS_SPLIT_POST_PARTITION, & DMUMPS_SPLIT_PROPAGATE_PARTI, DMUMPS_LOAD_POOL_UPD_NEW_POOL, & DMUMPS_LOAD_SBTR_UPD_NEW_POOL, DMUMPS_LOAD_POOL_CHECK_MEM, & DMUMPS_LOAD_SET_SBTR_MEM, & DMUMPS_REMOVE_NODE, DMUMPS_UPPER_PREDICT & ,DMUMPS_LOAD_SEND_MD_INFO, & DMUMPS_LOAD_CLEAN_MEMINFO_POOL, DMUMPS_LOAD_COMP_MAXMEM_POOL, & DMUMPS_LOAD_CHK_MEMCST_POOL, DMUMPS_CHECK_SBTR_COST, & DMUMPS_FIND_BEST_NODE_FOR_MEM, & DMUMPS_LOAD_INIT_SBTR_STRUCT DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE, PRIVATE :: LOAD_FLOPS INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PRIVATE :: BUF_LOAD_RECV INTEGER, SAVE, PRIVATE :: LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES INTEGER, SAVE, PRIVATE :: K50, K69, K35 INTEGER(8), SAVE, PRIVATE :: MAX_SURF_MASTER LOGICAL, SAVE, PRIVATE :: BDC_MEM, BDC_POOL, BDC_SBTR, & BDC_POOL_MNG, & BDC_M2_MEM,BDC_M2_FLOPS,BDC_MD,REMOVE_NODE_FLAG, & REMOVE_NODE_FLAG_MEM DOUBLE PRECISION, SAVE, PRIVATE :: REMOVE_NODE_COST, & REMOVE_NODE_COST_MEM INTEGER, SAVE, PRIVATE :: SBTR_WHICH_M DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, TARGET, SAVE, PRIVATE :: WLOAD DOUBLE PRECISION, SAVE, PRIVATE :: DELTA_LOAD, DELTA_MEM LOGICAL, SAVE, PRIVATE :: IS_MUMPS_LOAD_ENABLED PUBLIC:: MUMPS_LOAD_ENABLE, MUMPS_LOAD_DISABLE INTEGER(8), SAVE, PRIVATE :: CHECK_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, TARGET, PRIVATE :: & IDWLOAD DOUBLE PRECISION, SAVE, PRIVATE :: COST_SUBTREE DOUBLE PRECISION, SAVE, PRIVATE :: ALPHA DOUBLE PRECISION, SAVE, PRIVATE :: BETA INTEGER, SAVE, PRIVATE :: MYID, NPROCS, COMM_LD INTEGER, SAVE, PRIVATE :: COMM_NODES DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE :: POOL_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, PRIVATE, & SAVE :: SBTR_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: SBTR_CUR INTEGER, DIMENSION(:), ALLOCATABLE, & PRIVATE, SAVE :: NB_SON DOUBLE PRECISION, & PRIVATE, SAVE :: SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: PEAK_SBTR_CUR_LOCAL DOUBLE PRECISION, & PRIVATE, SAVE :: MAX_PEAK_STK DOUBLE PRECISION, SAVE, & PRIVATE :: POOL_LAST_COST_SENT DOUBLE PRECISION, SAVE, & PRIVATE :: MIN_DIFF INTEGER, SAVE :: POS_ID,POS_MEM INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: CB_COST_ID INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE & :: CB_COST_MEM PUBLIC :: CB_COST_ID, CB_COST_MEM,POS_MEM,POS_ID DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: LU_USAGE INTEGER(8), DIMENSION(:), ALLOCATABLE, SAVE, & PRIVATE::MD_MEM, TAB_MAXS DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE, SAVE ::MEM_SUBTREE INTEGER :: NB_SUBTREES,NIV1_FLAG INTEGER, PRIVATE :: INDICE_SBTR,INDICE_SBTR_ARRAY INTEGER :: POOL_NIV2_SIZE INTEGER,SAVE :: INSIDE_SUBTREE PUBLIC :: NB_SUBTREES,MEM_SUBTREE,INSIDE_SUBTREE,NIV1_FLAG DOUBLE PRECISION, SAVE, PRIVATE :: DM_SUMLU, & DM_THRES_MEM DOUBLE PRECISION, DIMENSION(:), & ALLOCATABLE, SAVE , PRIVATE:: DM_MEM INTEGER, SAVE, PRIVATE :: POOL_SIZE,ID_MAX_M2 DOUBLE PRECISION, SAVE, PRIVATE :: MAX_M2,TMP_M2 INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, PRIVATE:: POOL_NIV2 DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE :: POOL_NIV2_COST, NIV2 DOUBLE PRECISION, SAVE, PRIVATE :: CHK_LD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: & PROCNODE_LOAD, STEP_TO_NIV2_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, PRIVATE :: KEEP_LOAD INTEGER, SAVE, PRIVATE :: N_LOAD INTEGER(8), DIMENSION(:), POINTER, SAVE, PRIVATE:: KEEP8_LOAD INTEGER, DIMENSION(:),POINTER, SAVE :: & FILS_LOAD, STEP_LOAD, & FRERE_LOAD, ND_LOAD, & NE_LOAD,DAD_LOAD INTEGER, DIMENSION(:,:),POINTER, SAVE, PRIVATE :: CAND_LOAD INTEGER, DIMENSION(:),POINTER, SAVE, & PRIVATE :: MY_FIRST_LEAF,MY_NB_LEAF, MY_ROOT_SBTR INTEGER, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_FIRST_POS_IN_POOL DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE,SAVE, & PRIVATE ::SBTR_PEAK_ARRAY, & SBTR_CUR_ARRAY DOUBLE PRECISION,DIMENSION(:),POINTER, SAVE :: COST_TRAV INTEGER, DIMENSION(:),POINTER, SAVE :: DEPTH_FIRST_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD PUBLIC :: DEPTH_FIRST_LOAD,COST_TRAV, FILS_LOAD,STEP_LOAD, & FRERE_LOAD, ND_LOAD,NE_LOAD,DAD_LOAD, & DEPTH_FIRST_SEQ_LOAD,SBTR_ID_LOAD INTEGER, SAVE :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST PUBLIC :: ROOT_CURRENT_SUBTREE,CURRENT_BEST, & SECOND_CURRENT_BEST CONTAINS SUBROUTINE MUMPS_LOAD_ENABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .TRUE. RETURN END SUBROUTINE MUMPS_LOAD_ENABLE SUBROUTINE MUMPS_LOAD_DISABLE() IMPLICIT NONE IS_MUMPS_LOAD_ENABLED = .FALSE. RETURN END SUBROUTINE MUMPS_LOAD_DISABLE SUBROUTINE DMUMPS_LOAD_SET_INICOST( COST_SUBTREE_ARG, K64, DK15, & K375, MAXS ) IMPLICIT NONE DOUBLE PRECISION COST_SUBTREE_ARG INTEGER, INTENT(IN) :: K64, K375 DOUBLE PRECISION, INTENT(IN) :: DK15 INTEGER(8)::MAXS DOUBLE PRECISION :: T64, T66 LOGICAL :: AVOID_LOAD_MESSAGES T64 = max ( dble(K64), dble(1) ) T64 = min ( T64, dble(1000) ) T66 = max (dble(DK15), dble(100)) MIN_DIFF = ( T64 / dble(1000) )* & T66 * dble(1000000) DM_THRES_MEM = dble(MAXS/300_8) COST_SUBTREE = COST_SUBTREE_ARG AVOID_LOAD_MESSAGES = .FALSE. IF (K375.EQ.1) THEN AVOID_LOAD_MESSAGES = .TRUE. ENDIF IF (AVOID_LOAD_MESSAGES) THEN MIN_DIFF = MIN_DIFF * 1000.D0 DM_THRES_MEM = DM_THRES_MEM * 1000_8 ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_SET_INICOST SUBROUTINE DMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND, ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, SLAVES_LIST, & SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SIZE_SLAVES_LIST, SLAVEF, & KEEP(500) INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), CAND(SLAVEF+1), & FILS(N) INTEGER, intent(out) :: NBSPLIT, NUMORG_SPLIT INTEGER, intent(inout) :: SLAVES_LIST(SIZE_SLAVES_LIST), & COPY_CAND(SLAVEF+1) INTEGER :: IN, LP, II INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT LP = ICNTL(1) IN = INODE NBSPLIT = 0 NUMORG_SPLIT = 0 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT = NBSPLIT + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG_SPLIT = NUMORG_SPLIT + 1 II = FILS(II) ENDDO END DO SLAVES_LIST(1:NBSPLIT) = CAND(1:NBSPLIT) COPY_CAND(1:SIZE_SLAVES_LIST-NBSPLIT) = & CAND(1+NBSPLIT:SIZE_SLAVES_LIST) COPY_CAND(SIZE_SLAVES_LIST-NBSPLIT+1:SLAVEF) = -1 COPY_CAND(SLAVEF+1) = SIZE_SLAVES_LIST-NBSPLIT RETURN END SUBROUTINE DMUMPS_SPLIT_PREP_PARTITION SUBROUTINE DMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & TAB_POS, NSLAVES_NODE & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, N, SLAVEF, NCB, & KEEP(500), NBSPLIT INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N) INTEGER, intent(inout) :: TAB_POS ( SLAVEF+2 ), NSLAVES_NODE INTEGER :: IN, LP, II, NUMORG, NBSPLIT_LOC, I INTEGER MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPESPLIT DO I= NSLAVES_NODE+1, 1, -1 TAB_POS(I+NBSPLIT) = TAB_POS(I) END DO LP = ICNTL(1) IN = INODE NBSPLIT_LOC = 0 NUMORG = 0 TAB_POS(1) = 1 DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IN)))),KEEP(199)) & .EQ.6 & ) & ) NBSPLIT_LOC = NBSPLIT_LOC + 1 IN = DAD(STEP(IN)) II = IN DO WHILE (II.GT.0) NUMORG = NUMORG + 1 II = FILS(II) ENDDO TAB_POS(NBSPLIT_LOC+1) = NUMORG + 1 END DO DO I = NBSPLIT+2, NBSPLIT+NSLAVES_NODE+1 TAB_POS(I) = TAB_POS(I) + NUMORG ENDDO NSLAVES_NODE = NSLAVES_NODE + NBSPLIT TAB_POS (NSLAVES_NODE+2:SLAVEF+1) = -9999 TAB_POS ( SLAVEF+2 ) = NSLAVES_NODE RETURN END SUBROUTINE DMUMPS_SPLIT_POST_PARTITION SUBROUTINE DMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND, SIZE_CAND, & SON_SLAVE_LIST, NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, ICNTL, & ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES_NODE, & SLAVES_LIST, SIZE_SLAVES_LIST & ) IMPLICIT NONE INTEGER, intent(in) :: INODE, TYPESPLIT, IFSON, N, SLAVEF, & KEEP(500), & NSLSON, SIZE_SLAVES_LIST, SIZE_CAND INTEGER, intent(in) :: STEP(N), DAD (KEEP(28)), ICNTL(60), & PROCNODE_STEPS(KEEP(28)), & FILS(N), INIV2, & SON_SLAVE_LIST (NSLSON), & ISTEP_TO_INIV2(KEEP(71)), & CAND(SIZE_CAND) INTEGER, intent(out) :: NSLAVES_NODE INTEGER, intent(inout) :: & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(out) :: SLAVES_LIST (SIZE_SLAVES_LIST) INTEGER :: IN, LP, I, NSLAVES_SONS, & INIV2_FILS, ISHIFT LP = ICNTL(1) IN = INODE INIV2_FILS = ISTEP_TO_INIV2( STEP( IFSON )) NSLAVES_SONS = TAB_POS_IN_PERE (SLAVEF+2, INIV2_FILS) TAB_POS_IN_PERE (1,INIV2) = 1 ISHIFT = TAB_POS_IN_PERE (2, INIV2_FILS) -1 DO I = 2, NSLAVES_SONS TAB_POS_IN_PERE (I,INIV2) = & TAB_POS_IN_PERE (I+1,INIV2_FILS) - ISHIFT SLAVES_LIST(I-1) = SON_SLAVE_LIST (I) END DO TAB_POS_IN_PERE(NSLAVES_SONS+1:SLAVEF+1,INIV2) = -9999 NSLAVES_NODE = NSLAVES_SONS - 1 TAB_POS_IN_PERE (SLAVEF+2, INIV2) = NSLAVES_NODE RETURN END SUBROUTINE DMUMPS_SPLIT_PROPAGATE_PARTI SUBROUTINE DMUMPS_LOAD_SET_PARTITION( & NCBSON_MAX, SLAVEF, & KEEP,KEEP8,ICNTL, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,INODE &) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: SLAVEF, NFRONT INTEGER, intent (inout) ::NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER i INTEGER LP,MP INTEGER(8) DUMMY1 INTEGER DUMMY2 INTEGER TMP_ARRAY(2) LP=ICNTL(4) MP=ICNTL(2) IF ( KEEP(48) == 0 .OR. KEEP(48) .EQ. 3 ) THEN CALL DMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) ELSE IF ( KEEP(48) == 4 ) THEN CALL DMUMPS_SET_PARTI_ACTV_MEM( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'probleme de partition dans &DMUMPS_LOAD_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO ELSE IF ( KEEP(48) == 5 ) THEN IF (KEEP(375).EQ.1) THEN GOTO 458 ENDIF CALL DMUMPS_SET_PARTI_FLOP_IRR( & NCBSON_MAX, & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & MP,LP) DO i=1,NSLAVES_NODE IF(TAB_POS(i+1)-TAB_POS(i).LE.0)THEN WRITE(*,*)'problem with partition in &DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO GOTO 457 458 CONTINUE IF ( KEEP(375).EQ.1 )THEN TMP_ARRAY(1)=0 TMP_ARRAY(2)=0 ENDIF CALL DMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS,TMP_ARRAY,DUMMY1,DUMMY2 & ) ELSE WRITE(*,*) "Strategy 6 not implemented" CALL MUMPS_ABORT() ENDIF 457 CONTINUE RETURN END SUBROUTINE DMUMPS_LOAD_SET_PARTITION SUBROUTINE DMUMPS_LOAD_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & CAND_OF_NODE, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB INTEGER, intent(in) :: CAND_OF_NODE(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER ITEMP, NMB_OF_CAND, NSLAVES_LESS DOUBLE PRECISION MSG_SIZE LOGICAL FORCE_CAND INTEGER MUMPS_REG_GET_NSLAVES EXTERNAL MUMPS_REG_GET_NSLAVES IF ( KEEP(48) == 0 .AND. KEEP(50) .NE. 0) THEN write(*,*) "Internal error 2 in DMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF IF ( KEEP(48) == 3 .AND. KEEP(50) .EQ. 0) THEN write(*,*) "Internal error 3 in DMUMPS_LOAD_PARTI_REGULAR." CALL MUMPS_ABORT() END IF MSG_SIZE = dble( NFRONT - NCB ) * dble(NCB) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF (FORCE_CAND) THEN ITEMP=DMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB, & CAND_OF_NODE, & & KEEP(69), SLAVEF, MSG_SIZE, & NMB_OF_CAND ) ELSE ITEMP=DMUMPS_LOAD_LESS(KEEP(69),MEM_DISTRIB,MSG_SIZE) NMB_OF_CAND = SLAVEF - 1 END IF NSLAVES_LESS = max(ITEMP,1) NSLAVES_NODE = MUMPS_REG_GET_NSLAVES(KEEP8(21), KEEP(48), & KEEP(50),SLAVEF, & NCB, NFRONT, NSLAVES_LESS, NMB_OF_CAND, & KEEP(375), KEEP(119)) CALL MUMPS_BLOC2_SETPARTITION( & KEEP,KEEP8, SLAVEF, & TAB_POS, & NSLAVES_NODE, NFRONT, NCB & ) IF (FORCE_CAND) THEN CALL DMUMPS_LOAD_SET_SLAVES_CAND(MEM_DISTRIB(0), & CAND_OF_NODE, SLAVEF, NSLAVES_NODE, & SLAVES_LIST) ELSE CALL DMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB(0), & MSG_SIZE, SLAVES_LIST, NSLAVES_NODE) ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_PARTI_REGULAR SUBROUTINE DMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) USE DMUMPS_BUF USE DMUMPS_STRUC_DEF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id INTEGER(8), intent(in) :: MEMORY_MD_ARG INTEGER(8), intent(in) :: MAXS INTEGER K34_LOC INTEGER(8) :: I8SIZE INTEGER allocok, IERR, IERR_MPI, i, BUF_LOAD_SIZE DOUBLE PRECISION :: MAX_SBTR DOUBLE PRECISION ZERO DOUBLE PRECISION MEMORY_SENT PARAMETER( ZERO=0.0d0 ) DOUBLE PRECISION SIZE_DBLE(2) INTEGER WHAT INTEGER(8) MEMORY_MD, LA CALL MUMPS_LOAD_ENABLE() STEP_TO_NIV2_LOAD=>id%ISTEP_TO_INIV2 CAND_LOAD=>id%CANDIDATES ND_LOAD=>id%ND_STEPS KEEP_LOAD=>id%KEEP KEEP8_LOAD=>id%KEEP8 FILS_LOAD=>id%FILS FRERE_LOAD=>id%FRERE_STEPS DAD_LOAD=>id%DAD_STEPS PROCNODE_LOAD=>id%PROCNODE_STEPS STEP_LOAD=>id%STEP NE_LOAD=>id%NE_STEPS N_LOAD=id%N ROOT_CURRENT_SUBTREE=-9999 MEMORY_MD=MEMORY_MD_ARG LA=MAXS MAX_SURF_MASTER=id%MAX_SURF_MASTER+ & (int(id%KEEP(12),8)*int(id%MAX_SURF_MASTER,8)/int(100,8)) COMM_LD = id%COMM_LOAD COMM_NODES = id%COMM_NODES MAX_PEAK_STK = 0.0D0 K69 = id%KEEP(69) IF ( id%KEEP(47) .le. 0 .OR. id%KEEP(47) .gt. 4 ) THEN write(*,*) "Internal error 1 in DMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF CHK_LD=dble(0) BDC_MEM = ( id%KEEP(47) >= 2 ) BDC_POOL = ( id%KEEP(47) >= 3 ) BDC_SBTR = ( id%KEEP(47) >= 4 ) BDC_M2_MEM = ( ( id%KEEP(80) == 2 .OR. id%KEEP(80) == 3 ) & .AND. id%KEEP(47) == 4 ) BDC_M2_FLOPS = ( id%KEEP(80) == 1 & .AND. id%KEEP(47) .GE. 1 ) BDC_MD = (id%KEEP(86)==1) SBTR_WHICH_M = id%KEEP(90) REMOVE_NODE_FLAG=.FALSE. REMOVE_NODE_FLAG_MEM=.FALSE. REMOVE_NODE_COST_MEM=dble(0) REMOVE_NODE_COST=dble(0) IF (id%KEEP(80) .LT. 0 .OR. id%KEEP(80)>3) THEN WRITE(*,*) "Unimplemented KEEP(80) Strategy" CALL MUMPS_ABORT() ENDIF IF ((id%KEEP(80) == 2 .OR. id%KEEP(80)==3).AND. id%KEEP(47).NE.4) & THEN WRITE(*,*) "Internal error 3 in DMUMPS_LOAD_INIT" CALL MUMPS_ABORT() END IF IF (id%KEEP(81) == 1 .AND. id%KEEP(47) < 2) THEN WRITE(*,*) "Internal error 2 in DMUMPS_LOAD_INIT" CALL MUMPS_ABORT() ENDIF BDC_POOL_MNG = ((id%KEEP(81) == 1).AND.(id%KEEP(47) >= 2)) IF(id%KEEP(76).EQ.4)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST ENDIF IF(id%KEEP(76).EQ.5)THEN COST_TRAV=>id%COST_TRAV ENDIF IF(id%KEEP(76).EQ.6)THEN DEPTH_FIRST_LOAD=>id%DEPTH_FIRST DEPTH_FIRST_SEQ_LOAD=>id%DEPTH_FIRST_SEQ SBTR_ID_LOAD=>id%SBTR_ID ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN POOL_NIV2_SIZE=max(1,min(id%NBSA+id%KEEP(262),id%NA(1))) ALLOCATE(NIV2(id%NSLAVES), NB_SON(id%KEEP(28)), & POOL_NIV2(POOL_NIV2_SIZE), & POOL_NIV2_COST(POOL_NIV2_SIZE), & stat=allocok) DO i = 1, id%KEEP(28) NB_SON(i)=id%NE_STEPS(i) ENDDO NIV2=dble(0) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES + id%KEEP(28) + 200 RETURN ENDIF ENDIF K50 = id%KEEP(50) CALL MPI_COMM_RANK( COMM_LD, MYID, IERR_MPI ) NPROCS = id%NSLAVES DM_SUMLU=ZERO POOL_SIZE=0 IF(BDC_MD)THEN IF ( allocated(MD_MEM) ) DEALLOCATE(MD_MEM) ALLOCATE( MD_MEM( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(TAB_MAXS) ) DEALLOCATE(TAB_MAXS) ALLOCATE( TAB_MAXS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF TAB_MAXS=0_8 IF ( allocated(LU_USAGE) ) DEALLOCATE(LU_USAGE) ALLOCATE( LU_USAGE( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF LU_USAGE=dble(0) MD_MEM=int(0,8) ENDIF IF((id%KEEP(81).EQ.2).OR.(id%KEEP(81).EQ.3))THEN ALLOCATE(CB_COST_MEM(2*2000*id%NSLAVES), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_MEM=int(0,8) ALLOCATE(CB_COST_ID(2000*3), & stat=allocok) IF (allocok > 0) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NSLAVES RETURN ENDIF CB_COST_ID=0 POS_MEM=1 POS_ID=1 ENDIF ALLOCATE(FUTURE_NIV2(NPROCS), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN ENDIF DO i = 1, NPROCS FUTURE_NIV2(i) = id%FUTURE_NIV2(i) IF(BDC_MD)THEN IF(FUTURE_NIV2(i).EQ.0)THEN MD_MEM(i-1)=999999999_8 ENDIF ENDIF ENDDO DELTA_MEM=ZERO DELTA_LOAD=ZERO CHECK_MEM=0_8 IF(BDC_SBTR.OR.BDC_POOL_MNG)THEN NB_SUBTREES=id%NBSA_LOCAL IF (allocated(MEM_SUBTREE)) DEALLOCATE(MEM_SUBTREE) ALLOCATE(MEM_SUBTREE(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF DO i=1,id%NBSA_LOCAL MEM_SUBTREE(i)=id%MEM_SUBTREE(i) ENDDO MY_FIRST_LEAF=>id%MY_FIRST_LEAF MY_NB_LEAF=>id%MY_NB_LEAF MY_ROOT_SBTR=>id%MY_ROOT_SBTR IF (allocated(SBTR_FIRST_POS_IN_POOL)) & DEALLOCATE(SBTR_FIRST_POS_IN_POOL) ALLOCATE(SBTR_FIRST_POS_IN_POOL(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF INSIDE_SUBTREE=0 PEAK_SBTR_CUR_LOCAL = dble(0) SBTR_CUR_LOCAL = dble(0) IF (allocated(SBTR_PEAK_ARRAY)) DEALLOCATE(SBTR_PEAK_ARRAY) ALLOCATE(SBTR_PEAK_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_PEAK_ARRAY=dble(0) IF (allocated(SBTR_CUR_ARRAY)) DEALLOCATE(SBTR_CUR_ARRAY) ALLOCATE(SBTR_CUR_ARRAY(id%NBSA_LOCAL),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = id%NBSA_LOCAL RETURN ENDIF SBTR_CUR_ARRAY=dble(0) INDICE_SBTR_ARRAY=1 NIV1_FLAG=0 INDICE_SBTR=1 ENDIF IF ( allocated(LOAD_FLOPS) ) DEALLOCATE( LOAD_FLOPS ) ALLOCATE( LOAD_FLOPS( 0: NPROCS - 1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(WLOAD) ) DEALLOCATE( WLOAD ) ALLOCATE( WLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(IDWLOAD) ) DEALLOCATE( IDWLOAD ) ALLOCATE( IDWLOAD( NPROCS ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( BDC_MEM ) THEN IF ( allocated(DM_MEM) ) DEALLOCATE( DM_MEM ) ALLOCATE( DM_MEM( 0:NPROCS-1 ), stat=allocok ) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF END IF IF ( BDC_POOL ) THEN IF ( allocated(POOL_MEM) ) DEALLOCATE(POOL_MEM) ALLOCATE( POOL_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF POOL_MEM = dble(0) POOL_LAST_COST_SENT = dble(0) END IF IF ( BDC_SBTR ) THEN IF ( allocated(SBTR_MEM) ) DEALLOCATE(SBTR_MEM) ALLOCATE( SBTR_MEM(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF IF ( allocated(SBTR_CUR) ) DEALLOCATE(SBTR_CUR) ALLOCATE( SBTR_CUR(0: NPROCS -1), stat=allocok) IF ( allocok .gt. 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = NPROCS RETURN END IF SBTR_CUR = dble(0) SBTR_MEM = dble(0) END IF K34_LOC=id%KEEP(34) CALL MUMPS_SIZE_C(SIZE_DBLE(1),SIZE_DBLE(2),I8SIZE) K35 = int(I8SIZE) BUF_LOAD_SIZE = K34_LOC * 2 * ( NPROCS - 1 ) + & NPROCS * ( K35 + K34_LOC ) IF (BDC_MEM) THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 END IF IF (BDC_SBTR)THEN BUF_LOAD_SIZE = BUF_LOAD_SIZE + NPROCS * K35 ENDIF LBUF_LOAD_RECV = (BUF_LOAD_SIZE+K34_LOC)/K34_LOC LBUF_LOAD_RECV_BYTES = LBUF_LOAD_RECV * K34_LOC IF ( allocated(BUF_LOAD_RECV) ) DEALLOCATE(BUF_LOAD_RECV) ALLOCATE( BUF_LOAD_RECV( LBUF_LOAD_RECV), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_INIT' id%INFO(1) = -13 id%INFO(2) = LBUF_LOAD_RECV RETURN ENDIF BUF_LOAD_SIZE = BUF_LOAD_SIZE * 20 CALL DMUMPS_BUF_ALLOC_LOAD_BUFFER( BUF_LOAD_SIZE, IERR ) IF ( IERR .LT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = BUF_LOAD_SIZE RETURN END IF DO i = 0, NPROCS - 1 LOAD_FLOPS( i ) = ZERO END DO IF ( BDC_MEM ) THEN DO i = 0, NPROCS - 1 DM_MEM( i )=ZERO END DO ENDIF CALL DMUMPS_INIT_ALPHA_BETA(id%KEEP(69)) IF(BDC_MD)THEN MAX_SBTR=0.0D0 IF(BDC_SBTR)THEN DO i=1,id%NBSA_LOCAL MAX_SBTR=max(id%MEM_SUBTREE(i),MAX_SBTR) ENDDO ENDIF MD_MEM(MYID)=MEMORY_MD WHAT=8 CALL DMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & dble(MEMORY_MD),dble(0) ,MYID, id%KEEP, IERR ) WHAT=9 MEMORY_SENT = dble(LA-MAX_SURF_MASTER)-MAX_SBTR & - max( dble(LA) * dble(3) / dble(100), & dble(2) * & dble(max(id%KEEP(5),id%KEEP(6))) * dble(id%KEEP(127))) IF (id%KEEP(12) > 25) THEN MEMORY_SENT = MEMORY_SENT - & dble(id%KEEP(12))*0.2d0*dble(LA)/100.0d0 ENDIF IF (id%KEEP(375).EQ.1) THEN MEMORY_SENT=dble(LA) ENDIF TAB_MAXS(MYID)=int(MEMORY_SENT,8) CALL DMUMPS_BUF_BROADCAST( WHAT, & COMM_LD, NPROCS, & FUTURE_NIV2, & MEMORY_SENT, & dble(0),MYID, id%KEEP, IERR ) ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_INIT SUBROUTINE DMUMPS_LOAD_UPDATE( CHECK_FLOPS,PROCESS_BANDE, & INC_LOAD, KEEP,KEEP8 ) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE DOUBLE PRECISION INC_LOAD INTEGER KEEP(500) INTEGER(8) KEEP8(150) LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG INTEGER CHECK_FLOPS INTEGER IERR DOUBLE PRECISION ZERO, SEND_MEM, SEND_LOAD,SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN IF (INC_LOAD == 0.0D0) THEN IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN ENDIF IF((CHECK_FLOPS.NE.0).AND. & (CHECK_FLOPS.NE.1).AND.(CHECK_FLOPS.NE.2))THEN WRITE(*,*)MYID,': Bad value for CHECK_FLOPS' CALL MUMPS_ABORT() ENDIF IF(CHECK_FLOPS.EQ.1)THEN CHK_LD=CHK_LD+INC_LOAD ELSE IF(CHECK_FLOPS.EQ.2)THEN RETURN ENDIF ENDIF IF ( PROCESS_BANDE ) THEN RETURN ENDIF LOAD_FLOPS( MYID ) = max( LOAD_FLOPS( MYID ) + INC_LOAD, ZERO) IF(BDC_M2_FLOPS.AND.REMOVE_NODE_FLAG)THEN IF(INC_LOAD.NE.REMOVE_NODE_COST)THEN IF(INC_LOAD.GT.REMOVE_NODE_COST)THEN DELTA_LOAD = DELTA_LOAD + & (INC_LOAD-REMOVE_NODE_COST) GOTO 888 ELSE DELTA_LOAD = DELTA_LOAD - & (REMOVE_NODE_COST-INC_LOAD) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_LOAD = DELTA_LOAD + INC_LOAD 888 CONTINUE IF ( DELTA_LOAD > MIN_DIFF .OR. DELTA_LOAD < -MIN_DIFF) THEN SEND_LOAD = DELTA_LOAD IF (BDC_MEM) THEN SEND_MEM = DELTA_MEM ELSE SEND_MEM = ZERO END IF IF(BDC_SBTR)THEN SBTR_TMP=SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF 111 CONTINUE CALL DMUMPS_BUF_SEND_UPDATE_LOAD( BDC_SBTR,BDC_MEM, & BDC_MD,COMM_LD, NPROCS, & SEND_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE.0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO IF (BDC_MEM) DELTA_MEM = ZERO ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG)THEN REMOVE_NODE_FLAG=.FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_UPDATE SUBROUTINE DMUMPS_LOAD_MEM_UPDATE( SSARBR, & PROCESS_BANDE_ARG, MEM_VALUE, NEW_LU, INC_MEM_ARG, & KEEP,KEEP8,LRLUS) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_VALUE, INC_MEM_ARG, NEW_LU,LRLUS LOGICAL, INTENT(IN) :: PROCESS_BANDE_ARG, SSARBR INTEGER IERR, KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION ZERO, SEND_MEM, SBTR_TMP PARAMETER( ZERO=0.0d0 ) INTRINSIC max, abs INTEGER(8) :: INC_MEM LOGICAL PROCESS_BANDE LOGICAL :: EXIT_FLAG IF (.NOT. IS_MUMPS_LOAD_ENABLED) RETURN PROCESS_BANDE=PROCESS_BANDE_ARG INC_MEM = INC_MEM_ARG IF ( PROCESS_BANDE .AND. NEW_LU .NE. 0_8) THEN WRITE(*,*) " Internal Error in DMUMPS_LOAD_MEM_UPDATE." WRITE(*,*) " NEW_LU must be zero if called from PROCESS_BANDE" CALL MUMPS_ABORT() ENDIF DM_SUMLU = DM_SUMLU + dble(NEW_LU) IF(KEEP_LOAD(201).EQ.0)THEN CHECK_MEM = CHECK_MEM + INC_MEM ELSE CHECK_MEM = CHECK_MEM + INC_MEM - NEW_LU ENDIF IF ( MEM_VALUE .NE. CHECK_MEM ) THEN WRITE(*,*)MYID, & ':Problem with increments in DMUMPS_LOAD_MEM_UPDATE', & CHECK_MEM, MEM_VALUE, INC_MEM,NEW_LU CALL MUMPS_ABORT() ENDIF IF (PROCESS_BANDE) THEN RETURN ENDIF IF(BDC_POOL_MNG) THEN IF(SBTR_WHICH_M.EQ.0)THEN IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM-NEW_LU) ELSE IF (SSARBR) SBTR_CUR_LOCAL = SBTR_CUR_LOCAL+ & dble(INC_MEM) ENDIF ENDIF IF ( .NOT. BDC_MEM ) THEN RETURN ENDIF IF (BDC_SBTR .AND. SSARBR) THEN IF((SBTR_WHICH_M.EQ.0).AND.(KEEP(201).NE.0))THEN SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM-NEW_LU) ELSE SBTR_CUR(MYID) = SBTR_CUR(MYID)+dble(INC_MEM) ENDIF SBTR_TMP = SBTR_CUR(MYID) ELSE SBTR_TMP=dble(0) ENDIF IF ( NEW_LU > 0_8 ) THEN INC_MEM = INC_MEM - NEW_LU ENDIF DM_MEM( MYID ) = DM_MEM(MYID) + dble(INC_MEM) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MYID)) IF(BDC_M2_MEM.AND.REMOVE_NODE_FLAG_MEM)THEN IF(dble(INC_MEM).NE.REMOVE_NODE_COST_MEM)THEN IF(dble(INC_MEM).GT.REMOVE_NODE_COST_MEM)THEN DELTA_MEM = DELTA_MEM + & (dble(INC_MEM)-REMOVE_NODE_COST_MEM) GOTO 888 ELSE DELTA_MEM = DELTA_MEM - & (REMOVE_NODE_COST_MEM-dble(INC_MEM)) GOTO 888 ENDIF ENDIF GOTO 333 ENDIF DELTA_MEM = DELTA_MEM + dble(INC_MEM) 888 CONTINUE IF ((KEEP(48).NE.5).OR. & ((KEEP(48).EQ.5).AND.(abs(DELTA_MEM) & .GE.0.2d0*dble(LRLUS))))THEN IF ( abs(DELTA_MEM) > DM_THRES_MEM ) THEN SEND_MEM = DELTA_MEM 111 CONTINUE CALL DMUMPS_BUF_SEND_UPDATE_LOAD( & BDC_SBTR, & BDC_MEM,BDC_MD, COMM_LD, & NPROCS, & DELTA_LOAD, & SEND_MEM,SBTR_TMP, & DM_SUMLU, & FUTURE_NIV2, & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 333 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_MEM_UPDATE",IERR CALL MUMPS_ABORT() ENDIF DELTA_LOAD = ZERO DELTA_MEM = ZERO ENDIF ENDIF 333 CONTINUE IF(REMOVE_NODE_FLAG_MEM)THEN REMOVE_NODE_FLAG_MEM=.FALSE. ENDIF END SUBROUTINE DMUMPS_LOAD_MEM_UPDATE INTEGER FUNCTION DMUMPS_LOAD_LESS( K69, MEM_DISTRIB,MSG_SIZE ) IMPLICIT NONE INTEGER i, NLESS, K69 INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION LREF DOUBLE PRECISION MSG_SIZE NLESS = 0 DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO WLOAD(1:NPROCS) = LOAD_FLOPS(0:NPROCS-1) IF(BDC_M2_FLOPS)THEN DO i=1,NPROCS WLOAD(i)=WLOAD(i)+NIV2(i) ENDDO ENDIF IF(K69 .gt. 1) THEN CALL DMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,IDWLOAD,NPROCS) ENDIF LREF = LOAD_FLOPS(MYID) DO i=1, NPROCS IF (WLOAD(i).LT.LREF) NLESS=NLESS+1 ENDDO DMUMPS_LOAD_LESS = NLESS RETURN END FUNCTION DMUMPS_LOAD_LESS SUBROUTINE DMUMPS_LOAD_SET_SLAVES(MEM_DISTRIB,MSG_SIZE,DEST, & NSLAVES) IMPLICIT NONE INTEGER NSLAVES INTEGER DEST(NSLAVES) INTEGER, DIMENSION(0:NPROCS - 1) :: MEM_DISTRIB INTEGER i,J,NBDEST DOUBLE PRECISION MSG_SIZE IF ( NSLAVES.eq.NPROCS-1 ) THEN J = MYID+1 DO i=1,NSLAVES J=J+1 IF (J.GT.NPROCS) J=1 DEST(i) = J - 1 ENDDO ELSE DO i=1,NPROCS IDWLOAD(i) = i - 1 ENDDO CALL MUMPS_SORT_DOUBLES(NPROCS, WLOAD, IDWLOAD) NBDEST = 0 DO i=1, NSLAVES J = IDWLOAD(i) IF (J.NE.MYID) THEN NBDEST = NBDEST+1 DEST(NBDEST) = J ENDIF ENDDO IF (NBDEST.NE.NSLAVES) THEN DEST(NSLAVES) = IDWLOAD(NSLAVES+1) ENDIF IF(BDC_MD)THEN J=NSLAVES+1 do i=NSLAVES+1,NPROCS IF(IDWLOAD(i).NE.MYID)THEN DEST(J)= IDWLOAD(i) J=J+1 ENDIF end do ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_SET_SLAVES SUBROUTINE DMUMPS_LOAD_END( INFO1, NSLAVES, IERR ) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT(IN) :: INFO1 INTEGER, INTENT(IN) :: NSLAVES INTEGER, INTENT(OUT) :: IERR INTEGER :: DUMMY_COMMUNICATOR IERR=0 DUMMY_COMMUNICATOR = -999 CALL DMUMPS_CLEAN_PENDING( INFO1, KEEP_LOAD(1), BUF_LOAD_RECV(1), & LBUF_LOAD_RECV, & LBUF_LOAD_RECV_BYTES, DUMMY_COMMUNICATOR, COMM_LD, & NSLAVES, & .FALSE., & .TRUE. & ) DEALLOCATE( LOAD_FLOPS ) DEALLOCATE( WLOAD ) DEALLOCATE( IDWLOAD ) DEALLOCATE(FUTURE_NIV2) IF(BDC_MD)THEN DEALLOCATE(MD_MEM) DEALLOCATE(LU_USAGE) DEALLOCATE(TAB_MAXS) ENDIF IF ( BDC_MEM ) DEALLOCATE( DM_MEM ) IF ( BDC_POOL) DEALLOCATE( POOL_MEM ) IF ( BDC_SBTR) THEN DEALLOCATE( SBTR_MEM ) DEALLOCATE( SBTR_CUR ) DEALLOCATE(SBTR_FIRST_POS_IN_POOL) NULLIFY(MY_FIRST_LEAF) NULLIFY(MY_NB_LEAF) NULLIFY(MY_ROOT_SBTR) ENDIF IF(KEEP_LOAD(76).EQ.4)THEN NULLIFY(DEPTH_FIRST_LOAD) ENDIF IF(KEEP_LOAD(76).EQ.5)THEN NULLIFY(COST_TRAV) ENDIF IF((KEEP_LOAD(76).EQ.4).OR.(KEEP_LOAD(76).EQ.6))THEN NULLIFY(DEPTH_FIRST_LOAD) NULLIFY(DEPTH_FIRST_SEQ_LOAD) NULLIFY(SBTR_ID_LOAD) ENDIF IF (BDC_M2_MEM.OR.BDC_M2_FLOPS) THEN DEALLOCATE(NB_SON,POOL_NIV2,POOL_NIV2_COST, NIV2) END IF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN DEALLOCATE(CB_COST_MEM) DEALLOCATE(CB_COST_ID) ENDIF NULLIFY(ND_LOAD) NULLIFY(KEEP_LOAD) NULLIFY(KEEP8_LOAD) NULLIFY(FILS_LOAD) NULLIFY(FRERE_LOAD) NULLIFY(PROCNODE_LOAD) NULLIFY(STEP_LOAD) NULLIFY(NE_LOAD) NULLIFY(CAND_LOAD) NULLIFY(STEP_TO_NIV2_LOAD) NULLIFY(DAD_LOAD) IF (BDC_SBTR.OR.BDC_POOL_MNG) THEN DEALLOCATE(MEM_SUBTREE) DEALLOCATE(SBTR_PEAK_ARRAY) DEALLOCATE(SBTR_CUR_ARRAY) ENDIF CALL DMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) DEALLOCATE(BUF_LOAD_RECV) RETURN END SUBROUTINE DMUMPS_LOAD_END RECURSIVE SUBROUTINE DMUMPS_LOAD_RECV_MSGS(COMM) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGTAG, MSGLEN, MSGSOU,COMM INTEGER IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL FLAG 10 CONTINUE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR_MPI ) IF (FLAG) THEN KEEP_LOAD(65)=KEEP_LOAD(65)+1 KEEP_LOAD(267)=KEEP_LOAD(267)-1 MSGTAG = STATUS( MPI_TAG ) MSGSOU = STATUS( MPI_SOURCE ) IF ( MSGTAG .NE. UPDATE_LOAD) THEN write(*,*) "Internal error 1 in DMUMPS_LOAD_RECV_MSGS", & MSGTAG CALL MUMPS_ABORT() ENDIF CALL MPI_GET_COUNT(STATUS, MPI_PACKED, MSGLEN, IERR_MPI) IF ( MSGLEN > LBUF_LOAD_RECV_BYTES ) THEN write(*,*) "Internal error 2 in DMUMPS_LOAD_RECV_MSGS", & MSGLEN, LBUF_LOAD_RECV_BYTES CALL MUMPS_ABORT() ENDIF CALL MPI_RECV( BUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES, & MPI_PACKED, MSGSOU, MSGTAG, COMM_LD, STATUS, IERR_MPI) CALL DMUMPS_LOAD_PROCESS_MESSAGE( MSGSOU, BUF_LOAD_RECV, & LBUF_LOAD_RECV, LBUF_LOAD_RECV_BYTES ) GOTO 10 ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_RECV_MSGS RECURSIVE SUBROUTINE DMUMPS_LOAD_PROCESS_MESSAGE & ( MSGSOU, BUFR, LBUFR, LBUFR_BYTES ) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER MSGSOU, LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INCLUDE 'mpif.h' INTEGER POSITION, WHAT, NSLAVES, i INTEGER IERR_MPI DOUBLE PRECISION LOAD_RECEIVED INTEGER INODE_RECEIVED,NCB_RECEIVED DOUBLE PRECISION SURF INTEGER, POINTER, DIMENSION (:) :: LIST_SLAVES DOUBLE PRECISION, POINTER, DIMENSION (:) :: LOAD_INCR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WHAT, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) IF ( WHAT == 0 ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DM_MEM(MSGSOU) = DM_MEM(MSGSOU) + LOAD_RECEIVED MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(MSGSOU)) END IF IF(BDC_SBTR)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_CUR(MSGSOU)=LOAD_RECEIVED ENDIF IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(KEEP_LOAD(201).EQ.0)THEN LU_USAGE(MSGSOU)=LOAD_RECEIVED ENDIF ENDIF ELSEIF (( WHAT == 1).OR.(WHAT.EQ.19)) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = & LOAD_FLOPS(LIST_SLAVES(i)) + & LOAD_INCR(i) END DO IF ( BDC_MEM ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) DO i = 1, NSLAVES DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) + & LOAD_INCR(i) MAX_PEAK_STK=max(MAX_PEAK_STK,DM_MEM(LIST_SLAVES(i))) END DO END IF IF(WHAT.EQ.19)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI) CALL DMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE_RECEIVED) CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES WRITE(*,*)MYID,':',LIST_SLAVES(i),'->',LOAD_INCR(i) CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(LOAD_INCR(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF NULLIFY( LIST_SLAVES ) NULLIFY( LOAD_INCR ) ELSE IF (WHAT == 2 ) THEN IF ( .not. BDC_POOL ) THEN WRITE(*,*) "Internal error 2 in DMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) POOL_MEM(MSGSOU)=LOAD_RECEIVED ELSE IF ( WHAT == 3 ) THEN IF ( .NOT. BDC_SBTR) THEN WRITE(*,*) "Internal error 3 in DMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) SBTR_MEM(MSGSOU)=SBTR_MEM(MSGSOU)+LOAD_RECEIVED ELSE IF (WHAT == 4) THEN FUTURE_NIV2(MSGSOU+1)=0 IF(BDC_MD)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SURF, 1, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=999999999_8 TAB_MAXS(MSGSOU)=TAB_MAXS(MSGSOU)+int(SURF,8) ENDIF IF(BDC_M2_MEM.OR.BDC_M2_FLOPS)THEN ENDIF ELSE IF (WHAT == 5) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 7 in DMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN CALL DMUMPS_PROCESS_NIV2_MEM_MSG(INODE_RECEIVED) ELSEIF(BDC_M2_FLOPS) THEN CALL DMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE_RECEIVED) ENDIF IF((KEEP_LOAD(81).EQ.2).OR.(KEEP_LOAD(81).EQ.3))THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB_RECEIVED, 1, & MPI_INTEGER, & COMM_LD, IERR_MPI ) IF( & MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE_RECEIVED)), & KEEP_LOAD(199)).EQ.1 & )THEN CB_COST_ID(POS_ID)=INODE_RECEIVED CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MSGSOU,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB_RECEIVED,8)* & int(NCB_RECEIVED,8) POS_MEM=POS_MEM+1 ENDIF ENDIF ELSE IF ( WHAT == 6 ) THEN IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*) "Internal error 8 in DMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSEIF(WHAT == 17)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_M2_MEM) THEN NIV2(MSGSOU+1) = LOAD_RECEIVED CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) IF(BDC_MD)THEN DM_MEM(MYID)=DM_MEM(MYID)+LOAD_RECEIVED ELSEIF(BDC_POOL)THEN POOL_MEM(MSGSOU)=LOAD_RECEIVED ENDIF ELSEIF(BDC_M2_FLOPS) THEN NIV2(MSGSOU+1) = NIV2(MSGSOU+1) + LOAD_RECEIVED IF(NIV2(MSGSOU+1).LT.0.0D0)THEN IF(abs(NIV2(MSGSOU+1)) .LE. 1.0D-3) THEN NIV2(MSGSOU+1)=0.0D0 ELSE WRITE(*,*)'problem with NIV2_FLOPS message', & NIV2(MSGSOU+1),MSGSOU,LOAD_RECEIVED CALL MUMPS_ABORT() ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) LOAD_FLOPS( MSGSOU ) = LOAD_FLOPS(MSGSOU) + LOAD_RECEIVED ENDIF ELSEIF ( WHAT == 7 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 4 &in DMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE_RECEIVED, 1, MPI_INTEGER, & COMM_LD, IERR_MPI ) LIST_SLAVES => IDWLOAD LOAD_INCR => WLOAD CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LIST_SLAVES(1), NSLAVES, MPI_INTEGER, & COMM_LD, IERR_MPI ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_INCR(1), NSLAVES, MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) DO i = 1, NSLAVES MD_MEM(LIST_SLAVES(i)) = & MD_MEM(LIST_SLAVES(i)) + & int(LOAD_INCR(i),8) IF(FUTURE_NIV2(LIST_SLAVES(i)+1).EQ.0)THEN MD_MEM(LIST_SLAVES(i))=999999999_8 ENDIF END DO ELSEIF ( WHAT == 8 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 5 &in DMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) MD_MEM(MSGSOU)=MD_MEM(MSGSOU)+int(LOAD_RECEIVED,8) IF(FUTURE_NIV2(MSGSOU+1).EQ.0)THEN MD_MEM(MSGSOU)=999999999_8 ENDIF ELSEIF ( WHAT == 9 ) THEN IF(.NOT.BDC_MD)THEN WRITE(*,*)MYID,': Internal error 6 &in DMUMPS_LOAD_PROCESS_MESSAGE' CALL MUMPS_ABORT() ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LOAD_RECEIVED, 1, & MPI_DOUBLE_PRECISION, & COMM_LD, IERR_MPI ) TAB_MAXS(MSGSOU)=int(LOAD_RECEIVED,8) ELSE WRITE(*,*) "Internal error 1 in DMUMPS_LOAD_PROCESS_MESSAGE" CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE DMUMPS_LOAD_PROCESS_MESSAGE integer function DMUMPS_LOAD_LESS_CAND & (MEM_DISTRIB,CAND, & K69, & SLAVEF,MSG_SIZE, & NMB_OF_CAND ) implicit none integer, intent(in) :: K69, SLAVEF INTEGER, intent(in) :: CAND(SLAVEF+1) INTEGER, DIMENSION(0:NPROCS - 1), intent(in) :: MEM_DISTRIB INTEGER, intent(out) :: NMB_OF_CAND integer i,nless DOUBLE PRECISION lref DOUBLE PRECISION MSG_SIZE nless = 0 NMB_OF_CAND=CAND(SLAVEF+1) do i=1,NMB_OF_CAND WLOAD(i)=LOAD_FLOPS(CAND(i)) IF(BDC_M2_FLOPS)THEN WLOAD(i)=WLOAD(i)+NIV2(CAND(i)+1) ENDIF end do IF(K69 .gt. 1) THEN CALL DMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE, & CAND,NMB_OF_CAND) ENDIF lref = LOAD_FLOPS(MYID) do i=1, NMB_OF_CAND if (WLOAD(i).lt.lref) nless=nless+1 end do DMUMPS_LOAD_LESS_CAND = nless return end function DMUMPS_LOAD_LESS_CAND subroutine DMUMPS_LOAD_SET_SLAVES_CAND & (MEM_DISTRIB,CAND, & & SLAVEF, & nslaves_inode, DEST) implicit none integer, intent(in) :: nslaves_inode, SLAVEF integer, intent(in) :: CAND(SLAVEF+1) integer, dimension(0:NPROCS - 1), intent(in) :: MEM_DISTRIB integer, intent(out) :: DEST(CAND(SLAVEF+1)) integer i,j,NMB_OF_CAND external MUMPS_SORT_DOUBLES NMB_OF_CAND = CAND(SLAVEF+1) if(nslaves_inode.ge.NPROCS .or. & nslaves_inode.gt.NMB_OF_CAND) then write(*,*)'Internal error in DMUMPS_LOAD_SET_SLAVES_CAND', & nslaves_inode, NPROCS, NMB_OF_CAND CALL MUMPS_ABORT() end if if (nslaves_inode.eq.NPROCS-1) then j=MYID+1 do i=1,nslaves_inode if(j.ge.NPROCS) j=0 DEST(i)=j j=j+1 end do else do i=1,NMB_OF_CAND IDWLOAD(i)=i end do call MUMPS_SORT_DOUBLES(NMB_OF_CAND, & WLOAD(1),IDWLOAD(1) ) do i=1,nslaves_inode DEST(i)= CAND(IDWLOAD(i)) end do IF(BDC_MD)THEN do i=nslaves_inode+1,NMB_OF_CAND DEST(i)= CAND(IDWLOAD(i)) end do ENDIF end if return end subroutine DMUMPS_LOAD_SET_SLAVES_CAND SUBROUTINE DMUMPS_INIT_ALPHA_BETA(K69) IMPLICIT NONE INTEGER K69 IF (K69 .LE. 4) THEN ALPHA = 0.0d0 BETA = 0.0d0 RETURN ENDIF IF (K69 .EQ. 5) THEN ALPHA = 0.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 6) THEN ALPHA = 0.5d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 7) THEN ALPHA = 0.5d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 8) THEN ALPHA = 1.0d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 9) THEN ALPHA = 1.0d0 BETA = 100000.0d0 RETURN ENDIF IF (K69 .EQ. 10) THEN ALPHA = 1.0d0 BETA = 150000.0d0 RETURN ENDIF IF (K69 .EQ. 11) THEN ALPHA = 1.5d0 BETA = 50000.0d0 RETURN ENDIF IF (K69 .EQ. 12) THEN ALPHA = 1.5d0 BETA = 100000.0d0 RETURN ENDIF ALPHA = 1.5d0 BETA = 150000.0d0 RETURN END SUBROUTINE DMUMPS_INIT_ALPHA_BETA SUBROUTINE DMUMPS_ARCHGENWLOAD(MEM_DISTRIB,MSG_SIZE,ARRAY_ADM,LEN) IMPLICIT NONE INTEGER i,LEN INTEGER, DIMENSION(0:NPROCS-1) :: MEM_DISTRIB DOUBLE PRECISION MSG_SIZE,FORBIGMSG INTEGER ARRAY_ADM(LEN) DOUBLE PRECISION MY_LOAD FORBIGMSG = 1.0d0 IF (K69 .lt.2) THEN RETURN ENDIF IF(BDC_M2_FLOPS)THEN MY_LOAD=LOAD_FLOPS(MYID)+NIV2(MYID+1) ELSE MY_LOAD=LOAD_FLOPS(MYID) ENDIF IF((MSG_SIZE * dble(K35) ) .gt. 3200000.0d0) THEN FORBIGMSG = 2.0d0 ENDIF IF (K69 .le. 4) THEN DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i)/MY_LOAD ELSE IF ( MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1 ) THEN WLOAD(i) = WLOAD(i) * & dble(MEM_DISTRIB(ARRAY_ADM(i))) & * FORBIGMSG & + dble(2) ENDIF ENDIF ENDDO RETURN ENDIF DO i = 1,LEN IF ((MEM_DISTRIB(ARRAY_ADM(i)) .EQ. 1) .AND. & WLOAD(i) .LT. MY_LOAD ) THEN WLOAD(i) = WLOAD(i) / MY_LOAD ELSE IF(MEM_DISTRIB(ARRAY_ADM(i)) .NE. 1) THEN WLOAD(i) = (WLOAD(i) + & ALPHA * MSG_SIZE * dble(K35) + & BETA) * FORBIGMSG ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ARCHGENWLOAD SUBROUTINE DMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, NSLAVES,INODE) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: MYID, SLAVEF, COMM, NASS, NSLAVES INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES( NSLAVES ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER NCB, NFRONT, NBROWS_SLAVE INTEGER i, IERR,WHAT,INODE, allocok LOGICAL :: EXIT_FLAG DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: FLOPS_INCREMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: CB_BAND ALLOCATE(MEM_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of MEM_INCREMENT ' & // 'in routine DMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(FLOPS_INCREMENT(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of FLOPS_INCREMENT ' & // 'in routine DMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif ALLOCATE(CB_BAND(NSLAVES), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of CB_BAND ' & // 'in routine DMUMPS_LOAD_MASTER_2_ALL' CALL MUMPS_ABORT() endif IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN WHAT=1 ELSE WHAT=19 ENDIF FUTURE_NIV2(MYID+1) = FUTURE_NIV2(MYID+1) - 1 IF ( FUTURE_NIV2(MYID+1) < 0 ) THEN WRITE(*,*) "Internal error in DMUMPS_LOAD_MASTER_2_ALL" CALL MUMPS_ABORT() ENDIF IF ( FUTURE_NIV2(MYID + 1) == 0 ) THEN 112 CONTINUE CALL DMUMPS_BUF_SEND_NOT_MSTR(COMM,MYID,SLAVEF, & dble(MAX_SURF_MASTER),KEEP,IERR) IF (IERR == -1 ) THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF TAB_MAXS(MYID) = TAB_MAXS(MYID) + int(MAX_SURF_MASTER,8) ENDIF IF ( NSLAVES /= TAB_POS(SLAVEF + 2) ) THEN write(*,*) "Error 1 in DMUMPS_LOAD_MASTER_2_ALL", & NSLAVES, TAB_POS(SLAVEF+2) CALL MUMPS_ABORT() ENDIF NCB = TAB_POS(NSLAVES+1) - 1 NFRONT = NCB + NASS DO i = 1, NSLAVES NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) IF ( KEEP(50) == 0 ) THEN FLOPS_INCREMENT( i ) = (dble(NBROWS_SLAVE)*dble( NASS ))+ & dble(NBROWS_SLAVE) * dble(NASS) * & dble(2*NFRONT-NASS-1) ELSE FLOPS_INCREMENT( i ) = dble(NBROWS_SLAVE) * dble(NASS ) * & dble( 2 * ( NASS + TAB_POS(i+1) - 1 ) & - NBROWS_SLAVE - NASS + 1 ) ENDIF IF ( BDC_MEM ) THEN IF ( KEEP(50) == 0 ) THEN MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT) ELSE MEM_INCREMENT( i ) = dble(NBROWS_SLAVE) * & dble( NASS + TAB_POS(i+1) - 1 ) END IF ENDIF IF((KEEP(81).NE.2).AND.(KEEP(81).NE.3))THEN CB_BAND(i)=dble(-999999) ELSE IF ( KEEP(50) == 0 ) THEN CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(NFRONT-NASS) ELSE CB_BAND( i ) = dble(NBROWS_SLAVE) * & dble(TAB_POS(i+1)-1) END IF ENDIF END DO IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=NSLAVES CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 DO i=1,NSLAVES CB_COST_MEM(POS_MEM)=int(LIST_SLAVES(i),8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(CB_BAND(i),8) POS_MEM=POS_MEM+1 ENDDO ENDIF 111 CONTINUE CALL DMUMPS_BUF_BCAST_ARRAY(BDC_MEM, COMM, MYID, SLAVEF, & FUTURE_NIV2, & NSLAVES, LIST_SLAVES,INODE, & MEM_INCREMENT, & FLOPS_INCREMENT,CB_BAND, WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_MASTER_2_ALL", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NSLAVES LOAD_FLOPS(LIST_SLAVES(i)) = LOAD_FLOPS(LIST_SLAVES(i)) & + FLOPS_INCREMENT(i) IF ( BDC_MEM ) THEN DM_MEM(LIST_SLAVES(i)) = DM_MEM(LIST_SLAVES(i)) & + MEM_INCREMENT(i) END IF ENDDO ENDIF 100 CONTINUE DEALLOCATE(MEM_INCREMENT,FLOPS_INCREMENT,CB_BAND) RETURN END SUBROUTINE DMUMPS_LOAD_MASTER_2_ALL SUBROUTINE DMUMPS_LOAD_POOL_UPD_NEW_POOL( & POOL, LPOOL, & PROCNODE, KEEP,KEEP8, SLAVEF, COMM, MYID, STEP, N, & ND, FILS ) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL, SLAVEF, COMM, MYID INTEGER N, KEEP(500) INTEGER(8) KEEP8(150) INTEGER POOL( LPOOL ), PROCNODE( KEEP(28) ), STEP( N ) INTEGER ND( KEEP(28) ), FILS( N ) INTEGER i, INODE, NELIM, NFR, LEVEL, IERR, WHAT DOUBLE PRECISION COST LOGICAL :: EXIT_FLAG INTEGER NBINSUBTREE,NBTOP,INSUBTREE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF(BDC_MD)THEN RETURN ENDIF IF((KEEP(76).EQ.0).OR.(KEEP(76).EQ.2))THEN IF(NBTOP.NE.0)THEN DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE IF(KEEP(76).EQ.1)THEN IF(INSUBTREE.EQ.1)THEN DO i = NBINSUBTREE, max(1,NBINSUBTREE-3), -1 INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ELSE DO i = LPOOL-NBTOP-2, min(LPOOL-3,LPOOL-NBTOP-2+3) INODE = POOL( i ) IF (INODE .LE. N .AND. INODE .GE. 1 ) THEN GOTO 20 END IF END DO COST=dble(0) GOTO 30 ENDIF ELSE WRITE(*,*) & 'Internal error: Unknown pool management strategy' CALL MUMPS_ABORT() ENDIF ENDIF 20 CONTINUE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS(i) GOTO 10 ENDIF NFR = ND( STEP(INODE) ) LEVEL = MUMPS_TYPENODE( PROCNODE(STEP(INODE)), KEEP(199) ) IF (LEVEL .EQ. 1) THEN COST = dble( NFR ) * dble( NFR ) ELSE IF ( KEEP(50) == 0 ) THEN COST = dble( NFR ) * dble( NELIM ) ELSE COST = dble( NELIM ) * dble( NELIM ) ENDIF ENDIF 30 CONTINUE IF ( abs(POOL_LAST_COST_SENT-COST).GT.DM_THRES_MEM ) THEN WHAT = 2 111 CONTINUE CALL DMUMPS_BUF_BROADCAST( WHAT, & COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) POOL_LAST_COST_SENT = COST POOL_MEM(MYID)=COST IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_POOL_UPD_NEW_POOL SUBROUTINE DMUMPS_LOAD_SBTR_UPD_NEW_POOL( & OK,INODE,POOL,LPOOL,MYID,SLAVEF,COMM,KEEP,KEEP8) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER LPOOL,MYID,SLAVEF,COMM,INODE INTEGER POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER WHAT,IERR LOGICAL OK DOUBLE PRECISION COST LOGICAL FLAG, EXIT_FLAG EXTERNAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_ROOTSSARBR,MUMPS_IN_OR_ROOT_SSARBR IF((INODE.LE.0).OR.(INODE.GT.N_LOAD)) THEN RETURN ENDIF IF (.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_LOAD(STEP_LOAD(INODE)), KEEP(199)) & ) THEN RETURN ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)))THEN IF(NE_LOAD(STEP_LOAD(INODE)).EQ.0)THEN RETURN ENDIF ENDIF FLAG=.FALSE. IF(INDICE_SBTR.LE.NB_SUBTREES)THEN IF(INODE.EQ.MY_FIRST_LEAF(INDICE_SBTR))THEN FLAG=.TRUE. ENDIF ENDIF IF(FLAG)THEN SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY)=MEM_SUBTREE(INDICE_SBTR) SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY)=SBTR_CUR(MYID) INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY+1 WHAT = 3 IF(dble(MEM_SUBTREE(INDICE_SBTR)).GE.DM_THRES_MEM)THEN 111 CONTINUE CALL DMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & dble(MEM_SUBTREE(INDICE_SBTR)), dble(0), & MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 1 in DMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF SBTR_MEM(MYID)=SBTR_MEM(MYID)+ & dble(MEM_SUBTREE(INDICE_SBTR)) INDICE_SBTR=INDICE_SBTR+1 IF(INSIDE_SUBTREE.EQ.0)THEN INSIDE_SUBTREE=1 ENDIF ELSE IF(INODE.EQ.MY_ROOT_SBTR(INDICE_SBTR-1))THEN WHAT = 3 COST=-SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY-1) IF(abs(COST).GE.DM_THRES_MEM)THEN 112 CONTINUE CALL DMUMPS_BUF_BROADCAST( & WHAT, COMM, SLAVEF, & FUTURE_NIV2, & COST, dble(0), MYID, KEEP, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN ELSE GOTO 112 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) & "Internal Error 3 in DMUMPS_LOAD_SBTR_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF ENDIF INDICE_SBTR_ARRAY=INDICE_SBTR_ARRAY-1 SBTR_MEM(MYID)=SBTR_MEM(MYID)- & SBTR_PEAK_ARRAY(INDICE_SBTR_ARRAY) SBTR_CUR(MYID)=SBTR_CUR_ARRAY(INDICE_SBTR_ARRAY) IF(INDICE_SBTR_ARRAY.EQ.1)THEN SBTR_CUR(MYID)=dble(0) INSIDE_SUBTREE=0 ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_LOAD_SBTR_UPD_NEW_POOL SUBROUTINE DMUMPS_SET_PARTI_ACTV_MEM & (SLAVEF,KEEP,KEEP8,PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1) INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47, K48, K50 INTEGER(8) :: K821 DOUBLE PRECISION DK821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS INTEGER(8)::TOTAL_MEM LOGICAL FORCE_CAND DOUBLE PRECISION TEMP(SLAVEF),PEAK INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME IF (KEEP8(21) .GT. 0_8) THEN write(*,*)MYID, & ": Internal Error 1 in DMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF K821=abs(KEEP8(21)) DK821=dble(K821) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF IF(K48.NE.4)THEN WRITE(*,*)'DMUMPS_COMPUTE_PARTI_ACTV_MEM_K821 & should be called with KEEP(48) different from 4' CALL MUMPS_ABORT() ENDIF KMIN=1 KMAX=int(K821/int(NFRONT,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=DM_MEM(PROCS(i)) IDWLOAD(i)=PROCS(i) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = DM_MEM(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) TOTAL_MEM=int(NCB,8)*int(NFRONT,8) SOMME=dble(0) J=1 PEAK=dble(0) DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN PEAK=max(PEAK,WLOAD(i)) TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_SBTR)THEN TEMP(J)=TEMP(J)+SBTR_MEM(IDWLOAD(i))- & SBTR_CUR(IDWLOAD(i)) ENDIF IF(BDC_POOL)THEN TEMP(J)=TEMP(J)+POOL_MEM(TEMP_ID(J)) ENDIF IF(BDC_M2_MEM)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) IF(K50.EQ.0)THEN PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT)*dble(NFRONT-NCB)) ELSE PEAK=max(PEAK, & DM_MEM(MYID)+dble(NFRONT-NCB)*dble(NFRONT-NCB)) ENDIF PEAK=max(PEAK,TEMP(OTHERS)) SOMME=dble(0) DO i=1,NUMBER_OF_PROCS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(SOMME.LE.dble(TOTAL_MEM)) THEN GOTO 096 ENDIF 096 CONTINUE SOMME=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) ENDDO IF(dble(TOTAL_MEM).GE.SOMME) THEN AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,OTHERS IF(K50.EQ.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(OTHERS)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(OTHERS)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC IF(X.LE.0) THEN WRITE(*,*)"Internal Error 2 in & DMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 111 IF(NCB.EQ.ACC) GOTO 111 ENDDO 111 CONTINUE IF((ACC.GT.NCB))THEN X=0 DO i=1,OTHERS X=X+NB_ROWS(i) ENDDO WRITE(*,*)'NCB=',NCB,',SOMME=',X WRITE(*,*)MYID, & ": Internal Error 3 in DMUMPS_SET_PARTI_ACTV_MEM" CALL MUMPS_ABORT() ENDIF IF((NCB.NE.ACC))THEN IF(K50.NE.0)THEN IF(CHOSEN.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+ADDITIONNAL_ROWS ELSE TMP_SUM=dble(TOTAL_MEM)/dble(NUMBER_OF_PROCS) CHOSEN=0 ACC=0 DO i=1,OTHERS X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB-ACC.LT.KMIN) GOTO 002 IF(NCB.EQ.ACC) GOTO 002 ENDDO 002 CONTINUE IF(ACC.LT.NCB)THEN NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+(NCB-ACC) ENDIF ENDIF GOTO 333 ENDIF ADDITIONNAL_ROWS=NCB-ACC DO i=CHOSEN,1,-1 IF(int(dble(ADDITIONNAL_ROWS)/ & dble(i)).NE.0)THEN GOTO 222 ENDIF ENDDO 222 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(i)) DO J=1,i NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDDO IF(ADDITIONNAL_ROWS.NE.0) THEN NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 333 CONTINUE IF(NB_ROWS(CHOSEN).EQ.0) CHOSEN=CHOSEN-1 GOTO 889 ELSE DO i=OTHERS,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(dble(TOTAL_MEM).GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i DO J=1,i IF(TEMP(J).EQ.TEMP(i)) THEN SMALL_SET=J GOTO 123 ENDIF ENDDO 123 CONTINUE IF(i.EQ.1)THEN NB_ROWS(i)=NCB CHOSEN=1 GOTO 666 ENDIF 323 CONTINUE AFFECTED=0 CHOSEN=0 ACC=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int(TMP_SUM/dble(NFRONT)) IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN IF((TEMP(SMALL_SET)-TEMP(i)).GT.DK821)THEN TMP_SUM=DK821 ELSE TMP_SUM=TEMP(SMALL_SET)-TEMP(i) ENDIF X=int((-dble(NFRONT-NCB+ACC) & +sqrt(((dble(NFRONT-NCB+ACC)* & dble(NFRONT-NCB+ACC))+dble(4)* & (TMP_SUM))))/ & dble(2)) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 4 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 5 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ':Internal error 6 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LT.OTHERS)THEN SMALL_SET=REF+1 REF=SMALL_SET GOTO 323 ELSE NB_ROWS(CHOSEN)=NB_ROWS(CHOSEN)+NCB-ACC GOTO 666 ENDIF ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 X=int(ADDITIONNAL_ROWS/(i-1)) IF((X.EQ.0).AND.(ADDITIONNAL_ROWS.NE.0))THEN DO WHILE ((J.LT.i).AND.(ADDITIONNAL_ROWS.GT.0)) NB_ROWS(J)=NB_ROWS(J)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 J=J+1 ENDDO IF(ADDITIONNAL_ROWS.NE.0)THEN WRITE(*,*)MYID, & ':Internal error 7 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF GOTO 047 ENDIF IF((TEMP(1)+dble((NB_ROWS(1)+X)*NFRONT)).LE. & TEMP(i))THEN DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=X IF((AFFECTED+NB_ROWS(J)).GT. & KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED J=J+1 ENDDO ELSE DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))*dble(NFRONT)))) & /dble(NFRONT)) IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO ENDIF i=i+1 ENDDO 047 CONTINUE IF((ADDITIONNAL_ROWS.EQ.0).AND. & (i.LT.NUMBER_OF_PROCS))THEN CHOSEN=i-1 ELSE CHOSEN=i-2 ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LE.i)) AFFECTED=int((TEMP(i)-(TEMP(J)+ & (dble(NB_ROWS(J))* & dble(NFRONT))))/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED J=J+1 ENDDO i=i+1 ENDDO CHOSEN=i-2 ENDIF CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN IF(K50.NE.0) THEN IF((TEMP(i)+dble(NB_ROWS(i)) & *dble(X+NB_ROWS(i)+NFRONT-NCB)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF IF(K50.EQ.0) THEN IF((TEMP(i)+dble(NB_ROWS(i))*dble(NFRONT)) & .GT.PEAK)THEN SMALL_SET=SMALL_SET+1 ENDIF ENDIF X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO ENDIF 889 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN IF(X.EQ.1)THEN WRITE(*,*)MYID, & ':Internal error 12 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*) & 'Internal error 13 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 DO i=1,CHOSEN SLAVES_LIST(i)=TEMP_ID(i) TAB_POS(i)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*) & 'Internal error 14 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF ENDDO DO i=CHOSEN+1,NUMBER_OF_PROCS SLAVES_LIST(i)=TEMP_ID(i) ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*) & 'Internal error 15 in DMUMPS_SET_PARTI_ACTV_MEM' CALL MUMPS_ABORT() ENDIF END SUBROUTINE DMUMPS_SET_PARTI_ACTV_MEM SUBROUTINE DMUMPS_SET_PARTI_FLOP_IRR & (NCBSON_MAX,SLAVEF,KEEP,KEEP8, & PROCS,MEM_DISTRIB,NCB,NFRONT, & NSLAVES_NODE,TAB_POS, & SLAVES_LIST,SIZE_SLAVES_LIST,MYID,INODE,MP,LP) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: NCBSON_MAX INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(in) :: MP,LP INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE INTEGER NUMBER_OF_PROCS,K47,K48, K50,K83,K69 INTEGER(8) :: K821 INTEGER J INTEGER KMIN, KMAX INTEGER OTHERS,CHOSEN,SMALL_SET,ACC DOUBLE PRECISION SOMME,TMP_SUM,DELTA,A,B,C,MASTER_WORK INTEGER AFFECTED INTEGER ADDITIONNAL_ROWS,i,X,REF,POS,NELIM INTEGER(8) X8 LOGICAL FORCE_CAND,SMP DOUBLE PRECISION BANDE_K821 INTEGER NB_SAT,NB_ZERO DOUBLE PRECISION TEMP(SLAVEF),TOTAL_COST, MAX_MEM_ALLOW INTEGER TEMP_ID(SLAVEF),NB_ROWS(SLAVEF) INTEGER NSLAVES_REF,NCB_FILS EXTERNAL MPI_WTIME,MUMPS_GETKMIN INTEGER MUMPS_GETKMIN INTEGER POS_MIN_LOAD,SIZE_MY_SMP,WHAT,ADDITIONNAL_ROWS_SPECIAL LOGICAL HAVE_TYPE1_SON DOUBLE PRECISION MIN_LOAD,MAX_LOAD,TEMP_MAX_LOAD DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION BUF_SIZE,NELIM_MEM_SIZE DOUBLE PRECISION MEM_SIZE_STRONG(SLAVEF),MEM_SIZE_WEAK(SLAVEF) K821=abs(KEEP8(21)) TEMP_MAX_LOAD=dble(0) K50=KEEP(50) K48=KEEP(48) K47=KEEP(47) K83=KEEP(83) K69=0 NCB_FILS=NCBSON_MAX IF(int(NCB_FILS,8)*int(min(NCB,NCB_FILS),8).GT.K821)THEN HAVE_TYPE1_SON=.TRUE. ELSE HAVE_TYPE1_SON=.FALSE. ENDIF SMP=(K69.NE.0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF NELIM=NFRONT-NCB KMAX=int(K821/int(NCB,8)) IF(FORCE_CAND)THEN DO i=1,PROCS(SLAVEF+1) WLOAD(i)=LOAD_FLOPS(PROCS(i)) IDWLOAD(i)=PROCS(i) WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO NUMBER_OF_PROCS=PROCS(SLAVEF+1) OTHERS=NUMBER_OF_PROCS ELSE NUMBER_OF_PROCS=SLAVEF WLOAD(1:SLAVEF) = LOAD_FLOPS(0:NUMBER_OF_PROCS-1) DO i=1,NUMBER_OF_PROCS IDWLOAD(i) = i - 1 IF (WLOAD(i) < -0.5d0 ) THEN IF((MP.GT.0).AND.(LP.GE.2))THEN WRITE(MP,*)MYID,': Negative load ', & WLOAD(i) ENDIF ENDIF WLOAD(i)=max(WLOAD(i),0.0d0) ENDDO OTHERS=NUMBER_OF_PROCS-1 ENDIF KMAX=int(NCB/OTHERS) KMIN=MUMPS_GETKMIN(int(NCB,8)*int(KMAX,8),K50,KMAX,NCB) NB_ROWS=0 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, IDWLOAD) IF(K50.EQ.0)THEN TOTAL_COST=dble( NELIM ) * dble ( NCB ) + & dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE TOTAL_COST=dble(NELIM) * dble ( NCB ) * & dble(NFRONT+1) ENDIF CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM,K50, & 2,MASTER_WORK) SOMME=dble(0) J=1 IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.GT.K83))THEN MASTER_WORK=dble(KEEP(88))*MASTER_WORK/dble(100) ENDIF IF(FORCE_CAND.AND.(NUMBER_OF_PROCS.LE.K83))THEN MASTER_WORK=dble(KEEP(87))*MASTER_WORK/dble(100) ENDIF IF(MASTER_WORK.LT.dble(1))THEN MASTER_WORK=dble(1) ENDIF NSLAVES_REF=int(TOTAL_COST/MASTER_WORK)+1 IF(FORCE_CAND)THEN NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS) ELSE NSLAVES_REF=min(NSLAVES_REF,NUMBER_OF_PROCS-1) ENDIF DO i=1,NUMBER_OF_PROCS IF((IDWLOAD(i).NE.MYID))THEN TEMP_ID(J)=IDWLOAD(i) TEMP(J)=WLOAD(i) IF(BDC_M2_FLOPS)THEN TEMP(J)=TEMP(J)+NIV2(TEMP_ID(J)+1) ENDIF J=J+1 ENDIF ENDDO NUMBER_OF_PROCS=J-1 CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, TEMP, TEMP_ID) SOMME=dble(0) TMP_SUM=dble(0) DO i=1,OTHERS SOMME=SOMME+TEMP(OTHERS)-TEMP(i) TMP_SUM=TMP_SUM+TEMP(i) ENDDO TMP_SUM=(TMP_SUM/dble(OTHERS))+ & (TOTAL_COST/dble(OTHERS)) SIZE_MY_SMP=OTHERS MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 IF(.NOT.SMP) MAX_LOAD=TEMP(OTHERS) IF(SMP)THEN J=1 DO i=1,OTHERS IF(MEM_DISTRIB(TEMP_ID(i)).EQ.1)THEN IF(TEMP(i).LE.TMP_SUM)THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ELSE ENDIF ENDIF ENDDO MAX_LOAD=WLOAD(J-1) SIZE_MY_SMP=J-1 DO i=1,OTHERS IF((MEM_DISTRIB(TEMP_ID(i)).NE.1).OR. & ((MEM_DISTRIB(TEMP_ID(i)).EQ.1).AND. & (TEMP(i).GE.TMP_SUM)))THEN WLOAD(J)=TEMP(i) IDWLOAD(J)=TEMP_ID(i) J=J+1 ENDIF ENDDO TEMP=WLOAD TEMP_ID=IDWLOAD ENDIF IF(BDC_MD)THEN BUF_SIZE=dble(K821) IF (KEEP(201).EQ.2) THEN A=dble(int((dble(KEEP(100))/dble(2))/dble(NELIM))) IF(K50.EQ.0)THEN BUF_SIZE=min(BUF_SIZE,A*dble(NCB)) ELSE BUF_SIZE=min(BUF_SIZE,A*A) ENDIF ENDIF BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS A=dble(MD_MEM(TEMP_ID(i)))/ & dble(NELIM) A=A*dble(NFRONT) IF(K50.EQ.0)THEN B=dble(int(dble(NCB)/dble(NUMBER_OF_PROCS))+1)* & dble(NFRONT) ELSE WHAT = 5 CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, NCB, & NFRONT, min(NCB,OTHERS), J, X8) B=dble(X8)+(dble(J)*dble(NELIM)) ENDIF NELIM_MEM_SIZE=A+B MEM_SIZE_WEAK(i)=NELIM_MEM_SIZE IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF IF(min(MEM_SIZE_STRONG(i),MEM_SIZE_WEAK(i)).LT.dble(0))THEN IF(MEM_SIZE_STRONG(i).LT.0.0d0)THEN MEM_SIZE_STRONG(i)=dble(0) ELSE MEM_SIZE_WEAK(i)=dble(0) ENDIF ENDIF ENDDO ELSE BUF_SIZE=dble(K821) DO i=1,NUMBER_OF_PROCS IF((SBTR_WHICH_M.EQ.0).OR.(.NOT.BDC_SBTR))THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i)) ENDIF ELSE IF(BDC_SBTR)THEN IF(BDC_M2_MEM)THEN MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))-NIV2(TEMP_ID(i)+1)- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ELSE MEM_SIZE_STRONG(i)= & dble(TAB_MAXS(TEMP_ID(i)))-DM_MEM(TEMP_ID(i))- & LU_USAGE(TEMP_ID(i))- & (SBTR_MEM(TEMP_ID(i))-SBTR_CUR(TEMP_ID(i))) ENDIF ENDIF ENDIF MEM_SIZE_STRONG(i)=max(dble(0),MEM_SIZE_STRONG(i)) MEM_SIZE_WEAK(i)=huge(MEM_SIZE_WEAK(i)) ENDDO ENDIF IF((((NUMBER_OF_PROCS.LE.K83).AND.FORCE_CAND).AND. & (TOTAL_COST.GE.SOMME)).OR. & (.NOT.FORCE_CAND).OR. & (((NUMBER_OF_PROCS+1).GT.K83).AND.FORCE_CAND))THEN REF=NSLAVES_REF SMALL_SET=NSLAVES_REF IF(.NOT.SMP)THEN DO i=NSLAVES_REF,1,-1 SOMME=dble(0) DO J=1,i SOMME=SOMME+TEMP(J) ENDDO SOMME=(dble(i)*TEMP(i))-SOMME IF(TOTAL_COST.GE.SOMME) GOTO 444 ENDDO 444 CONTINUE REF=i SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) 450 CONTINUE SOMME=dble(0) DO J=1,X SOMME=SOMME+(TEMP(X)-TEMP(J)) ENDDO IF(SOMME.GT.TOTAL_COST)THEN X=X-1 GOTO 450 ELSE IF(X.LT.SIZE_MY_SMP) THEN REF=X SMALL_SET=REF MAX_LOAD=TEMP(SMALL_SET) ELSE X=min(SIZE_MY_SMP,NSLAVES_REF) J=X+1 MAX_LOAD=TEMP(X) TMP_SUM=MAX_LOAD DO i=X+1,OTHERS IF(TEMP(i).GT.MAX_LOAD)THEN SOMME=SOMME+(dble(i-1)*(TEMP(i)-MAX_LOAD)) TMP_SUM=MAX_LOAD MAX_LOAD=TEMP(i) ELSE SOMME=SOMME+(MAX_LOAD-TEMP(i)) ENDIF IF(i.EQ.NSLAVES_REF)THEN SMALL_SET=NSLAVES_REF REF=SMALL_SET GOTO 323 ENDIF IF(SOMME.GT.TOTAL_COST)THEN REF=i-1 SMALL_SET=i-1 MAX_LOAD=TMP_SUM GOTO 323 ENDIF ENDDO ENDIF ENDIF ENDIF 323 CONTINUE MAX_LOAD=dble(0) DO i=1,SMALL_SET MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO TEMP_MAX_LOAD=MAX_LOAD NB_ROWS=0 TMP_SUM=dble(0) CHOSEN=0 ACC=0 NB_SAT=0 NB_ZERO=0 DO i=1,SMALL_SET IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) X=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 1 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF NB_ROWS(i)=X ACC=ACC+X CHOSEN=CHOSEN+1 IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF TMP_SUM=MAX_LOAD IF(K50.EQ.0)THEN MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM)* & dble(2*NFRONT-NELIM-1)))) ELSE MAX_LOAD=max(MAX_LOAD, & TEMP(i)+(dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ACC)-NB_ROWS(i) & -NELIM+1)) ENDIF IF(TMP_SUM.LT.MAX_LOAD)THEN ENDIF IF(NCB-ACC.LT.KMIN) GOTO 888 IF(NCB.EQ.ACC) GOTO 888 IF(ACC.GT.NCB) THEN WRITE(*,*)MYID, & ': Internal error 2 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDDO 888 CONTINUE SOMME=dble(0) X=NFRONT-NCB IF((ACC.GT.NCB))THEN WRITE(*,*)MYID, & ': Internal error 3 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC.LT.NCB))THEN IF(K50.NE.0)THEN IF(SMALL_SET.LE.OTHERS)THEN IF((NB_SAT.EQ.SMALL_SET).AND.(SMALL_SET.LT. & NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ADDITIONNAL_ROWS_SPECIAL=NCB-ACC DO i=1,SMALL_SET MAX_LOAD=TEMP_MAX_LOAD ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS-NELIM & +1) SOMME=SOMME/dble(SMALL_SET-NB_SAT) NB_ROWS=0 NB_ZERO=0 ACC=0 CHOSEN=0 NB_SAT=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO J=1,SMALL_SET A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=(dble(NELIM)*dble(NELIM+2*ACC+1)) C=-(MAX_LOAD-TEMP(J)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) X=X+1 IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 4 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE NB_ZERO=NB_ZERO+1 X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN NB_ZERO=NB_ZERO+1 X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X TMP_SUM=MAX_LOAD TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(J)+(dble(NELIM) * & dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(NCB.EQ.ACC) GOTO 666 ENDDO IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF(NB_ZERO.EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF IF((NB_SAT+NB_ZERO).EQ.SMALL_SET)THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE GOTO 434 ENDIF ENDIF ENDDO 434 CONTINUE ADDITIONNAL_ROWS=NCB-ACC IF(ADDITIONNAL_ROWS.NE.0)THEN IF(ADDITIONNAL_ROWS.LT.KMIN)THEN i=CHOSEN J=ACC 436 CONTINUE IF(NB_ROWS(i).NE.0)THEN J=J-NB_ROWS(i) A=dble(1) B=dble(J+2) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(J+2+NELIM) C=-BUF_SIZE+dble(J+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-J) X=NCB-J BANDE_K821=dble(X)*dble(NELIM+J+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(J+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(NB_ROWS(i).NE.KMAX)THEN IF(NCB-J.LE.KMAX)THEN NB_ROWS(i)=+NCB-J ADDITIONNAL_ROWS=0 ENDIF ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD, & TEMP(i)+ & (dble(NELIM) * dble(NB_ROWS(i)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(i) & -NELIM+1)) IF(REF.LE.NUMBER_OF_PROCS-1)THEN IF(TEMP_MAX_LOAD.GT.TEMP(REF+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF ELSE i=i-1 IF(i.NE.0)GOTO 436 ENDIF IF(ADDITIONNAL_ROWS.NE.0)THEN i=CHOSEN IF(i.NE.SMALL_SET)THEN i=i+1 IF(NB_ROWS(i).NE.0)THEN WRITE(*,*)MYID, & ': Internal error 5 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF CHOSEN=i ENDIF ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.KMIN)THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X ACC=ACC+X ADDITIONNAL_ROWS=NCB-ACC ELSE IF((TEMP(i).GT.MAX_LOAD))THEN MAX_LOAD=TEMP(i) NB_SAT=0 ACC=0 NB_ROWS=0 DO J=1,i A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(J)) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 6 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX NB_SAT=NB_SAT+1 ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=0 ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(J)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(J))THEN MIN_LOAD=TEMP(J) POS_MIN_LOAD=i ENDIF ENDIF ACC=ACC+X MAX_LOAD=max(MAX_LOAD, & TEMP(J)+ & (dble(NELIM)*dble(NB_ROWS(J)))* & dble(2*(NELIM+ & ACC)-NB_ROWS(J) & -NELIM+1)) IF(NCB.EQ.ACC) GOTO 741 IF(NCB-ACC.LT.KMIN) GOTO 210 ENDDO 210 CONTINUE ENDIF 741 CONTINUE i=i+1 ADDITIONNAL_ROWS=NCB-ACC ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)*dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 7 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GE.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LT.min(KMIN,KMAX))THEN X=min(KMAX,KMIN) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 488 ENDDO 488 CONTINUE ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS) NB_ROWS=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) C=-(MAX_LOAD-TEMP(i)+SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 8 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=KMIN ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC NB_ROWS(i)=X IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 ACC=ACC+X IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 477 ENDDO 477 CONTINUE IF(ACC.NE.NCB)THEN NB_SAT=0 ACC=0 CHOSEN=0 IF(SMP)THEN MIN_LOAD=TEMP(1) POS_MIN_LOAD=1 ENDIF DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN NB_SAT=NB_SAT+1 ENDIF ACC=ACC+NB_ROWS(i) IF(SMP)THEN IF(MIN_LOAD.GT.TEMP(i))THEN MIN_LOAD=TEMP(i) POS_MIN_LOAD=i ENDIF ENDIF CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 666 IF(NCB-ACC.LT.KMIN) GOTO 834 ENDDO 834 CONTINUE ENDIF IF(ACC.NE.NCB)THEN ADDITIONNAL_ROWS=NCB-ACC SOMME=dble(NELIM)* & dble(ADDITIONNAL_ROWS)* & dble(2*NFRONT-ADDITIONNAL_ROWS- & NELIM+1) SOMME=SOMME/dble(NUMBER_OF_PROCS-NB_SAT) ACC=0 DO i=1,CHOSEN A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF((dble(NB_ROWS(i))* & dble(NB_ROWS(i)+ACC)).EQ. & BANDE_K821)THEN GOTO 102 ENDIF A=dble(NELIM) B=dble(NELIM)* & dble(NELIM+2*(ACC+NB_ROWS(i))+1) C=-(SOMME) DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(1) B=dble(ACC+NELIM) C=dble(-BANDE_K821) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 9 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF((ACC+X+NB_ROWS(i)).GT.NCB)THEN IF((NCB-ACC).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NCB-ACC ENDIF ELSE IF((NB_ROWS(i)+X).GT.KMAX)THEN NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+X ENDIF ENDIF 102 CONTINUE ACC=ACC+NB_ROWS(i) IF(NCB.EQ.ACC) THEN CHOSEN=i GOTO 666 ENDIF IF(NCB-ACC.LT.KMIN) THEN CHOSEN=i GOTO 007 ENDIF ENDDO 007 CONTINUE DO i=1,CHOSEN NB_ROWS(i)=NB_ROWS(i)+1 ACC=ACC+1 IF(ACC.EQ.NCB)GOTO 666 ENDDO IF(ACC.LT.NCB)THEN IF(SMP)THEN NB_ROWS(1)=NB_ROWS(1)+NCB-ACC ELSE NB_ROWS(POS_MIN_LOAD)= & NB_ROWS(POS_MIN_LOAD)+NCB-ACC ENDIF ENDIF ENDIF GOTO 666 ENDIF ENDIF GOTO 666 ENDIF ADDITIONNAL_ROWS=NCB-ACC i=CHOSEN+1 IF(NB_SAT.EQ.SMALL_SET) GOTO 777 DO i=1,SMALL_SET IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & (dble(NFRONT+1))) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF WLOAD(i)=MAX_MEM_ALLOW ENDDO CALL MUMPS_SORT_DOUBLES(SMALL_SET, WLOAD, IDWLOAD) NB_ZERO=0 IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LT.NSLAVES_REF))THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF IF((NB_SAT.EQ.SMALL_SET).AND. & (SMALL_SET.LE.NUMBER_OF_PROCS))GOTO 777 AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) DO i=1,SMALL_SET KMAX=int(WLOAD(i)/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN GOTO 912 ENDIF IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GT.KMAX)THEN IF(NB_ROWS(IDWLOAD(i)).GT.KMAX)THEN ENDIF ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX NB_SAT=NB_SAT+1 IF(NB_SAT.EQ.SMALL_SET)THEN IF(SMALL_SET.NE.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ELSE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM) * & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))* & dble(NELIM))* & dble(2*NFRONT-NELIM-1))) GOTO 777 ENDIF ENDIF AFFECTED=int(ADDITIONNAL_ROWS/(SMALL_SET-NB_SAT)) AFFECTED=max(AFFECTED,1) ELSE IF((NB_ROWS(IDWLOAD(i))+min(AFFECTED, & ADDITIONNAL_ROWS)).GE.KMIN)THEN X=min(AFFECTED,ADDITIONNAL_ROWS) NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE X=int((MAX_LOAD-TEMP(IDWLOAD(i)))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X+AFFECTED.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ELSE X=AFFECTED+X ENDIF IF(X.GE.KMIN)THEN NB_ROWS(IDWLOAD(i))=NB_ROWS(IDWLOAD(i))+ & X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & X ELSE NB_ZERO=NB_ZERO+1 ENDIF ENDIF ENDIF 912 CONTINUE MAX_LOAD=max(MAX_LOAD, & (TEMP(IDWLOAD(i))+(dble(NELIM)* & dble(NB_ROWS(IDWLOAD(i))))+ & (dble(NB_ROWS(IDWLOAD(i)))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(SMALL_SET.LT.NUMBER_OF_PROCS)THEN IF(MAX_LOAD.GT.TEMP(SMALL_SET+1))THEN IF(SMALL_SET.LT.NSLAVES_REF)THEN SMALL_SET=REF+1 REF=REF+1 NB_ROWS=0 GOTO 323 ENDIF ENDIF ENDIF IF(SMALL_SET.EQ.NB_SAT)GOTO 777 IF(ADDITIONNAL_ROWS.EQ.0)THEN CHOSEN=SMALL_SET GOTO 049 ENDIF ENDDO 777 CONTINUE IF((NB_ZERO.NE.0).AND.(ADDITIONNAL_ROWS.GE.KMIN))THEN J=NB_ZERO 732 CONTINUE X=int(ADDITIONNAL_ROWS/(J)) IF(X.LT.KMIN)THEN J=J-1 GOTO 732 ENDIF IF(X*J.LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,SMALL_SET AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(i).EQ.0)THEN IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(X.GT.KMAX)THEN X=KMAX ENDIF IF(X.GT.KMIN)THEN NB_ROWS(i)=X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) ENDIF ENDIF ENDDO ENDIF i=CHOSEN+1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF((TEMP(i).LE.MAX_LOAD))THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) AFFECTED=int((MAX_LOAD-TEMP(i))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF ELSE IF((TEMP(i).GT.MAX_LOAD))THEN IF(NB_SAT.EQ.i-1) GOTO 218 X=(ADDITIONNAL_ROWS/(i-1-NB_SAT)) ACC=1 DO J=1,i-1 TMP_SUM=((dble(NELIM) * dble(NB_ROWS(J)+X)) & +(dble(NB_ROWS(J)+X)*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) IF((TEMP(J)+TMP_SUM).GT.MAX_LOAD)THEN ACC=0 ENDIF ENDDO IF(ACC.EQ.1)THEN MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ELSE MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF TMP_SUM=((dble(NELIM)* dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 10 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF AFFECTED=X MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(J)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(J) NB_SAT=NB_SAT+1 ELSE IF((AFFECTED+NB_ROWS(J)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & AFFECTED ENDIF J=J+1 ENDDO ENDIF ENDIF 218 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF((CHOSEN.EQ.NUMBER_OF_PROCS-1).AND. & (ADDITIONNAL_ROWS.NE.0))THEN DO i=1,CHOSEN IF(NB_ROWS(i)+1.GE.KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+1 ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-1 ENDIF MAX_LOAD=max(MAX_LOAD, & (TEMP(i)+(dble(NELIM) * & dble(NB_ROWS(i)))+ & (dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1))) IF(ADDITIONNAL_ROWS.EQ.0) GOTO 048 ENDDO 048 CONTINUE ENDIF IF((ADDITIONNAL_ROWS.NE.0))THEN IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN i=CHOSEN+1 ELSE IF(CHOSEN.NE.NUMBER_OF_PROCS)THEN WRITE(*,*)MYID, & ': Internal error 11 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF i=CHOSEN ENDIF DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(i.LE.NUMBER_OF_PROCS)) IF(TEMP(i).LE.MAX_LOAD)THEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD-(TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) AFFECTED=X IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 12 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(AFFECTED.GT.ADDITIONNAL_ROWS)THEN AFFECTED=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((AFFECTED+NB_ROWS(i)).GT.KMAX)THEN AFFECTED=KMAX-NB_ROWS(i) ELSE IF((AFFECTED+NB_ROWS(i)).LT. & KMIN)THEN AFFECTED=0 ENDIF ENDIF NB_ROWS(i)=NB_ROWS(i)+AFFECTED ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-AFFECTED ENDIF IF(i.NE.NUMBER_OF_PROCS) GOTO 624 ELSE IF((TEMP(i).GT.MAX_LOAD))THEN X=int(ADDITIONNAL_ROWS/i-1) X=max(X,1) IF((MAX_LOAD+((dble(NELIM)* & dble(X))+(dble( & X)*dble(NELIM))*dble( & (2*NFRONT-NELIM-1)))).LE.TEMP(i))THEN AFFECTED=X POS=1 ELSE POS=0 ENDIF MAX_LOAD=TEMP(i) J=1 DO WHILE ((ADDITIONNAL_ROWS.NE.0) & .AND.(J.LT.i)) X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) MAX_MEM_ALLOW=BANDE_K821 IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(POS.EQ.0)THEN TMP_SUM=((dble(NELIM) * & dble(NB_ROWS(J))) & +(dble(NB_ROWS(J))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((TEMP(i)-(TEMP(J)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT- & NELIM))) ELSE X=int(TMP_SUM) ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(J).LT.KMAX)THEN IF((X+NB_ROWS(J)).GT.KMAX)THEN X=KMAX-NB_ROWS(J) ELSE IF((NB_ROWS(J)+X).LT. & KMIN)THEN X=0 ENDIF ENDIF NB_ROWS(J)=NB_ROWS(J)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ENDIF J=J+1 ENDDO ENDIF 624 CONTINUE i=i+1 ENDDO CHOSEN=i-1 IF(ADDITIONNAL_ROWS.NE.0)THEN ACC=0 DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) X=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.LT.0)THEN WRITE(*,*)MYID, & ': Internal error 13 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GT.ADDITIONNAL_ROWS)THEN X=ADDITIONNAL_ROWS ENDIF IF(NB_ROWS(i).LT.KMAX)THEN IF((X+NB_ROWS(i)).GE.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF((X+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ACC=ACC+1 ELSE ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(CHOSEN.LT.NUMBER_OF_PROCS)THEN CHOSEN=CHOSEN+1 ENDIF IF(ACC.EQ.0)THEN ACC=1 ENDIF X=int(ADDITIONNAL_ROWS/ACC) X=max(X,1) ACC=0 DO i=1,CHOSEN J=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(J)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN J=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(J)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) TMP_SUM=((dble(NELIM) * dble(NB_ROWS(i))) & +(dble(NB_ROWS(i))*dble(NELIM))* & dble(2*NFRONT-NELIM-1)) J=int((MAX_LOAD- & (TEMP(i)+TMP_SUM))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).LT.KMAX)THEN IF((min(X,J)+NB_ROWS(i)).GE.KMAX)THEN IF((KMAX-NB_ROWS(i)).GT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ENDIF ELSE IF((min(X,J)+NB_ROWS(i)).GE. & KMIN)THEN NB_ROWS(i)=NB_ROWS(i)+min(X,J) ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & min(X,J) ACC=ACC+1 ENDIF ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO IF(ACC.GT.0)THEN DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i)), & BANDE_K821) MAX_MEM_ALLOW=max(dble(0), & MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT. & ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE IF(NB_ROWS(i).EQ.0)THEN IF(min(KMIN,KMAX).LT. & ADDITIONNAL_ROWS)THEN NB_ROWS(i)=min(KMIN,KMAX) ADDITIONNAL_ROWS= & ADDITIONNAL_ROWS- & min(KMIN,KMAX) ENDIF ELSE NB_ROWS(i)=NB_ROWS(i)+ & ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO ENDIF DO i=1,CHOSEN IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-dble(NB_ROWS(i)*NFRONT)) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 049 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO i=1,CHOSEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(i)=NB_ROWS(i)+X IF(ADDITIONNAL_ROWS.EQ.0)GOTO 049 ENDDO NB_ROWS(1)=NB_ROWS(1)+ADDITIONNAL_ROWS ENDIF ENDIF 049 CONTINUE ENDIF 666 CONTINUE SOMME=dble(0) X=0 POS=0 DO i=1,CHOSEN X=X+NB_ROWS(i) SOMME=SOMME+ dble(NB_ROWS(i)) ENDDO GOTO 890 ELSE IF((KEEP(83).GE.NUMBER_OF_PROCS).AND.FORCE_CAND)THEN MAX_LOAD=dble(0) DO i=1,OTHERS MAX_LOAD=max(MAX_LOAD,TEMP(i)) ENDDO ACC=0 CHOSEN=0 X=1 DO i=1,OTHERS ENDDO DO i=2,OTHERS IF(TEMP(i).EQ.TEMP(1))THEN X=X+1 ELSE GOTO 329 ENDIF ENDDO 329 CONTINUE TMP_SUM=TOTAL_COST/dble(X) TEMP_MAX_LOAD=dble(0) DO i=1,OTHERS IF(K50.EQ.0)THEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF IF(HAVE_TYPE1_SON)THEN IF(K50.EQ.0)THEN X=int((BUF_SIZE-dble(NFRONT))/dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ELSE A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & min(MEM_SIZE_WEAK(i),MEM_SIZE_STRONG(i))) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF IF(K50.EQ.0)THEN KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN SOMME=MAX_LOAD-TEMP(i) ELSE SOMME=TMP_SUM ENDIF X=int(SOMME/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(X.GT.KMAX)THEN X=KMAX ELSE IF(X.LT.KMIN)THEN X=min(KMIN,KMAX) ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF IF(K50.NE.0)THEN A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) A=dble(NELIM) B=dble(NELIM)*dble(NELIM+2*ACC+1) IF(TMP_SUM+TEMP(i).GT.MAX_LOAD)THEN C=-(MAX_LOAD-TEMP(i)) ELSE C=-TMP_SUM ENDIF DELTA=(B*B-(dble(4)*A*C)) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.LT.0) THEN WRITE(*,*)MYID, & ': Internal error 14 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF IF(X.GE.KMAX)THEN IF(KMAX.GT.KMIN)THEN X=KMAX ELSE X=0 ENDIF ELSE IF(X.LE.min(KMIN,KMAX))THEN IF(KMAX.LT.KMIN)THEN X=0 ELSE X=min(KMIN,KMAX) ENDIF ENDIF ENDIF IF((ACC+X).GT.NCB) X=NCB-ACC ENDIF TEMP_MAX_LOAD=max(TEMP_MAX_LOAD,TEMP(i)) NB_ROWS(i)=X CHOSEN=CHOSEN+1 ACC=ACC+X IF(ACC.EQ.NCB) GOTO 541 ENDDO 541 CONTINUE IF(ACC.LT.NCB)THEN IF(K50.EQ.0)THEN ADDITIONNAL_ROWS=NCB-ACC DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min( & min(MEM_SIZE_WEAK(J),MEM_SIZE_STRONG(J)), & dble(BANDE_K821)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)).LT.KMAX)THEN IF(ADDITIONNAL_ROWS.GT.(KMAX-NB_ROWS(J)))THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE NB_ROWS(J)=NB_ROWS(J)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO X=int(ADDITIONNAL_ROWS/CHOSEN) X=max(X,1) DO J=1,CHOSEN AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(J)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF((NB_ROWS(J)+X).GT.KMAX)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(J)) NB_ROWS(J)=KMAX ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X NB_ROWS(J)=NB_ROWS(J)+X ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,CHOSEN X=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(X)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN X=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(X)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(KMAX-NB_ROWS(i).LT.ADDITIONNAL_ROWS)THEN ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(i)) NB_ROWS(i)=KMAX ELSE NB_ROWS(i)=NB_ROWS(i)+ADDITIONNAL_ROWS ADDITIONNAL_ROWS=0 ENDIF IF(ADDITIONNAL_ROWS.EQ.0)GOTO 889 ENDDO DO i=1,NUMBER_OF_PROCS IDWLOAD(i)=i AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF WLOAD(i)=(BANDE_K821-(dble(NB_ROWS(i))* & dble(NFRONT))) ENDDO CALL MUMPS_SORT_DOUBLES(NUMBER_OF_PROCS, WLOAD, & IDWLOAD) NB_SAT=0 DO i=1,CHOSEN X=int(ADDITIONNAL_ROWS/(CHOSEN-NB_SAT)) X=max(X,1) AFFECTED=int(BUF_SIZE/dble(NCB+1))-1 BANDE_K821=dble(AFFECTED)*dble(NFRONT) IF(HAVE_TYPE1_SON)THEN AFFECTED=int((BUF_SIZE-dble(NFRONT))/ & dble(NFRONT+1)) BANDE_K821=dble(AFFECTED)*dble(NFRONT) ENDIF MAX_MEM_ALLOW=BANDE_K821 KMAX=int(MAX_MEM_ALLOW/dble(NFRONT)) IF(NB_ROWS(IDWLOAD(i)).LT.KMAX)THEN IF((NB_ROWS(IDWLOAD(i))+X).LT.KMAX)THEN NB_ROWS(IDWLOAD(i))= & NB_ROWS(IDWLOAD(i))+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X ELSE ADDITIONNAL_ROWS=ADDITIONNAL_ROWS- & (KMAX-NB_ROWS(IDWLOAD(i))) NB_ROWS(IDWLOAD(i))=KMAX ENDIF ENDIF IF(NB_ROWS(IDWLOAD(i)).EQ.KMAX)THEN NB_SAT=NB_SAT+1 ENDIF IF(ADDITIONNAL_ROWS.EQ.0) GOTO 889 ENDDO GOTO 994 ELSE ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 IF(BDC_MD)THEN MAX_MEM_ALLOW=min(BANDE_K821, & MEM_SIZE_STRONG(i)) MAX_MEM_ALLOW=max(dble(0),MAX_MEM_ALLOW) ENDIF A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC ENDIF ACC=0 CHOSEN=0 DO i=1,OTHERS A=dble(1) B=dble(ACC+2) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) IF(HAVE_TYPE1_SON)THEN A=dble(1) B=dble(ACC+2+NELIM) C=-BUF_SIZE+dble(ACC+NELIM) DELTA=(B*B)-(dble(4)*A*C) X=int((-B+sqrt(DELTA))/(dble(2)*A)) IF(X.GT.NCB-ACC) X=NCB-ACC BANDE_K821=dble(X)*dble(NELIM+ACC+X) ENDIF MAX_MEM_ALLOW=BANDE_K821 A=dble(1) B=dble(ACC+NELIM) C=dble(-MAX_MEM_ALLOW) DELTA=((B*B)-(dble(4)*A*C)) KMAX=int((-B+sqrt(DELTA))/(dble(2)*A)) X=KMAX-NB_ROWS(i) IF((ACC+NB_ROWS(i)+X).GT.NCB) & X=NCB-(ACC+NB_ROWS(i)) NB_ROWS(i)=NB_ROWS(i)+X ACC=ACC+NB_ROWS(i) CHOSEN=CHOSEN+1 IF(NCB.EQ.ACC) GOTO 889 ENDDO ADDITIONNAL_ROWS=NCB-ACC 994 CONTINUE X=int(dble(ADDITIONNAL_ROWS)/dble(OTHERS)) IF((X*OTHERS).LT.ADDITIONNAL_ROWS)THEN X=X+1 ENDIF DO i=1,OTHERS NB_ROWS(i)=NB_ROWS(i)+X ADDITIONNAL_ROWS=ADDITIONNAL_ROWS-X IF(ADDITIONNAL_ROWS.LT.X)X=ADDITIONNAL_ROWS ENDDO CHOSEN=OTHERS ENDIF ENDIF 889 CONTINUE MAX_LOAD=TEMP_MAX_LOAD 890 CONTINUE J=CHOSEN X=0 DO i=J,1,-1 IF(NB_ROWS(i).EQ.0)THEN CHOSEN=CHOSEN-1 ELSE IF(NB_ROWS(i).GT.0)THEN X=1 ELSE WRITE(*,*)MYID, & ': Internal error 15 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF ENDIF ENDDO NSLAVES_NODE=CHOSEN TAB_POS(NSLAVES_NODE+1)= NCB+1 TAB_POS(SLAVEF+2) = CHOSEN POS=1 X=1 DO i=1,J IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(X)=TEMP_ID(i) TAB_POS(X)=POS POS=POS+NB_ROWS(i) IF(NB_ROWS(i).LE.0)THEN WRITE(*,*)MYID, & ': Internal error 16 in DMUMPS_SET_PARTI_FLOP_IRR' CALL MUMPS_ABORT() ENDIF X=X+1 ENDIF ENDDO IF(POS.NE.(NCB+1))THEN WRITE(*,*)MYID, & ': Internal error 17 in DMUMPS_SET_PARTI_FLOP_IRR', & POS,NCB+1 CALL MUMPS_ABORT() ENDIF END SUBROUTINE DMUMPS_SET_PARTI_FLOP_IRR SUBROUTINE DMUMPS_LOAD_POOL_CHECK_MEM & (INODE,UPPER,SLAVEF,KEEP,KEEP8, & STEP,POOL,LPOOL,PROCNODE,N) IMPLICIT NONE INTEGER INODE, LPOOL, SLAVEF, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(KEEP(28)), POOL(LPOOL), PROCNODE(KEEP(28)) LOGICAL UPPER INTEGER J DOUBLE PRECISION MEM_COST INTEGER NBINSUBTREE,i,NBTOP EXTERNAL DMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR LOGICAL DMUMPS_POOL_EMPTY, & MUMPS_IN_OR_ROOT_SSARBR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) IF(KEEP(47).LT.2)THEN WRITE(*,*)'DMUMPS_LOAD_POOL_CHECK_MEM must & be called with K47>=2' CALL MUMPS_ABORT() ENDIF IF((INODE.GT.0).AND.(INODE.LE.N))THEN MEM_COST=DMUMPS_LOAD_GET_MEM(INODE) IF((DM_MEM(MYID)+dble(MEM_COST)+ PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL) & .GT.MAX_PEAK_STK)THEN DO i=NBTOP-1,1,-1 INODE = POOL( LPOOL - 2 - i) MEM_COST=DMUMPS_LOAD_GET_MEM(INODE) IF((INODE.LT.0).OR.(INODE.GT.N)) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF IF((DM_MEM(MYID)+dble(MEM_COST)+PEAK_SBTR_CUR_LOCAL- & SBTR_CUR_LOCAL).LE. & MAX_PEAK_STK) THEN DO J=i+1,NBTOP,-1 POOL(J-1)=POOL(J) ENDDO UPPER=.TRUE. RETURN ENDIF ENDDO IF(NBINSUBTREE.NE.0)THEN INODE = POOL( NBINSUBTREE ) IF(.NOT.MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)))THEN WRITE(*,*) & 'Internal error 1 in DMUMPS_LOAD_POOL_CHECK_MEM' CALL MUMPS_ABORT() ENDIF UPPER=.FALSE. RETURN ENDIF INODE=POOL(LPOOL-2-NBTOP) UPPER=.TRUE. RETURN ENDIF ENDIF UPPER=.TRUE. END SUBROUTINE DMUMPS_LOAD_POOL_CHECK_MEM SUBROUTINE DMUMPS_LOAD_SET_SBTR_MEM(WHAT) IMPLICIT NONE LOGICAL WHAT IF(.NOT.BDC_POOL_MNG)THEN WRITE(*,*)'DMUMPS_LOAD_SET_SBTR_MEM & should be called when K81>0 and K47>2' ENDIF IF(WHAT)THEN PEAK_SBTR_CUR_LOCAL=PEAK_SBTR_CUR_LOCAL+ & dble(MEM_SUBTREE(INDICE_SBTR)) IF(.NOT.BDC_SBTR) INDICE_SBTR=INDICE_SBTR+1 ELSE PEAK_SBTR_CUR_LOCAL=dble(0) SBTR_CUR_LOCAL=dble(0) ENDIF END SUBROUTINE DMUMPS_LOAD_SET_SBTR_MEM DOUBLE PRECISION FUNCTION DMUMPS_LOAD_GET_MEM( INODE ) IMPLICIT NONE INTEGER INODE,LEVEL,i,NELIM,NFR DOUBLE PRECISION COST EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFR = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) IF (LEVEL .EQ. 1) THEN COST = dble(NFR) * dble(NFR) ELSE IF ( K50 == 0 ) THEN COST = dble(NFR) * dble(NELIM) ELSE COST = dble(NELIM) * dble(NELIM) ENDIF ENDIF DMUMPS_LOAD_GET_MEM=COST RETURN END FUNCTION DMUMPS_LOAD_GET_MEM RECURSIVE SUBROUTINE DMUMPS_NEXT_NODE(FLAG,COST,COMM) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER COMM,WHAT,IERR LOGICAL FLAG, EXIT_FLAG DOUBLE PRECISION COST DOUBLE PRECISION TO_BE_SENT EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF(FLAG)THEN WHAT=17 IF(BDC_M2_FLOPS)THEN TO_BE_SENT=DELTA_LOAD-COST DELTA_LOAD=dble(0) ELSE IF(BDC_M2_MEM)THEN IF(BDC_POOL.AND.(.NOT.BDC_MD))THEN TO_BE_SENT=max(TMP_M2,POOL_LAST_COST_SENT) POOL_LAST_COST_SENT=TO_BE_SENT ELSE IF(BDC_MD)THEN DELTA_MEM=DELTA_MEM+TMP_M2 TO_BE_SENT=DELTA_MEM ELSE TO_BE_SENT=dble(0) ENDIF ENDIF ELSE WHAT=6 TO_BE_SENT=dble(0) ENDIF 111 CONTINUE CALL DMUMPS_BUF_BROADCAST( WHAT, & COMM, NPROCS, & FUTURE_NIV2, & COST, & TO_BE_SENT, & MYID, KEEP_LOAD, IERR ) IF ( IERR == -1 )THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_LOAD_POOL_UPD_NEW_POOL", & IERR CALL MUMPS_ABORT() ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_NEXT_NODE SUBROUTINE DMUMPS_UPPER_PREDICT(INODE,STEP,NSTEPS,PROCNODE,FRERE, & NE,COMM,SLAVEF,MYID,KEEP,KEEP8,N) USE DMUMPS_BUF IMPLICIT NONE INTEGER INODE,NSTEPS,MYID,SLAVEF,COMM,N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE(NSTEPS),NE(NSTEPS),STEP(N),PROCNODE(NSTEPS) EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_PROCNODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR INTEGER i,NCB,NELIM INTEGER MUMPS_PROCNODE INTEGER FATHER_NODE,FATHER,WHAT,IERR EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE LOGICAL :: EXIT_FLAG IF((.NOT.BDC_M2_MEM).AND.(.NOT.BDC_M2_FLOPS))THEN WRITE(*,*)MYID,': Problem in DMUMPS_UPPER_PREDICT' CALL MUMPS_ABORT() ENDIF IF((INODE.LT.0).OR.(INODE.GT.N)) THEN RETURN ENDIF i=INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NCB=ND_LOAD(STEP_LOAD(INODE))-NELIM + KEEP_LOAD(253) WHAT=5 FATHER_NODE=DAD_LOAD(STEP_LOAD(INODE)) IF (FATHER_NODE.EQ.0) THEN RETURN ENDIF IF((FRERE(STEP(FATHER_NODE)).EQ.0).AND. & ((FATHER_NODE.EQ.KEEP(38)).OR. & (FATHER_NODE.EQ.KEEP(20))))THEN RETURN ENDIF IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(FATHER_NODE)), & KEEP(199))) THEN RETURN ENDIF FATHER=MUMPS_PROCNODE(PROCNODE(STEP(FATHER_NODE)),KEEP(199)) IF(FATHER.EQ.MYID)THEN IF(BDC_M2_MEM)THEN CALL DMUMPS_PROCESS_NIV2_MEM_MSG(FATHER_NODE) ELSEIF(BDC_M2_FLOPS)THEN CALL DMUMPS_PROCESS_NIV2_FLOPS_MSG(FATHER_NODE) ENDIF IF((KEEP(81).EQ.2).OR.(KEEP(81).EQ.3))THEN IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP(199)).EQ.1)THEN CB_COST_ID(POS_ID)=INODE CB_COST_ID(POS_ID+1)=1 CB_COST_ID(POS_ID+2)=POS_MEM POS_ID=POS_ID+3 CB_COST_MEM(POS_MEM)=int(MYID,8) POS_MEM=POS_MEM+1 CB_COST_MEM(POS_MEM)=int(NCB,8)*int(NCB,8) POS_MEM=POS_MEM+1 ENDIF ENDIF GOTO 666 ENDIF 111 CONTINUE CALL DMUMPS_BUF_SEND_FILS(WHAT, COMM, NPROCS, & FATHER_NODE,INODE,NCB, KEEP,MYID, & FATHER, IERR) IF (IERR == -1 ) THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 666 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error in DMUMPS_UPPER_PREDICT", & IERR CALL MUMPS_ABORT() ENDIF 666 CONTINUE RETURN END SUBROUTINE DMUMPS_UPPER_PREDICT SUBROUTINE DMUMPS_REMOVE_NODE(INODE,NUM_CALL) IMPLICIT NONE DOUBLE PRECISION MAXI INTEGER i,J,IND_MAXI INTEGER INODE,NUM_CALL IF(BDC_M2_MEM)THEN IF(((NUM_CALL.EQ.1).AND.(BDC_MD)).OR. & ((NUM_CALL.EQ.2).AND.(.NOT.BDC_MD)))THEN RETURN ENDIF ENDIF IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0).AND. & ((INODE.EQ.KEEP_LOAD(38)).OR. & (INODE.EQ.KEEP_LOAD(20)))) THEN RETURN ENDIF DO i=POOL_SIZE,1,-1 IF(POOL_NIV2(i).EQ.INODE) GOTO 666 ENDDO NB_SON(STEP_LOAD(INODE))=-1 RETURN 666 CONTINUE IF(BDC_M2_MEM)THEN IF(POOL_NIV2_COST(i).EQ.MAX_M2)THEN TMP_M2=MAX_M2 MAXI=dble(0) IND_MAXI=-9999 DO J=POOL_SIZE,1,-1 IF(J.NE.i) THEN IF(POOL_NIV2_COST(J).GT.MAXI)THEN MAXI=POOL_NIV2_COST(J) IND_MAXI=J ENDIF ENDIF ENDDO MAX_M2=MAXI J=IND_MAXI REMOVE_NODE_FLAG_MEM=.TRUE. REMOVE_NODE_COST_MEM=TMP_M2 CALL DMUMPS_NEXT_NODE(REMOVE_NODE_FLAG,MAX_M2,COMM_LD) NIV2(MYID+1)=MAX_M2 ENDIF ELSEIF(BDC_M2_FLOPS)THEN REMOVE_NODE_COST=POOL_NIV2_COST(i) REMOVE_NODE_FLAG=.TRUE. CALL DMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & -POOL_NIV2_COST(i),COMM_LD) NIV2(MYID+1)=NIV2(MYID+1)-POOL_NIV2_COST(i) ENDIF DO J=i+1,POOL_SIZE POOL_NIV2(J-1)=POOL_NIV2(J) POOL_NIV2_COST(J-1)=POOL_NIV2_COST(J) ENDDO POOL_SIZE=POOL_SIZE-1 END SUBROUTINE DMUMPS_REMOVE_NODE RECURSIVE SUBROUTINE DMUMPS_PROCESS_NIV2_MEM_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in DMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &DMUMPS_PROCESS_NIV2_MEM_MSG' CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & DMUMPS_LOAD_GET_MEM(INODE) POOL_SIZE=POOL_SIZE+1 IF(POOL_NIV2_COST(POOL_SIZE).GT.MAX_M2)THEN MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL DMUMPS_NEXT_NODE(REMOVE_NODE_FLAG_MEM,MAX_M2,COMM_LD) NIV2(1+MYID)=MAX_M2 ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_NIV2_MEM_MSG RECURSIVE SUBROUTINE DMUMPS_PROCESS_NIV2_FLOPS_MSG(INODE) IMPLICIT NONE INTEGER INODE EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE IF((INODE.EQ.KEEP_LOAD(20)).OR. & (INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF IF(NB_SON(STEP_LOAD(INODE)).EQ.-1)THEN RETURN ELSE IF(NB_SON(STEP_LOAD(INODE)).LT.0)THEN WRITE(*,*) & 'Internal error 1 in DMUMPS_PROCESS_NIV2_FLOPS_MSG' CALL MUMPS_ABORT() ENDIF ENDIF NB_SON(STEP_LOAD(INODE))= & NB_SON(STEP_LOAD(INODE))-1 IF(NB_SON(STEP_LOAD(INODE)).EQ.0)THEN IF(POOL_SIZE.EQ.POOL_NIV2_SIZE)THEN WRITE(*,*)MYID,': Internal Error 2 in &DMUMPS_PROCESS_NIV2_FLOPS_MSG',POOL_NIV2_SIZE, & POOL_SIZE CALL MUMPS_ABORT() ENDIF POOL_NIV2(POOL_SIZE+1)=INODE POOL_NIV2_COST(POOL_SIZE+1)= & DMUMPS_LOAD_GET_FLOPS_COST(INODE) POOL_SIZE=POOL_SIZE+1 MAX_M2=POOL_NIV2_COST(POOL_SIZE) ID_MAX_M2=POOL_NIV2(POOL_SIZE) CALL DMUMPS_NEXT_NODE(REMOVE_NODE_FLAG, & POOL_NIV2_COST(POOL_SIZE), & COMM_LD) NIV2(MYID+1)=POOL_NIV2_COST(POOL_SIZE)+NIV2(MYID+1) ENDIF RETURN END SUBROUTINE DMUMPS_PROCESS_NIV2_FLOPS_MSG DOUBLE PRECISION FUNCTION DMUMPS_LOAD_GET_FLOPS_COST(INODE) USE MUMPS_FUTURE_NIV2 INTEGER INODE INTEGER NFRONT,NELIM,i,LEVEL EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION COST i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF NFRONT = ND_LOAD( STEP_LOAD(INODE) ) + KEEP_LOAD(253) LEVEL = MUMPS_TYPENODE( PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) COST=dble(0) CALL MUMPS_GET_FLOPS_COST(NFRONT,NELIM,NELIM, & KEEP_LOAD(50),LEVEL,COST) DMUMPS_LOAD_GET_FLOPS_COST=COST RETURN END FUNCTION DMUMPS_LOAD_GET_FLOPS_COST INTEGER FUNCTION DMUMPS_LOAD_GET_CB_FREED( INODE ) IMPLICIT NONE INTEGER INODE,NELIM,NFR,SON,IN,i INTEGER COST_CB COST_CB=0 i = INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i DO i=1, NE_LOAD(STEP_LOAD(INODE)) NFR = ND_LOAD( STEP_LOAD(SON) ) + KEEP_LOAD(253) IN=SON NELIM = 0 20 CONTINUE IF ( IN > 0 ) THEN NELIM = NELIM + 1 IN = FILS_LOAD(IN) GOTO 20 ENDIF COST_CB=COST_CB+((NFR-NELIM)*(NFR-NELIM)) SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO DMUMPS_LOAD_GET_CB_FREED=COST_CB RETURN END FUNCTION DMUMPS_LOAD_GET_CB_FREED SUBROUTINE DMUMPS_LOAD_SEND_MD_INFO(SLAVEF,NMB_OF_CAND, & LIST_OF_CAND, & TAB_POS, NASS, KEEP,KEEP8, LIST_SLAVES, & NSLAVES,INODE) USE DMUMPS_BUF USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER, INTENT (IN) :: SLAVEF, NASS, NSLAVES INTEGER, INTENT (IN) :: NMB_OF_CAND INTEGER, INTENT (IN) :: LIST_OF_CAND(NMB_OF_CAND) INTEGER, INTENT (IN) :: TAB_POS(SLAVEF+2) INTEGER, INTENT (IN) :: LIST_SLAVES(NSLAVES) INTEGER KEEP(500),INODE INTEGER(8) KEEP8(150) INTEGER allocok DOUBLE PRECISION MEM_COST,FCT_COST DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: DELTA_MD INTEGER, DIMENSION(:), ALLOCATABLE :: IPROC2POSINDELTAMD INTEGER, DIMENSION(:), ALLOCATABLE :: P_TO_UPDATE INTEGER NBROWS_SLAVE,i,WHAT,IERR INTEGER :: NP_TO_UPDATE, K LOGICAL FORCE_CAND LOGICAL :: EXIT_FLAG MEM_COST=dble(0) FCT_COST=dble(0) IF ( KEEP(24) == 0 .OR. KEEP(24) == 1 ) THEN FORCE_CAND = .FALSE. ELSE FORCE_CAND = (mod(KEEP(24),2).eq.0) END IF CALL DMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NMB_OF_CAND,NASS) ALLOCATE(IPROC2POSINDELTAMD(0:SLAVEF-1), & DELTA_MD(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & P_TO_UPDATE(min(SLAVEF, NMB_OF_CAND+NSLAVES)), & stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) "PB ALLOC IN DMUMPS_LOAD_SEND_MD_INFO", & SLAVEF, NMB_OF_CAND, NSLAVES CALL MUMPS_ABORT() ENDIF IPROC2POSINDELTAMD = -99 NP_TO_UPDATE = 0 DO i = 1, NSLAVES NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_SLAVES(i)) = NP_TO_UPDATE NBROWS_SLAVE = TAB_POS(i+1) - TAB_POS(i) DELTA_MD(NP_TO_UPDATE)=-dble(NBROWS_SLAVE)* & dble(NASS) P_TO_UPDATE(NP_TO_UPDATE) = LIST_SLAVES(i) ENDDO DO i = 1, NMB_OF_CAND K = IPROC2POSINDELTAMD(LIST_OF_CAND(i)) IF ( K > 0 ) THEN DELTA_MD(K)=DELTA_MD(K)+FCT_COST ELSE NP_TO_UPDATE = NP_TO_UPDATE + 1 IPROC2POSINDELTAMD (LIST_OF_CAND(i)) = NP_TO_UPDATE DELTA_MD (NP_TO_UPDATE) = FCT_COST P_TO_UPDATE(NP_TO_UPDATE) = LIST_OF_CAND(i) ENDIF ENDDO WHAT=7 111 CONTINUE CALL DMUMPS_BUF_BCAST_ARRAY(.FALSE., COMM_LD, MYID, SLAVEF, & FUTURE_NIV2, & NP_TO_UPDATE, P_TO_UPDATE,0, & DELTA_MD, & DELTA_MD, & DELTA_MD, & WHAT, KEEP, IERR) IF ( IERR == -1 ) THEN CALL DMUMPS_LOAD_RECV_MSGS(COMM_LD) CALL MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IF (EXIT_FLAG) THEN GOTO 100 ELSE GOTO 111 ENDIF ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal Error 2 in DMUMPS_LOAD_SEND_MD_INFO", & IERR CALL MUMPS_ABORT() ENDIF IF (FUTURE_NIV2(MYID+1) .NE. 0) THEN DO i = 1, NP_TO_UPDATE MD_MEM(P_TO_UPDATE(i))=MD_MEM(P_TO_UPDATE(i))+ & int(DELTA_MD( i ),8) IF(FUTURE_NIV2(P_TO_UPDATE(i)+1).EQ.0)THEN MD_MEM(P_TO_UPDATE(i))=999999999_8 ENDIF ENDDO ENDIF 100 CONTINUE DEALLOCATE(DELTA_MD,P_TO_UPDATE,IPROC2POSINDELTAMD) RETURN END SUBROUTINE DMUMPS_LOAD_SEND_MD_INFO SUBROUTINE DMUMPS_LOAD_GET_ESTIM_MEM_COST(INODE,FCT_COST, & MEM_COST,NSLAVES,NELIM) IMPLICIT NONE INTEGER INODE,NSLAVES,NFR,NELIM,IN DOUBLE PRECISION MEM_COST,FCT_COST NFR=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) IN = INODE FCT_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NELIM) MEM_COST=dble(int(dble(NFR-NELIM)/dble(NSLAVES))+1)* & dble(NFR) END SUBROUTINE DMUMPS_LOAD_GET_ESTIM_MEM_COST SUBROUTINE DMUMPS_LOAD_CLEAN_MEMINFO_POOL(INODE) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE INTEGER i,J,SON,NSLAVES_TEMP,POS_TEMP,K INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF((INODE.LT.0).OR.(INODE.GT.N_LOAD))THEN RETURN ENDIF IF(POS_ID.GT.1)THEN i=INODE 10 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i IF(POS_ID.LT.NE_LOAD(STEP_LOAD(INODE))*3)THEN i=1 ENDIF DO i=1, NE_LOAD(STEP_LOAD(INODE)) J=1 DO WHILE (J.LT.POS_ID) IF(CB_COST_ID(J).EQ.SON)GOTO 295 J=J+3 ENDDO 295 CONTINUE IF(J.GE.POS_ID)THEN IF ( MUMPS_PROCNODE( & PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199) ) .EQ. MYID ) THEN IF(INODE.EQ.KEEP_LOAD(38))THEN GOTO 666 ELSE IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': i did not find ',SON CALL MUMPS_ABORT() ENDIF GOTO 666 ENDIF ELSE GOTO 666 ENDIF ENDIF NSLAVES_TEMP=CB_COST_ID(J+1) POS_TEMP=CB_COST_ID(J+2) DO K=J,POS_ID-1 CB_COST_ID(K)=CB_COST_ID(K+3) ENDDO K=POS_TEMP DO WHILE (K.LE.POS_MEM-1) CB_COST_MEM(K)=CB_COST_MEM(K+2*NSLAVES_TEMP) K=K+1 ENDDO POS_MEM=POS_MEM-2*NSLAVES_TEMP POS_ID=POS_ID-3 IF((POS_MEM.LT.1).OR.(POS_ID.LT.1))THEN WRITE(*,*)MYID,': negative pos_mem or pos_id' CALL MUMPS_ABORT() ENDIF 666 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO ENDIF END SUBROUTINE DMUMPS_LOAD_CLEAN_MEMINFO_POOL SUBROUTINE DMUMPS_LOAD_CHK_MEMCST_POOL(FLAG) IMPLICIT NONE LOGICAL FLAG INTEGER i DOUBLE PRECISION MEM FLAG=.FALSE. DO i=0,NPROCS-1 MEM=DM_MEM(i)+LU_USAGE(i) IF(BDC_SBTR)THEN MEM=MEM+SBTR_MEM(i)-SBTR_CUR(i) ENDIF IF((MEM/dble(TAB_MAXS(i))).GT.0.8d0)THEN FLAG=.TRUE. GOTO 666 ENDIF ENDDO 666 CONTINUE END SUBROUTINE DMUMPS_LOAD_CHK_MEMCST_POOL SUBROUTINE DMUMPS_CHECK_SBTR_COST(NBINSUBTREE,INSUBTREE,NBTOP, & MIN_COST,SBTR) IMPLICIT NONE INTEGER NBINSUBTREE,INSUBTREE,NBTOP DOUBLE PRECISION MIN_COST LOGICAL SBTR INTEGER i DOUBLE PRECISION TMP_COST,TMP_MIN TMP_MIN=huge(TMP_MIN) DO i=0,NPROCS-1 IF(i.NE.MYID)THEN IF(BDC_SBTR)THEN TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i))-(SBTR_MEM(i)-SBTR_CUR(i))) ELSE TMP_MIN=min(TMP_MIN,dble(TAB_MAXS(i))- & (DM_MEM(i)+LU_USAGE(i))) ENDIF ENDIF ENDDO IF(NBINSUBTREE.GT.0)THEN IF(INSUBTREE.EQ.1)THEN TMP_COST=dble(TAB_MAXS(MYID))-(DM_MEM(MYID)+ & LU_USAGE(MYID)) & -(SBTR_MEM(MYID)-SBTR_CUR(MYID)) ELSE SBTR=.FALSE. GOTO 777 ENDIF ENDIF TMP_MIN=min(TMP_COST,TMP_MIN) IF(TMP_MIN.GT.MIN_COST) SBTR=.TRUE. 777 CONTINUE END SUBROUTINE DMUMPS_CHECK_SBTR_COST SUBROUTINE DMUMPS_LOAD_COMP_MAXMEM_POOL(INODE,MAX_MEM,PROC) USE MUMPS_FUTURE_NIV2 IMPLICIT NONE INTEGER INODE,PROC INTEGER i,POS,NSLAVES,SLAVE,NCAND,J,NELIM,NCB,NFRONT,SON,K INTEGER allocok EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE DOUBLE PRECISION MAX_MEM DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: MEM_ON_PROCS, & RECV_BUF LOGICAL, DIMENSION(:), ALLOCATABLE :: CONCERNED DOUBLE PRECISION MAX_SENT_MSG IF((FRERE_LOAD(STEP_LOAD(INODE)).EQ.0) & .AND.(INODE.EQ.KEEP_LOAD(38)))THEN RETURN ENDIF ALLOCATE( MEM_ON_PROCS(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( CONCERNED(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF ALLOCATE( RECV_BUF(0:NPROCS-1), stat=allocok) IF ( allocok > 0 ) THEN WRITE(*,*) 'PB allocation in DMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF RECV_BUF=dble(0) MAX_SENT_MSG=dble(0) i = INODE NELIM = 0 10 CONTINUE IF ( i > 0 ) THEN NELIM = NELIM + 1 i = FILS_LOAD(i) GOTO 10 ENDIF SON=-i NFRONT=ND_LOAD(STEP_LOAD(INODE)) + KEEP_LOAD(253) NCB=NFRONT-NELIM IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN NCAND=CAND_LOAD(NPROCS+1, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) ENDIF DO i=0,NPROCS-1 IF(i.EQ.MYID)THEN MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+ & LU_USAGE(i)+ & DMUMPS_LOAD_GET_MEM(INODE)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF CONCERNED(i)=.TRUE. ELSE MEM_ON_PROCS(i)=dble(TAB_MAXS(i))-(DM_MEM(i)+LU_USAGE(i)) IF(BDC_SBTR)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-(SBTR_MEM(i)-SBTR_CUR(i)) ENDIF IF(BDC_M2_MEM)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)-NIV2(i+1) ENDIF ENDIF IF(MUMPS_TYPENODE(PROCNODE_LOAD(STEP_LOAD(INODE)), & KEEP_LOAD(199)).EQ.2)THEN IF(BDC_MD.AND.(KEEP_LOAD(48).EQ.5))THEN DO J=1,NCAND IF(CAND_LOAD(J, STEP_TO_NIV2_LOAD(STEP_LOAD(INODE))) & .EQ.i)THEN MEM_ON_PROCS(i)=MEM_ON_PROCS(i)- & ((dble(NFRONT)*dble(NCB))/dble(NCAND)) CONCERNED(i)=.TRUE. GOTO 666 ENDIF ENDDO ENDIF ENDIF 666 CONTINUE ENDDO DO K=1, NE_LOAD(STEP_LOAD(INODE)) i=1 DO WHILE (i.LE.POS_ID) IF(CB_COST_ID(i).EQ.SON)GOTO 295 i=i+3 ENDDO 295 CONTINUE IF(i.GE.POS_ID)THEN IF(FUTURE_NIV2(MYID+1).NE.0)THEN WRITE(*,*)MYID,': ',SON,'has not been found & in DMUMPS_LOAD_COMP_MAXMEM_POOL' CALL MUMPS_ABORT() ENDIF GOTO 777 ENDIF NSLAVES=CB_COST_ID(i+1) POS=CB_COST_ID(i+2) DO i=1,NSLAVES SLAVE=int(CB_COST_MEM(POS)) IF(.NOT.CONCERNED(SLAVE))THEN MEM_ON_PROCS(SLAVE)=MEM_ON_PROCS(SLAVE)+ & dble(CB_COST_MEM(POS+1)) ENDIF DO J=0,NPROCS-1 IF(CONCERNED(J))THEN IF(SLAVE.NE.J)THEN RECV_BUF(J)=max(RECV_BUF(J), & dble(CB_COST_MEM(POS+1))) ENDIF ENDIF ENDDO POS=POS+2 ENDDO 777 CONTINUE SON=FRERE_LOAD(STEP_LOAD(SON)) ENDDO MAX_MEM=huge(MAX_MEM) WRITE(*,*)'NPROCS=',NPROCS,MAX_MEM DO i=0,NPROCS-1 IF(MAX_MEM.GT.MEM_ON_PROCS(i))THEN PROC=i ENDIF MAX_MEM=min(MEM_ON_PROCS(i),MAX_MEM) ENDDO DEALLOCATE(MEM_ON_PROCS) DEALLOCATE(CONCERNED) DEALLOCATE(RECV_BUF) END SUBROUTINE DMUMPS_LOAD_COMP_MAXMEM_POOL SUBROUTINE DMUMPS_FIND_BEST_NODE_FOR_MEM(MIN_PROC,POOL, & LPOOL,INODE) IMPLICIT NONE INTEGER INODE,LPOOL,MIN_PROC INTEGER POOL(LPOOL) EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER i,NBTOP,INSUBTREE,NBINSUBTREE,NODE,FATHER,SON,J INTEGER SBTR_NB_LEAF,POS,K,allocok,L INTEGER, ALLOCATABLE, DIMENSION (:) :: TMP_SBTR NBINSUBTREE = POOL(LPOOL) NBTOP = POOL(LPOOL - 1) INSUBTREE = POOL(LPOOL - 2) IF((KEEP_LOAD(47).EQ.4).AND. & ((NBINSUBTREE.NE.0)))THEN DO J=INDICE_SBTR,NB_SUBTREES NODE=MY_ROOT_SBTR(J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 110 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 110 ENDIF SON=-i i=SON 120 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN SBTR_NB_LEAF=MY_NB_LEAF(J) POS=SBTR_FIRST_POS_IN_POOL(J) IF(POOL(POS+SBTR_NB_LEAF).NE.MY_FIRST_LEAF(J))THEN WRITE(*,*)MYID,': The first leaf is not ok' CALL MUMPS_ABORT() ENDIF ALLOCATE (TMP_SBTR(SBTR_NB_LEAF), stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*)MYID,': Not enough space & for allocation' CALL MUMPS_ABORT() ENDIF POS=SBTR_FIRST_POS_IN_POOL(J) DO K=1,SBTR_NB_LEAF TMP_SBTR(K)=POOL(POS+K-1) ENDDO DO K=POS+1,NBINSUBTREE-SBTR_NB_LEAF POOL(K)=POOL(K+SBTR_NB_LEAF) ENDDO POS=1 DO K=NBINSUBTREE-SBTR_NB_LEAF+1,NBINSUBTREE POOL(K)=TMP_SBTR(POS) POS=POS+1 ENDDO DO K=INDICE_SBTR,J SBTR_FIRST_POS_IN_POOL(K)=SBTR_FIRST_POS_IN_POOL(K) & -SBTR_FIRST_POS_IN_POOL(J) ENDDO SBTR_FIRST_POS_IN_POOL(J)=NBINSUBTREE-SBTR_NB_LEAF POS=MY_FIRST_LEAF(J) L=MY_NB_LEAF(J) DO K=INDICE_SBTR,J MY_FIRST_LEAF(J)=MY_FIRST_LEAF(J+1) MY_NB_LEAF(J)=MY_NB_LEAF(J+1) ENDDO MY_FIRST_LEAF(INDICE_SBTR)=POS MY_NB_LEAF(INDICE_SBTR)=L INODE=POOL(NBINSUBTREE) DEALLOCATE(TMP_SBTR) RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 120 ENDIF ENDDO ENDIF DO J=NBTOP,1,-1 NODE=POOL(LPOOL-2-J) FATHER=DAD_LOAD(STEP_LOAD(NODE)) i=FATHER 11 CONTINUE IF ( i > 0 ) THEN i = FILS_LOAD(i) GOTO 11 ENDIF SON=-i i=SON 12 CONTINUE IF ( i > 0 ) THEN IF( MUMPS_PROCNODE(PROCNODE_LOAD(STEP_LOAD(i)), & KEEP_LOAD(199)) .EQ. MIN_PROC ) THEN INODE=NODE RETURN ENDIF i = FRERE_LOAD(STEP_LOAD(i)) GOTO 12 ENDIF ENDDO END SUBROUTINE DMUMPS_FIND_BEST_NODE_FOR_MEM SUBROUTINE DMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IMPLICIT NONE INTEGER LPOOL,POOL(LPOOL),KEEP(500) INTEGER(8) KEEP8(150) INTEGER i,POS EXTERNAL MUMPS_ROOTSSARBR LOGICAL MUMPS_ROOTSSARBR IF(.NOT.BDC_SBTR) RETURN POS=0 DO i=NB_SUBTREES,1,-1 DO WHILE(MUMPS_ROOTSSARBR( & PROCNODE_LOAD(STEP_LOAD(POOL(POS+1))), & KEEP(199))) POS=POS+1 ENDDO SBTR_FIRST_POS_IN_POOL(i)=POS+1 POS=POS+MY_NB_LEAF(i) ENDDO END SUBROUTINE DMUMPS_LOAD_INIT_SBTR_STRUCT END MODULE DMUMPS_LOAD SUBROUTINE DMUMPS_SET_PARTI_REGULAR( & SLAVEF, & KEEP,KEEP8, & PROCS, & MEM_DISTRIB, NCB, NFRONT, NSLAVES_NODE, & TAB_POS, SLAVES_LIST, SIZE_SLAVES_LIST,MYID,INODE, & TAB_MAXS_ARG,SUP_PROC_ARG,MAX_SURF,NB_ROW_MAX & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500),SIZE_SLAVES_LIST INTEGER(8) KEEP8(150) INTEGER, intent(in) :: SLAVEF, NFRONT, NCB,MYID INTEGER, intent(in) :: PROCS(SLAVEF+1) INTEGER(8), intent(in) :: TAB_MAXS_ARG(0:SLAVEF-1) INTEGER, intent(in) :: SUP_PROC_ARG(2) INTEGER, intent(in) :: MEM_DISTRIB(0:SLAVEF-1),INODE INTEGER, intent(out):: SLAVES_LIST(SIZE_SLAVES_LIST) INTEGER, intent(out):: TAB_POS(SLAVEF+2) INTEGER, intent(out):: NSLAVES_NODE,NB_ROW_MAX INTEGER(8), intent(out):: MAX_SURF LOGICAL :: FORCE_LDLTRegular_NIV2 INTEGER NSLAVES,ACC INTEGER i,J,NELIM,NB_SUP,K50,NB_ROWS(PROCS(SLAVEF+1)) INTEGER TMP_NROW,X,K LOGICAL SUP,MEM_CSTR DOUBLE PRECISION MAX_LOAD,TOTAL_LOAD,VAR,TMP,A,B,C,DELTA, & LOAD_CORR INTEGER IDWLOAD(SLAVEF) INTEGER(8) MEM_CONSTRAINT(2) K50=KEEP(50) FORCE_LDLTRegular_NIV2 = .FALSE. MAX_SURF=0 NB_ROW_MAX=0 NELIM=NFRONT-NCB NB_SUP=0 TOTAL_LOAD=0.0D0 SUP=.FALSE. IF(SUP_PROC_ARG(1).NE. & 0)THEN MEM_CONSTRAINT(1)=TAB_MAXS_ARG(PROCS(1)) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(1))/100.0D0 NB_SUP=NB_SUP+1 ENDIF IF(SUP_PROC_ARG(2).NE. & 0)THEN MEM_CONSTRAINT(2)=TAB_MAXS_ARG(PROCS(PROCS(SLAVEF+1))) TOTAL_LOAD=TOTAL_LOAD+dble(SUP_PROC_ARG(2))/100.0D0 NB_SUP=NB_SUP+1 ENDIF TOTAL_LOAD=TOTAL_LOAD+(PROCS(SLAVEF+1)-NB_SUP) IF(K50.EQ.0)THEN MAX_LOAD=dble( NELIM ) * dble ( NCB ) + * dble(NCB) * dble(NELIM)*dble(2*NFRONT-NELIM-1) ELSE MAX_LOAD=dble(NELIM) * dble ( NCB ) * * dble(NFRONT+1) ENDIF TMP=min(MAX_LOAD,MAX_LOAD/TOTAL_LOAD) J=1 DO i=1,PROCS(SLAVEF+1) IF((NB_SUP.GT.0).AND.(i.EQ.1))THEN CYCLE ELSEIF((NB_SUP.EQ.2).AND.(i.EQ.PROCS(SLAVEF+1)))THEN CYCLE ENDIF IDWLOAD(J)=PROCS(i) J=J+1 ENDDO DO i=1,NB_SUP IF(i.EQ.1)THEN IDWLOAD(J)=PROCS(1) ELSE IDWLOAD(J)=PROCS(PROCS(SLAVEF+1)) ENDIF J=J+1 ENDDO IF ((K50.EQ.0).OR.FORCE_LDLTRegular_NIV2) THEN ACC=0 J=PROCS(SLAVEF+1)-NB_SUP+1 DO i=1,NB_SUP VAR=dble(SUP_PROC_ARG(i))/100.0D0 TMP_NROW=int(dble(MEM_CONSTRAINT(i))/dble(NFRONT)) NB_ROWS(J)=int(max((VAR*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM)), & dble(1))) IF(NB_ROWS(J).GT.TMP_NROW)THEN NB_ROWS(J)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(J)) THEN NB_ROWS(J)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(J) J=J+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF DO i=1,PROCS(SLAVEF+1)-NB_SUP VAR=1.0D0 TMP_NROW=int((dble(TAB_MAXS_ARG(IDWLOAD(i))))/dble(NFRONT)) NB_ROWS(i)=int((dble(VAR)*dble(TMP))/ & (dble(NELIM)*dble(2*NFRONT-NELIM))) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW ENDIF IF(NCB-ACC.LT.NB_ROWS(i)) THEN NB_ROWS(i)=NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE TMP_NROW=(NCB-ACC)/(PROCS(SLAVEF+1)-NB_SUP)+1 DO i=1,PROCS(SLAVEF+1)-NB_SUP NB_ROWS(i)=NB_ROWS(i)+TMP_NROW ACC=ACC+TMP_NROW IF(ACC.GT.NCB) THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+ & (NCB-(ACC-TMP_NROW)) EXIT ENDIF ENDDO ENDIF ENDIF ELSE ACC=0 i=PROCS(SLAVEF+1)-NB_SUP+1 X=NCB LOAD_CORR=0.0D0 MEM_CSTR=.FALSE. DO J=1,NB_SUP VAR=DBLE(SUP_PROC_ARG(J))/DBLE(100) A=1.0D0 B=dble(X+NELIM) C=-dble(max(MEM_CONSTRAINT(J),0_8)) DELTA=((B*B)-(4*A*C)) TMP_NROW=int((-B+sqrt(DELTA))/(2*A)) A=dble(-NELIM) B=dble(NELIM)*(dble(-NELIM)+dble(2*(X+NELIM)+1)) C=-(VAR*TMP) DELTA=(B*B-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NB_ROWS(i).GT.TMP_NROW)THEN NB_ROWS(i)=TMP_NROW MEM_CSTR=.TRUE. ENDIF IF(ACC+NB_ROWS(i).GT.NCB)THEN NB_ROWS(i)=NCB-ACC ACC=NCB X=0 EXIT ENDIF X=X-NB_ROWS(i) ACC=ACC+NB_ROWS(i) LOAD_CORR=LOAD_CORR+(dble(NELIM) * dble (NB_ROWS(i)) * * dble(2*(X+NELIM) - NELIM - NB_ROWS(i) + 1)) i=i+1 ENDDO IF(ACC.EQ.NCB)THEN GOTO 777 ENDIF IF((PROCS(SLAVEF+1).NE.NB_SUP).AND.MEM_CSTR)THEN TMP=(MAX_LOAD-LOAD_CORR)/(PROCS(SLAVEF+1)-NB_SUP) ENDIF X=ACC ACC=0 DO i=1,PROCS(SLAVEF+1)-NB_SUP IF (KEEP(375) .EQ. 1) THEN VAR=1.0D0 A=dble(NELIM) B=dble(NELIM)*(dble(NELIM)+dble(2*ACC+1)) C=-(VAR*TMP) ELSE A=1.0D0 B=dble(ACC+NELIM) C=-TMP ENDIF DELTA=((B*B)-(4*A*C)) NB_ROWS(i)=int((-B+sqrt(DELTA))/(2*A)) IF(NCB-ACC-X.LT.NB_ROWS(i))THEN NB_ROWS(i)=NCB-ACC-X ACC=NCB-X EXIT ENDIF ACC=ACC+NB_ROWS(i) ENDDO ACC=ACC+X IF(ACC.NE.NCB)THEN IF(PROCS(SLAVEF+1).EQ.NB_SUP)THEN TMP_NROW=(NCB-ACC)/PROCS(SLAVEF+1)+1 DO i=1,PROCS(SLAVEF+1) NB_ROWS(i)=NB_ROWS(i)+TMP_NROW IF(ACC+TMP_NROW.GT.NCB)THEN NB_ROWS(i)=NB_ROWS(i)-TMP_NROW+NCB-ACC ACC=NCB EXIT ENDIF ACC=ACC+TMP_NROW ENDDO ELSE NB_ROWS(PROCS(SLAVEF+1)-NB_SUP)= & NB_ROWS(PROCS(SLAVEF+1) & -NB_SUP)+NCB-ACC ENDIF ENDIF ENDIF 777 CONTINUE NSLAVES=0 ACC=1 J=1 K=1 DO i=1,PROCS(SLAVEF+1) IF(NB_ROWS(i).NE.0)THEN SLAVES_LIST(J)=IDWLOAD(i) TAB_POS(J)=ACC ACC=ACC+NB_ROWS(i) NB_ROW_MAX=max(NB_ROW_MAX,NB_ROWS(i)) IF(K50.EQ.0)THEN MAX_SURF=max(int(NB_ROWS(i),8)*int(NCB,8),int(0,8)) ELSE MAX_SURF=max(int(NB_ROWS(i),8)*int(ACC,8),int(0,8)) ENDIF NSLAVES=NSLAVES+1 J=J+1 ELSE SLAVES_LIST(PROCS(SLAVEF+1)-K+1)=IDWLOAD(i) K=K+1 ENDIF ENDDO TAB_POS(SLAVEF+2) = NSLAVES TAB_POS(NSLAVES+1)= NCB+1 NSLAVES_NODE=NSLAVES END SUBROUTINE DMUMPS_SET_PARTI_REGULAR MUMPS_5.4.1/src/sfac_process_message.F0000664000175000017500000010360014102210521017766 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_LOAD USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(N) REAL A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER MP, LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL SMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL SMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="SMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL SMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL SMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="SMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL SMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="SMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL SMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL SMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL SMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL SMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL SMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="SMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL SMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="SMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL SMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="SMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL SMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL SMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL SMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL SMUMPS_PROCESS_RTNELIND( root, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="SMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in SMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine SMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE SMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL SMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) RETURN END SUBROUTINE SMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE SMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE SMUMPS_LOAD USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL SMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN IF (KEEP(117).NE.0) THEN WRITE(*,*) "Problem of active IRECV with KEEP(117)=",KEEP(117) CALL MUMPS_ABORT() ENDIF RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in SMUMPS_TRY_RECVTREAT' CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL SMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL SMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE SMUMPS_TRY_RECVTREAT SUBROUTINE SMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE SMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL SMUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE SMUMPS_CANCEL_IRECV SUBROUTINE SMUMPS_CLEAN_PENDING( & INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & CLEAN_COMM_NODES, CLEAN_COMM_LOAD ) USE SMUMPS_BUF IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR, LBUFR_BYTES INTEGER, INTENT(OUT) :: BUFR( LBUFR ) INTEGER, INTENT(IN) :: COMM_NODES, COMM_LOAD, SLAVEF, INFO1 INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, INTENT(IN) :: CLEAN_COMM_LOAD, CLEAN_COMM_NODES INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER :: MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER :: COMM_EFF INTEGER :: IERR INTEGER :: IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS INTEGER :: TOTAL_SEND_MINUS_RECV266 INTEGER :: TOTAL_SEND_MINUS_RECV267 IF (SLAVEF.EQ.1) RETURN IF (.NOT. CLEAN_COMM_NODES .AND. .NOT. CLEAN_COMM_LOAD) THEN RETURN ENDIF DO WHILE (.TRUE.) FLAG = .TRUE. DO WHILE ( FLAG ) FLAG = .FALSE. IF (CLEAN_COMM_NODES) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) END IF END IF IF (CLEAN_COMM_LOAD) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) IF (COMM_EFF .EQ. COMM_NODES) THEN KEEP(266) = KEEP(266) - 1 ELSE KEEP(267) = KEEP(267) - 1 ENDIF CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (MSGLEN_LOC .LE. LBUFR_BYTES) THEN CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF ENDIF END DO CALL SMUMPS_BUF_ALL_EMPTY( CLEAN_COMM_NODES, & CLEAN_COMM_LOAD, & BUFFERS_EMPTY ) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF IF (CLEAN_COMM_NODES) THEN COMM_EFF = COMM_NODES ELSE COMM_EFF = COMM_LOAD ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_EFF, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN IF (CLEAN_COMM_NODES) THEN CALL MPI_ALLREDUCE(KEEP(266), & TOTAL_SEND_MINUS_RECV266, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV266 = 0 ENDIF IF (CLEAN_COMM_LOAD) THEN CALL MPI_ALLREDUCE(KEEP(267), & TOTAL_SEND_MINUS_RECV267, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV267 = 0 ENDIF IF (TOTAL_SEND_MINUS_RECV266 .EQ. 0 .AND. & TOTAL_SEND_MINUS_RECV267 .EQ. 0) THEN EXIT ENDIF ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_CLEAN_PENDING MUMPS_5.4.1/src/dsol_driver.F0000664000175000017500000070465614102210525016152 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOLVE_DRIVER(id) USE DMUMPS_STRUC_DEF USE DMUMPS_SOL_ES C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C C C USE DMUMPS_BUF USE DMUMPS_OOC USE MUMPS_MEMORY_MOD USE DMUMPS_LR_DATA_M, only : DMUMPS_BLR_STRUC_TO_MOD & , DMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC USE DMUMPS_SAVE_RESTORE IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE DMUMPS_SIZE_IN_STRUCT( id, NB_INT,NB_CMPLX,NB_CHAR ) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE DMUMPS_SIZE_IN_STRUCT SUBROUTINE DMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE DMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (DMUMPS_STRUC), TARGET :: id C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,IPERM,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8, LWCB8_SOL_C C buffer sizes INTEGER DMUMPS_LBUF, DMUMPS_LBUF_INT INTEGER(8) :: DMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS C true if DMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_allocated DOUBLE PRECISION, DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSCOMP_FWD, & PTR_POSINRHSCOMP_BWD DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR_RHS INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ DOUBLE PRECISION ONE DOUBLE PRECISION ZERO PARAMETER( ONE = 1.0D0 ) PARAMETER( ZERO = 0.0D0 ) DOUBLE PRECISION RZERO, RONE PARAMETER( RZERO = 0.0D0, RONE = 1.0D0 ) C C RHS_IR is internal to DMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. DOUBLE PRECISION, DIMENSION(:), POINTER :: RHS_IR DOUBLE PRECISION, DIMENSION(:), POINTER :: WORK_WCB DOUBLE PRECISION, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C DOUBLE PRECISION, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK DOUBLE PRECISION, ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) DOUBLE PRECISION, ALLOCATABLE :: R_Y(:), D(:) DOUBLE PRECISION, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSCOMP, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS DOUBLE PRECISION, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS DOUBLE PRECISION, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs adn solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*S(ISTW3) C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D2) **(-1)] x0 and so x0= D2*y0 is modified C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2ATD1 D1-1 x0 = D2b0 C b(sca) = D2 * b0 = COLSCA*S(ISTW3) C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS we need C scaling information on each processor C type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data_sol, scaling_data_dr C To scale on the fly during GATHER SOLUTION DOUBLE PRECISION, DIMENSION(:), POINTER :: PT_SCALING DOUBLE PRECISION, TARGET :: Dummy_SCAL(1) C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG DOUBLE PRECISION ARRET DOUBLE PRECISION C_DUMMY(1) DOUBLE PRECISION R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) DOUBLE PRECISION, TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IPT_RHS_ROOT INTEGER(8) :: IBEG, IBEG_RHSCOMP, KDEC, IBEG_loc, IBEG_REDRHS INTEGER LD_RHSCOMP, NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8 INTEGER(8) K16_8, ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSCOMP LOGICAL :: BUILD_RHSMAPINFO LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER(8) :: FILE_SIZE,STRUC_SIZE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation IRHS_PTR_COPY => IDUMMY_TARGET IRHS_PTR_COPY_ALLOCATED = .FALSE. IRHS_SPARSE_COPY => IDUMMY_TARGET IRHS_SPARSE_COPY_ALLOCATED=.FALSE. RHS_SPARSE_COPY => CDUMMY_TARGET RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO C ASPK =>id%A C COLSCA =>id%COLSCA C ROWSCA =>id%ROWSCA RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) K16_8 = int(KEEP(16), 8) NBENT_RHSCOMP = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSCOMP =-152525_8 ! Should not be used BUILD_POSINRHSCOMP = .TRUE. IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C Not needed anymore (since new version of gather) C LD_RHSCOMP = max(KEEP(89),1) ! at the nb of pivots eliminated on ! that proc LD_RHSCOMP = 1 NB_FS_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Compute the number of integers and nb of reals in the structure CALL DMUMPS_SIZE_IN_STRUCT (id, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 + NB_CHAR NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok CALL DMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== C The checks below used to be in DMUMPS_DRIVER. It is much better C to have them here in DMUMPS_SOL_DRIVER because this enables C more flexibility in the management of priorities between various C checks. IF (id%MYID .EQ. MASTER) THEN c subroutine only because called at facto and solve CALL DMUMPS_SET_K221(id) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN C -- input RHS is indeed stored in REDRHS and RHSCOMP id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and RHSCOMP id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (KEEP(248) .EQ. -1) THEN C V0 distributed RHS: no ES id%KEEP(235) = 0 ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0)) THEN C In the context of null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( (id%KEEP(221).EQ.1 ).AND.(id%KEEP(235).NE.0) ) THEN C -- Do not permute RHS with REDRHS for the time being id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0D0 id%DKEEP(113)=0.0D0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0D0 id%DKEEP(120)=0.0D0 id%DKEEP(121)=0.0D0 id%DKEEP(115)=0.0D0 id%DKEEP(116)=0.0D0 id%DKEEP(122)=0.0D0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0D0 id%DKEEP(118)=0.0D0 id%DKEEP(119)=0.0D0 id%DKEEP(123)=0.0D0 id%DKEEP(124)=0.0D0 id%DKEEP(125)=0.0D0 id%DKEEP(126)=0.0D0 id%DKEEP(127)=0.0D0 id%DKEEP(128:134)=0.0D0 id%DKEEP(140:153)=0.0D0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN C RHS must be of size N on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL DMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C Check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)=-47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1) THEN C ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL DMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( I_AM_SLAVE ) THEN C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc < id%KEEP(89) ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF (id%KEEP(89) .NE. 0) THEN IF ( .not. associated(id%ISOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 ENDIF IF ( .not. associated(id%SOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 ENDIF IF (size(id%ISOL_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_F2003) IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(id%KEEP(89),8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+id%KEEP(89)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ENDIF ENDIF IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF IF (I_AM_SLAVE .AND. id%KEEP(248).EQ.-1) THEN CALL DMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & id%INFO) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to DMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF IF (I_AM_SLAVE .AND. ICNTL21.EQ.1 .AND. & KEEP(248) .EQ. -1) THEN ! Dist RHS and dist solution IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN IF (id%KEEP(89).GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks (REDRHS), depending on KEEP(221) CALL DMUMPS_CHECK_REDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ==================================== C Process case of NZ_RHS = 0 with C sparse RHS and General Sparse (NOT A-1) C ----------------------------------- IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN C CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (id%NZ_RHS.EQ.0) THEN C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL DMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , .FALSE., IDUMMY(1), 1 & ) DO J=1, id%NRHS DO I=1, KEEP(89) id%SOL_loc((J-1)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF ENDIF IF (ICNTL21.NE.1) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN C write(6,*) " NZ_RHS is zero " WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== ENDIF ! test NZ_RHS.EQ.0 C -------- ENDIF ! (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF NB_BYTES = NB_BYTES + NBT*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT * K34_8 C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN CALL DMUMPS_BUILD_MAPPING_INFO(id) END IF END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) & CALL DMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS does IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSCOMP on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. C IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(id%root%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)*int(NBRHS,8) C C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor. Note that we are C inside a block "IF (I_AM_SLAVE)" WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (id%LWK_USER.EQ.0) THEN ITMP8 = 0_8 ELSE IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ! jump to propinfo ! (S is used in between and not allocated) ! NO COMM must occur then before next propinfo ! it happens in Mila's code but only with ! KEEP(209) > 0 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF C KEEP8(24) holds the size of WK_USER provided by user. C MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN C Avoid the use of "size(id%S)" because it returns C a default integer that may overflow. Also "size(id%S,kind=8)" C will only be available with Fortran 2003 compilers. MAXS = KEEP8(23) ELSE ! S not allocated and WK_USER not provided ==> must be in OOC IF (KEEP(201).EQ.0) THEN ! incore WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' C IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C --- end of OOC case ENDIF C -- end of id%S already associated ENDIF C C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE C MAXS has normally be dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL DMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL DMUMPS_OOC_INIT_SOLVE(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in DMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in DMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL DMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== C LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. C FORBID ERROR ANALYSIS AND ITERATIVE REFINEMENT C if there are options that are not compatible IF (KEEP(111).NE.0) THEN C IF WE RETURN A NULL SPACE BASIS or compute entries in A-1 C of Fwd in facto C -When only one columns of A-1 is requested then C we could try to reactivate IR even if C -code need be updated C -accuracy could be # when one or more columns are requested IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN C Forbid error analysis and iterative refinement C in case of reduced rhs/solution IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN C Forbid error analysis and iterative refinement if C the solution is distributed or C in the case where nrhs > 1 IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN C Forbid error analysis and iterative refinement C in case of distributed RHS IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF C -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( id%MYID .eq. MASTER ) THEN IF (MAT_ALLOC.EQ.0) THEN POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL21,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(35),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety C Note that IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(MSG_MAX_BYTES_SOLVE),8)) THEN INFO(1) = -18 INFO(2) = ( huge(MSG_MAX_BYTES_SOLVE) - & ( 16 + 4 + KEEP(133) ) ) / & ( KEEP(133) * KEEP(35) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for DMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE #if defined(MPI_TO_K_OMPP) #endif C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for DMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(35) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for DMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ DMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL DMUMPS_BUF_ALLOC_SMALL_BUF( DMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = DMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (DMUMPS_LBUF) C using integer8 in DMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C DMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... DMUMPS_LBUF_8 = min(DMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously DMUMPS_LBUF_8 = max(DMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) DMUMPS_LBUF_8 = DMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. DMUMPS_LBUF_8 = min(DMUMPS_LBUF_8, & int(huge(DMUMPS_LBUF),8) & - 10_8*int(KEEP(34),8) & ) DMUMPS_LBUF = int(DMUMPS_LBUF_8, kind(DMUMPS_LBUF)) CALL DMUMPS_BUF_ALLOC_CB( DMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = DMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSCOMP must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C POSINRHSCOMP_ROW/COL are meaningful and could even be reused IF (.NOT.associated(id%POSINRHSCOMP_ROW) ) ! .OR. ! & .NOT.(id%POSINRHSCOMP_COL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%POSINRHSCOMP_COL_ALLOC) THEN C POSINRHSCOMP_COL that is kept from C previous call to solve must then (already) C point to id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW ENDIF ELSE C ---------------------- C Allocate POSINRHSCOMP_ROW/COL C ---------------------- C The size of POSINRHSCOMP arrays C does not depend on the block of RHS C POSINRHSCOMP_ROW/COL are initialized in the loop of RHS IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) ENDIF ALLOCATE (id%POSINRHSCOMP_ROW(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C IF ((KEEP(50).EQ.0).OR.KEEP(237).NE.0) THEN ALLOCATE (id%POSINRHSCOMP_COL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%POSINRHSCOMP_COL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_COL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate POSINRHSCOMP_COL id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after reduced RHS C -- we have to keep "old" RHSCOMP IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (DMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in DMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to DMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(SRW3),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine DMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in DMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before theC C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) ) ) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSCOMP to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF IF (LSCAL .AND. id%KEEP(248).EQ.-1) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL DMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(id%KEEP(89)), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=id%KEEP(89) GOTO 38 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF ENDIF ! LSCAL IF ( I_AM_SLAVE ) THEN C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL DMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF ENDIF ! I_AM_SLAVE IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C ---------------------------- C Preparation for reduced RHS C ---------------------------- IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL DMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL DMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within DMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in DMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN c - In case of NS/A-1 we may want to permute RHS c - for NS thus is to apply permutation to PIVNUL_LIST * - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL DMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C ============================== C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_LOC) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * DMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSCOMP to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C ====================== IF (KEEP(248)==1) THEN C ====================== C C Sparse RHS format ( A-1 or sparse input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IRHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ELSE IRHS_SPARSE_COPY = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C if scaling is on or if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one; it might be C modified if scaling is on (one first entry in each col is scaled) RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) THEN C -- Columns are not contiguous and need be copied one by one C -- This need not be done if scaling is on because it C -- will done and scaled later. IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IF (COLSIZE .EQ. 0) CYCLE RHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C ----- ENDIF ! ============ KEEP(248)==1 C ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) IF (IERR.GT.0) THEN WRITE (*,*)'NOT OK FOR ALLOC PTR ON SLAVES' call MUMPS_ABORT() ENDIF ENDIF ENDIF C C ========================================================= C INITIALIZE POSINRHSCOMP_ROW/COL, RHSCOMP and related data C For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= IF ( I_AM_SLAVE ) THEN C -------------------------------------------------- C If I am involved in the solve and if C either C no null space comput (keep(111)=0) and sparse rhs C or C null space computation C then C compute POSINRHSCOMP C endif C C Fwd in facto: in this case only POSINRHSCOMP need be computed C C (POSINRHSCOMP_ROW/COL indirection arrays should C have been allocated once outside loop) C Compute size of RHSCOMP since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize POSINRHSCOMP_ROW/COL C C Note that LD_RHSCOMP and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSCOMP is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE POSINRHSCOMP_ROW/COL C ------------------------------- C IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSCOMP was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSCOMP would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, we do not C need to compute POSINRHSCOMP BUILD_POSINRHSCOMP = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSCOMP C ------------------------ IF (BUILD_POSINRHSCOMP) THEN C -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSCOMP for next iteration in loop C C general case only POSINRHSCOMP is computed BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSCOMP to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSCOMP C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C POSINRHSCOMP_ROW will allow to find the (row) index of a C zero in RHSCOMP before calling DMUMPS_SOL_S. Then C DMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSCOMP MTYPE_LOC = 1 ! (no transpose) C BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSCOMP = .TRUE. ENDIF ENDIF C -- compute POSINRHSCOMP LIW_PASSED=max(1,LIW) IF (KEEP(237).EQ.0) THEN CALL DMUMPS_BUILD_POSINRHSCOMP( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW_PASSED, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & NBENT_RHSCOMP, NB_FS_RHSCOMP_TOT ) NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT ELSE CALL DMUMPS_BUILD_POSINRHSCOMP_AM1( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK,PERM_RHS, size(PERM_RHS) , JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_RHSCOMP_F, NB_FS_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1) THEN C C Prepare symbolic data for sends. C For the moment: MAP_RHS_loc C CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%POSINRHSCOMP_ROW(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN IF (KEEP(221).EQ.1) THEN C we need to save the reduced RHS for all RHS to perform C later the backward phase with an updated reduced RHS C thus we allocate NRHS_NONEMPTY columns in one shot. C Note that RHSCOMP might have been allocated in previous block C and RHSCOMP has been deallocated previous to entering loop on RHS IF (.not. associated(id%RHSCOMP)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSCOMP will not change in the loop C and can be used to dimension RHSCOMP C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. LD_RHSCOMP = max(NBENT_RHSCOMP,1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(id%NRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSCOMP (case of RHSCOMP allocated at each block of RHS) C ------------------ C RHSCOMP allocated per block of maximum size NBRHS LD_RHSCOMP = max(NBENT_RHSCOMP, LD_RHSCOMP) C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSCOMP)) THEN IF ( (id%KEEP8(25).LT.int(LD_RHSCOMP,8)*int(NBRHS,8)) & .OR. (KEEP(235).NE.0).OR.(KEEP(237).NE.0) ) THEN ! deallocate and reallocate if: ! _larger array needed ! OR ! _exploit sparsity/A-1: since size of RHSCOMP ! is expected to vary much in these cases ! this should improve locality NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF IF (.not. associated(id%RHSCOMP)) THEN LD_RHSCOMP = max(NBENT_RHSCOMP, 1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(NBRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF (KEEP(221).EQ.2) THEN C RHSCOMP has been allocated (call with KEEP(221).EQ.1) C even in the case fwd in facto ! Not correct: LD_RHSCOMP = LENRHSCOMP/id%NRHS_NONEMPTY LD_RHSCOMP = int(id%KEEP8(25)/int(id%NRHS,8)) ENDIF C C Shift on RHSCOMP C IF ( KEEP(221).EQ.0 ) THEN C -- RHSCOMP reused in the loop IBEG_RHSCOMP= 1_8 ELSE C Initialize IBEG_RHSCOMP C IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in DMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF C C RHS is set to scaled right hand side C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL DMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) ENDIF C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSCOMP. C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1_8:int(NBRHS_EFF,8)*int(LD_RHSCOMP,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSCOMP to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSCOMP = id%POSINRHSCOMP_ROW(J) C IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_F) C & .AND.(IPOSRHSCOMP.GT.0) ) THEN IF (IPOSRHSCOMP.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc C Note that : C In first entry in column C we have and MUST have already scaled value of diagonal. C This need have been done on master because we do not C have scaling arrays available on slaves. C Furthermore we know that only one entry is C needed the diagonal entry (for the forward with A-1). C id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8)+ & int(IPOSRHSCOMP,8)) = & RHS_SPARSE_COPY(IPOS) ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- reset to zero RHSCOMP for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(LD_RHSCOMP,8) + & IBEG_RHSCOMP - 1_8 id%RHSCOMP(KDEC+1_8:KDEC+NBENT_RHSCOMP) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSCOMP = id%POSINRHSCOMP_ROW(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSCOMP, we can compare to KEEP(89) C to know if RHSCOMP should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSCOMP so we compare to C NB_FS_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to DMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C DMUMPS_RHS must be passed to C DMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSCOMP to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHSCOMP,8) id%RHSCOMP(KDEC+1_8:KDEC+int(LD_RHSCOMP,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%POSINRHSCOMP_ROW(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = & id%DKEEP(2) ELSE ! Symmetric: always set to one id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to DMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSCOMP need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 C ------------------------------------------- C Reserve space at the end of WORK_WCB on the C master of the root node. It will be used to C store the reduced RHS. C ------------------------------------------- IF ( I_AM_SLAVE ) THEN LWCB8_SOL_C = LWCB8 IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_F2003) LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT,kind=8) # else LPTR_RHS_ROOT = int(size(id%root%RHS_CNTR_MASTER_ROOT),8) # endif ELSE C Otherwise, we use workspace in WCB LPTR_RHS_ROOT = int(NBRHS_EFF,8) * int(SIZE_ROOT,8) IPT_RHS_ROOT = LWCB8 - LPTR_RHS_ROOT + 1_8 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 IPT_RHS_ROOT = LWCB8 ! Will be passed, but not accessed PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN C C --- Normal case : we do not exploit sparsity of the RHS C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) PRUNED_SIZE_LOADED = 0_8 ! From DMUMPS_SOL_ES module CALL DMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, IS(1), & LIW_PASSED, WORK_WCB(1), LWCB8_SOL_C, IWCB, LIWCB, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), FROM_PP, & id%STEP(1), id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), & id%PTLUST_S(1), id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, & LIWK_PTRACB, id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1), & KEEP8(1), id%DKEEP(1), id%COMM_NODES, id%MYID, id%MYID_NODES, & BUFR(1), LBUFR, LBUFR_BYTES, id%ISTEP_TO_INIV2(1), & id%TAB_POS_IN_PERE(1,1), IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, & MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1) & , 1, 1, 1, 1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & , 1, 1, NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) ELSE C Exploit sparsity of the RHS (all cases) C Remark that JBEG_RHS is already initialized C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) CALL DMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED,IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,MTYPE,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1),LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1,PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP, id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, JBEG_RHS, id%Step2node(1), & id%KEEP(28),IRHS_SPARSE_COPY(1),IRHS_PTR_COPY(1), size(PERM_RHS), & PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT,NBSPARSE_LOC,PTR_RHS_BOUNDS(1),LPTR_RHS_BOUNDS & ) ENDIF ! end of exploit sparsity (pruning nodes of the tree) END IF C ----------------- C End of slave code C ----------------- C C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_DOUBLE_PRECISION, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ====== END OF REDUCED RHS (Fwd only performed) ====== C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (DMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (MTYPE.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL DMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_COL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL DMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%POSINRHSCOMP_COL(1), id%N, NB_FS_RHSCOMP_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN CALL DMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & NBRHS_EFF, id%POSINRHSCOMP_COL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, & id%STEP(1), scaling_data_sol, LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal ERROR 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0D0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0D0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call DMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL DMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL DMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = dble(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. C Test of convergence should be made IF (( id%MYID .eq. MASTER ).AND.(ICNTL10.GT.0)) THEN TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0D0) THEN ARRET = sqrt(epsilon(0.0D0)) END IF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL DMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL DMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL DMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL DMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL DMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+TIMEEA1 ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL DMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in DMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL DMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=TIMEIT ELSE C IR has been requested id%DKEEP(114)=TIMEIT - id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL DMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL DMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_DOUBLE_PRECISION, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL DMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_DOUBLE_PRECISION, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL DMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL DMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+TIMEEA ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL DMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL DMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+TIMELCOND IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N WRITE(*,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min0(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min0(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO C DO WHILE (BEG_RHS.LE.id%NRHS) C ========================== C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 CYCLE ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSCOMP and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP(int(JBEG_NEW -1,8)*int(LD_RHSCOMP,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=TIME3 id%DKEEP(113)=TIMEC2 id%DKEEP(115)=TIMESCATTER2 id%DKEEP(116)=TIMEGATHER2 id%DKEEP(122)=TIMECOPYSCALE2 C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_DOUBLE_PRECISION, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL DMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL DMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL DMUMPS_BUF_DEALL_CB( IERR ) CALL DMUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN C Free local scaling arrays NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF C Free memory until next call to DMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be saved and is used C in incore to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN C OOC: free space for S that was allocated NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) ENDIF IF (KEEP(221).NE.1) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time to copy/scale dist. solution=',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12 & ) 151 FORMAT (' --- (25) =',I12) 152 FORMAT (' --- (26) =',I12) 153 FORMAT (' --- (32) =',I12) 160 FORMAT (' RHS'/(1X,1P,5D14.6)) 170 FORMAT (/' ERROR ANALYSIS' ) 240 FORMAT (1X, A42,I4) 270 FORMAT (//' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 131 FORMAT (/' END ITERATIVE REFINEMENT ') 141 FORMAT(1X, A52,I4) CONTAINS SUBROUTINE DMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS #if defined(MUMPS_F2003) INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) DOUBLE PRECISION, INTENT( IN ), POINTER :: idRHS_loc (:) #else INTEGER, POINTER :: idIRHS_loc (:) DOUBLE PRECISION, POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_F2003) IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #else IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN C (Warning: this assumes that size(idRHS_loc) C does not overflow) #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_CHECK_DISTRHS SUBROUTINE DMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of DMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in DMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C POSINRHSCOMP_ROW is with respect to the C original linear system (transposed or not) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL ENDIF LIW_PASSED = max( LIW, 1 ) CALL DMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 1, & PTR_POSINRHSCOMP_FWD(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_COL ELSE PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_ROW ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL DMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP,PTR_POSINRHSCOMP_FWD(1),PTR_POSINRHSCOMP_BWD(1), & 1,1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C DMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (SOLVET.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) C Solution computed during DMUMPS_SOL_C has been stored C in id%RHSCOMP and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), ! RHSCOMP not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL DMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & PTR_POSINRHSCOMP_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE DMUMPS_PP_SOLVE END SUBROUTINE DMUMPS_SOLVE_DRIVER MUMPS_5.4.1/src/dmumps_iXamax.F0000664000175000017500000000132714102210522016430 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C INTEGER FUNCTION DMUMPS_IXAMAX(N,X,INCX,GRAIN) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: X(*) INTEGER, intent(in) :: INCX,N INTEGER, intent(in) :: GRAIN INTEGER idamax DMUMPS_IXAMAX = idamax(N,X,INCX) RETURN END FUNCTION DMUMPS_IXAMAX MUMPS_5.4.1/src/dlr_core.F0000664000175000017500000022331014102210525015406 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Note: the last routine of this file, xMUMPS_TRUNCATED_RRQR is derived from C the LAPACK package, for which BSD 3-clause license applies C (see header of the routine). MODULE DMUMPS_LR_CORE USE MUMPS_LR_COMMON USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_LR_DATA_M !$ USE OMP_LIB IMPLICIT NONE CONTAINS SUBROUTINE INIT_LRB(LRB_OUT,K,M,N,ISLR) C This routine simply initializes a LR block but does NOT allocate it C (allocation occurs somewhere else) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N LOGICAL,INTENT(IN) :: ISLR LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR NULLIFY(LRB_OUT%Q) NULLIFY(LRB_OUT%R) END SUBROUTINE INIT_LRB C C SUBROUTINE IS_FRONT_BLR_CANDIDATE(INODE, NIV, NFRONT, NASS, & BLRON, K489, & K490, K491, K492, K20, K60, IDAD, K38, & LRSTATUS, N, LRGROUPS) INTEGER,INTENT(IN) :: INODE, NFRONT, NASS, BLRON, K489, K490, & K491, K492, NIV, K20, K60, IDAD, K38 INTEGER,INTENT(OUT):: LRSTATUS INTEGER, INTENT(IN):: N INTEGER, INTENT(IN), OPTIONAL :: LRGROUPS(N) C C Local variables LOGICAL :: COMPRESS_PANEL, COMPRESS_CB LRSTATUS = 0 COMPRESS_PANEL = .FALSE. IF ((BLRON.NE.0).and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ( (K492.GT.0).and.(K491.LE.NFRONT) & .and.(K490.LE.NASS)))) THEN COMPRESS_PANEL = .TRUE. C Compression for NASS =1 is useless IF (NASS.LE.1) THEN COMPRESS_PANEL =.FALSE. ENDIF IF (present(LRGROUPS)) THEN IF (LRGROUPS (INODE) .LT. 0) COMPRESS_PANEL = .FALSE. ENDIF ENDIF COMPRESS_CB = .FALSE. IF ((BLRON.NE.0).and. & (K489.GT.0.AND.(K489.NE.2.OR.NIV.EQ.2)) & .and.( & ((K492.LT.0).and.INODE.EQ.abs(K492)) & .or. & ((K492.GT.0).AND.(NFRONT-NASS.GT.K491)))) & THEN COMPRESS_CB = .TRUE. ENDIF IF (.NOT.COMPRESS_PANEL) COMPRESS_CB=.FALSE. IF (COMPRESS_PANEL.OR.COMPRESS_CB) THEN IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN LRSTATUS = 1 ELSE IF (COMPRESS_PANEL.AND.(.NOT.COMPRESS_CB)) THEN LRSTATUS = 2 ELSE LRSTATUS = 3 ENDIF ELSE LRSTATUS = 0 ENDIF C C Schur complement cannot be BLR for now C IF ( INODE .EQ. K20 .AND. K60 .NE. 0 ) THEN LRSTATUS = 0 ENDIF C C Do not compress CB of children of root C IF ( IDAD .EQ. K38 .AND. K38 .NE.0 ) THEN COMPRESS_CB = .FALSE. IF (LRSTATUS.GE.2) THEN LRSTATUS = 2 ELSE LRSTATUS = 0 ENDIF ENDIF RETURN END SUBROUTINE IS_FRONT_BLR_CANDIDATE SUBROUTINE ALLOC_LRB(LRB_OUT,K,M,N,ISLR,IFLAG,IERROR,KEEP8) TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K,M,N INTEGER,INTENT(INOUT) :: IFLAG, IERROR LOGICAL,INTENT(IN) :: ISLR INTEGER(8) :: KEEP8(150) INTEGER :: MEM, allocok DOUBLE PRECISION :: ZERO PARAMETER (ZERO = 0.0D0) INTEGER(8) :: KEEP8TMPCOPY, KEEP873COPY LRB_OUT%M = M LRB_OUT%N = N LRB_OUT%K = K LRB_OUT%ISLR = ISLR IF ((M.EQ.0).OR.(N.EQ.0)) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) RETURN ENDIF IF (ISLR) THEN IF (K.EQ.0) THEN nullify(LRB_OUT%Q) nullify(LRB_OUT%R) ELSE allocate(LRB_OUT%Q(M,K),LRB_OUT%R(K,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = K*(M+N) RETURN ENDIF ENDIF ELSE nullify(LRB_OUT%R) allocate(LRB_OUT%Q(M,N),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = M*N RETURN ENDIF ENDIF IF (ISLR) THEN MEM = M*K + N*K ELSE MEM = M*N ENDIF !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF RETURN END SUBROUTINE ALLOC_LRB SUBROUTINE ALLOC_LRB_FROM_ACC(ACC_LRB, LRB_OUT, K, M, N, LorU, & IFLAG, IERROR, KEEP8) TYPE(LRB_TYPE), INTENT(IN) :: ACC_LRB TYPE(LRB_TYPE), INTENT(OUT) :: LRB_OUT INTEGER,INTENT(IN) :: K, M, N, LorU INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER :: I IF (LorU.EQ.1) THEN CALL ALLOC_LRB(LRB_OUT,K,M,N,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:M,I) = ACC_LRB%Q(1:M,I) LRB_OUT%R(I,1:N) = -ACC_LRB%R(I,1:N) ENDDO ELSE CALL ALLOC_LRB(LRB_OUT,K,N,M,.TRUE.,IFLAG,IERROR,KEEP8) IF (IFLAG.LT.0) RETURN DO I=1,K LRB_OUT%Q(1:N,I) = ACC_LRB%R(I,1:N) LRB_OUT%R(I,1:M) = -ACC_LRB%Q(1:M,I) ENDDO ENDIF END SUBROUTINE ALLOC_LRB_FROM_ACC SUBROUTINE REGROUPING2(CUT, NPARTSASS, NASS, & NPARTSCB, NCB, IBCKSZ, ONLYCB, K472) INTEGER, INTENT(IN) :: IBCKSZ, NASS, NCB INTEGER, INTENT(INOUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER, POINTER, DIMENSION(:) :: NEW_CUT INTEGER :: I, INEW, MINSIZE, NEW_NPARTSASS, allocok LOGICAL :: ONLYCB, TRACE INTEGER, INTENT(IN) :: K472 INTEGER :: IBCKSZ2,IFLAG,IERROR ALLOCATE(NEW_CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = max(NPARTSASS,1)+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF CALL COMPUTE_BLR_VCS(K472, IBCKSZ2, IBCKSZ, NASS) MINSIZE = int(IBCKSZ2 / 2) NEW_NPARTSASS = max(NPARTSASS,1) IF (.NOT. ONLYCB) THEN NEW_CUT(1) = 1 INEW = 2 I = 2 DO WHILE (I .LE. NPARTSASS + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. 2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NEW_NPARTSASS = INEW - 1 ENDIF IF (ONLYCB) THEN DO I=1,max(NPARTSASS,1)+1 NEW_CUT(I) = CUT(I) ENDDO ENDIF IF (NCB .EQ. 0) GO TO 50 INEW = NEW_NPARTSASS+2 I = max(NPARTSASS,1) + 2 DO WHILE (I .LE. max(NPARTSASS,1) + NPARTSCB + 1) NEW_CUT(INEW) = CUT(I) TRACE = .FALSE. IF (NEW_CUT(INEW) - NEW_CUT(INEW-1) .GT. MINSIZE) THEN INEW = INEW + 1 TRACE = .TRUE. ENDIF I = I + 1 END DO IF (TRACE) THEN INEW = INEW - 1 ELSE IF (INEW .NE. NEW_NPARTSASS+2) THEN NEW_CUT(INEW-1) = NEW_CUT(INEW) INEW = INEW - 1 ENDIF ENDIF NPARTSCB = INEW - 1 - NEW_NPARTSASS 50 CONTINUE NPARTSASS = NEW_NPARTSASS DEALLOCATE(CUT) ALLOCATE(CUT(NPARTSASS+NPARTSCB+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS+NPARTSCB+1 write(*,*) 'Allocation problem in BLR routine REGROUPING2:', & ' not enough memory? memory requested = ' , IERROR RETURN ENDIF DO I=1,NPARTSASS+NPARTSCB+1 CUT(I) = NEW_CUT(I) ENDDO DEALLOCATE(NEW_CUT) END SUBROUTINE REGROUPING2 SUBROUTINE DMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, LRB, & NIV, SYM, LorU, IW, OFFSET_IW) C ----------- C Parameters C ----------- INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NIV, SYM, LorU, LDA INTEGER(8), intent(in) :: POSELT_LOCAL DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: LRB INTEGER, OPTIONAL:: OFFSET_IW INTEGER, OPTIONAL :: IW(*) C ----------- C Local variables C ----------- INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER :: M, N, I, J DOUBLE PRECISION, POINTER :: LR_BLOCK_PTR(:,:) DOUBLE PRECISION :: ONE, MONE, ZERO DOUBLE PRECISION :: MULT1, MULT2, A11, DETPIV, A22, A12 PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) N = LRB%N IF (LRB%ISLR) THEN M = LRB%K LR_BLOCK_PTR => LRB%R ELSE M = LRB%M LR_BLOCK_PTR => LRB%Q END IF IF (M.NE.0) THEN C Why is it Right, Lower, Tranpose? C Because A is stored by rows C but BLR_L is stored by columns IF (SYM.EQ.0.AND.LorU.EQ.0) THEN CALL dtrsm('R', 'L', 'T', 'N', M, N, ONE, & A(POSELT_LOCAL), NFRONT, & LR_BLOCK_PTR(1,1), M) ELSE CALL dtrsm('R', 'U', 'N', 'U', M, N, ONE, & A(POSELT_LOCAL), LDA, & LR_BLOCK_PTR(1,1), M) IF (LorU.EQ.0) THEN C Now apply D scaling IF (.NOT.present(OFFSET_IW)) THEN write(*,*) 'Internal error in ', & 'DMUMPS_LRTRSM' CALL MUMPS_ABORT() ENDIF DPOS = POSELT_LOCAL I = 1 DO IF(I .GT. N) EXIT IF(IW(OFFSET_IW+I-1) .GT. 0) THEN C 1x1 pivot A11 = ONE/A(DPOS) CALL dscal(M, A11, LR_BLOCK_PTR(1,I), 1) DPOS = DPOS + int(LDA + 1,8) I = I+1 ELSE C 2x2 pivot POSPV1 = DPOS POSPV2 = DPOS+ int(LDA + 1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,M MULT1 = A11*LR_BLOCK_PTR(J,I)+A12*LR_BLOCK_PTR(J,I+1) MULT2 = A12*LR_BLOCK_PTR(J,I)+A22*LR_BLOCK_PTR(J,I+1) LR_BLOCK_PTR(J,I) = MULT1 LR_BLOCK_PTR(J,I+1) = MULT2 ENDDO DPOS = POSPV2 + int(LDA + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF ENDIF CALL UPD_FLOP_TRSM(LRB, LorU) END SUBROUTINE DMUMPS_LRTRSM SUBROUTINE DMUMPS_LRGEMM_SCALING(LRB, SCALED, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, MAXI_CLUSTER) C This routine does the scaling (for the symmetric case) before C computing the LR product (done in DMUMPS_LRGEMM4) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(inout), DIMENSION(:,:) :: SCALED INTEGER,INTENT(IN) :: LD_DIAG, NFRONT, IW2(*) INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER, INTENT(IN) :: MAXI_CLUSTER DOUBLE PRECISION, intent(inout) :: BLOCK(MAXI_CLUSTER) INTEGER :: J, NROWS DOUBLE PRECISION :: PIV1, PIV2, OFFDIAG IF (LRB%ISLR) THEN NROWS = LRB%K ELSE NROWS = LRB%M ENDIF J = 1 DO WHILE (J <= LRB%N) IF (IW2(J) > 0) THEN SCALED(1:NROWS,J) = DIAG(1+LD_DIAG*(J-1)+J-1) & * SCALED(1:NROWS,J) J = J+1 ELSE !2x2 pivot PIV1 = DIAG(1+LD_DIAG*(J-1)+J-1) PIV2 = DIAG(1+LD_DIAG*J+J) OFFDIAG = DIAG(1+LD_DIAG*(J-1)+J) BLOCK(1:NROWS) = SCALED(1:NROWS,J) SCALED(1:NROWS,J) = PIV1 * SCALED(1:NROWS,J) & + OFFDIAG * SCALED(1:NROWS,J+1) SCALED(1:NROWS,J+1) = OFFDIAG * BLOCK(1:NROWS) & + PIV2 * SCALED(1:NROWS,J+1) J=J+2 ENDIF END DO END SUBROUTINE DMUMPS_LRGEMM_SCALING SUBROUTINE DMUMPS_LRGEMM4(ALPHA, & LRB1, LRB2, BETA, & A, LA, POSELTT, NFRONT, SYM, & IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & RANK, BUILDQ, & LUA_ACTIVATED, C Start of OPTIONAL arguments & LorU, & LRB3, MAXI_RANK, & MAXI_CLUSTER, & DIAG, LD_DIAG, IW2, BLOCK & ) C CC TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, SYM, TOL_OPT INTEGER,INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, INTENT(IN), OPTIONAL :: DIAG(*) INTEGER,INTENT(IN), OPTIONAL :: LD_DIAG, IW2(*) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION :: ALPHA,BETA LOGICAL, INTENT(OUT) :: BUILDQ DOUBLE PRECISION, intent(inout), OPTIONAL :: BLOCK(*) INTEGER, INTENT(IN), OPTIONAL :: LorU LOGICAL, INTENT(IN) :: LUA_ACTIVATED INTEGER, INTENT(IN), OPTIONAL :: MAXI_CLUSTER INTEGER, INTENT(IN), OPTIONAL :: MAXI_RANK TYPE(LRB_TYPE), INTENT(INOUT), OPTIONAL :: LRB3 DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: XY_YZ DOUBLE PRECISION, ALLOCATABLE, TARGET, DIMENSION(:,:) :: XQ, R_Y DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: X, Y, Y1, Y2, Z CHARACTER(len=1) :: SIDE, TRANSY INTEGER :: K_XY, K_YZ, LDY, LDY1, LDY2, K_Y INTEGER :: LDXY_YZ, SAVE_K INTEGER :: I, J, RANK, MAXRANK, INFO, LWORK DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:), & Y_RRQR(:,:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: allocok, MREQ DOUBLE PRECISION, EXTERNAL ::dnrm2 DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (LRB1%M.EQ.0) THEN RETURN ENDIF IF (LRB2%M.EQ.0) THEN ENDIF RANK = 0 BUILDQ = .FALSE. IF (LRB1%ISLR.AND.LRB2%ISLR) THEN IF ((LRB1%K.EQ.0).OR.(LRB2%K.EQ.0)) THEN GOTO 1200 ENDIF allocate(Y(LRB1%K,LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K GOTO 1570 ENDIF X => LRB1%Q K_Y = LRB1%N IF (SYM .EQ. 0) THEN Y1 => LRB1%R ELSE allocate(Y1(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y1(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB1, Y1, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY1 = LRB1%K Z => LRB2%Q Y2 => LRB2%R LDY2 = LRB2%K CALL dgemm('N', 'T', LRB1%K, LRB2%K, K_Y, ONE, & Y1(1,1), LDY1, Y2(1,1), LDY2, ZERO, Y(1,1), LRB1%K ) IF (MIDBLK_COMPRESS.GE.1) THEN LWORK = LRB2%K*(LRB2%K+1) allocate(Y_RRQR(LRB1%K,LRB2%K), & WORK_RRQR(LWORK), RWORK_RRQR(2*LRB2%K), & TAU_RRQR(MIN(LRB1%K,LRB2%K)), & JPVT_RRQR(LRB2%K),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB2%K + LWORK + 2*LRB2%K + & MIN(LRB1%K,LRB2%K) + LRB2%K GOTO 1570 ENDIF DO J=1,LRB2%K DO I=1,LRB1%K Y_RRQR(I,J) = Y(I,J) ENDDO ENDDO MAXRANK = MIN(LRB1%K, LRB2%K)-1 MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(LRB1%K, LRB2%K, Y_RRQR(1,1), & LRB1%K, JPVT_RRQR, TAU_RRQR, WORK_RRQR, & LRB2%K, RWORK_RRQR, TOLEPS, TOL_OPT, RANK, & MAXRANK, INFO) IF (RANK.GT.MAXRANK) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) BUILDQ = .FALSE. ELSE BUILDQ = .TRUE. ENDIF IF (BUILDQ) THEN IF (RANK.EQ.0) THEN deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) deallocate(Y) nullify(Y) C GOTO 1580 not ok because BUILDQ .EQV. true C would try to free XQ and R_Y that are not allocated C in that case. So we free Y1 now if it was allocated. IF (SYM .NE. 0) deallocate(Y1) GOTO 1200 ELSE allocate(XQ(LRB1%M,RANK), R_Y(RANK,LRB2%K), & stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*RANK + RANK*LRB2%K GOTO 1570 ENDIF DO J=1, LRB2%K R_Y(1:MIN(RANK,J),JPVT_RRQR(J)) = & Y_RRQR(1:MIN(RANK,J),J) IF(J.LT.RANK) R_Y(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO C LWORK=LRB2%K*(LRB2%K+1), with LRB2%K>RANK C large enough for dorgqr CALL dorgqr & (LRB1%K, RANK, RANK, Y_RRQR(1,1), & LRB1%K, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) CALL dgemm('N', 'N', LRB1%M, RANK, LRB1%K, ONE, & X(1,1), LRB1%M, Y_RRQR(1,1), LRB1%K, ZERO, & XQ(1,1), LRB1%M) deallocate(Y_RRQR, WORK_RRQR, RWORK_RRQR, TAU_RRQR, & JPVT_RRQR) nullify(X) X => XQ K_XY = RANK deallocate(Y) nullify(Y) Y => R_Y LDY = RANK K_YZ = LRB2%K TRANSY = 'N' SIDE = 'R' ENDIF ENDIF ENDIF IF (.NOT.BUILDQ) THEN LDY = LRB1%K K_XY = LRB1%K K_YZ = LRB2%K TRANSY = 'N' IF (LRB1%K .GE. LRB2%K) THEN SIDE = 'L' ELSE SIDE = 'R' ENDIF ENDIF ENDIF IF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (LRB1%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'R' K_XY = LRB1%K TRANSY = 'N' Z => LRB2%Q X => LRB1%Q LDY = LRB1%K IF (SYM .EQ. 0) THEN Y => LRB1%R ELSE allocate(Y(LRB1%K,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%K*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%K Y(I,J) = LRB1%R(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB1, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF K_YZ = LRB2%N ENDIF IF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (LRB2%K.EQ.0) THEN GOTO 1200 ENDIF SIDE = 'L' K_YZ = LRB2%K X => LRB1%Q TRANSY = 'T' K_XY = LRB1%N IF (SYM .EQ. 0) THEN Y => LRB2%R ELSE allocate(Y(LRB2%K,LRB2%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB2%K*LRB2%N GOTO 1570 ENDIF DO J=1,LRB2%N DO I=1,LRB2%K Y(I,J) = LRB2%R(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB2, Y, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF LDY = LRB2%K Z => LRB2%Q ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .EQ. 0) THEN X => LRB1%Q ELSE allocate(X(LRB1%M,LRB1%N),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*LRB1%N GOTO 1570 ENDIF DO J=1,LRB1%N DO I=1,LRB1%M X(I,J) = LRB1%Q(I,J) ENDDO ENDDO CALL DMUMPS_LRGEMM_SCALING(LRB1, X, A, LA, DIAG, & LD_DIAG, IW2, POSELTT, NFRONT, BLOCK, & MAXI_CLUSTER) ENDIF SIDE = 'N' Z => LRB2%Q K_XY = LRB1%N ENDIF IF (LUA_ACTIVATED) THEN SAVE_K = LRB3%K IF (SIDE == 'L') THEN LRB3%K = LRB3%K+K_YZ ELSEIF (SIDE == 'R') THEN LRB3%K = LRB3%K+K_XY ENDIF ENDIF IF (SIDE == 'L') THEN ! LEFT: XY_YZ = X*Y; A = XY_YZ*Z IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(LRB1%M,K_YZ),stat=allocok) IF (allocok > 0) THEN MREQ = LRB1%M*K_YZ GOTO 1570 ENDIF LDXY_YZ = LRB1%M ELSE IF (SAVE_K+K_YZ.GT.MAXI_RANK) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 1a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_YZ,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%M.NE.LRB1%M) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 1b', & 'LRB1%M =/= LRB3%M',LRB1%M,LRB3%M CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%Q(1:LRB1%M,SAVE_K+1:SAVE_K+K_YZ) LDXY_YZ = MAXI_CLUSTER DO I=1,K_YZ LRB3%R(SAVE_K+I,1:LRB2%M) = Z(1:LRB2%M,I) ENDDO ENDIF CALL dgemm('N', TRANSY, LRB1%M, K_YZ, K_XY, ONE, & X(1,1), LRB1%M, Y(1,1), LDY, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL dgemm('N', 'T', LRB1%M, LRB2%M, K_YZ, ALPHA, & XY_YZ(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, & A(POSELTT), NFRONT) deallocate(XY_YZ) ENDIF ELSEIF (SIDE == 'R') THEN ! RIGHT: XY_YZ = Y*Z; A = X*XY_YZ IF (.NOT.LUA_ACTIVATED) THEN allocate(XY_YZ(K_XY,LRB2%M),stat=allocok) IF (allocok > 0) THEN MREQ = K_XY*LRB2%M GOTO 1570 ENDIF LDXY_YZ = K_XY ELSE IF (SAVE_K+K_XY.GT.MAXI_RANK) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 2a', & 'K_ACC+K_CUR>K_MAX:',SAVE_K,K_XY,MAXI_RANK CALL MUMPS_ABORT() ENDIF IF (LRB3%N.NE.LRB2%M) THEN write(*,*) 'Internal error in DMUMPS_LRGEMM4 2b', & 'LRB2%M =/= LRB3%N',LRB2%M,LRB3%N CALL MUMPS_ABORT() ENDIF XY_YZ => LRB3%R(SAVE_K+1:SAVE_K+K_XY,1:LRB2%M) LDXY_YZ = MAXI_RANK DO I=1,K_XY LRB3%Q(1:LRB1%M,SAVE_K+I) = X(1:LRB1%M,I) ENDDO ENDIF CALL dgemm(TRANSY, 'T', K_XY, LRB2%M, K_YZ, ONE, & Y(1,1), LDY, Z(1,1), LRB2%M, ZERO, XY_YZ(1,1), & LDXY_YZ) IF (.NOT.LUA_ACTIVATED) THEN CALL dgemm('N', 'N', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, XY_YZ(1,1), K_XY, BETA, A(POSELTT), & NFRONT) deallocate(XY_YZ) ENDIF ELSE ! SIDE == 'N' : NONE; A = X*Z CALL dgemm('N', 'T', LRB1%M, LRB2%M, K_XY, ALPHA, & X(1,1), LRB1%M, Z(1,1), LRB2%M, BETA, A(POSELTT), & NFRONT) ENDIF GOTO 1580 1570 CONTINUE C Alloc NOT ok!! IFLAG = -13 IERROR = MREQ RETURN 1580 CONTINUE C Alloc ok!! IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(X) ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN IF (SYM .NE. 0) deallocate(Y) ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN IF (SYM .NE. 0) deallocate(Y) ELSE IF (SYM .NE. 0) deallocate(Y1) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN deallocate(XQ) deallocate(R_Y) ELSE deallocate(Y) ENDIF ENDIF 1200 CONTINUE END SUBROUTINE DMUMPS_LRGEMM4 SUBROUTINE DMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, LorU, & COUNT_FLOPS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK INTEGER(8), INTENT(IN) :: POSELTT LOGICAL, OPTIONAL :: COUNT_FLOPS LOGICAL :: COUNT_FLOPS_LOC INTEGER :: LorU DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (present(COUNT_FLOPS)) THEN COUNT_FLOPS_LOC=COUNT_FLOPS ELSE COUNT_FLOPS_LOC=.TRUE. ENDIF CALL dgemm('N', 'N', ACC_LRB%M, ACC_LRB%N, ACC_LRB%K, & MONE, ACC_LRB%Q(1,1), MAXI_CLUSTER, ACC_LRB%R(1,1), & MAXI_RANK, ONE, A(POSELTT), NFRONT) ACC_LRB%K = 0 END SUBROUTINE DMUMPS_DECOMPRESS_ACC SUBROUTINE DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & TOLEPS, TOL_OPT, KPERCENT, BUILDQ, LorU, CB_COMPRESS) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, LorU, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT INTEGER(8), INTENT(IN) :: POSELTT DOUBLE PRECISION, intent(in) :: TOLEPS LOGICAL, INTENT(OUT) :: BUILDQ LOGICAL, INTENT(IN) :: CB_COMPRESS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK, MAXRANK, LWORK INTEGER :: I, J, M, N INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) M = ACC_LRB%M N = ACC_LRB%N MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) LWORK = N*(N+1) allocate(WORK_RRQR(LWORK), RWORK_RRQR(2*N), & TAU_RRQR(N), & JPVT_RRQR(N), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK +4 *N GOTO 100 ENDIF DO I=1,N ACC_LRB%Q(1:M,I)= & - A(POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8) + int(M-1,8) ) END DO JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(M, N, ACC_LRB%Q(1,1), & MAXI_CLUSTER, JPVT_RRQR(1), TAU_RRQR(1), & WORK_RRQR(1), & N, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK, MAXRANK, INFO) BUILDQ = (RANK.LE.MAXRANK) IF (BUILDQ) THEN DO J=1, N ACC_LRB%R(1:MIN(RANK,J),JPVT_RRQR(J)) = & ACC_LRB%Q(1:MIN(RANK,J),J) IF(J.LT.RANK) ACC_LRB%R(MIN(RANK,J)+1: & RANK,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (M, RANK, RANK, ACC_LRB%Q(1,1), & MAXI_CLUSTER, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO I=1,N A( POSELTT+int(I-1,8)*int(NFRONT,8) : & POSELTT+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) = ZERO END DO ACC_LRB%K = RANK CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ELSE ACC_LRB%K = RANK ACC_LRB%ISLR = .FALSE. CALL UPD_FLOP_COMPRESS(ACC_LRB, CB_COMPRESS=CB_COMPRESS) ACC_LRB%ISLR = .TRUE. ACC_LRB%K = 0 ENDIF deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & DMUMPS_COMPRESS_FR_UPDATES: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE DMUMPS_COMPRESS_FR_UPDATES SUBROUTINE DMUMPS_RECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER :: IFLAG, IERROR INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:), TARGET :: Q1, R1, & Q2, R2 INTEGER, ALLOCATABLE :: JPVT_RRQR(:) TYPE(LRB_TYPE) :: LRB1, LRB2 INTEGER :: INFO, RANK1, RANK2, RANK, MAXRANK, LWORK LOGICAL :: BUILDQ, BUILDQ1, BUILDQ2, SKIP1, SKIP2 INTEGER :: I, J, M, N, K INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) SKIP1 = .FALSE. SKIP2 = .FALSE. SKIP1 = .TRUE. 1500 CONTINUE M = ACC_LRB%M N = ACC_LRB%N K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) IF (.FALSE.) THEN CALL DMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, & NEW_ACC_RANK) K = ACC_LRB%K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) SKIP1 = .TRUE. SKIP2 = K.EQ.0 ENDIF IF (SKIP1.AND.SKIP2) GOTO 1600 allocate(Q1(M,K), Q2(N,K), & WORK_RRQR(LWORK), & RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = LWORK + M*N + N*K+ 4 * K GOTO 100 ENDIF IF (SKIP1) THEN BUILDQ1 = .FALSE. ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, RANK1, & MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) ENDIF IF (BUILDQ1) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF IF (SKIP2) THEN BUILDQ2 = .FALSE. ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(N, K, Q2(1,1), & N, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK2, MAXRANK, INFO) BUILDQ2 = (RANK2.LE.MAXRANK) ENDIF IF (BUILDQ2) THEN allocate(R2(RANK2,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK2*K GOTO 100 ENDIF DO J=1, K R2(1:MIN(RANK2,J),JPVT_RRQR(J)) = & Q2(1:MIN(RANK2,J),J) IF(J.LT.RANK2) R2(MIN(RANK2,J)+1: & RANK2,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (N, RANK2, RANK2, Q2(1,1), & N, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) ENDIF CALL INIT_LRB(LRB1,RANK1,M,K,BUILDQ1) CALL INIT_LRB(LRB2,RANK2,N,K,BUILDQ2) IF (BUILDQ1.OR.BUILDQ2) THEN IF (BUILDQ1) THEN LRB1%R => R1 ELSE DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J) ENDDO ENDDO ENDIF LRB1%Q => Q1 IF (BUILDQ2) THEN LRB2%R => R2 ELSE DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J,I) ENDDO ENDDO ENDIF LRB2%Q => Q2 ACC_LRB%K = 0 CALL DMUMPS_LRGEMM4(MONE, LRB1, LRB2, ONE, & A, LA, POSELTT, NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS-1, TOLEPS, TOL_OPT, & KPERCENT_RMB, & RANK, BUILDQ, .TRUE., LRB3=ACC_LRB, & MAXI_RANK=MAXI_RANK, MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS-1, RANK, BUILDQ, & .TRUE., .FALSE., REC_ACC=.TRUE.) ENDIF IF (.NOT. SKIP1) & CALL UPD_FLOP_COMPRESS(LRB1, REC_ACC=.TRUE.) IF (.NOT. SKIP2) & CALL UPD_FLOP_COMPRESS(LRB2, REC_ACC=.TRUE.) deallocate(Q1,Q2) IF (BUILDQ1) deallocate(R1) IF (BUILDQ2) deallocate(R2) deallocate(JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) IF (SKIP1.AND.(RANK2.GT.0)) THEN SKIP1 = .FALSE. SKIP2 = .TRUE. GOTO 1500 ENDIF 1600 CONTINUE NEW_ACC_RANK = 0 RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & DMUMPS_RECOMPRESS_ACC: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE DMUMPS_RECOMPRESS_ACC RECURSIVE SUBROUTINE DMUMPS_RECOMPRESS_ACC_NARYTREE( & ACC_LRB, MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, & KPERCENT_LUA, K478, RANK_LIST, POS_LIST, NB_NODES, & LEVEL, ACC_TMP) TYPE(LRB_TYPE),TARGET,INTENT(INOUT) :: ACC_LRB TYPE(LRB_TYPE),TARGET,INTENT(INOUT),OPTIONAL :: ACC_TMP INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER(8), INTENT(IN) :: POSELTT INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS INTEGER,INTENT(IN) :: K478, NB_NODES, LEVEL INTEGER,INTENT(INOUT) :: RANK_LIST(NB_NODES), POS_LIST(NB_NODES) TYPE(LRB_TYPE) :: LRB, ACC_NEW TYPE(LRB_TYPE), POINTER :: LRB_PTR LOGICAL :: RESORT INTEGER :: I, J, M, N, L, NODE_RANK, NARY, IOFF, IMAX, CURPOS INTEGER :: NB_NODES_NEW, KTOT, NEW_ACC_RANK INTEGER, ALLOCATABLE :: RANK_LIST_NEW(:), POS_LIST_NEW(:) DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) INTEGER :: allocok RESORT = .FALSE. M = ACC_LRB%M N = ACC_LRB%N NARY = -K478 IOFF = 0 NB_NODES_NEW = NB_NODES/NARY IF (NB_NODES_NEW*NARY.NE.NB_NODES) THEN NB_NODES_NEW = NB_NODES_NEW + 1 ENDIF ALLOCATE(RANK_LIST_NEW(NB_NODES_NEW),POS_LIST_NEW(NB_NODES_NEW), & stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of RANK_LIST_NEW/POS_LIST_NEW ', & 'in DMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF DO J=1,NB_NODES_NEW NODE_RANK = RANK_LIST(IOFF+1) CURPOS = POS_LIST(IOFF+1) IMAX = MIN(NARY,NB_NODES-IOFF) IF (IMAX.GE.2) THEN DO I=2,IMAX IF (POS_LIST(IOFF+I).NE.CURPOS+NODE_RANK) THEN DO L=0,RANK_LIST(IOFF+I)-1 ACC_LRB%Q(1:M,CURPOS+NODE_RANK+L) = & ACC_LRB%Q(1:M,POS_LIST(IOFF+I)+L) ACC_LRB%R(CURPOS+NODE_RANK+L,1:N) = & ACC_LRB%R(POS_LIST(IOFF+I)+L,1:N) ENDDO POS_LIST(IOFF+I) = CURPOS+NODE_RANK ENDIF NODE_RANK = NODE_RANK+RANK_LIST(IOFF+I) ENDDO CALL INIT_LRB(LRB,NODE_RANK,M,N,.TRUE.) IF (.NOT.RESORT.OR.LEVEL.EQ.0) THEN LRB%Q => ACC_LRB%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_LRB%R(CURPOS:CURPOS+NODE_RANK,1:N) ELSE LRB%Q => ACC_TMP%Q(1:M,CURPOS:CURPOS+NODE_RANK) LRB%R => ACC_TMP%R(CURPOS:CURPOS+NODE_RANK,1:N) ENDIF NEW_ACC_RANK = NODE_RANK-RANK_LIST(IOFF+1) IF (NEW_ACC_RANK.GT.0) THEN CALL DMUMPS_RECOMPRESS_ACC(LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF RANK_LIST_NEW(J) = LRB%K POS_LIST_NEW(J) = CURPOS ELSE RANK_LIST_NEW(J) = NODE_RANK POS_LIST_NEW(J) = CURPOS ENDIF IOFF = IOFF+IMAX ENDDO IF (NB_NODES_NEW.GT.1) THEN IF (RESORT) THEN KTOT = SUM(RANK_LIST_NEW) CALL INIT_LRB(ACC_NEW,KTOT,M,N,.TRUE.) ALLOCATE(ACC_NEW%Q(MAXI_CLUSTER,MAXI_RANK), & ACC_NEW%R(MAXI_RANK,MAXI_CLUSTER), stat=allocok) IF (allocok > 0) THEN write(*,*) 'Allocation error of ACC_NEW%Q/ACC_NEW%R ', & 'in DMUMPS_RECOMPRESS_ACC_NARYTREE' call MUMPS_ABORT() ENDIF CALL MUMPS_SORT_INT(NB_NODES_NEW, RANK_LIST_NEW, & POS_LIST_NEW) CURPOS = 1 IF (LEVEL.EQ.0) THEN LRB_PTR => ACC_LRB ELSE LRB_PTR => ACC_TMP ENDIF DO J=1,NB_NODES_NEW DO L=0,RANK_LIST_NEW(J)-1 ACC_NEW%Q(1:M,CURPOS+L) = & LRB_PTR%Q(1:M,POS_LIST_NEW(J)+L) ACC_NEW%R(CURPOS+L,1:N) = & LRB_PTR%R(POS_LIST_NEW(J)+L,1:N) ENDDO POS_LIST_NEW(J) = CURPOS CURPOS = CURPOS + RANK_LIST_NEW(J) ENDDO IF (LEVEL.GT.0) THEN CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, & LEVEL+1, ACC_NEW) ELSE CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELTT, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST_NEW, POS_LIST_NEW, NB_NODES_NEW, LEVEL+1) ENDIF ELSE IF (POS_LIST_NEW(1).NE.1) THEN write(*,*) 'Internal error in ', & 'DMUMPS_RECOMPRESS_ACC_NARYTREE', POS_LIST_NEW(1) ENDIF ACC_LRB%K = RANK_LIST_NEW(1) IF (RESORT.AND.LEVEL.GT.0) THEN DO L=1,ACC_LRB%K DO I=1,M ACC_LRB%Q(I,L) = ACC_TMP%Q(I,L) ENDDO DO I=1,N ACC_LRB%R(L,I) = ACC_TMP%R(L,I) ENDDO ENDDO CALL DEALLOC_LRB(ACC_TMP, KEEP8) ENDIF ENDIF DEALLOCATE(RANK_LIST_NEW, POS_LIST_NEW) END SUBROUTINE DMUMPS_RECOMPRESS_ACC_NARYTREE SUBROUTINE DMUMPS_RECOMPRESS_ACC_V2(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELTT, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) TYPE(LRB_TYPE),INTENT(INOUT) :: ACC_LRB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER,INTENT(IN) :: NFRONT, NIV, TOL_OPT INTEGER,INTENT(IN) :: MAXI_CLUSTER, MAXI_RANK, KPERCENT_LUA INTEGER,INTENT(INOUT) :: NEW_ACC_RANK INTEGER(8), INTENT(IN) :: POSELTT INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION, intent(in) :: TOLEPS DOUBLE PRECISION, ALLOCATABLE :: RWORK_RRQR(:) DOUBLE PRECISION, ALLOCATABLE :: WORK_RRQR(:), TAU_RRQR(:) DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:), TARGET :: & Q1, R1, Q2, PROJ INTEGER, ALLOCATABLE :: JPVT_RRQR(:) INTEGER :: INFO, RANK1, MAXRANK, LWORK LOGICAL :: BUILDQ1 INTEGER :: I, J, M, N, K, K1 INTEGER :: allocok, MREQ DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) M = ACC_LRB%M N = ACC_LRB%N K = NEW_ACC_RANK K1 = ACC_LRB%K - K MAXRANK = K-1 MAXRANK = max (1, int((MAXRANK*KPERCENT_LUA/100))) LWORK = K*(K+1) allocate(Q1(M,K), PROJ(K1, K), & WORK_RRQR(LWORK), RWORK_RRQR(2*K), & TAU_RRQR(K), & JPVT_RRQR(K), stat=allocok) IF (allocok > 0) THEN MREQ = M * K + K1 * K + LWORK + 4 * K GOTO 100 ENDIF DO J=1,K DO I=1,M Q1(I,J) = ACC_LRB%Q(I,J+K1) ENDDO ENDDO CALL dgemm('T', 'N', K1, K, M, ONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, Q1(1,1), M, ZERO, PROJ(1,1), K1) CALL dgemm('N', 'N', M, K, K1, MONE, ACC_LRB%Q(1,1), & MAXI_CLUSTER, PROJ(1,1), K1, ONE, Q1(1,1), M) JPVT_RRQR = 0 CALL DMUMPS_TRUNCATED_RRQR(M, K, Q1(1,1), & M, JPVT_RRQR(1), TAU_RRQR(1), WORK_RRQR(1), & K, RWORK_RRQR(1), TOLEPS, TOL_OPT, & RANK1, MAXRANK, INFO) BUILDQ1 = (RANK1.LE.MAXRANK) IF (BUILDQ1) THEN allocate(Q2(N,K), stat=allocok) IF (allocok > 0) THEN MREQ = N*K GOTO 100 ENDIF DO J=1,K DO I=1,N Q2(I,J) = ACC_LRB%R(J+K1,I) ENDDO ENDDO CALL dgemm('N', 'T', K1, N, K, ONE, PROJ(1,1), K1, & Q2(1,1), N, ONE, ACC_LRB%R(1,1), MAXI_RANK) IF (RANK1.GT.0) THEN allocate(R1(RANK1,K), stat=allocok) IF (allocok > 0) THEN MREQ = RANK1*K GOTO 100 ENDIF DO J=1, K R1(1:MIN(RANK1,J),JPVT_RRQR(J)) = & Q1(1:MIN(RANK1,J),J) IF(J.LT.RANK1) R1(MIN(RANK1,J)+1: & RANK1,JPVT_RRQR(J))= ZERO END DO CALL dorgqr & (M, RANK1, RANK1, Q1(1,1), & M, TAU_RRQR(1), & WORK_RRQR(1), LWORK, INFO ) DO J=1,K DO I=1,M ACC_LRB%Q(I,J+K1) = Q1(I,J) ENDDO ENDDO CALL dgemm('N', 'T', RANK1, N, K, ONE, R1(1,1), RANK1, & Q2(1,1), N, ZERO, ACC_LRB%R(K1+1,1), MAXI_RANK) deallocate(R1) ENDIF deallocate(Q2) ACC_LRB%K = K1 + RANK1 ENDIF deallocate(PROJ) deallocate(Q1, JPVT_RRQR, TAU_RRQR, WORK_RRQR, RWORK_RRQR) RETURN 100 CONTINUE C Alloc NOT ok!! write(*,*) 'Allocation problem in BLR routine & DMUMPS_RECOMPRESS_ACC_V2: ', & 'not enough memory? memory requested = ' , MREQ CALL MUMPS_ABORT() RETURN END SUBROUTINE DMUMPS_RECOMPRESS_ACC_V2 SUBROUTINE MAX_CLUSTER(CUT,CUT_SIZE,MAXI_CLUSTER) INTEGER, intent(in) :: CUT_SIZE INTEGER, intent(out) :: MAXI_CLUSTER INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I MAXI_CLUSTER = 0 DO I = 1, CUT_SIZE IF (CUT(I+1) - CUT(I) .GE. MAXI_CLUSTER) THEN MAXI_CLUSTER = CUT(I+1) - CUT(I) END IF END DO END SUBROUTINE MAX_CLUSTER SUBROUTINE DMUMPS_GET_LUA_ORDER(NB_BLOCKS, ORDER, RANK, IWHANDLER, & SYM, FS_OR_CB, I, J, FRFR_UPDATES, & LBANDSLAVE_IN, K474, BLR_U_COL) C ----------- C Parameters C ----------- INTEGER, INTENT(IN) :: NB_BLOCKS, IWHANDLER, SYM, FS_OR_CB, I, J INTEGER, INTENT(OUT) :: ORDER(NB_BLOCKS), RANK(NB_BLOCKS), & FRFR_UPDATES LOGICAL, OPTIONAL, INTENT(IN) :: LBANDSLAVE_IN INTEGER, OPTIONAL, INTENT(IN) :: K474 TYPE(LRB_TYPE), POINTER, OPTIONAL :: BLR_U_COL(:) C ----------- C Local variables C ----------- INTEGER :: K, IND_L, IND_U LOGICAL :: LBANDSLAVE TYPE(LRB_TYPE), POINTER :: BLR_L(:), BLR_U(:) IF (PRESENT(LBANDSLAVE_IN)) THEN LBANDSLAVE = LBANDSLAVE_IN ELSE LBANDSLAVE = .FALSE. ENDIF IF ((SYM.NE.0).AND.(FS_OR_CB.EQ.0).AND.(J.NE.0)) THEN write(6,*) 'Internal error in DMUMPS_GET_LUA_ORDER', & 'SYM, FS_OR_CB, J = ',SYM,FS_OR_CB,J CALL MUMPS_ABORT() ENDIF FRFR_UPDATES = 0 DO K = 1, NB_BLOCKS ORDER(K) = K IF (FS_OR_CB.EQ.0) THEN ! FS IF (J.EQ.0) THEN ! L panel IND_L = NB_BLOCKS+I-K IND_U = NB_BLOCKS+1-K ELSE ! U panel IND_L = NB_BLOCKS+1-K IND_U = NB_BLOCKS+I-K ENDIF ELSE ! CB IND_L = I-K IND_U = J-K ENDIF IF (LBANDSLAVE) THEN IND_L = I IF (K474.GE.2) THEN IND_U = K ENDIF ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, ! L Panel & K, BLR_L) IF (SYM.EQ.0) THEN IF (LBANDSLAVE.AND.K474.GE.2) THEN BLR_U => BLR_U_COL ELSE CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, ! L Panel & K, BLR_U) ENDIF ELSE BLR_U => BLR_L ENDIF IF (BLR_L(IND_L)%ISLR) THEN IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = min(BLR_L(IND_L)%K, BLR_U(IND_U)%K) ELSE RANK(K) = BLR_L(IND_L)%K ENDIF ELSE IF (BLR_U(IND_U)%ISLR) THEN RANK(K) = BLR_U(IND_U)%K ELSE RANK(K) = -1 FRFR_UPDATES = FRFR_UPDATES + 1 ENDIF ENDIF ENDDO CALL MUMPS_SORT_INT(NB_BLOCKS, RANK, ORDER) END SUBROUTINE DMUMPS_GET_LUA_ORDER SUBROUTINE DMUMPS_BLR_ASM_NIV1 (A, LA, POSEL1, NFRONT, NASS1, & IWHANDLER, SON_IW, LIW, LSTK, NELIM, K1, K2, SYM, & KEEP, KEEP8, OPASSW) C C Purpose C ======= C C Called by a level 1 master assembling the contribution C block of a level 1 son that has been BLR-compressed C C C Parameters C ========== C INTEGER(8) :: LA, POSEL1 INTEGER :: LIW, NFRONT, NASS1, LSTK, NELIM, K1, K2, IWHANDLER DOUBLE PRECISION :: A(LA) C INTEGER :: SON_IW(LIW) INTEGER :: SON_IW(:) ! contiguity information lost but no copy INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER :: SYM DOUBLE PRECISION, INTENT(INOUT) :: OPASSW C C Local variables C =============== C DOUBLE PRECISION, ALLOCATABLE :: SON_A(:) INTEGER(8) :: APOS, SON_APOS, IACHK, JJ2, NFRONT8 INTEGER :: KK, KK1, allocok, SON_LA TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:), LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC INTEGER :: NB_INCB, NB_INASM, NB_BLR, I, J, M, N, II, NPIV, & IBIS, IBIS_END, FIRST_ROW, LAST_ROW, FIRST_COL, LAST_COL, & SON_LDA DOUBLE PRECISION :: PROMOTE_COST DOUBLE PRECISION :: ONE, ZERO PARAMETER (ONE = 1.0D0) PARAMETER (ZERO = 0.0D0) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IWHANDLER, & BEGS_BLR_DYNAMIC) CALL DMUMPS_BLR_RETRIEVE_CB_LRB(IWHANDLER, CB_LRB) NB_BLR = size(BEGS_BLR_DYNAMIC)-1 NB_INCB = size(CB_LRB,1) NB_INASM = NB_BLR - NB_INCB NPIV = BEGS_BLR_DYNAMIC(NB_INASM+1)-1 NFRONT8 = int(NFRONT,8) IF (SYM.EQ.0) THEN IBIS_END = NB_INCB*NB_INCB ELSE IBIS_END = NB_INCB*(NB_INCB+1)/2 ENDIF #if defined(BLR_MT) !$OMP PARALLEL !$OMP DO PRIVATE(IBIS, I, J, M, N, SON_LA, SON_LDA, FIRST_ROW, !$OMP& LAST_ROW, FIRST_COL, LAST_COL, LRB, SON_A, II, KK, !$OMP& APOS, IACHK, KK1, JJ2, PROMOTE_COST, allocok, SON_APOS) #endif DO IBIS = 1,IBIS_END C Determining I,J from IBIS IF (SYM.EQ.0) THEN I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB ELSE I = ceiling((1.0D0+sqrt(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF I = I+NB_INASM J = J+NB_INASM IF (I.EQ.NB_INASM+1) THEN C first CB block, add NELIM because FIRST_ROW starts at NELIM+1 FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV+NELIM ELSE FIRST_ROW = BEGS_BLR_DYNAMIC(I)-NPIV ENDIF LAST_ROW = BEGS_BLR_DYNAMIC(I+1)-1-NPIV M=LAST_ROW-FIRST_ROW+1 FIRST_COL = BEGS_BLR_DYNAMIC(J)-NPIV LAST_COL = BEGS_BLR_DYNAMIC(J+1)-1-NPIV N = BEGS_BLR_DYNAMIC(J+1)-BEGS_BLR_DYNAMIC(J) SON_APOS = 1_8 SON_LA = M*N SON_LDA = N LRB => CB_LRB(I-NB_INASM,J-NB_INASM) IF (LRB%ISLR.AND.LRB%K.EQ.0) THEN C No need to perform extend-add CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) CYCLE ENDIF allocate(SON_A(SON_LA),stat=allocok) IF (allocok.GT.0) THEN write(*,*) 'Not enough memory in DMUMPS_BLR_ASM_NIV1', & ", Memory requested = ", SON_LA CALL MUMPS_ABORT() ENDIF C decompress block IF (LRB%ISLR) THEN CALL dgemm('T', 'T', N, M, LRB%K, ONE, LRB%R(1,1), LRB%K, & LRB%Q(1,1), M, ZERO, SON_A(SON_APOS), SON_LDA) PROMOTE_COST = 2.0D0*M*N*LRB%K CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSE IF (I.EQ.J.AND.SYM.NE.0) THEN C Diag block and LDLT, copy only lower half IF (J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C The first diagonal block is rectangular !! C with NELIM more cols than rows DO II=1,M DO KK=1,II+NELIM SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ELSE DO II=1,M DO KK=1,II SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ELSE DO II=1,M DO KK=1,N SON_A(SON_APOS+int(II-1,8)*int(SON_LDA,8) + & int(KK-1,8)) & = LRB%Q(II,KK) ENDDO ENDDO ENDIF ENDIF C Deallocate block CALL DEALLOC_LRB(LRB, KEEP8) NULLIFY(LRB) C extend add in father IF (SYM.NE.0.AND.J-NB_INASM.EQ.1.AND.NELIM.GT.0) THEN C Case of LDLT with NELIM: first-block column is treated C differently as the NELIM are assembled at the end of the C father DO KK = FIRST_ROW, LAST_ROW IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (SON_IW(KK+K1-1).LE.NASS1) THEN C Fully summed row of the father => permute destination in C father, symmetric swap to be done C First NELIM columns APOS = POSEL1 + int(SON_IW(KK+K1-1),8) - 1_8 DO KK1 = FIRST_COL, FIRST_COL+NELIM-1 JJ2 = APOS + int(SON_IW(K1+KK1-1)-1,8)*NFRONT8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO C Remaining columns APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 C DO KK1 = FIRST_COL+NELIM, LAST_COL C In case I=J and first block, one may have C LAST_COL > KK, but only lower triangular part C should be assembled. We use min(LAST_COL,KK) C below index to cover this case. DO KK1 = FIRST_COL+NELIM, min(LAST_COL,KK) JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ELSE C Case of LDLT without NELIM or LU: everything is simpler DO KK = FIRST_ROW, LAST_ROW APOS = POSEL1 + int(SON_IW(KK+K1-1)-1,8)*NFRONT8 IACHK = 1_8 + int(KK-FIRST_ROW,8)*int(SON_LDA,8) IF (I.EQ.J.AND.SYM.NE.0) THEN C LDLT diag block: assemble only lower half DO KK1 = FIRST_COL, KK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ELSE DO KK1 = FIRST_COL, LAST_COL JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1-FIRST_COL,8)) ENDDO ENDIF ENDDO ENDIF C Deallocate SON_A DEALLOCATE(SON_A) ENDDO #if defined(BLR_MT) !$OMP END DO !$OMP END PARALLEL #endif CALL DMUMPS_BLR_FREE_CB_LRB(IWHANDLER, C Only CB_LRB structure is left to deallocate & .TRUE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN C Case of FR solve: the BLR structure could not be freed C in DMUMPS_END_FACTO_SLAVE and should be freed here C Not reachable in case of error: set INFO1 to 0 CALL DMUMPS_BLR_END_FRONT(IWHANDLER, 0, KEEP8, & MTK405=KEEP(405)) ENDIF END SUBROUTINE DMUMPS_BLR_ASM_NIV1 END MODULE DMUMPS_LR_CORE C -------------------------------------------------------------------- SUBROUTINE DMUMPS_TRUNCATED_RRQR( M, N, A, LDA, JPVT, TAU, WORK, & LDW, RWORK, TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) C This routine computes a Rank-Revealing QR factorization of a dense C matrix A. The factorization is truncated when the absolute value of C a diagonal coefficient of the R factor becomes smaller than a C prescribed threshold TOLEPS. The resulting partial Q and R factors C provide a rank-k approximation of the input matrix A with accuracy C TOLEPS. C C This routine is obtained by merging the LAPACK C (http://www.netlib.org/lapack/) CGEQP3 and CLAQPS routines and by C applying a minor modification to the outer factorization loop in C order to stop computations as soon as possible when the required C accuracy is reached. C C Copyright (c) 1992-2017 The University of Tennessee and The C University of Tennessee Research Foundation. All rights reserved. C Copyright (c) 2000-2017 The University of California Berkeley. C All rights reserved. C Copyright (c) 2006-2017 The University of Colorado Denver. C All rights reserved. C C Redistribution and use in source and binary forms, with or without C modification, are permitted provided that the following conditions C are met: C C - Redistributions of source code must retain the above copyright C notice, this list of conditions and the following disclaimer. C C - Redistributions in binary form must reproduce the above C copyright notice, this list of conditions and the following C disclaimer listed in this license in the documentation and/or C other materials provided with the distribution. C C - Neither the name of the copyright holders nor the names of its C contributors may be used to endorse or promote products derived from C this software without specific prior written permission. C C The copyright holders provide no reassurances that the source code C provided does not infringe any patent, copyright, or any other C intellectual property rights of third parties. The copyright holders C disclaim any liability to any recipient for claims brought against C recipient by any third party for infringement of that parties C intellectual property rights. C C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. C IMPLICIT NONE C INTEGER :: INFO, LDA, LDW, M, N, RANK, MAXRANK C TOL_OPT controls the tolerance option used C >0 => use 2-norm (||.||_X = ||.||_2) C <0 => use Frobenius-norm (||.||_X = ||.||_F) C Furthermore, depending on abs(TOL_OPT): C 1 => absolute: ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS C 2 => relative to 2-norm of the compressed block: C ||B_{I(k+1:end),J(k+1:end)}||_X <= TOLEPS*||B_{I,J}||_2 C 3 => relative to the max of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*max(||B_{I,I}||_2,||B_{J,J}||_2) C 4 => relative to the sqrt of product of the 2-norms of the row and column diagonal blocks C ||B_{I(k+1:end),J{k+1:end}}||_X <= TOLEPS*sqrt(||B_{I,I}||_2*||B_{J,J}||_2) INTEGER :: TOL_OPT DOUBLE PRECISION :: TOLEPS INTEGER :: JPVT(*) DOUBLE PRECISION :: RWORK(*) DOUBLE PRECISION :: A(LDA,*), TAU(*) DOUBLE PRECISION :: WORK(LDW,*) DOUBLE PRECISION :: TOLEPS_EFF, TRUNC_ERR INTEGER, PARAMETER :: INB=1, INBMIN=2 INTEGER :: J, JB, MINMN, NB INTEGER :: OFFSET, ITEMP INTEGER :: LSTICC, PVT, K, RK DOUBLE PRECISION :: TEMP, TEMP2, TOL3Z DOUBLE PRECISION :: AKK DOUBLE PRECISION, PARAMETER :: RZERO=0.0D+0, RONE=1.0D+0 DOUBLE PRECISION :: ZERO DOUBLE PRECISION :: ONE PARAMETER ( ONE = 1.0D+0 ) PARAMETER ( ZERO = 0.0D+0 ) DOUBLE PRECISION :: dlamch INTEGER :: ilaenv, idamax EXTERNAL :: idamax, dlamch EXTERNAL dgeqrf, dormqr, xerbla EXTERNAL ilaenv EXTERNAL dgemm, dgemv, dlarfg, dswap DOUBLE PRECISION, EXTERNAL :: dnrm2 INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -4 END IF IF( INFO.EQ.0 ) THEN IF( LDW.LT.N ) THEN INFO = -8 END IF END IF IF( INFO.NE.0 ) THEN WRITE(*,999) -INFO RETURN END IF MINMN = MIN(M,N) IF( MINMN.EQ.0 ) THEN RANK = 0 RETURN END IF NB = ilaenv( INB, 'CGEQRF', ' ', M, N, -1, -1 ) SELECT CASE(abs(TOL_OPT)) CASE(1) TOLEPS_EFF = TOLEPS CASE(2) C TOLEPS_EFF will be computed at step K=1 below CASE DEFAULT write(*,*) 'Internal error in DMUMPS_TRUNCATED_RRQR: TOL_OPT =', & TOL_OPT CALL MUMPS_ABORT() END SELECT TOLEPS_EFF = TOLEPS C C Avoid pointers (and TARGET attribute on RWORK/WORK) C because of implicit interface. An implicit interface C is needed to avoid intermediate array copies C VN1 => RWORK(1:N) C VN2 => RWORK(N+1:2*N) C AUXV => WORK(1:LDW,1:1) C F => WORK(1:LDW,2:NB+1) C LDF = LDW * Initialize partial column norms. The first N elements of work * store the exact column norms. DO J = 1, N C VN1( J ) = dnrm2( M, A( 1, J ), 1 ) RWORK( J ) = dnrm2( M, A( 1, J ), 1 ) C VN2( J ) = VN1( J ) RWORK( N + J ) = RWORK( J ) JPVT(J) = J END DO IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for first step C TRUNC_ERR = dnrm2( N, VN1( 1 ), 1 ) TRUNC_ERR = dnrm2( N, RWORK( 1 ), 1 ) ENDIF OFFSET = 0 TOL3Z = SQRT(dlamch('Epsilon')) DO JB = MIN(NB,MINMN-OFFSET) LSTICC = 0 K = 0 DO IF(K.EQ.JB) EXIT K = K+1 RK = OFFSET+K C PVT = ( RK-1 ) + IDAMAX( N-RK+1, VN1( RK ), 1 ) PVT = ( RK-1 ) + idamax( N-RK+1, RWORK( RK ), 1 ) IF (RK.EQ.1) THEN C IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = VN1(PVT)*TOLEPS IF (abs(TOL_OPT).EQ.2) TOLEPS_EFF = RWORK(PVT)*TOLEPS ENDIF IF (TOL_OPT.GT.0) THEN C TRUNC_ERR = VN1(PVT) TRUNC_ERR = RWORK(PVT) C ELSE C TRUNC_ERR has been already computed at previous step ENDIF IF(TRUNC_ERR.LT.TOLEPS_EFF) THEN RANK = RK-1 RETURN END IF IF (RK.GT.MAXRANK) THEN RANK = RK INFO = RK RETURN END IF IF( PVT.NE.RK ) THEN CALL dswap( M, A( 1, PVT ), 1, A( 1, RK ), 1 ) c CALL dswap( K-1, F( PVT-OFFSET, 1 ), LDF, c & F( K, 1 ), LDF ) CALL dswap( K-1, WORK( PVT-OFFSET, 2 ), LDW, & WORK( K, 2 ), LDW ) ITEMP = JPVT(PVT) JPVT(PVT) = JPVT(RK) JPVT(RK) = ITEMP C VN1(PVT) = VN1(RK) C VN2(PVT) = VN2(RK) RWORK(PVT) = RWORK(RK) RWORK(N+PVT) = RWORK(N+RK) END IF * Apply previous Householder reflectors to column K: * A(RK:M,RK) := A(RK:M,RK) - A(RK:M,OFFSET+1:RK-1)*F(K,1:K-1)**H. IF( K.GT.1 ) THEN CALL dgemv( 'No transpose', M-RK+1, K-1, -ONE, C & A(RK,OFFSET+1), LDA, F(K,1), LDF, & A(RK,OFFSET+1), LDA, WORK(K,2), LDW, & ONE, A(RK,RK), 1 ) END IF * Generate elementary reflector H(k). IF( RK.LT.M ) THEN CALL dlarfg( M-RK+1, A(RK,RK), A(RK+1,RK), 1, TAU(RK) ) ELSE CALL dlarfg( 1, A(RK,RK), A(RK,RK), 1, TAU(RK) ) END IF AKK = A(RK,RK) A(RK,RK) = ONE * Compute Kth column of F: * F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). IF( RK.LT.N ) THEN CALL dgemv( 'Transpose', M-RK+1, N-RK, TAU(RK), & A(RK,RK+1), LDA, A(RK,RK), 1, ZERO, C & F( K+1, K ), 1 ) & WORK( K+1, K+1 ), 1 ) END IF * Padding F(1:K,K) with zeros. DO J = 1, K C F( J, K ) = ZERO WORK( J, K+1 ) = ZERO END DO * Incremental updating of F: * F(1:N,K) := F(1:N-OFFSET,K) - * tau(RK)*F(1:N,1:K-1)*A(RK:M,OFFSET+1:RK-1)**H*A(RK:M,RK). IF( K.GT.1 ) THEN CALL dgemv( 'Transpose', M-RK+1, K-1, -TAU(RK), & A(RK,OFFSET+1), LDA, A(RK,RK), 1, ZERO, & WORK(1,1), 1 ) C & AUXV(1,1), 1 ) CALL dgemv( 'No transpose', N-OFFSET, K-1, ONE, & WORK(1,2), LDW, WORK(1,1), 1, ONE, WORK(1,K+1), 1 ) C & F(1,1), LDF, AUXV(1,1), 1, ONE, F(1,K), 1 ) END IF * Update the current row of A: * A(RK,RK+1:N) := A(RK,RK+1:N) - A(RK,OFFSET+1:RK)*F(K+1:N,1:K)**H. IF( RK.LT.N ) THEN C CALL dgemv( 'No Transpose', N-RK, K, -ONE, F( K+1, 1 ), CALL dgemv( 'No Transpose', N-RK, K, -ONE, WORK( K+1,2 ), & LDW, & A( RK, OFFSET+1 ), LDA, ONE, A( RK, RK+1 ), LDA ) END IF * Update partial column norms. * IF( RK.LT.MINMN ) THEN DO J = RK + 1, N C IF( VN1( J ).NE.RZERO ) THEN IF( RWORK( J ).NE.RZERO ) THEN * * NOTE: The following 4 lines follow from the analysis in * Lapack Working Note 176. * C TEMP = ABS( A( RK, J ) ) / VN1( J ) TEMP = ABS( A( RK, J ) ) / RWORK( J ) TEMP = MAX( RZERO, ( RONE+TEMP )*( RONE-TEMP ) ) C TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN C VN2( J ) = dble( LSTICC ) RWORK( N+J ) = dble( LSTICC ) LSTICC = J ELSE C VN1( J ) = VN1( J )*SQRT( TEMP ) RWORK( J ) = RWORK( J )*SQRT( TEMP ) END IF END IF END DO END IF A( RK, RK ) = AKK IF (LSTICC.NE.0) EXIT IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO * Apply the block reflector to the rest of the matrix: * A(RK+1:M,RK+1:N) := A(RK+1:M,RK+1:N) - * A(RK+1:M,OFFSET+1:RK)*F(K+1:N-OFFSET,1:K)**H. IF( RK.LT.MIN(N,M) ) THEN CALL dgemm( 'No transpose', 'Transpose', M-RK, & N-RK, K, -ONE, A(RK+1,OFFSET+1), LDA, C & F(K+1,1), LDF, ONE, A(RK+1,RK+1), LDA ) & WORK(K+1,2), LDW, ONE, A(RK+1,RK+1), LDA ) END IF * Recomputation of difficult columns. DO WHILE( LSTICC.GT.0 ) C ITEMP = NINT( VN2( LSTICC ) ) ITEMP = NINT( RWORK( N + LSTICC ) ) C VN1( LSTICC ) = dnrm2( M-RK, A( RK+1, LSTICC ), 1 ) RWORK( LSTICC ) = dnrm2( M-RK, A( RK+1, LSTICC ), 1 ) * * NOTE: The computation of RWORK( LSTICC ) relies on the fact that * SNRM2 does not fail on vectors with norm below the value of * SQRT(DLAMCH('S')) * C VN2( LSTICC ) = VN1( LSTICC ) RWORK( N + LSTICC ) = RWORK( LSTICC ) LSTICC = ITEMP END DO IF(RK.GE.MINMN) EXIT OFFSET = RK IF (TOL_OPT.LT.0) THEN C Compute TRUNC_ERR for next step C TRUNC_ERR = dnrm2( N-RK, VN1( RK+1 ), 1 ) TRUNC_ERR = dnrm2( N-RK, RWORK( RK+1 ), 1 ) ENDIF END DO RANK = RK RETURN 999 FORMAT ('On entry to DMUMPS_TRUNCATED_RRQR, parameter number', & I2,' had an illegal value') END SUBROUTINE DMUMPS_TRUNCATED_RRQR MUMPS_5.4.1/src/zfac_mem_alloc_cb.F0000664000175000017500000001566514102210524017227 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, PROCESS_BANDE, & MYID,N, KEEP,KEEP8,DKEEP, & IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & LREQ, LREQCB, NODE_ARG, STATE_ARG, SET_HEADER, & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) !$ USE OMP_LIB USE ZMUMPS_LOAD IMPLICIT NONE INTEGER N,LIW, KEEP(500) INTEGER(8) LA, LRLU, IPTRLU, LRLUS, LRLUSM, LREQCB INTEGER(8) PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER IWPOS,IWPOSCB INTEGER(8) :: MIN_SPACE_IN_PLACE INTEGER NODE_ARG, STATE_ARG INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER IW(LIW),PTRIST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER MYID, IXXP COMPLEX(kind=8) A(LA) LOGICAL INPLACE, PROCESS_BANDE, SSARBR, SET_HEADER INTEGER COMP, LREQ, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER INODE_LOC,NPIV,NASS,NROW,NCB INTEGER ISIZEHOLE INTEGER(8) :: MEM_GAIN, RSIZEHOLE, LREQCB_EFF, LREQCB_WISHED INTEGER(8) :: DYN_SIZE, KEEP8TMPCOPY IF ( INPLACE ) THEN LREQCB_EFF = MIN_SPACE_IN_PLACE IF ( MIN_SPACE_IN_PLACE > 0_8 ) THEN LREQCB_WISHED = LREQCB ELSE LREQCB_WISHED = 0_8 ENDIF ELSE LREQCB_EFF = LREQCB LREQCB_WISHED = LREQCB ENDIF IF (IWPOSCB.EQ.LIW) THEN IF (LREQ.NE.KEEP(IXSZ).OR.LREQCB.NE.0_8 & .OR. .NOT. SET_HEADER) THEN WRITE(*,*) "Internal error in ZMUMPS_ALLOC_CB ", & SET_HEADER, LREQ, LREQCB CALL MUMPS_ABORT() ENDIF IF (IWPOSCB-IWPOS+1 .LT. KEEP(IXSZ)) THEN WRITE(*,*) "Problem with integer stack size",IWPOSCB, & IWPOS, KEEP(IXSZ) IFLAG = -8 IERROR = LREQ RETURN ENDIF IWPOSCB=IWPOSCB-KEEP(IXSZ) IW(IWPOSCB+1+XXI)=KEEP(IXSZ) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8,IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXN)=-919191 IW(IWPOSCB+1+XXS)=S_NOTFREE IW(IWPOSCB+1+XXP)=TOP_OF_STACK RETURN ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IWPOSCB+1 + XXD)) IF (DYN_SIZE .EQ. 0_8 & .AND. KEEP(214).EQ.1.AND. & KEEP(216).EQ.1.AND. & IWPOSCB.NE.LIW) THEN IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG.OR. & IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NCB = IW( IWPOSCB+1 + KEEP(IXSZ) ) NROW = IW( IWPOSCB+1 + KEEP(IXSZ) + 2) NPIV = IW( IWPOSCB+1 + KEEP(IXSZ) + 3) INODE_LOC= IW( IWPOSCB+1 + XXN) CALL ZMUMPS_GET_SIZEHOLE(IWPOSCB+1,IW,LIW, & ISIZEHOLE,RSIZEHOLE) IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,0, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED MEM_GAIN = int(NROW,8)*int(NPIV,8) ENDIF IF (IW(IWPOSCB+1 + XXS).EQ.S_NOLCBNOCONTIG38) THEN NASS = IW( IWPOSCB+1 + KEEP(IXSZ) + 4) CALL ZMUMPS_MAKECBCONTIG(A,LA,IPTRLU+1_8, & NROW,NCB,NPIV+NCB,NASS-NPIV, & IW(IWPOSCB+1 + XXS),RSIZEHOLE) IW(IWPOSCB+1 + XXS) =S_NOLCLEANED38 MEM_GAIN = int(NROW,8)*int(NPIV+NCB-(NASS-NPIV),8) ENDIF IF (ISIZEHOLE.NE.0) THEN CALL ZMUMPS_ISHIFT( IW,LIW,IWPOSCB+1, & IWPOSCB+IW(IWPOSCB+1+XXI), & ISIZEHOLE ) IWPOSCB=IWPOSCB+ISIZEHOLE IW(IWPOSCB+1+XXP+IW(IWPOSCB+1+XXI))=IWPOSCB+1 PTRIST(STEP(INODE_LOC))=PTRIST(STEP(INODE_LOC))+ & ISIZEHOLE ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(IWPOSCB+1+XXR), MEM_GAIN) IPTRLU = IPTRLU+MEM_GAIN+RSIZEHOLE LRLU = LRLU+MEM_GAIN+RSIZEHOLE PTRAST(STEP(INODE_LOC))= & PTRAST(STEP(INODE_LOC))+MEM_GAIN+RSIZEHOLE ENDIF ENDIF IF (LRLU.LT.LREQCB_WISHED)THEN IF (LREQCB_EFF.LT.LREQCB_WISHED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) ENDIF ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (LREQ, LREQCB_EFF, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 650 IXXP=IWPOSCB+XXP+1 IF (IXXP.GT.LIW) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_ALLOC_CB ",IXXP ENDIF IF (IW(IXXP).GT.0) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_ALLOC_CB ",IW(IXXP),IXXP ENDIF IWPOSCB = IWPOSCB - LREQ IF (SET_HEADER) THEN IW(IXXP)= IWPOSCB + 1 IW(IWPOSCB+1:IWPOSCB+1+KEEP(IXSZ))=-99999 IW(IWPOSCB+1+XXI)=LREQ CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXR)) CALL MUMPS_STOREI8(0_8, IW(IWPOSCB+1+XXD)) IW(IWPOSCB+1+XXS)=STATE_ARG IW(IWPOSCB+1+XXN)=NODE_ARG IW(IWPOSCB+1+XXP)=TOP_OF_STACK IW(IWPOSCB+1+XXNBPR)=0 ENDIF IPTRLU = IPTRLU - LREQCB LRLU = LRLU - LREQCB LRLUS = LRLUS - LREQCB_EFF LRLUSM = min(LRLUS, LRLUSM) IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LREQCB_EFF KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC ENDIF CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,PROCESS_BANDE, & LA-LRLUS,0_8,LREQCB_EFF,KEEP,KEEP8,LRLUS) 650 CONTINUE RETURN END SUBROUTINE ZMUMPS_ALLOC_CB MUMPS_5.4.1/src/zfac_process_contrib_type2.F0000664000175000017500000004770514102210524021154 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, & COMP, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, & MYID, COMM, ICNTL, KEEP,KEEP8,DKEEP, IFLAG, IERROR, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_LOAD USE ZMUMPS_BUF USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_FAC_LR, ONLY: ZMUMPS_DECOMPRESS_PANEL USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR, & ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV, MSGLEN INTEGER BUFR( LBUFR ) INTEGER(8) :: LRLU, IPTRLU, LRLUS, LA, POSFAC INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER NBFIN INTEGER COMP INTEGER NELT, LPTRAR INTEGER PROCNODE_STEPS( KEEP(28) ), PTRIST(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PTLUST( KEEP(28) ) INTEGER PERM(N) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER ITLOC( N + KEEP(253)), NSTK_S( KEEP(28) ) INTEGER :: FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER ND(KEEP(28)), FRERE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, IFLAG, IERROR INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER FRTPTR(N+1), FRTELT( NELT ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NFS4FATHER INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER IERR INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER I, INODE, ISON, POSITION, NBROW, LROW, IROW, INDCOL INTEGER LREQI INTEGER(8) :: LREQA, POSCONTRIB INTEGER ROW_LENGTH INTEGER MASTER INTEGER ISTCHK LOGICAL SAME_PROC LOGICAL SLAVE_NODE LOGICAL IS_ofType5or6 INTEGER ISHIFT_BUFR, LBUFR_LOC, LBUFR_BYTES_LOC INTEGER TYPESPLIT INTEGER DECR INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR INTEGER :: CB_IS_LR_INT, NB_BLR_COLS, allocok, & NBROWS_PACKET_2PACK, PANEL_BEG_OFFSET INTEGER(8) :: LA_TEMP COMPLEX(kind=8), ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: LRB TYPE (LRB_TYPE), ALLOCATABLE, TARGET :: BLR_CB(:) INTEGER(8) :: IACHK, SIZFR8, DYN_SIZE COMPLEX(kind=8), DIMENSION(:), POINTER :: DYNPTR INTEGER :: NSLAVES, NFRONT, NASS1, IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER(8) :: POSELT INCLUDE 'mumps_headers.h' POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, ISON, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LROW, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & CB_IS_LR_INT, 1, & MPI_INTEGER, COMM, IERR ) CB_IS_LR = (CB_IS_LR_INT.EQ.1) MASTER = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SLAVE_NODE = MASTER .NE. MYID TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) IF (SLAVE_NODE .AND. PTRIST(STEP(INODE)) ==0) THEN ISHIFT_BUFR = ( MSGLEN + KEEP(34) ) / KEEP(34) LBUFR_LOC = LBUFR - ISHIFT_BUFR + 1 LBUFR_BYTES_LOC = LBUFR_LOC * KEEP(34) CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR(ISHIFT_BUFR), LBUFR_LOC, LBUFR_BYTES_LOC, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG.LT.0) RETURN ENDIF IF ( SLAVE_NODE ) THEN LREQI = LROW + NBROWS_PACKET ELSE LREQI = NBROWS_PACKET END IF LREQA = int(LROW,8) CALL ZMUMPS_GET_SIZE_NEEDED( & LREQI, LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA POSCONTRIB = POSFAC POSFAC = POSFAC + LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) IF ( SLAVE_NODE ) THEN IROW = IWPOS INDCOL = IWPOS + NBROWS_PACKET ELSE IROW = IWPOS INDCOL = -1 END IF IWPOS = IWPOS + LREQI IF ( SLAVE_NODE ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( INDCOL ), LROW, MPI_INTEGER, & COMM, IERR ) END IF DO I = 1, NBROWS_PACKET CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IROW + I - 1 ), 1, MPI_INTEGER, & COMM, IERR ) END DO IF ( SLAVE_NODE ) THEN IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN IW(PTRIST(STEP(INODE))+XXNBPR) = & IW(PTRIST(STEP(INODE))+XXNBPR) - NBROW ENDIF IF ( KEEP(55) .eq. 0 ) THEN CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL ZMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, & NBROW, LROW, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ENDIF IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL ZMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 3, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF (KEEP(50).EQ.0) THEN ROW_LENGTH = LROW ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ENDIF CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & LROW) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 200 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) CALL ZMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & 1, ROW_LENGTH, IW( IROW+I-1 ),IW(INDCOL), & A(POSCONTRIB), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, & ROW_LENGTH ) ENDDO 200 CONTINUE CALL ZMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, & NBROWS_PACKET, STEP, PTRIST, & ITLOC, RHS_MUMPS,KEEP,KEEP8) ELSE IF (CB_IS_LR) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_COLS, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PANEL_BEG_OFFSET, 1, & MPI_INTEGER, COMM, IERR ) allocate(BLR_CB(NB_BLR_COLS),stat=allocok) IF (allocok.GT.0) THEN IERROR = NB_BLR_COLS IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF DO I=1,NB_BLR_COLS LRB => BLR_CB(I) CALL ZMUMPS_MPI_UNPACK_LRB(BUFR, LBUFR, & LBUFR_BYTES, POSITION, LRB, KEEP8, & COMM, IFLAG, IERROR) ENDDO NBROWS_PACKET_2PACK = max(NBROWS_PACKET,BLR_CB(1)%M) LA_TEMP = NBROWS_PACKET_2PACK*LROW allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & LROW, LROW, .TRUE., 1, 1, & NB_BLR_COLS, BLR_CB, 0, 'V', 4, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=NBROWS_PACKET_2PACK-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW+I-1 ), & A_TEMP(1+(I-1+PANEL_BEG_OFFSET)*LROW), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LROW & ) ENDDO CALL DEALLOC_BLR_PANEL(BLR_CB, NB_BLR_COLS, KEEP8) deallocate(A_TEMP, BLR_CB) GOTO 300 ENDIF DO I=1,NBROWS_PACKET IF(KEEP(50).NE.0)THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ROW_LENGTH, & 1, & MPI_INTEGER, & COMM, IERR ) ELSE ROW_LENGTH=LROW ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSCONTRIB), & ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) CALL ZMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, 1, ROW_LENGTH, IW( IROW +I-1 ), & A(POSCONTRIB), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, ROW_LENGTH &) ENDDO 300 CONTINUE IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (KEEP(219).NE.0) THEN IF(KEEP(50) .EQ. 2) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NFS4FATHER, & 1, & MPI_INTEGER, & COMM, IERR ) IF(NFS4FATHER .GT. 0) THEN CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERROR = BUF_LMAX_ARRAY IFLAG = -13 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BUF_MAX_ARRAY, & NFS4FATHER, & MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL ZMUMPS_ASM_MAX(N, INODE, IW, LIW, A, LA, & ISON, NFS4FATHER, & BUF_MAX_ARRAY, PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8) ENDIF ENDIF ENDIF ENDIF IF (NBROWS_ALREADY_SENT + NBROWS_PACKET == NBROW ) THEN DECR = 1 ISTCHK = PIMASTER(STEP(ISON)) SAME_PROC = ISTCHK .LT. IWPOSCB IW(PTLUST(STEP(INODE))+XXNBPR) = & IW(PTLUST(STEP(INODE))+XXNBPR) - DECR IF (SAME_PROC) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IW(INBPROCFILS_SON) = IW(INBPROCFILS_SON) - DECR IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL ZMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST, IW, LIW, STEP, KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL ZMUMPS_DM_SET_DYNPTR( IW(ISTCHK+XXS), A, LA, & PAMASTER(STEP(ISON)), IW(ISTCHK+XXD), & IW(ISTCHK+XXR), DYNPTR, IACHK, SIZFR8) CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK+XXD)) CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL ZMUMPS_DM_FREE_BLOCK( DYNPTR, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF (IW(PTLUST(STEP(INODE))+XXNBPR) .EQ. 0) THEN IOLDPS = PTLUST(STEP(INODE)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) POSELT = PTRAST(STEP(INODE)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF CALL ZMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE+N ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ENDIF ENDIF END IF IWPOS = IWPOS - LREQI LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA KEEP8(69) = KEEP8(69) - LREQA POSFAC = POSFAC - LREQA CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LREQA,KEEP,KEEP8,LRLUS) RETURN END SUBROUTINE ZMUMPS_PROCESS_CONTRIB_TYPE2 MUMPS_5.4.1/src/dfac_process_root2slave.F0000664000175000017500000003171114102210522020427 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE DMUMPS_LOAD USE DMUMPS_OOC USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER :: allocok DOUBLE PRECISION, DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INCLUDE 'mumps_headers.h' INTEGER numroc, MUMPS_PROCNODE EXTERNAL numroc, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = numroc( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = numroc( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL DMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL DMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL DMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL DMUMPS_ASM_ELT_ROOT(N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL DMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL DMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL DMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL DMUMPS_ASM_ELT_ROOT( N, root, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL DMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL DMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL DMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(root%RHS_ROOT)) DEALLOCATE(root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN root%RHS_ROOT=ZERO CALL DMUMPS_ASM_RHS_ROOT( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => root%RHS_ROOT NULLIFY(root%RHS_ROOT) ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = NEW_LOCAL_M*root%RHS_NLOC GOTO 700 ENDIF DO J = 1, root%RHS_NLOC DO I = 1, OLD_LOCAL_M root%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M root%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL DMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE DMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD DOUBLE PRECISION NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE DMUMPS_COPY_ROOT MUMPS_5.4.1/src/mumps_io.h0000664000175000017500000001542414102210474015517 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_IO_H #define MUMPS_IO_H #include "mumps_common.h" #include "mumps_c_types.h" /* * Two character arrays that are used by low_level_init_prefix * and low_level_init_tmpdir to store intermediate file names. * They are passed to mumps_io_basic.c inside the routine * mumps_low_level_init_ooc_c. * Note that both low_level_init_prefix and low_level_init_tmpdir * MUST be called before low_level_init_ooc_c. * */ #define MUMPS_OOC_PREFIX_MAX_LENGTH 63 #define MUMPS_OOC_TMPDIR_MAX_LENGTH 255 static char MUMPS_OOC_STORE_PREFIX[MUMPS_OOC_PREFIX_MAX_LENGTH]; static MUMPS_INT MUMPS_OOC_STORE_PREFIXLEN=-1; static char MUMPS_OOC_STORE_TMPDIR[MUMPS_OOC_TMPDIR_MAX_LENGTH]; static MUMPS_INT MUMPS_OOC_STORE_TMPDIRLEN=-1; #define MUMPS_DUMPRHSBINARY_C \ F_SYMBOL(dumprhsbinary_c,DUMP_RHSBINARY_C) void MUMPS_CALL MUMPS_DUMPRHSBINARY_C ( MUMPS_INT *N, MUMPS_INT *NRHS, MUMPS_INT *LRHS, float *RHS, MUMPS_INT *K35, char *filename, mumps_ftnlen l1 ); #define MUMPS_DUMPMATBINARY_C \ F_SYMBOL(dumpmatbinary_c,DUMP_MATBINARY_C) void MUMPS_CALL MUMPS_DUMPMATBINARY_C ( MUMPS_INT* N, MUMPS_INT8 *NNZ, MUMPS_INT* K35, MUMPS_INT *irn, MUMPS_INT *jcn, void *A, MUMPS_INT *is_A_provided, char *file_name, mumps_ftnlen l1 ); #define MUMPS_LOW_LEVEL_INIT_PREFIX \ F_SYMBOL(low_level_init_prefix,LOW_LEVEL_INIT_PREFIX) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_PREFIX(MUMPS_INT * dim, char * str, mumps_ftnlen l1); #define MUMPS_LOW_LEVEL_INIT_TMPDIR \ F_SYMBOL(low_level_init_tmpdir,LOW_LEVEL_INIT_TMPDIR) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(MUMPS_INT * dim, char * str, mumps_ftnlen l1); MUMPS_INLINE MUMPS_INT mumps_convert_2fint_to_longlong( MUMPS_INT *, MUMPS_INT *, long long *); #define MUMPS_LOW_LEVEL_INIT_OOC_C \ F_SYMBOL(low_level_init_ooc_c,LOW_LEVEL_INIT_OOC_C) void MUMPS_CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MUMPS_INT *_myid, MUMPS_INT *total_size_io,MUMPS_INT *size_element, MUMPS_INT *async, MUMPS_INT *k211, MUMPS_INT *nb_file_type, MUMPS_INT *flag_tab , MUMPS_INT* ierr); #define MUMPS_TEST_REQUEST_C \ F_SYMBOL(test_request_c,TEST_REQUEST_C) void MUMPS_CALL MUMPS_TEST_REQUEST_C(MUMPS_INT *request_id,MUMPS_INT *flag,MUMPS_INT *ierr); #define MUMPS_WAIT_REQUEST \ F_SYMBOL(wait_request,WAIT_REQUEST) void MUMPS_CALL MUMPS_WAIT_REQUEST(MUMPS_INT *request_id,MUMPS_INT *ierr); #define MUMPS_LOW_LEVEL_WRITE_OOC_C \ F_SYMBOL(low_level_write_ooc_c,LOW_LEVEL_WRITE_OOC_C) void MUMPS_CALL MUMPS_LOW_LEVEL_WRITE_OOC_C( const MUMPS_INT * strat_IO, void * address_block, MUMPS_INT * block_size_int1, MUMPS_INT * block_size_int2, MUMPS_INT * inode, MUMPS_INT * request_arg, MUMPS_INT * type, MUMPS_INT * vaddr_int1, MUMPS_INT * vaddr_int2, MUMPS_INT * ierr); #define MUMPS_LOW_LEVEL_READ_OOC_C \ F_SYMBOL(low_level_read_ooc_c,LOW_LEVEL_READ_OOC_C) void MUMPS_CALL MUMPS_LOW_LEVEL_READ_OOC_C( const MUMPS_INT * strat_IO, void * address_block, MUMPS_INT * block_size_int1, MUMPS_INT * block_size_int2, MUMPS_INT * inode, MUMPS_INT * request_arg, MUMPS_INT * type, MUMPS_INT * vaddr_int1, MUMPS_INT * vaddr_int2, MUMPS_INT * ierr); #define MUMPS_LOW_LEVEL_DIRECT_READ \ F_SYMBOL(low_level_direct_read,LOW_LEVEL_DIRECT_READ) void MUMPS_CALL MUMPS_LOW_LEVEL_DIRECT_READ(void * address_block, MUMPS_INT * block_size_int1, MUMPS_INT * block_size_int2, MUMPS_INT * type, MUMPS_INT * vaddr_int1, MUMPS_INT * vaddr_int2, MUMPS_INT * ierr); #define MUMPS_CLEAN_IO_DATA_C \ F_SYMBOL(clean_io_data_c,CLEAN_IO_DATA_C) void MUMPS_CALL MUMPS_CLEAN_IO_DATA_C(MUMPS_INT *myid,MUMPS_INT *step,MUMPS_INT *ierr); #define MUMPS_GET_MAX_NB_REQ_C \ F_SYMBOL(get_max_nb_req_c,GET_MAX_NB_REQ_C) void MUMPS_CALL MUMPS_GET_MAX_NB_REQ_C(MUMPS_INT *max,MUMPS_INT *ierr); #define MUMPS_GET_MAX_FILE_SIZE_C \ F_SYMBOL(get_max_file_size_c,GET_MAX_FILE_SIZE_C) void MUMPS_CALL MUMPS_GET_MAX_FILE_SIZE_C(double * max_ooc_file_size); #define MUMPS_OOC_GET_NB_FILES_C \ F_SYMBOL(ooc_get_nb_files_c,OOC_GET_NB_FILES_C) void MUMPS_CALL MUMPS_OOC_GET_NB_FILES_C(const MUMPS_INT *type, MUMPS_INT *nb_files); #define MUMPS_OOC_GET_FILE_NAME_C \ F_SYMBOL(ooc_get_file_name_c,OOC_GET_FILE_NAME_C) void MUMPS_CALL MUMPS_OOC_GET_FILE_NAME_C(MUMPS_INT *type, MUMPS_INT *indice, MUMPS_INT *length, char* name, mumps_ftnlen l1); #define MUMPS_OOC_SET_FILE_NAME_C \ F_SYMBOL(ooc_set_file_name_c,OOC_SET_FILE_NAME_C) void MUMPS_CALL MUMPS_OOC_SET_FILE_NAME_C(MUMPS_INT *type, MUMPS_INT *indice, MUMPS_INT *length, MUMPS_INT *ierr, char* name, mumps_ftnlen l1); #define MUMPS_OOC_ALLOC_POINTERS_C \ F_SYMBOL(ooc_alloc_pointers_c,OOC_ALLOC_POINTERS_C) void MUMPS_CALL MUMPS_OOC_ALLOC_POINTERS_C(MUMPS_INT *nb_file_type, MUMPS_INT *dim, MUMPS_INT *ierr); #define MUMPS_OOC_INIT_VARS_C \ F_SYMBOL(ooc_init_vars_c,OOC_INIT_VARS_C) void MUMPS_CALL MUMPS_OOC_INIT_VARS_C(MUMPS_INT *myid_arg, MUMPS_INT *size_element, MUMPS_INT *async, MUMPS_INT *k211, MUMPS_INT *ierr); #define MUMPS_OOC_START_LOW_LEVEL \ F_SYMBOL(ooc_start_low_level,OOC_START_LOW_LEVEL) void MUMPS_CALL MUMPS_OOC_START_LOW_LEVEL(MUMPS_INT *ierr); #define MUMPS_OOC_PRINT_STATS \ F_SYMBOL(ooc_print_stats,OOC_PRINT_STATS) void MUMPS_CALL MUMPS_OOC_PRINT_STATS(); #define MUMPS_OOC_REMOVE_FILE_C \ F_SYMBOL(ooc_remove_file_c,OOC_REMOVE_FILE_C) void MUMPS_CALL MUMPS_OOC_REMOVE_FILE_C(MUMPS_INT *ierr, char *name, mumps_ftnlen l1); #define MUMPS_OOC_END_WRITE_C \ F_SYMBOL(ooc_end_write_c,OOC_END_WRITE_C) void MUMPS_CALL MUMPS_OOC_END_WRITE_C(MUMPS_INT *ierr); #define MUMPS_OOC_IS_ASYNC_AVAIL \ F_SYMBOL(ooc_is_async_avail,OOC_IS_ASYNC_AVAIL) void MUMPS_CALL MUMPS_OOC_IS_ASYNC_AVAIL(MUMPS_INT *flag); #endif /* MUMPS_IO_H */ MUMPS_5.4.1/src/cfac_front_type2_aux.F0000664000175000017500000007035514102210524017731 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE CMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE CMUMPS_FAC_FRONT_AUX_M IMPLICIT NONE INTEGER SIZEDIAG_ORIG REAL DIAG_ORIG(SIZEDIAG_ORIG) REAL GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA COMPLEX A(LA) REAL UU, UULOC, SEUIL COMPLEX CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF REAL RMAX,AMAX,TMAX,RMAX_NORELAX REAL MAXPIV, ABS_PIVOT REAL RMAX_NOSLAVE, TMAX_NOSLAVE COMPLEX PIVOT,DETPIV REAL ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK REAL :: GROWTH, RSWOP REAL :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 REAL, PARAMETER :: RZERO = 0.0E0 REAL, PARAMETER :: RONE = 1.0E0 COMPLEX ZERO, ONE PARAMETER( ZERO = (0.0E0,0.0E0) ) PARAMETER( ONE = (1.0E0,0.0E0) ) REAL PIVNUL, VALTMP COMPLEX FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L REAL GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (ABS_PIVOT.EQ.RZERO) GO TO 630 CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL CMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0E10*RMAX, sqrt(huge(RMAX))/1.0E8) A(POSPV1) = cmplx(VALTMP,kind=kind(A)) ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL CMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1,real(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL CMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL CMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL CMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL CMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE CMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 COMPLEX, intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 COMPLEX ONE, ALPHA COMPLEX ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 COMPLEX SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL ccopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL ccopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE CMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_BLOCK, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_TYPE USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTBL COMPLEX A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(N) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in CMUMPS_SEND_FACTORED_BLK ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_BLOCK + 1 NCOL = LDA_FS - IBEG_BLOCK + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) IF (IBEG_BLOCK > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_BLOCK-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL CMUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTBL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL CMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, & NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_SEND_FACTORED_BLK END MODULE CMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.4.1/src/dfac_asm_master_ELT_m.F0000664000175000017500000020411614102210522017745 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_ASM_MASTER_ELT_M CONTAINS SUBROUTINE DMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) !$ USE OMP_LIB USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_IS_DYNAMIC, & DMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_ELT_M USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & DMUMPS_BLR_ASM_NIV1 USE DMUMPS_LR_DATA_M, ONLY : DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_NFS4FATHER USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER NELT INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER ETATASS LOGICAL SON_LEVEL2 DOUBLE PRECISION, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER PARPIV_T1 INTEGER(8) NFRONT8, LAELL8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT INTEGER :: J253 #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER(8) APOS, APOS2, LAPOS2 INTEGER(8) POSELT, POSEL1, ICT12, ICT21 INTEGER(8) IACHK INTEGER(8) JJ2 INTEGER(8) :: JJ8, J18, J28 INTEGER(8) :: AINPUT8, AII8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER JPOS,ICT11, IJROW INTEGER Pos_First_NUMORG,NUMORG,IOLDPS, & NUMELT, ELBEG INTEGER :: J INTEGER NSLAVES, NSLSON, NPIVS, NPIV_ANA, NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER(8) :: II8 INTEGER :: I LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) LOGICAL MUMPS_INSSARBR, SSARBR EXTERNAL MUMPS_INSSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NFS4FATHER = -1 ETATASS = 0 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in DMUMPS_FAC_ASM_NIV1_ELT ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .ne. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN WRITE( *, * ) 'PB compress DMUMPS_FAC_ASM_NIV1_ELT' WRITE( *, * ) 'LRLU,LRLUS=',LRLU,LRLUS GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .TRUE. CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, & SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL DMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) & ' ERROR 1 during ass_niv1_ELT', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 LRLUSM = min( LRLUS, LRLUSM ) IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + LAELL8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF NUMROWS = NFRONT8 !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL DMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL DMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF ENDIF IF (NUMSTK.NE.0) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL DMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (K2.GE.K1) THEN DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * NFRONT8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + LSTK8 170 CONTINUE END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (SIZFR8 .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF (SAME_PROC) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & .FALSE. & ) IF (IS_DYNAMIC_CB) THEN CALL DMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL DMUMPS_BUF_SEND_MAPLIG( INODE, NFRONT, & NASS1, NFS4FATHER,ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, & SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF END DO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) 220 CONTINUE END IF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * NFRONT8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE ICT12 = POSELT + int(- NFRONT + I - 1,8) ICT21 = POSELT + int(I-1,8)*NFRONT8 - 1_8 DO JJ8=II8,J28 J = INTARR(JJ8) IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*NFRONT8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) AII8 = AII8 + 1_8 END DO END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_ASM_NIV1_ELT' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_ASM_NIV1_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) ' FAILURE IN INTEGER', & ' DYNAMIC ALLOCATION DURING DMUMPS_ASM_NIV1_ELT' ENDIF INFO(2) = NUMSTK ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV1_ELT SUBROUTINE DMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_ELT_M USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_IS_DYNAMIC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER NELT INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF DOUBLE PRECISION, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER MYID, COMM INTEGER IFATH INTEGER LBUFR, LBUFR_BYTES INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: AII8, AINPUT8, II8 INTEGER(8) :: J18,J28,JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: NFRONT8, POSELT, POSEL1, LDAFS8, & IACHK, ICT12, ICT21 INTEGER(8) APOS, APOS2 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IORG INTEGER LDAFS, LDA_SON, IJROW, IBROT INTEGER Pos_First_NUMORG,NBCOL,NUMORG,IOLDPS INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER ELTI INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J INTEGER :: ELBEG, NUMELT LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT DOUBLE PRECISION ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = 0.0D0 ) logical :: force_cand INTEGER ETATASS INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT, & NUMORG_SPLIT, TYPESPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTEGER :: NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL :: IS_ofType5or6, SPLIT_MAP_RESTART !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMELT = FRT_PTR(INODE+1) - FRT_PTR(INODE) IF ( NUMELT .NE. 0 ) THEN ELBEG = FRT_PTR(INODE) ELSE ELBEG = 1 END IF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 WRITE(6,*) "NMB_OF_CAND, SIZE_TMP_SLAVES_LIST ", & NMB_OF_CAND, SIZE_TMP_SLAVES_LIST IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL DMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL DMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL DMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress DMUMPS_FAC_ASM_NIV2_ELT', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF CALL MUMPS_ELT_BUILD_SORT( & NUMELT, FRT_ELT(ELBEG), & MYID, INODE, N, IOLDPS, HF, & NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & KEEP, SON_LEVEL2, NIV1, INFO(1), & DAD,PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, NFRONT - NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(6,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(6,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL DMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL DMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 2 during ass_niv2' ENDIF GOTO 270 ENDIF ENDIF NFRONT8=int(NFRONT,8) IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+NSLAVES+KEEP(IXSZ))= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL DMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL DMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL DMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * NFRONT8 LDAFS = NFRONT LDAFS8 = NFRONT8 ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 LDAFS8 = int(NASS1,8) ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR)= LRSTATUS CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8, & LRLUS) POSEL1 = POSELT - LDAFS8 #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & DMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * LDAFS8 DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) IF (KEEP(219).NE.0) THEN IF (KEEP(50).EQ.2) THEN A( APOSMAX: APOSMAX+int(NASS1-1,8))=ZERO ENDIF ENDIF DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1) - 1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = INTARR(II8) IF (KEEP(50).EQ.0) THEN IF (I.LE.NASS1) THEN AINPUT8 = AII8 + II8 - J18 ICT12 = POSELT + int(I-1,8) * LDAFS8 DO JJ8=J18,J28 APOS2 = ICT12 + int(INTARR(JJ8) - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ENDIF ELSE ICT12 = POSELT - LDAFS8 + int(I,8) - 1_8 ICT21 = POSELT + int(I-1,8)*LDAFS8 - 1_8 IF ( I .GT. NASS1 ) THEN IF (KEEP(219).NE.0 .AND. KEEP(50).EQ.2) THEN AINPUT8=AII8 DO JJ8=II8,J28 J=INTARR(JJ8) IF (J.LE.NASS1) THEN A(APOSMAX+int(J-1,8))= & max(dble(A(APOSMAX+int(J-1,8))), & abs(DBLARR(AINPUT8))) ENDIF AINPUT8=AINPUT8+1_8 ENDDO ENDIF AII8 = AII8 + J28 - II8 + 1_8 CYCLE ELSE IF (KEEP(219).NE.0) THEN MAXARR = RZERO ENDIF DO JJ8=II8,J28 J = INTARR(JJ8) IF ( J .LE. NASS1) THEN IF (I.LT.J) THEN APOS2 = ICT12 + int(J,8)*LDAFS8 ELSE APOS2 = ICT21 + int(J,8) ENDIF A(APOS2) = A(APOS2) + DBLARR(AII8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AII8))) ENDIF AII8 = AII8 + 1_8 END DO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(I-1,8)) = & max( MAXARR, dble(A(APOSMAX+int(I-1,8)))) ENDIF ENDIF END IF END DO END DO IF (KEEP(253).GT.0) THEN POSELT = PTRAST(STEP(INODE)) IBROT = INODE IJROW = Pos_First_NUMORG DO IORG = 1, NUMORG IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) IJROW = IJROW+1 ENDDO ENDIF PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL DMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL DMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL DMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, NELT+1, NELT, & FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL DMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL DMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & NELT+1, NELT, FRT_PTR, FRT_ELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_ASM_NIV2_ELT' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING DMUMPS_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF (LPOK) THEN WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2_ELT' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV2_ELT END MODULE DMUMPS_FAC_ASM_MASTER_ELT_M MUMPS_5.4.1/src/cmumps_driver.F0000664000175000017500000030322314102210525016476 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for CMUMPS C (MPI based code) C =========================== C SUBROUTINE CMUMPS( id ) USE CMUMPS_OOC USE MUMPS_MEMORY_MOD USE CMUMPS_STRUC_DEF USE CMUMPS_STATIC_PTR_M ! For Schur pointer USE CMUMPS_SAVE_RESTORE C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C C P. Amestoy, J.-Y. L'Excellent, G. Moreau, On exploiting sparsity of C multiple right-hand sides in sparse direct solvers, C SIAM Journal on Scientific Computing, volume 41, number 2, C pages A269-A291 (2019) C C G. Moreau, PhD Thesis, ENS-Lyon, University of Lyon, C On the solution phase of direct methods for sparse linear systems C with multiple sparse right-hand sides, December 10th, 2018 C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C Performance and scalability of the block low-rank multifrontal C factorization on multicore architectures, C ACM Transactions on Mathematical Software (2018) C C T. Mary, PhD Thesis, University of Toulouse, C Block Low-Rank multifrontal solvers: complexity, performance, and C scalability, November 2017. C C S. de la Kethulle de Ryhove, P. Jaysaval and D.V. Shantsev, C P. R. Amestoy, J.-Y. L'Excellent and T. Mary, C Large-scale 3D EM modeling with a Block Low-Rank MUMPS solver, C Geophysical Journal International, volume 209, number 3, C pages 1558-1571 (2017) . C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C On the complexity of the Block Low-Rank multifrontal factorization, C SIAM Journal on Scientific Computing, volume 39, C number 4, pages A1710-A1740 (2017). C C P. Amestoy, R. Brossier, A. Buttari, J.-Y. L'Excellent, T. Mary, C L. Metivier, A. Miniussi, and S. Operto. C Fast 3D frequency-domain full waveform inversion with a parallel C Block Low-Rank multifrontal direct solver: application to OBC data C from the North Sea, Geophysics, 81(6):R363--R383, (2016). C C P. Amestoy, C. Ashcraft, O. Boiteau, A. Buttari, J.-Y. L'Excellent, C and C. Weisbecker. C Improving multifrontal methods by means of block low-rank representations. C SIAM Journal on Scientific Computing, 37(3):A1451--A1474 (2015). C C W. M. Sid-Lakhdar, PhD Thesis from Universite de Lyon prepared at ENS Lyon, C Scaling the solution of large sparse linear systems using multifrontal C methods on hybrid shared-distributed memory architectures (2014). C C P. Amestoy, J.-Y. L'Excellent, W. Sid-Lakhdar, C Characterizing asynchronous broadcast trees for multifrontal factorizations, C Workshop on Combinatorial Scientific Computing, C Lyon, France, July 21-23 (2014). C C P. Amestoy, J.-Y. L'Excellent, F.-H. Rouet, W. Sid-Lakhdar, C Modeling 1D distributed-memory dense kernels for an asynchronous C multifrontal sparse solver, High-Performance Computing for Computational C Science, VECPAR 2014, Eugene, Oregon, USA, June 30 - July 3 (2014). C C J.-Y. L'Excellent and W. M. Sid-Lakhdar, C Introduction of shared-memory parallelism in a distributed-memroy C multifrontal solver, Parallel Computing (40):3-4, pages 34-46 (2014). C C C. Weisbecker, PhD Thesis supported by EDF, INPT-IRIT, C Improving multifrontal solvers by means of algebraic block low-rank C representations (2013). C C E. Agullo, P. Amestoy, A. Buttari, A. Guermouche, G. Joslin, J.-Y. C L'Excellent, X. S. Li, A. Napov, F.-H. Rouet, M. Sid-Lakhdar, S. Wang, C. C Weisbecker, I. Yamazaki, C Recent Advances in Sparse Direct Solvers, 22nd Conference on Structural C Mechanics in Reactor Technology, San Francisco (2013). C C P. Amestoy, A. Buttari, G. Joslin, J.-Y. L'Excellent, W. Sid-Lakhdar, C. C Weisbecker, M. Forzan, C. Pozza, R. Perrin, V. Pellissier, C Shared memory parallelism and low-rank approximation techniques applied C applied to direct solvers in FEM simulation in IEEE Transactions on C Magnetics, IEEE, Special issue, Compumag 2013 (2013). C C L. Boucher, P. Amestoy, A, Buttari, F.-H. Rouet and M. Chauvin, C INTEGRAL/SPI data segmentation to retrieve sources intensity variations, C Astronomy & Astrophysics, Article 52, 20 pages, C http://dx.doi.org/10.1051/0004-6361/201219605 (2013). C C F.-H. Rouet, PhD thesis from INPT, Toulouse, France, C Memory and Performance issues in parallel multifrontal factorization and C triangular solutions with sparse right-hand sides (2014). C C J.-Y. L'Excellent, Habilitation thesis from ENS Lyon, C Multifrontal methods: Parallelism, Memory Usage and Numerical C Aspects (2012). C C P. Amestoy, I.S. Duff, J.-Y. L'Excellent, Y. Robert, F.H. Rouet C and B. Ucar, On computing inverse entries of a sparse matrix in C an out-of-core environment, C SIAM J. on Scientific Computing Vol. 34 N. 4, p. 1975-1999 (2012). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C The Multifrontal Method, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C MUMPS, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Agullo, Guermouche and L'Excellent, Reducing the {I/O} Volume in C Sparse Out-of-core Multifrontal Methods}, SIAM SISC, Vol 31, Nb. 6, C 4774-4794 (2010). C C Amestoy, Duff, Guermouche, Slavova, Analysis of the Solution Phase of a C Parallel Multifrontal Approach, Parallel Computing, Vol. 36, 3--15 (2010). C C Tzvetomila Slavova, PhD from INPT prepared at CERFACS, C Parallel triangular solution in the out-of-core multifrontal approach C for solving large sparse linear systems, available as CERFACS C Report TH/PA/09/59 (2009). C C Agullo, Guermouche and L'Excellent, A Parallel Out-of-core Multifrontal C Method: Storage of Factors on Disk and Analysis of Models for an C Out-of-core Active Memory, Parallel Computing, Special Issue on Parallel C Matrix Algorithms, Vol. 34, Nb 6-8, 296--317 (2008). C C Emmanuel Agullo, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C On the Out-of-core Factorization of Large Sparse Matrices (Nov 2008). C C Amestoy, Duff, Ruiz, and Ucar, "A parallel C matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, (Jan 2008). C C Guermouche and L'Excellent, Constructing Memory-minimizing Schedules C for Multifrontal Methods, ACM TOMS, Vol. 32, Nb. 1, 17--32 (2006). C C Amestoy, Guermouche, L'Excellent, and Pralet, C Hybrid scheduling for the parallel solution C of linear systems. Vol 32 (2), pp 136-156 (2006). C C Stephane Pralet, PhD from INPT prepared at CERFACS, C Constrained orderings and scheduling for parallel sparse linear algebra, C available as CERFACS technical report, TH/PA/04/105, (Sept 2004). C C Abdou Guermouche, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C Etude et optimisation du comportement memoire dans les methodes paralleles C de factorisation de matrices creuses (2004). C C Guermouche, L'Excellent and Utard, Impact of Reordering on the Memory of a C Multifrontal Solver, Parallel Computing, Vol. 29, Nb. 9, 1191--1218 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Impact of the Implementation C of MPI Point-to-Point Communications on the Performance of Two General C Sparse Solvers, Parallel Computing, Vol. 29, Nb 7, 833--847 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Analysis and Comparison of C Two General Sparse Solvers for Distributed Memory Computers, ACM TOMS, C Vol. 27, Nb 4, 388--421 (2001). C C Amestoy, Duff, Koster and L'Excellent (2001), C A fully asynchronous multifrontal solver using distributed dynamic C scheduling, SIAM Journal of Matrix Analysis and Applications, C Vol 23, No 1, pp 15-41 (2001). C C Amestoy, Duff and L'Excellent (2000), C Multifrontal parallel distributed symmetric and unsymmetric solvers, C Comput. Methods in Appl. Mech. Eng., 184, 501-520 (2000) C C Amestoy, Duff and L'Excellent (1998), C Parallelisation de la factorisation LU de matrices C creuses non-symmetriques pour des architectures a memoire distribuee, C Calculateurs Paralleles Reseaux et systemes repartis, C Vol 10(5), 509-520 (1998). C C PARASOL Deliverable D2.1d (final report), C CMUMPS Version 3.1, A MUltifrontal Massively Parallel Solver, C PARASOL project, EU ESPRIT IV LTR project 20160, (June 1999). C C Jacko Koster, PhD from INPT prepared at CERFACS, On the parallel solution C and the reordering of unsymmetric sparse linear systems (1997). C C Vincent Espirat, Master's thesis from INPT(ENSEEIHT)-IRIT, Developpement C d'une approche multifrontale pour machines a memoire distribuee et C reseau heterogene de stations de travail (1996). C C Patrick Amestoy, PhD from INPT prepared at CERFACS, Factorization of large C sparse matrices based on a multifrontal approach in a multiprocessor C environment, Available as CERFACS report TH/PA/91/2 (1991). C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine CMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine CMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of CMUMPS_STRUC, which may then be altered before C subsequent calls to CMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE CMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE CMUMPS_CHECK_DENSE_RHS SUBROUTINE CMUMPS_ANA_DRIVER( id ) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id END SUBROUTINE CMUMPS_ANA_DRIVER SUBROUTINE CMUMPS_FAC_DRIVER( id ) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id END SUBROUTINE CMUMPS_FAC_DRIVER SUBROUTINE CMUMPS_SOLVE_DRIVER( id ) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id END SUBROUTINE CMUMPS_SOLVE_DRIVER SUBROUTINE CMUMPS_PRINT_ICNTL(id, LP) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE CMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (CMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a COMPLEX array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a COMPLEX array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are REAL C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF C Initialize id%MYID now because it is C required by MUMPS_PROPINFO. id%MYID C used to be initialized inside CMUMPS_INI_DRIVER, C leading to an uninitialized access here. CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN C C If there was an error, then initialization C was already called and we can rely on the null C or non null value of the pointers related to OOC C stuff. C We use CMUMPS_CLEAN_OOC_DATA that should work even C on the master. Note that KEEP(201) was also C initialized in a previous call to Mumps. C C If CMUMPS_END_DRIVER or CMUMPS_FAC_DRIVER is called after C this error, then CMUMPS_CLEAN_OOC_DATA will be called C a second time, though. C IF (id%KEEP(201).GT.0) THEN CALL CMUMPS_CLEAN_OOC_DATA(id, IERR) ENDIF GOTO 499 ENDIF C ---------------------------------------- C Initialization CMUMPS_INI_DRIVER C ---------------------------------------- C - Default values for ICNTL, KEEP,KEEP8, CNTL C - Attach emission buffer for buffered Send C - Nullify pointers in the structure C - Get rank and size of the communicator C ---------------------------------------- CALL CMUMPS_INI_DRIVER( id ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN C ------------------------------------- C Deallocation of the instance id C ------------------------------------- id%KEEP(40)= -2 - 456789 CALL CMUMPS_END_DRIVER( id ) GOTO 500 END IF C C TIMINGS: for JOBS different from -1 and -2, C we measure TIMETOTAL: C IF (id%MYID.EQ.MASTER) THEN id%DKEEP(70)=0.0E0 CALL MUMPS_SECDEB(TIMETOTAL) ENDIF C C---------------------------------------------------------------- C C JOB = 7 : SAVE THE INSTANCE C C JOB = 8 : RESTORE THE INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. 7 .OR. JOB .EQ. 8 ) THEN IF( JOB.EQ.8 .AND. OLDJOB.NE.-1) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 IF ( JOB .EQ. 7 ) THEN IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL CMUMPS_SAVE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in save structure driver= ', TIMEG END IF ENDIF ELSE IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL CMUMPS_RESTORE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in restore structure driver= ' & , TIMEG ENDIF END IF ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C JOB = -3 : REMOVE SAVED INSTANCE C C---------------------------------------------------------------- C IF (JOB .EQ. -3) THEN CALL CMUMPS_REMOVE_SAVED(id) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF IF (JOB.EQ.9) THEN C Check that factorization was performed IF ( OLDJOB .LT. 2 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ELSE CALL CMUMPS_SOL_INIT_IRHS_loc(id) ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C MAIN DRIVER C OTHER VALUES OF JOB : 1 to 6 C C---------------------------------------------------------------- CALL MUMPS_MEMORY_SET_DATA_SIZES() IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF C C Propagate possible error to all nodes CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 C C Print ICNTL and KEEP C IF (PROK) CALL CMUMPS_PRINT_ICNTL(id, MP) C----------------------------------------------------------------------- C C CHECK SEQUENCE C C----------------------------------------------------------------------- IF ( LANA ) THEN IF ( PROKG .AND. OLDJOB .EQ. -1 ) THEN C Print compilation options at first call to analysis CALL MUMPS_PRINT_IF_DEFINED(MPG) ENDIF C C User wants to perform analysis. Previous value of C JOB must be -1, 1, 2 or 3. C IF ( OLDJOB .EQ. 0 .OR. OLDJOB .GT. 3 .OR. OLDJOB .LT. -1 ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( OLDJOB .GE. 2 ) THEN C ----------------------------------------- C Previous step was factorization or solve. C As analysis is now performed, deallocate C at least some big arrays from facto. C ----------------------------------------- IF (associated(id%IS)) THEN DEALLOCATE (id%IS) NULLIFY (id%IS) END IF IF (associated(id%S)) THEN DEALLOCATE (id%S) NULLIFY (id%S) END IF END IF END IF IF ( LFACTO ) THEN C ------------------------------------ C User wants to perform factorization. C Analysis must have been performed. C ------------------------------------ IF ( OLDJOB .LT. 1 .and. .NOT. LANA ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN C ------------------------------- C User wants to perform solve. C Facto must have been performed. C ------------------------------- IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF C ------------------------------------------ C Permute JCN on entry to JOB if no analysis C to be performed and IRN/JCN are needed. C (facto: arrowheads + solve: iterative C refinement and error analysis) C ------------------------------------------ #if ! defined (LARGEMATRICES) NOERRORBEFOREPERM =.TRUE. UNS_PERM_DONE=.FALSE. IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF ( id%JOB .EQ. 2 .OR. id%JOB .EQ. 5 .OR. & (id%JOB .EQ. 3 .AND. (id%ICNTL(10) .NE.0 .OR. & id%ICNTL(11).NE. 0))) THEN UNS_PERM_DONE = .TRUE. ALLOCATE(UNS_PERM_INV(id%N),stat=IERR) IF (IERR .GT. 0) THEN C -------------------------------- C Exit with an error. C We are not able to permute C JCN correctly after a MAX-TRANS C permutation resulting from a C previous call to CMUMPS. C -------------------------------- id%INFO(1)=-13 id%INFO(2)=id%N IF (LPOK) WRITE(LP,99993) GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I8 = 1_8, id%KEEP8(28) J = id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 * ********* * MaxTrans-Analysis-Distri, Scale-Arrowhead-factorize, and * Solve-IR-Error_Analysis (depending on the value of JOB) ********* * C IF ( LANA ) THEN C----------------------------------------------------- C- C- ANALYSIS : Max-Trans, Analysis, Distribution C- C----------------------------------------------------- C C Few checks + allocations C C IS : will be allocated on the slaves later C PROCNODE : on the master only, C because slave does not know N yet. C Will be allocated in analysis for the slave. C C For assembled entry: C IRN, JCN : check that they have been allocated by the C user on the master, and if their size is adequate C C For element entry: C ELTPTR, ELTVAR : check that they have been allocated by the C user on the master, and if their size is adequate C ---------------------------- C Reset KEEP(40) to -1 for the C case where an error occurs C ---------------------------- id%KEEP(40)=-1 -456789 C IF (id%MYID.EQ.MASTER) THEN C Check N, [N]NZ, NELT IF ((id%N.LE.0).OR.((id%N+id%N+id%N)/3.NE.id%N)) THEN id%INFO(1) = -16 id%INFO(2) = id%N GOTO 100 END IF IF (id%ICNTL(5).NE.1) THEN C Assembled input IF (id%ICNTL(18) .LT. 1 .OR. id%ICNTL(18) .GT. 3) THEN C Centralized input IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) GOTO 100 ENDIF ENDIF ELSE C Element entry: check NELT on the master IF (id%NELT .LE. 0) THEN id%INFO(1) = -24 id%INFO(2) = id%NELT GOTO 100 ENDIF ENDIF C -- initialize values of respectively C icntl(6), (7) and (12) to not done/chosen id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 C --------------------------------------- C Element entry: allocate ELTPROC(1:NELT) C --------------------------------------- IF ( id%ICNTL(5) .EQ. 1 ) THEN ! Elemental matrix IF ( associated( id%ELTPROC ) ) & DEALLOCATE( id%ELTPROC ) ALLOCATE( id%ELTPROC(id%NELT), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%NELT IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array ELTPROC' GOTO 100 END IF END IF C --------------------------------------------------- C Assembled centralized entry: check input parameters C IRN/JCN C Element entry: check input parameters ELTPTR/ELTVAR C --------------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! Assembled matrix id%KEEP8(30)=0_8 IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available before f2002. One can C still check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: IRN/JCN badly allocated.' END IF ELSE IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE id%LELTVAR = id%ELTPTR( id%NELT+1 ) - 1 IF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE C If no error, we compute KEEP8(30) (formerly NA_ELT), C required for CMUMPS_MAX_MEM already in analysis, and C then later during facto to check the size of A_ELT id%KEEP8(30) = 0_8 IF ( id%KEEP(50) .EQ. 0 ) THEN C Unsymmetric elements (but symmetric structure) DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + int(J,8) * int(J,8) ENDDO ELSE C Symmetric elements DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + & (int(J,8) *int(J+1,8))/2_8 ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 C ----------------------------------------- C Call analysis procedure CMUMPS_ANA_DRIVER C ----------------------------------------- IF (id%MYID .eq. MASTER) THEN id%DKEEP(71)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C ------------------------------------------------- C Set scaling option for analysis in KEEP(52) C (ICNTL(8) only defined on host at analysis phase) C ------------------------------------------------- IF (id%MYID.EQ.MASTER) THEN C{ id%KEEP(52) = id%ICNTL(8) C Out-of-range values => automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after CMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL CMUMPS_ANA_DRIVER( id ) C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL CMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL CMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_F2003) ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_F2003) IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #else IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL CMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ------------------------ C If Schur has been asked C for, scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with Schur)' END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: This scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: Scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of CMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL CMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks CALL CMUMPS_SET_K221(id) CALL CMUMPS_CHECK_REDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in CMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C CMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ C & id%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL CMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(id%root%SCHUR_NLOC-1,8)+ & int(id%root%SCHUR_MLOC,8)) CALL CMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < id%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & id%root%SCHUR_MLOC id%INFO(1)=-30 id%INFO(2)=id%SCHUR_LLD ELSE IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF (size(id%SCHUR) < & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) THEN IF (LP.GT.0) THEN write(LP,'(A)') & ' SCHUR allocated but too small' write(LP,*) id%MYID, ' : Size Schur=', & size(id%SCHUR), & ' SCHUR_LLD= ', id%SCHUR_LLD, & ' SCHUR_MLOC=', id%root%SCHUR_NLOC, & ' SCHUR_NLOC=', id%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within CMUMPS here. id%root%SCHUR_LLD=id%SCHUR_LLD IF (id%root%SCHUR_NLOC==0) THEN ALLOCATE(id%root%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE id%root%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure CMUMPS_FAC_DRIVER C ----------------------------------------------- CALL CMUMPS_FAC_DRIVER(id) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C id%root%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (id%root%yes) THEN IF (id%root%SCHUR_NLOC==0) THEN DEALLOCATE(id%root%SCHUR_POINTER) NULLIFY(id%root%SCHUR_POINTER) ELSE NULLIFY(id%root%SCHUR_POINTER) ENDIF ENDIF ENDIF C root%RG2L_ROW and root%RG2L_COL C are not used outside of the facto IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver= ', TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C Free id%S if facto failed if (associated(id%S)) then DEALLOCATE(id%S) NULLIFY(id%S) endif GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure CMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL CMUMPS_SOLVE_DRIVER(id) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL CMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to CMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO ENDIF END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL CMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = real(TIMETOTAL) ENDIF ENDIF *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN CALL CMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=REAL(id%KEEP8(55))/1E6 id%RINFO(8)=REAL(id%KEEP8(56))/1E6 id%RINFOG(17)=REAL(id%KEEP8(57))/1E6 id%RINFOG(18)=REAL(id%KEEP8(58))/1E6 ENDIF !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from CMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from CMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM CMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE CMUMPS * SUBROUTINE CMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE CMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE CMUMPS_PRINT_ICNTL (id, LP) USE CMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL REAL, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Null pivot detection threshold =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE CMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE CMUMPS_PRINT_KEEP(id, LP) USE CMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (CMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).NE.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) KEEP(12) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),KEEP(248),ICNTL(21) WRITE (LP,993) KEEP(12) END SELECT ENDIF 980 FORMAT (/'******INTERNAL VALUE OF PARAMETERS (ICNTL/KEEP)****'/) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=Off, >0=ON) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) END SUBROUTINE CMUMPS_PRINT_KEEP SUBROUTINE CMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_F2003) & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #else C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE CMUMPS_CHECK_DENSE_RHS C SUBROUTINE CMUMPS_SET_K221(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C Constraint: must be called before CMUMPS_CHECK_REDRHS. C Can be called at factorization or solve phase C TYPE (CMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).ne.0 .and. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).ne.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE CMUMPS_SET_K221 C SUBROUTINE CMUMPS_CHECK_REDRHS(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)=1 is C forbidden in case of fwd in facto. C TYPE (CMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID .EQ. MASTER) THEN IF ( id%KEEP(221) == 1 .or. id%KEEP(221) == 2 ) THEN IF (id%KEEP(221) == 2 .and. id%JOB == 2) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF (id%KEEP(221) == 1 .and. id%KEEP(252) == 1 & .and. id%JOB == 3) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) ENDIF IF ( id%KEEP(60).eq. 0 .or. id%SIZE_SCHUR.EQ.0 ) THEN id%INFO(1)=-33 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF ( .NOT. associated( id%REDRHS)) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ELSE IF (id%NRHS.EQ.1) THEN IF (size(id%REDRHS) < id%SIZE_SCHUR ) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ELSE IF (id%LREDRHS < id%SIZE_SCHUR) THEN id%INFO(1)=-34 id%INFO(2)=id%LREDRHS GOTO 333 ELSE IF & (size(id%REDRHS)< & id%NRHS*id%LREDRHS-id%LREDRHS+id%SIZE_SCHUR) & THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ENDIF ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE CMUMPS_CHECK_REDRHS MUMPS_5.4.1/src/stools.F0000664000175000017500000021750514102210521015145 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE SMUMPS_LOAD USE SMUMPS_OOC !$ USE OMP_LIB USE SMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) REAL A( LA ) INTEGER IWPOS, LDLT INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(N), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I, SIZESHIFT, ITMP8 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR INTEGER PARPIV_T1 LOGICAL LR_ACTIVATED IERR=0 LDLT = KEEP(50) IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF (LDLT.EQ.0) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF IF ( TYPE .EQ. 2 ) THEN IF (LDLT.EQ.0) THEN SIZECB = int(NELIM,8) * int(LCONT,8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN SIZECB = int(NELIM+1,8) * int(NELIM + NPIV,8) ELSE SIZECB = int(NELIM,8) * int(NELIM + NPIV,8) ENDIF ENDIF ELSE LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (LDLT.EQ.0) THEN CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(LCONT,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ELSE CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(NROW,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZELU ELSE SIZESHIFT = 0_8 IF (SIZECB.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL SMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in SMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ MOVEPTRAST = .FALSE. DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 SMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 SMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 SMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZESHIFT MOVEPTRAST = .TRUE. PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 SMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 SMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZECB+SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZELU-SIZESHIFT, POSFAC-SIZECB-SIZESHIFT-1_8 A( I ) = A( I + SIZECB + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - (SIZECB+SIZESHIFT) LRLU = LRLU + (SIZECB+SIZESHIFT) ITMP8 = (SIZECB+SIZESHIFT) - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU-SIZESHIFT,-(SIZECB+SIZESHIFT)+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE SMUMPS_COMPRESS_LU SUBROUTINE SMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE SMUMPS_OOC USE SMUMPS_LOAD USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE REAL A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL SMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL SMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL SMUMPS_COMPRE_NEW( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress SMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL SMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+LREQA ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN CALL SMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in SMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL SMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL SMUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_STACK_BAND SUBROUTINE SMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_PTR, & SMUMPS_DM_FREE_BLOCK IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) REAL A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE REAL, DIMENSION(:), POINTER :: FORTRAN_POINTER ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE SMUMPS_FREE_BAND SUBROUTINE SMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF END SUBROUTINE SMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE SMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: SMUMPS_LBUF_INT INTEGER(8) :: SMUMPS_LBUFR_BYTES8, SMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8 * N8 IF (KEEP(23).ne.0 .and. I_AM_MASTER) NB_INT=NB_INT + N8 IF (KEEP(55).eq.0) THEN NB_INT = NB_INT + 2_8 * N8 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) ENDIF IF (KEEP(55) .ne. 0 ) THEN NB_INT = NB_INT + N8 + 1_8 + NELT8 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 CALL SMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF NB_REAL = NB_REAL + KEEP8(26) IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF IF ( I_AM_SLAVE .and. KEEP(38) .ne. 0 ) THEN NB_INT = NB_INT + 2_8 * N8 END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = max( NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + (NB_REAL+TEMPR) * int(KEEP(35),8) & , TEMP ) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN SMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE SMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF SMUMPS_LBUFR_BYTES8 = max( SMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(489).GT.0) THEN SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( 0.5E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0,8) ELSE SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0,8) ENDIF SMUMPS_LBUFR_BYTES8 = min(SMUMPS_LBUFR_BYTES8, & int(huge (KEEP(43))-100,8)) NB_BYTES = NB_BYTES + SMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF SMUMPS_LBUF8 = max( SMUMPS_LBUF8, 100000_8 ) SMUMPS_LBUF8 = SMUMPS_LBUF8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUF8)/100E0, 8) SMUMPS_LBUF8 = min(SMUMPS_LBUF8, int(huge (KEEP(43)-100),8)) SMUMPS_LBUF8 = max(SMUMPS_LBUF8, SMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + SMUMPS_LBUF8 ENDIF SMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(SMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN NB_INT = NB_INT + N8*KEEP(400) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 2 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 2 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI IF (KEEP(494).NE.0) THEN NB_INT = NB_INT + N8 ENDIF ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( real(MEMORY_BYTES) / real(1000000) ) RETURN END SUBROUTINE SMUMPS_MAX_MEM SUBROUTINE SMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL SMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE SMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE SMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(36)) * ( 1.0E0 - & real(ICNTL38)/real(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -real(KEEP8(11)-KEEP8(32)) * & real(ICNTL38) / 1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(38)) * ( 1.0E0 - & real(ICNTL38+ICNTL39)/ & real(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL38+ICNTL39)/1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(37)) * ( 1.0E0 - & real(ICNTL39)/real(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL39)/1000.0E0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (KEEP8(4)/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF CALL SMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, & .FALSE., & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE SMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL SMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE SMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE SMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE REAL M_ARRAY(M_SIZE) REAL ZERO PARAMETER (ZERO=0.0E0) M_ARRAY=ZERO RETURN END SUBROUTINE SMUMPS_SETMAXTOZERO SUBROUTINE SMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE SMUMPS_COMPUTE_NBROWSinF SUBROUTINE SMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE SMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB REAL A(ASIZE) REAL M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW REAL ZERO,TMP PARAMETER (ZERO=0.0E0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE SMUMPS_COMPUTE_MAXPERCOL SUBROUTINE SMUMPS_SIZE_IN_STRUCT( id, NB_INT, NB_CMPLX, NB_CHAR ) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) NB_INT=NB_INT+size(id%STEP) IF (associated(id%NE_STEPS )) NB_INT=NB_INT+size(id%NE_STEPS ) IF (associated(id%ND_STEPS)) NB_INT=NB_INT+size(id%ND_STEPS) IF (associated(id%Step2node)) NB_INT=NB_INT+size(id%Step2node) IF (associated(id%FRERE_STEPS)) NB_INT=NB_INT+size(id%FRERE_STEPS) IF (associated(id%DAD_STEPS)) NB_INT=NB_INT+size(id%DAD_STEPS) IF (associated(id%FILS)) NB_INT=NB_INT+size(id%FILS) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) NB_INT=NB_INT+size(id%KEEP8) * id%KEEP(10) IF (associated(id%PTRFAC)) NB_INT=NB_INT+size(id%PTRFAC) * & id%KEEP(10) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%NA)) NB_INT=NB_INT+size(id%NA) IF (associated(id%PROCNODE_STEPS)) & NB_INT=NB_INT+size(id%PROCNODE_STEPS) IF (associated(id%PTLUST_S)) NB_INT=NB_INT+size(id%PTLUST_S) IF (associated(id%INTARR)) NB_INT=NB_INT+id%KEEP8(27) IF (associated(id%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES) IF (associated(id%SYM_PERM)) & NB_INT=NB_INT+size(id%SYM_PERM) IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE) IF (associated(id%I_AM_CAND)) & NB_INT=NB_INT+size(id%I_AM_CAND) IF (associated(id%MEM_DIST)) & NB_INT=NB_INT+size(id%MEM_DIST) IF (associated(id%POSINRHSCOMP_ROW)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_ROW) IF(id%POSINRHSCOMP_COL_ALLOC.AND.associated(id%POSINRHSCOMP_COL)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_COL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) & NB_INT=NB_INT+size(id%LRGROUPS) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(id%root%RG2L_COL)) & NB_INT=NB_INT+size(id%root%RG2L_COL) IF (associated(id%root%RG2L_ROW)) & NB_INT=NB_INT+size(id%root%RG2L_ROW) IF (associated(id%root%IPIV)) & NB_INT=NB_INT+size(id%root%IPIV) IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_CNTR_MASTER_ROOT) IF (associated(id%root%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(id%root%SCHUR_POINTER) IF (associated(id%root%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(id%root%QR_TAU) IF (associated(id%root%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_ROOT) IF (associated(id%root%SVD_U)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_U) IF (associated(id%root%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_VT) IF (associated(id%root%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%root%SINGULAR_VALUES) IF (associated(id%DBLARR)) NB_CMPLX=NB_CMPLX+id%KEEP8(26) IF (associated(id%RHSCOMP)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL NB_CMPLX = NB_CMPLX + id%KEEP8(71) + id%KEEP8(64) RETURN END SUBROUTINE SMUMPS_SIZE_IN_STRUCT SUBROUTINE SMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 REAL, intent(in) :: SRC(N8) REAL, intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL scopy(N8, SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL scopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE SMUMPS_COPYI8SIZE SUBROUTINE SMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE SMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 REAL, INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL SMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE SMUMPS_SET_TMP_PTR SUBROUTINE SMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE SMUMPS_OOC, ONLY : IO_BLOCK, & SMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE SMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) USE SMUMPS_BUF, ONLY : SMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) REAL VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT CALL SMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) RETURN END SUBROUTINE SMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT REAL, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL SMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE SMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE SMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR REAL, intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) REAL :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) REAL :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL SMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE SMUMPS_COMPRESS_CB_I SUBROUTINE SMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, OMP_NUM & ) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) REAL, intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) REAL :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) REAL :: WORK(MAXI_CLUSTER*MAXI_CLUSTER*OMP_NUM) REAL :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL SMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE SMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE SMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE SMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR REAL, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL SMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE SMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE SMUMPS_LR_TYPE, ONLY : LRB_TYPE USE SMUMPS_FAC_LR, ONLY : SMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO REAL, intent(inout) :: A(LA) REAL, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS REAL, INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL SMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I MUMPS_5.4.1/src/clr_type.F0000664000175000017500000000477214102210524015446 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE COMPLEX,POINTER,DIMENSION(:,:) :: Q => null() COMPLEX,POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: MEM IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) IF(associated(LRB_OUT%R)) MEM = MEM + size(LRB_OUT%R) ELSE IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) ENDIF !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - int(MEM,8) !$OMP END ATOMIC IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE CMUMPS_LR_TYPE MUMPS_5.4.1/src/mumps_metis_int.c0000664000175000017500000000252614102210474017075 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_metis_int.h" #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) # include "metis.h" # if defined(parmetis3) || defined(metis4) /* IDXTYPEWIDTH not available, use sizeof(idxtype) */ /* We use metis.h and assume that parmetis datatypes will be identical to those of metis.h since it does not make senss to combine metis and parmetis with different int sizes */ void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_idx_size) { *metis_idx_size=8*sizeof(idxtype); } # else /* Rely on IDXTYPEWIDTH */ void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_idx_size) { /* *metis_idx_size=sizeof(idx_t); */ *metis_idx_size=IDXTYPEWIDTH; } # endif #else void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_int_size) { *metis_int_size=-99999; } #endif MUMPS_5.4.1/src/zfac_b.F0000664000175000017500000003732214102210524015046 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ZMUMPS_LBUF, INTARR, DBLARR, root, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS & ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_FAC_UPD_DYN_MEMCNTS USE ZMUMPS_LOAD USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_ALLOC_CB, ZMUMPS_BUF_DEALL_CB USE ZMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS DOUBLE PRECISION RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: ZMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) DOUBLE PRECISION CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) DOUBLE PRECISION SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok DOUBLE PRECISION UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK DOUBLE PRECISION ZERO, ONE DATA ZERO /0.0D0/ DATA ONE /1.0D0/ INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN COMPLEX(kind=8) :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR COMPLEX(kind=8), TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = cmplx(1.0D0,0.0D0, kind=kind(1.0D0)) IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL ZMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) CALL ZMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 KEEP8(67) = LRLUS IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error ZMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN ALLOCATE(S_IS_POINTERS%A(LA), stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) KEEP8(23)=0_8 ELSE KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL ZMUMPS_BUF_ALLOC_CB( ZMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (ZMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in ZMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) DEALLOCATE(S_IS_POINTERS%A); NULLIFY(S_IS_POINTERS%A) END IF ENDIF IW_DUMMY = .FALSE. A_DUMMY = .FALSE. IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL ZMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), & NFSIZ,FILS,STEP,FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), & ITLOC, RHS_MUMPS, POOL, LPOOL, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF CALL ZMUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = dble(OPASS) RINFO(3) = dble(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL ZMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = dble(KEEP8(31)*int(KEEP(35),8))/1D6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE ZMUMPS_FAC_B SUBROUTINE ZMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, & MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_FAC_ASM_MASTER_M USE ZMUMPS_FAC_ASM_MASTER_ELT_M USE ZMUMPS_FAC1_LDLT_M USE ZMUMPS_FAC2_LDLT_M USE ZMUMPS_FAC1_LU_M USE ZMUMPS_FAC2_LU_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_FAC_PAR_M, ONLY : ZMUMPS_FAC_PAR IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX(kind=8), INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX(kind=8) :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) DOUBLE PRECISION RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV DOUBLE PRECISION UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER LRGROUPS(N) CALL ZMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root, PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) RETURN END SUBROUTINE ZMUMPS_FAC_PAR_I MUMPS_5.4.1/src/cfac_front_LDLT_type1.F0000664000175000017500000011330714102210524017665 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE CMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) USE CMUMPS_FAC_FRONT_AUX_M USE CMUMPS_OOC USE CMUMPS_FAC_LR USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL COMPLEX A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW REAL MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L COMPLEX, POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG COMPLEX, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL,ALLOCATABLE :: RWORK(:) COMPLEX, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS COMPLEX :: ONE, MONE, ZERO PARAMETER (ONE=(1.0E0,0.0E0), MONE=(-1.0E0,0.0E0)) PARAMETER (ZERO=(0.0E0,0.0E0)) INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL CMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL CMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL CMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0E0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTBL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL CMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL CMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if defined(BLR_MT) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL CMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL CMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL CMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL CMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL CMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC) #endif IF ( (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL CMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL CMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL CMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif END IF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL CMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL CMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL CMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL CMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL CMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL CMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL CMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FAC1_LDLT END MODULE CMUMPS_FAC1_LDLT_M MUMPS_5.4.1/src/mumps_config_file_C.h0000664000175000017500000000131214102210474017605 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_CONFIG_FILE_C_H #define MUMPS_CONFIG_FILE_C_H #include "mumps_common.h" #define MUMPS_CONFIG_FILE_RETURN_C \ F_SYMBOL(config_file_return_c,CONFIG_FILE_RETURN_C) void MUMPS_CALL MUMPS_CONFIG_FILE_RETURN_C(); #endif /* MUMPS_CONFIG_FILE_C_H */ MUMPS_5.4.1/src/cana_reordertree.F0000664000175000017500000012342114102210523017121 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE REAL PEAK REAL, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,NSTK,INODE,I,allocok,LOCAL_PERM INTEGER(8) NCB INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER, DIMENSION (:), POINTER :: TAB INTEGER dernier,fin INTEGER cour,II INTEGER CB_current,CB_MAX,ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE,SUM,MEM_SEC_PERM,FACT_SIZE_T, & MEM_SIZE_T,TOTAL_MEM_SIZE,TMP_TOTAL_MEM_SIZE,TMP_SUM, & SIZECB, SIZECB_LASTSON INTEGER(8) TMP8 LOGICAL SBTR_M INTEGER FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in CMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL CMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NSTK = NE(STEP(INODE)) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL CMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL CMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL CMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF CONTINUE IFATH=INODE DO II=1,2 SUM=0_8 FACT_SIZE=0_8 FACT_SIZE_T=0_8 MEM_SIZE=0_8 MEM_SIZE_T=0_8 CB_MAX=0 CB_current=0 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in CMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL CMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(real(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL CMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_REORDER_TREE SUBROUTINE CMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE REAL PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR REAL COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok,LOCAL_PERM INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER x,dernier,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE, & TOTAL_MEM_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF IF (K47 == 4 .OR. ((K47.GE.2).AND.(K81.GE. 1))) THEN DO I=1,SLAVEF INDICE(I)=1 ENDDO DO I=1,SLAVEF DO x=1,SIZE_MEM_SBTR MEM_SUBTREE(x,I)=-1.0D0 ENDDO ENDDO ENDIF SBTR_M=((K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1)))) MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in CMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL CMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & CMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0E0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=real(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & real(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=real(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0E0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,real(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE CMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL CMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL CMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE CMUMPS_FUSION_SORT MUMPS_5.4.1/src/dmumps_config_file.F0000664000175000017500000000103314102210523017440 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE DMUMPS_CONFIG_FILE_RETURN MUMPS_5.4.1/src/sfac_b.F0000664000175000017500000003725314102210521015037 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & SMUMPS_LBUF, INTARR, DBLARR, root, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS & ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY: SMUMPS_DM_FAC_UPD_DYN_MEMCNTS USE SMUMPS_LOAD USE SMUMPS_BUF, ONLY : SMUMPS_BUF_ALLOC_CB, SMUMPS_BUF_DEALL_CB USE SMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS REAL RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: SMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) REAL CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) REAL SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok REAL UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK REAL ZERO, ONE DATA ZERO /0.0E0/ DATA ONE /1.0E0/ INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN REAL :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR REAL, TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = cmplx(1.0E0,0.0E0, kind=kind(1.0E0)) IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL SMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) CALL SMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 KEEP8(67) = LRLUS IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error SMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN ALLOCATE(S_IS_POINTERS%A(LA), stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) KEEP8(23)=0_8 ELSE KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL SMUMPS_BUF_ALLOC_CB( SMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (SMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in SMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) DEALLOCATE(S_IS_POINTERS%A); NULLIFY(S_IS_POINTERS%A) END IF ENDIF IW_DUMMY = .FALSE. A_DUMMY = .FALSE. IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL SMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL SMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), & NFSIZ,FILS,STEP,FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), & ITLOC, RHS_MUMPS, POOL, LPOOL, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF CALL SMUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = real(OPASS) RINFO(3) = real(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL SMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = real(KEEP8(31)*int(KEEP(35),8))/1E6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF IF (KEEP(50) .NE. 0) THEN WRITE(MPRINT,99984) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99984 FORMAT (' --- (12) Number of negative pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE SMUMPS_FAC_B SUBROUTINE SMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, & MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) USE SMUMPS_LOAD USE SMUMPS_OOC USE SMUMPS_FAC_ASM_MASTER_M USE SMUMPS_FAC_ASM_MASTER_ELT_M USE SMUMPS_FAC1_LDLT_M USE SMUMPS_FAC2_LDLT_M USE SMUMPS_FAC1_LU_M USE SMUMPS_FAC2_LU_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_FAC_PAR_M, ONLY : SMUMPS_FAC_PAR IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP REAL, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA REAL :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER LRGROUPS(N) CALL SMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root, PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) RETURN END SUBROUTINE SMUMPS_FAC_PAR_I MUMPS_5.4.1/src/csol_fwd_aux.F0000664000175000017500000011666614102210523016307 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) USE CMUMPS_OOC USE CMUMPS_SOL_LR, ONLY: CMUMPS_SOL_SLAVE_LR_U USE CMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) COMPLEX WCB( LWCB ), A( LA ) COMPLEX RHSCOMP( LRHSCOMP, NRHS ) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSCOMP INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG !$ LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR COMPLEX ALPHA, ONE PARAMETER (ONE=(1.0E0,0.0E0), ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_COMPLEX, COMM, IERR ) DO I = 1, LONG IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(IWCB(I))) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 CMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_COMPLEX, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_COMPLEX, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL CMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL CMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in CMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE CMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE CMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE CMUMPS_SOL_LR USE CMUMPS_OOC USE CMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS COMPLEX WCB( LWCB ), A( LA ) INTEGER(8) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP COMPLEX RHSCOMP(LRHSCOMP, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL cgemv, ctrsv, cgemm, ctrsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE COMPLEX ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSCOMPLASTFSDYN !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) ERROR_WAS_BROADCASTED = .FALSE. DUMMY(1)=1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN LDADIAG = NPIV ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IFR_ini8 = IFR8 !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(IFR8,JJ) IF(OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in CMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL CMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP(1, JBDEB), LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL CMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL ctrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL ctrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL ctrsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL cgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL CMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE CALL CMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( KEEP(50) .eq. 0 ) THEN APOS1 = APOS + int(NPIV,8) * int(LIELL,8) ELSE APOS1 = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL CMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN CALL CMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSCOMPLASTFSDYN = 0 ELSE IPOSINRHSCOMPLASTFSDYN = & abs(POSINRHSCOMP_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSCOMP_FWD( IW(J3+I) )) .GT. & IPOSINRHSCOMPLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN IF (.NOT. CBINITZERO) THEN WRITE(*,*) ' Internal error 3 in CMUMPS_SOLVE_NODE_FWD', & CBINITZERO, INODE, NUPDATE, NUPDATE_NONCRITICAL CALL MUMPS_ABORT() ENDIF DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) !$OMP CRITICAL(CMUMPS_RHSCOMP_CRI) DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO !$OMP END CRITICAL(CMUMPS_RHSCOMP_CRI) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL CMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE CMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE CMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) COMPLEX WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSCOMP, POSINRHSCOMP_FWD(N) COMPLEX RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL CMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE CMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE CMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP, LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSCOMP, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSCOMP_FWD( N ), IW( LIW ) COMPLEX, INTENT( INOUT ) :: RHSCOMP( LRHSCOMP, NRHS_B ) COMPLEX, INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) REAL :: DKEEP(150) INTEGER, PARAMETER :: ZERO = (0.0E0,0.0E0) INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSCOMP INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' !$ LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP(IPOSINRHSCOMP,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( CBINITZERO ) THEN !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) !$OMP PARALLEL DO COLLAPSE(2) IF ( OMP_FLAG ) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_RHSCOMP_TO_WCB MUMPS_5.4.1/src/sfac_process_blocfacto_LDLT.F0000664000175000017500000013317214102210521021124 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_PROCESS_SYM_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE SMUMPS_LOAD USE SMUMPS_BUF USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_FAC_LR USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR USE SMUMPS_FAC_FRONT_AUX_M, & ONLY : SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)), PTRFAC(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PIVI INTEGER (8) POSPV1,POSPV2,OFFDAG,LPOS1 INTEGER J2 REAL MULT1,MULT2, A11, DETPIV, A22, A12 INTEGER :: NFS4FATHER, NVSCHUR_K253, NSLAVES_L, IROW_L REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY INTEGER NBROWSinF INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER INODE, POSITION, NPIV, IERR INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT REAL, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW, DEST INTEGER ICT11 INTEGER(8) LPOS, LPOS2, DPOS, UPOS INTEGER (8) IPOS, KPOS INTEGER I, IPIV, FPERE, NSLAVES_TOT, & NSLAVES_FOLLOW, NB_BLOC_FAC INTEGER IPOSK, JPOSK, NPIVSENT, Block, IROW, BLSIZE INTEGER allocok, TO_UPDATE_CPT_END REAL, DIMENSION(:), ALLOCATABLE :: UIP21K, BLFCTDYN INTEGER, DIMENSION(:), ALLOCATABLE :: LIST_SLAVES_FOLLOW, PIVDYN LOGICAL LASTBL INTEGER SRC_DESCBAND LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO LOGICAL COUNTER_WAS_HUGE INTEGER TO_UPDATE_CPT_RECUR INTEGER :: LR_ACTIVATED_INT LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL :: DYNPIVBLFCT LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: XSIZE, CURRENT_BLR, NSLAVES_PREC, INFO_TMP(2) INTEGER :: NELIM, NB_BLR_LM, NB_BLR_LS, & MAXI_CLUSTER_LM, MAXI_CLUSTER_LS, MAXI_CLUSTER, & NPARTSASS, NPARTSCB, NPARTSCB_COL, NPARTSASS_COL, & NB_BLR_COL, MAXI_CLUSTER_COL INTEGER :: NPARTSASS_MASTER, IPANEL, NB_ACCESSES_INIT TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_LM TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS, & BEGS_BLR_COL, BEGS_BLR_COL_TMP LOGICAL KEEP_BEGS_BLR_LS, KEEP_BEGS_BLR_COL, KEEP_BLR_LS REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ, SHIFT INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 POSITION = 0 TO_UPDATE_CPT_END = -654321 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NB_BLOC_FAC, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER, 1, & MPI_INTEGER, COMM, IERR ) NPARTSASS_COL = NPARTSASS_MASTER CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NSLAVES_TOT, 1, & MPI_INTEGER, COMM, IERR ) XSIZE = KEEP(IXSZ) KEEP_BEGS_BLR_LS =.FALSE. KEEP_BEGS_BLR_COL =.FALSE. KEEP_BLR_LS =.FALSE. IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) LD_BLOCFACTO = max(NPIV+NELIM,1) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) LD_BLOCFACTO = max(NCOL,1) ENDIF IF (LR_ACTIVATED) THEN DYNPIVBLFCT = .TRUE. ELSE DYNPIVBLFCT = .FALSE. ENDIF IF ( .NOT. DYNPIVBLFCT ) THEN IF ( NPIV .EQ. 0 ) THEN IPIV = 1 POSBLOCFACTO = 1_8 ELSE CALL SMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO IPIV = IWPOS IWPOS = IWPOS + NPIV CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ELSE ALLOCATE(PIVDYN(max(1,NPIV)),BLFCTDYN(max(1_8,LA_BLOCFACTO)), & stat=allocok) IF (allocok.GT.0) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR PIVDYN and BLFCTDYN IN ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 CALL MUMPS_SET_IERROR(max(1_8,LA_BLOCFACTO), IERROR) GOTO 700 ENDIF POSBLOCFACTO = 1_8 IPIV = 1 ENDIF IF (NPIV.GT.0) THEN IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & PIVDYN, NPIV, & MPI_INTEGER, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF (DYNPIVBLFCT) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLFCTDYN, int(LA_BLOCFACTO), & MPI_REAL, & COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), int(LA_BLOCFACTO), & MPI_REAL, & COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_LM, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_LM(max(NB_BLR_LM,1)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BLR_LM IN ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(NB_BLR_LM,1) GOTO 700 END IF ALLOCATE(BEGS_BLR_LM(NB_BLR_LM+2), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_LM IN ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NB_BLR_LM+2 GOTO 700 END IF CALL SMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, NPIV, NELIM, & 'V', BLR_LM, NB_BLR_LM, & BEGS_BLR_LM(1), KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN SRC_DESCBAND = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL SMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 + KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL SMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL SMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) NSLAVES_FOLLOW = NSLAV1 - XTRA_SLAVES_SYM HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF ( LASTBL ) THEN TO_UPDATE_CPT_END = ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & NB_BLOC_FAC END IF IF (NPIV.GT.0) THEN IF ( NPIV1 + NCOL .NE. NASS1 ) THEN WRITE(*,*) 'SymBLFC Error: NPIV1 + NCOL .NE. NASS1 :', & NPIV1,NCOL,NASS1 CALL MUMPS_ABORT() END IF ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 DO I = 1, NPIV IF (DYNPIVBLFCT) THEN PIVI = abs(PIVDYN(I)) ELSE PIVI = abs(IW(IPIV+I-1)) ENDIF IF (PIVI.EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+PIVI) IW(ICT11+PIVI) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + PIVI - 1,8) CALL sswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO IF (.NOT.LR_ACTIVATED) THEN ALLOCATE( UIP21K( NPIV * NROW1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * NROW1 GOTO 700 END IF ELSE ALLOCATE( UIP21K( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR UIP21K IN SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NPIV * 1 GOTO 700 END IF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN ALLOCATE( LIST_SLAVES_FOLLOW ( NSLAVES_FOLLOW ), & stat = allocok ) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": ALLOCATION FAILURE FOR LIST_SLAVES_FOLLOW & IN SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = NSLAVES_FOLLOW GOTO 700 END IF LIST_SLAVES_FOLLOW(1:NSLAVES_FOLLOW)= & IW(IOLDPS+6+XTRA_SLAVES_SYM+KEEP(IXSZ): & IOLDPS+5+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_FOLLOW) END IF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNPIVBLFCT) THEN CALL strsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & BLFCTDYN, LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ELSE CALL strsm( 'L', 'U', 'T', 'U', NPIV, NROW1, ONE, & A( POSBLOCFACTO ), LD_BLOCFACTO, & A_PTR(POSELT+int(NPIV1,8)), NCOL1 ) ENDIF ENDIF IF (.NOT.LR_ACTIVATED) THEN LPOS = POSELT + int(NPIV1,8) UPOS = 1_8 DO I = 1, NROW1 UIP21K( UPOS: UPOS + int(NPIV-1,8) ) = & A_PTR(LPOS: LPOS+int(NPIV-1,8)) LPOS = LPOS + int(NCOL1,8) UPOS = UPOS + int(NPIV,8) END DO ENDIF IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN LPOS = POSELT + int(NPIV1,8) IF (DYNPIVBLFCT) THEN DPOS = 1_8 ELSE DPOS = POSBLOCFACTO ENDIF I = 1 DO IF(I .GT. NPIV) EXIT IF (DYNPIVBLFCT) THEN PIVI = PIVDYN(I) ELSE PIVI = IW(IPIV+I-1) ENDIF IF(PIVI .GT. 0) THEN IF (DYNPIVBLFCT) THEN A11 = ONE/BLFCTDYN(DPOS) ELSE A11 = ONE/A(DPOS) ENDIF CALL sscal( NROW1, A11, A_PTR(LPOS), NCOL1 ) LPOS = LPOS + 1_8 DPOS = DPOS + int(LD_BLOCFACTO + 1,8) I = I+1 ELSE POSPV1 = DPOS POSPV2 = DPOS+ int(LD_BLOCFACTO + 1,8) OFFDAG = POSPV1+1_8 IF (DYNPIVBLFCT) THEN A11 = BLFCTDYN(POSPV1) A22 = BLFCTDYN(POSPV2) A12 = BLFCTDYN(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = BLFCTDYN(POSPV2)/DETPIV A12 = -A12/DETPIV ELSE A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV ENDIF LPOS1 = LPOS DO J2 = 1,NROW1 MULT1 = A11*A_PTR(LPOS1)+A12*A_PTR(LPOS1+1_8) MULT2 = A12*A_PTR(LPOS1)+A22*A_PTR(LPOS1+1_8) A_PTR(LPOS1) = MULT1 A_PTR(LPOS1+1_8) = MULT2 LPOS1 = LPOS1 + int(NCOL1,8) ENDDO LPOS = LPOS + 2_8 DPOS = POSPV2 + int(LD_BLOCFACTO + 1,8) I = I+2 ENDIF ENDDO ENDIF ENDIF COMPRESS_CB = .FALSE. IF (LR_ACTIVATED) THEN NSLAVES_PREC = NSLAVES_TOT - NSLAVES_FOLLOW -1 COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) ENDIF IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.GT.0) THEN IF (NROW1.LE.0) THEN CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF (NPIV1.NE.0) THEN CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_LS) KEEP_BEGS_BLR_LS = .TRUE. NB_BLR_LS = size(BEGS_BLR_LS) - 2 NPARTSCB = NB_BLR_LS ELSE CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) CALL REGROUPING2(BEGS_BLR_LS, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_LS = NPARTSCB ENDIF call MAX_CLUSTER(BEGS_BLR_LM,NB_BLR_LM+1,MAXI_CLUSTER_LM) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) MAXI_CLUSTER=max(MAXI_CLUSTER_LS,MAXI_CLUSTER_LM,NPIV) IF (COMPRESS_CB) THEN IF (NPIV1.EQ.0) THEN CALL GET_CUT(IW(IOLDPS+HS+NROW1:IOLDPS+HS+NROW1+NCOL1-1), & NASS1, & NCOL1-NASS1, LRGROUPS, NPARTSCB_COL, & NPARTSASS_COL, BEGS_BLR_COL) CALL REGROUPING2(BEGS_BLR_COL, NPARTSASS_COL, NASS1, & NPARTSCB_COL, & NCOL1-NASS1, KEEP(488), .FALSE., KEEP(472)) NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL IF (NPARTSASS_MASTER.NE.NPARTSASS_COL) THEN IF (NPARTSASS_MASTER.GT.NPARTSASS_COL) THEN ENDIF SHIFT = NPARTSASS_COL-NPARTSASS_MASTER ALLOCATE(BEGS_BLR_COL_TMP(size(BEGS_BLR_COL)-SHIFT), & stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR BEGS_BLR_COL_TMP in", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = size(BEGS_BLR_COL)-SHIFT GOTO 700 END IF DO II= 1, size(BEGS_BLR_COL)-SHIFT BEGS_BLR_COL_TMP (II) = BEGS_BLR_COL(II+SHIFT) ENDDO BEGS_BLR_COL_TMP(1) = 1 DEALLOCATE(BEGS_BLR_COL) BEGS_BLR_COL => BEGS_BLR_COL_TMP NPARTSASS_COL = NPARTSASS_MASTER NB_BLR_COL = NPARTSCB_COL + NPARTSASS_COL ENDIF ELSE CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_COL ) KEEP_BEGS_BLR_COL = .TRUE. NB_BLR_COL = size(BEGS_BLR_COL) - 1 NPARTSCB_COL = NB_BLR_COL - NPARTSASS_COL ENDIF CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER,MAXI_CLUSTER_COL+NELIM) ELSE NULLIFY(BEGS_BLR_COL) ENDIF IF (NPIV1.EQ.0) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR NB_ACCESSES_INIT=0 IF (NSLAVES_PREC.GT.0) THEN NB_ACCESSES_INIT=NSLAVES_PREC+1 ENDIF IF ( (KEEP(486).EQ.2) & ) THEN NB_ACCESSES_INIT = huge(NPARTSASS_MASTER) END IF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., .TRUE., .TRUE., NPARTSASS_COL, & BEGS_BLR_LS, BEGS_BLR_COL, NB_ACCESSES_INIT, & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 700 ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF CURRENT_BLR = 1 ALLOCATE(BLR_LS(NB_BLR_LS), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_LS GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_LS(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCKLR, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNPIVBLFCT) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(BLFCTDYN, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & PIVDYN, OFFSET_IW=1) ELSE CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_LS+1, & BLR_LS, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_LS+1, & 2, 1, 0, & .TRUE., & IW, OFFSET_IW=IPIV) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL SMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_LS+1, BLR_LS(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF (NPIV.GT.0) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8+int(NPIV,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & BLFCTDYN, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL SMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & CURRENT_BLR, BLR_LS(1), NB_BLR_LS+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (DYNPIVBLFCT) THEN CALL SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & BLFCTDYN, LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & PIVDYN, & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ELSE CALL SMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, NROW1, & A(POSBLOCFACTO), LA_BLOCFACTO, & LD_BLOCFACTO, & BEGS_BLR_LM(1), size(BEGS_BLR_LM), NB_BLR_LM+1, & BLR_LM(1), NPIV1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), NB_BLR_LS+1, & BLR_LS(1), 0, & CURRENT_BLR, CURRENT_BLR, & IW(IPIV), & BLOCKLR, & MAXI_CLUSTER, OMP_NUM, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF IF (IFLAG.LT.0) GOTO 400 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 CALL UPD_MRY_LU_LRGAIN(BLR_LS, 0, NPARTSCB, 'V') CALL DEALLOC_BLR_PANEL (BLR_LM, NB_BLR_LM, KEEP8) DEALLOCATE(BLR_LM) IF (NSLAVES_PREC.GT.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_LS) KEEP_BLR_LS = .TRUE. ENDIF ELSE IF (NPIV .GT. 0 .AND. NCOL-NPIV.GT.0)THEN LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF (DYNPIVBLFCT) THEN UPOS = int(NPIV+1,8) CALL sgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA, BLFCTDYN(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL sgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF DPOS = POSELT + int(NCOL1 - NROW1,8) #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS2 = POSELT + int(NPIV1,8) UPOS = 1_8 CALL sgemmt( 'U', 'T', 'N', NROW1, NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 ), NCOL1, ONE, & A_PTR( DPOS ), NCOL1 ) ELSE #endif IF ( NROW1 .GT. KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = NROW1 ENDIF IF ( NROW1 .GT. 0 ) THEN DO IROW = 1, NROW1, BLSIZE Block = min( BLSIZE, NROW1 - IROW + 1 ) DPOS = POSELT + int(NCOL1 - NROW1,8) & + int( IROW - 1, 8 ) * int( NCOL1 + 1, 8 ) LPOS2 = POSELT + int(NPIV1,8) & + int( IROW - 1, 8 ) * int( NCOL1, 8 ) UPOS = int( IROW - 1, 8 ) * int(NPIV, 8) + 1_8 DO I = 1, Block CALL sgemv( 'T', NPIV, Block-I+1, ALPHA, & A_PTR( LPOS2 + int(I - 1,8) * int(NCOL1,8) ), NCOL1, & UIP21K( UPOS + int(NPIV,8) * int( I - 1, 8 ) ), & 1, ONE, A_PTR(DPOS+int(NCOL1+1,8)*int(I-1,8)),NCOL1 ) END DO IF ( NROW1-IROW+1-Block .ne. 0 ) & CALL sgemm( 'T', 'N', Block, NROW1-IROW+1-Block, & NPIV, ALPHA, & UIP21K( UPOS ), NPIV, & A_PTR( LPOS2 + int(Block,8) * int(NCOL1,8) ), NCOL1, & ONE, & A_PTR( DPOS + int(Block,8) * int(NCOL1,8) ), NCOL1 ) ENDDO ENDIF #if defined(GEMMT_AVAILABLE) ENDIF #endif ENDIF FLOP1 = dble(NROW1) * dble(NPIV) * & dble( 2 * NCOL - NPIV + NROW1 +1 ) FLOP1 = -FLOP1 CALL SMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IW(IOLDPS+KEEP(IXSZ)) = IW(IOLDPS+KEEP(IXSZ)) - NPIV IW(IOLDPS+3+KEEP(IXSZ)) = IW(IOLDPS+3+KEEP(IXSZ)) + NPIV IF (LASTBL) IW(IOLDPS+1+KEEP(IXSZ)) = IW(IOLDPS + 3+KEEP(IXSZ)) IF ( .NOT. LR_ACTIVATED ) THEN IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN) ) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NSLAVES_FOLLOW .NE. 0 .and. NPIV .NE. 0 ) THEN IPOSK = NPIV1 + 1 JPOSK = NCOL1 - NROW1 + 1 NPIVSENT = NPIV IERR = -1 DO WHILE ( IERR .eq. -1 ) IF (DYNPIVBLFCT) THEN CALL SMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & BLFCTDYN, LA_BLOCFACTO, & 1_8, LD_BLOCFACTO, & PIVDYN, MAXI_CLUSTER, & IERR ) ELSE CALL SMUMPS_BUF_SEND_BLFAC_SLAVE( & INODE, NPIVSENT, FPERE, & IPOSK, JPOSK, & UIP21K, NROW1, & NSLAVES_FOLLOW, & LIST_SLAVES_FOLLOW(1), & COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A, LA, & POSBLOCFACTO, LD_BLOCFACTO, & IW(IPIV), MAXI_CLUSTER, & IERR ) ENDIF IF (IERR .EQ. -1 ) THEN IOLDPS = PTRIST(STEP(INODE)) IF ( IW(IOLDPS+6+KEEP(IXSZ)) .eq. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN COUNTER_WAS_HUGE=.TRUE. IW(IOLDPS+6+KEEP(IXSZ)) = 1 ELSE COUNTER_WAS_HUGE=.FALSE. ENDIF TO_UPDATE_CPT_RECUR = & ( NSLAVES_TOT - NSLAVES_FOLLOW - 1 ) * & (2*NASS1/KEEP(6)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) - TO_UPDATE_CPT_RECUR - 10 BLOCKING = .FALSE. SET_IRECV= .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + TO_UPDATE_CPT_RECUR + 10 IF ( COUNTER_WAS_HUGE .AND. & IW(IOLDPS+6+KEEP(IXSZ)).EQ.1 ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = huge(IW(IOLDPS+6+KEEP(IXSZ))) ENDIF IF ( IFLAG .LT. 0 ) GOTO 600 END IF END DO IF ( IERR .eq. -2 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING & SMUMPS_PROCESS_SYM_BLOCFACTO" WRITE(LP,*) "NPIV=", NPIV, "NROW1=",NROW1 IFLAG = -17 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF IF ( IERR .eq. -3 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING & SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -20 IERROR = 5 * KEEP(34) + NPIV * NROW1 * KEEP(35) GOTO 700 END IF DEALLOCATE(LIST_SLAVES_FOLLOW) END IF IF ( LR_ACTIVATED ) THEN IF (NPIV.GT.0 .AND. NSLAVES_PREC.GT.0 & .AND. KEEP(486).EQ.3 & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_BLR_DEC_AND_TRYFREE_L(IW(IOLDPS+XXF),IPANEL, & KEEP8) ENDIF IF (DYNPIVBLFCT) THEN IF (allocated(PIVDYN)) DEALLOCATE(PIVDYN) IF (allocated(BLFCTDYN)) THEN DEALLOCATE(BLFCTDYN) ENDIF ELSE IF (NPIV .GT. 0) THEN LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO IWPOS = IWPOS - NPIV CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) ENDIF ENDIF IF ( NPIV .NE. 0 ) THEN IF (allocated(UIP21K)) THEN DEALLOCATE( UIP21K ) ENDIF ENDIF IOLDPS = PTRIST(STEP(INODE)) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) IF (LASTBL) THEN IF ( KEEP(486) .NE. 0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = IW(IOLDPS+6+KEEP(IXSZ)) & - TO_UPDATE_CPT_END & - 1 IF ( IW(IOLDPS+6+KEEP(IXSZ) ) .eq. 0 & .and. KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 & .and. NSLAVES_TOT.NE.1 ) THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) CALL SMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_SYM_BLOCFACTO.' IFLAG = -99 GOTO 700 END IF ENDIF END IF IF (IW(IOLDPS+6+KEEP(IXSZ)) .eq. 0 ) THEN IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_COL), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_COL) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_COL NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF IF (COMPRESS_CB) THEN NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL SMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(1,NFS4FATHER)), stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0 ) WRITE(LP,*) MYID, & ": ALLOCATION FAILURE FOR M_ARRAY ", & "SMUMPS_PROCESS_SYM_BLOCFACTO" IFLAG = -13 IERROR = max(1,NFS4FATHER) ENDIF BEGS_BLR_COL(1+NPARTSASS_COL) = & BEGS_BLR_COL(1+NPARTSASS_COL) - NELIM NBROWSinF = 0 NVSCHUR_K253 = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL SMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV+NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE IF (KEEP(253).NE.0) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & 0, & IW(IROW_L), & PERM, NVSCHUR_K253 ) ENDIF ENDIF IF (IFLAG.LT.0) GOTO 700 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_COL, & NPARTSASS_COL, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1+NPIV, NVSCHUR_K253, KEEP(1), & M_ARRAY & , NELIM, NBROWSinF & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) 650 CONTINUE ENDIF IF (IFLAG.LT.0) GOTO 700 ENDIF CALL SMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (NPIV.GT.0) THEN IF (.NOT.KEEP_BEGS_BLR_LS) THEN IF (associated(BEGS_BLR_LS)) DEALLOCATE(BEGS_BLR_LS) ENDIF IF (.NOT.KEEP_BLR_LS) THEN CALL DEALLOC_BLR_PANEL (BLR_LS, NB_BLR_LS, KEEP8) IF (associated(BLR_LS)) DEALLOCATE(BLR_LS) ENDIF IF (associated(BEGS_BLR_LM)) DEALLOCATE(BEGS_BLR_LM) IF (.NOT.KEEP_BEGS_BLR_COL) THEN IF (COMPRESS_CB) THEN IF (associated(BEGS_BLR_COL)) THEN DEALLOCATE( BEGS_BLR_COL) ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_PROCESS_SYM_BLOCFACTO MUMPS_5.4.1/src/dmumps_ooc.F0000664000175000017500000036154214102210522015771 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_OOC USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ DOUBLE PRECISION,SAVE :: MAX_OOC_FILE_SIZE INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER DMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: DMUMPS_OOC_INIT_FACTO,DMUMPS_NEW_FACTOR, & DMUMPS_READ_OOC, & DMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & DMUMPS_IS_THERE_FREE_SPACE, & DMUMPS_OOC_END_SOLVE, & DMUMPS_SOLVE_INIT_OOC_FWD,DMUMPS_SOLVE_INIT_OOC_BWD, & DMUMPS_INITIATE_READ_OPS,DMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC DMUMPS_OOC_IO_LU_PANEL, & DMUMPS_OOC_PANEL_SIZE PRIVATE DMUMPS_OOC_STORE_LorU, & DMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE DMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_STRAT_IO_FLAGS FUNCTION DMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL DMUMPS_IS_THERE_FREE_SPACE DMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION DMUMPS_IS_THERE_FREE_SPACE SUBROUTINE DMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE DMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE DMUMPS_OOC_INIT_FACTO(id, MAXS) USE DMUMPS_STRUC_DEF USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER TMPDIR_MAX_LENGTH, PREFIX_MAX_LENGTH PARAMETER (TMPDIR_MAX_LENGTH=255, PREFIX_MAX_LENGTH=63) INTEGER(8), intent(in) :: MAXS TYPE(DMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER allocok INTEGER ASYNC CHARACTER(len=1):: TMP_DIR(TMPDIR_MAX_LENGTH), & TMP_PREFIX(PREFIX_MAX_LENGTH) INTEGER DIM_DIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER K211_LOC ICNTL1=id%ICNTL(1) MAX_SIZE_FACTOR_OOC=0_8 N_OOC=id%N ASYNC=0 SOLVE=.FALSE. IERR=0 IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) IF (id%KEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS MYID_OOC=id%MYID SLAVEF_OOC=id%NSLAVES KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_VADDR=>id%OOC_VADDR IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(19),int(dble(MAXS)* & 0.9d0*0.2d0,8)) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF DMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(id%OOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF id%OOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL DMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(99), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO ) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 MAX_NB_NODES_FOR_ZONE=0 OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL DMUMPS_INIT_OOC_BUF(id%INFO(1),id%INFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ENDIF DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) DIM_DIR=len(trim(id%OOC_TMPDIR)) DIM_PREFIX=len(trim(id%OOC_PREFIX)) CALL DMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL DMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_PREFIX(1), & id%OOC_PREFIX, PREFIX_MAX_LENGTH, DIM_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, TMP_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_DIR, TMP_DIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(id%KEEP8(11)/1000000_8)+1 IF((id%KEEP(201).EQ.1).AND.(id%KEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & id%KEEP(35),LOW_LEVEL_STRAT_IO,K211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0 ) THEN WRITE(ICNTL1,*)MYID_OOC,': PB in MUMPS_LOW_LEVEL_INIT_OOC_C' WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) ENDIF id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_GET_MAX_FILE_SIZE_C(MAX_OOC_FILE_SIZE) DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE DMUMPS_OOC_INIT_FACTO SUBROUTINE DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE DOUBLE PRECISION A(LA) INTEGER IERR,NODE,ASYNC,REQUEST LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL DMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL DMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF NODE=-9999 PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_NEW_FACTOR SUBROUTINE DMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE DOUBLE PRECISION DEST INTEGER ASYNC LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN GOTO 555 ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_READ_OOC SUBROUTINE DMUMPS_OOC_CLEAN_PENDING(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL DMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE DMUMPS_OOC_CLEAN_PENDING SUBROUTINE DMUMPS_OOC_END_FACTO(id,IERR) USE DMUMPS_OOC_BUFFER USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF(WITH_BUF)THEN CALL DMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF id%OOC_MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DO I=1,OOC_NB_FILE_TYPE id%OOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF id%KEEP8(20)=MAX_SIZE_FACTOR_OOC CALL DMUMPS_STRUC_STORE_FILE_NAME(id,IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_OOC_END_FACTO SUBROUTINE DMUMPS_OOC_CLEAN_FILES(id,IERR) USE DMUMPS_STRUC_DEF IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(DMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(350) IERR=0 K=1 IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0)THEN WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE DMUMPS_OOC_CLEAN_FILES SUBROUTINE DMUMPS_CLEAN_OOC_DATA(id,IERR) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL DMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE DMUMPS_CLEAN_OOC_DATA SUBROUTINE DMUMPS_OOC_INIT_SOLVE(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(DMUMPS_STRUC), TARGET :: id INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=id%ICNTL(1) SOLVE=.TRUE. N_OOC=id%N IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL DMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) IF(id%INFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS SLAVEF_OOC=id%NSLAVES MYID_OOC=id%MYID KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE OOC_VADDR=>id%OOC_VADDR ALLOCATE(IO_REQ(id%KEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF DMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) MAX_NB_NODES_FOR_ZONE=id%OOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>id%OOC_TOTAL_NB_NODES CALL DMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(20) SIZE_ZONE_SOLVE=int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) ENDIF ELSE SIZE_ZONE_SOLVE=FACT_AREA_SIZE SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF IF(SIZE_SOLVE_EMM.LT.id%KEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in DMUMPS_OOC_INIT_SOLVE' id%INFO(1) = -11 CALL MUMPS_SET_IERROR(id%KEEP8(20), id%INFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,id%COMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(id%KEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. id%root%yes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE DMUMPS_OOC_INIT_SOLVE SUBROUTINE DMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_INITIATE_READ_OPS SUBROUTINE DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL DMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL DMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE DMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE DMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES DOUBLE PRECISION DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL DMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL DMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE DMUMPS_READ_SOLVE_BLOCK SUBROUTINE DMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE DMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE DMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL DMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' DMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' DMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' DMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE DMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR DOUBLE PRECISION A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J, FREE_HOLE_FLAG INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in DMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL DMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE FREE_HOLE_FLAG=0 IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL DMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3D0*dble(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL DMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION DMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR DOUBLE PRECISION A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER DMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL DMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL DMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE DMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION DMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE DMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE DMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE DMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL DMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE DMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE DMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE DMUMPS_SOLVE_FIND_ZONE SUBROUTINE DMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE DMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE DMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE DMUMPS_SOLVE_SELECT_ZONE SUBROUTINE DMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(DMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE DMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS DOUBLE PRECISION A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' DMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' DMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' DMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE DMUMPS_GET_TOP_AREA_SPACE SUBROUTINE DMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) DOUBLE PRECISION A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' DMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' DMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' DMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'DMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE DMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' DMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE DMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE DMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) DOUBLE PRECISION A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in DMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' DMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL DMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE DMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE DMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' DMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE DMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE DMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE DMUMPS_SEARCH_SOLVE FUNCTION DMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL DMUMPS_SOLVE_IS_END_REACHED DMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN DMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN DMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION DMUMPS_SOLVE_IS_END_REACHED SUBROUTINE DMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(DMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(DMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(DMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL DMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL DMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL DMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL DMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE DMUMPS_SOLVE_ZONE_READ SUBROUTINE DMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(DMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' DMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL DMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE DMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE DMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE DMUMPS_OOC_END_SOLVE SUBROUTINE DMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA DOUBLE PRECISION :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL DMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL DMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN CALL DMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to DMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_PREPARE_PREF SUBROUTINE DMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA DOUBLE PRECISION A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL DMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL DMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL DMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE DMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR DOUBLE PRECISION A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL DMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL DMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL DMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & DMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL DMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL DMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL DMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE DMUMPS_STRUC_STORE_FILE_NAME(id,IERR) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(350) EXTERNAL MUMPS_OOC_GET_NB_FILES_C, MUMPS_OOC_GET_FILE_NAME_C IERR=0 SIZE=0 DO J=1,OOC_NB_FILE_TYPE TMP=J-1 CALL MUMPS_OOC_GET_NB_FILES_C(TMP,I) id%OOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF ALLOCATE(id%OOC_FILE_NAMES(SIZE,350),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(id%INFO(1).GE.0)THEN id%INFO(1) = -13 id%INFO(2) = SIZE*350 RETURN ENDIF ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(id%OOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in DMUMPS_STRUC_STORE_FILE_NAME' ENDIF id%INFO(1) = -13 id%INFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,id%OOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 id%OOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO id%OOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO END SUBROUTINE DMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE DMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC), TARGET :: id CHARACTER(len=1):: TMP_NAME(350) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES INTEGER K211 ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in DMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=id%OOC_NB_FILES I=id%MYID K=id%KEEP(35) L=mod(id%KEEP(204),3) K211=id%KEEP(211) CALL MUMPS_OOC_ALLOC_POINTERS_C(OOC_NB_FILE_TYPE,NB_FILES,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,K211,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=id%OOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO TMP=I1-1 CALL MUMPS_OOC_SET_FILE_NAME_C(TMP,I,DIM,IERR,TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=K+1 ENDDO ENDDO CALL MUMPS_OOC_START_LOW_LEVEL(IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE DMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE DMUMPS_CONVERT_STR_TO_CHR_ARRAY(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB):: SRC CHARACTER(len=1):: DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE DMUMPS_CONVERT_STR_TO_CHR_ARRAY SUBROUTINE DMUMPS_FORCE_WRITE_BUF(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE DMUMPS_FORCE_WRITE_BUF SUBROUTINE DMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL DMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE DMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE DMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE DMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL DMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL DMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE RETURN END SUBROUTINE DMUMPS_OOC_IO_LU_PANEL SUBROUTINE DMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR, ILAST INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = DMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = DMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = DMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in DMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in DMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in DMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in DMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL DMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in DMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE ILAST = ICUR IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in DMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE DMUMPS_OOC_STORE_LorU SUBROUTINE DMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE DMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL DMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE DMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION DMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE DMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION DMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION DMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER DMUMPS_OOC_GET_PANEL_SIZE DMUMPS_OOC_PANEL_SIZE=DMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION DMUMPS_OOC_PANEL_SIZE SUBROUTINE DMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.DMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE DMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_OOC_SET_STATES_ES END MODULE DMUMPS_OOC MUMPS_5.4.1/src/stype3_root.F0000664000175000017500000015142714102210521016114 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ASS_ROOT( root, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N REAL VAL_SON( NCOL_SON, NROW_SON ) REAL VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT REAL RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_ASS_ROOT RECURSIVE SUBROUTINE SMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_OOC USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) REAL DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL, DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL SMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in SMUMPS_BUILD_AND_SEND_CB_ROOT' CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ELSE IF (IGLOB .GT. N) THEN POS_IN_ROOT = IGLOB - N ELSE POS_IN_ROOT = root%RG2L_COL( IGLOB ) ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL(JGLOB) ELSE POS_IN_ROOT = JGLOB-N ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) IF (JGLOB.GT.N) THEN NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 ENDIF PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_COL(JGLOB) JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN POS_IN_ROOT = root%RG2L_ROW(JGLOB) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) NSUPROW(IROW+1) = NSUPROW(IROW+1)+1 PTRROW( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ENDIF ELSE IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod( ( POS_IN_ROOT - 1 ) / root%MBLOCK, & root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW ( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ELSE IF (IGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL( IGLOB ) ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_COL( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / & root%NBLOCK, root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ELSE IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 END IF END DO IF (BCP_SYM_NONEMPTY) THEN DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (IGLOB.LE.N) CYCLE POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ENDDO DO I=1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF (JGLOB.GT.N) THEN EXIT ELSE POS_IN_ROOT = root%RG2L_ROW(JGLOB) ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL SMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL SMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL SMUMPS_ROOT_LOCAL_ASSEMBLY( N, & root%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL SMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL SMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "SMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL SMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L_ROW(1), root%RG2L_COL(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW,INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL SMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING SMUMPS_BUILD_AND_SEND_CB_ROOT" CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING SMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE SMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in SMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE SMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE SMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE SMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L_ROW, RG2L_COL, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N REAL VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL REAL VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L_ROW( N ), RG2L_COL( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC REAL RHS_ROOT( LOCAL_M, NLOC) INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB IF (KEEP(50).EQ.0) THEN DO ISUB = 1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL-NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL -NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IPOS_ROOT = RG2L_ROW(IGLOB) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( I, J ) END DO END DO ELSE DO ISUB = 1, NSUBSET_COL-NSUPCOL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = RG2L_COL( IGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = IGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE SMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE SMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (SMUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE, NPROWtemp, NPCOLtemp LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL SMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE SMUMPS_INIT_ROOT_ANA SUBROUTINE SMUMPS_INIT_ROOT_FAC( N, root, FILS, IROOT, & KEEP, INFO ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( SMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(80), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) THEN DEALLOCATE( root%RG2L_ROW ) NULLIFY( root%RG2L_ROW ) ENDIF IF ( associated( root%RG2L_COL ) ) THEN DEALLOCATE( root%RG2L_COL ) NULLIFY( root%RG2L_COL ) ENDIF ALLOCATE( root%RG2L_ROW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=N RETURN ENDIF ALLOCATE( root%RG2L_COL( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN DEALLOCATE( root%RG2L_ROW ); NULLIFY( root%RG2L_ROW ) INFO(1)=-13 INFO(2)=N RETURN ENDIF INODE = IROOT I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L_ROW( INODE ) = I root%RG2L_COL( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE SMUMPS_INIT_ROOT_FAC SUBROUTINE SMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(real(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE SMUMPS_DEF_GRID SUBROUTINE SMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK REAL APAR( LOCAL_M, LOCAL_N ) REAL ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) REAL, DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine SMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE SMUMPS_SCATTER_ROOT SUBROUTINE SMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK REAL APAR( LOCAL_M, LOCAL_N ) REAL ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) REAL,DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine SMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_REAL, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE SMUMPS_GATHER_ROOT SUBROUTINE SMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) TYPE (SMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) REAL A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) INTEGER numroc EXTERNAL numroc REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max(1, root%RHS_NLOC) ELSE root%RHS_NLOC = 1 ENDIF IF (associated( root%RHS_ROOT) ) & DEALLOCATE (root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(LOCAL_M,root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = LOCAL_M*root%RHS_NLOC RETURN ENDIF IF (KEEP(253).NE.0) THEN root%RHS_ROOT = ZERO CALL SMUMPS_ASM_RHS_ROOT ( N, FILS, & root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL SMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL SMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL SMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL SMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL SMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL SMUMPS_ASM_ELT_ROOT( N, root, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL SMUMPS_ASM_ELT_ROOT( N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_ROOT_ALLOC_STATIC SUBROUTINE SMUMPS_ASM_ELT_ROOT( N, root, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) REAL VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) REAL DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, JGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI JGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L_ROW(JGLOB) ENDDO DO J = 1, SIZEI JGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = INTARR(J1+I-1) IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_ASM_ELT_ROOT SUBROUTINE SMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER FILS(N) TYPE (SMUMPS_ROOT_STRUC ) :: root REAL :: RHS_MUMPS(KEEP(255)) INTEGER JCOL, IPOS_ROOT, JPOS_ROOT, & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS, & INODE INODE = KEEP(38) DO WHILE (INODE.GT.0) IPOS_ROOT = root%RG2L_ROW( INODE ) IROW_GRID = mod( ( IPOS_ROOT - 1 ) / root%MBLOCK, root%NPROW ) IF ( IROW_GRID .NE. root%MYROW ) GOTO 100 ILOCRHS = root%MBLOCK * ( ( IPOS_ROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOS_ROOT - 1, root%MBLOCK ) + 1 DO JCOL = 1, KEEP(253) JPOS_ROOT = JCOL JCOL_GRID = mod((JPOS_ROOT-1)/root%NBLOCK, root%NPCOL) IF (JCOL_GRID.NE.root%MYCOL ) CYCLE JLOCRHS = root%NBLOCK * ( ( JPOS_ROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOS_ROOT - 1, root%NBLOCK ) + 1 root%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE SMUMPS_ASM_RHS_ROOT SUBROUTINE SMUMPS_ASM_ARR_ROOT( N, root, IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRARW( N ), PTRAIW( N ) REAL VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) REAL DBLARR(LDBLARR) REAL VAL INTEGER(8) :: JJ, J1,JK, J2,J3, J4, AINPUT INTEGER IORG, IBROT, NUMORG, & IROW, JCOL INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IBROT = IROOT DO IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) IBROT = FILS(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_ASM_ARR_ROOT MUMPS_5.4.1/src/dbcast_int.F0000664000175000017500000000307714102210522015732 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE DMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL DMUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to DMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE DMUMPS_MCAST2 SUBROUTINE DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE DMUMPS_BDC_ERROR MUMPS_5.4.1/src/smumps_lr_data_m.F0000664000175000017500000036620314102210522017151 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_LR_DATA_M USE SMUMPS_LR_TYPE IMPLICIT NONE PRIVATE PUBLIC :: SMUMPS_BLR_END_FRONT, SMUMPS_BLR_INIT_MODULE, & SMUMPS_BLR_END_MODULE, SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_INIT, & SMUMPS_BLR_SAVE_PANEL_LORU, SMUMPS_BLR_RETRIEVE_BEGS_BLR_L, & SMUMPS_BLR_SAVE_BEGS_BLR_C, SMUMPS_BLR_RETRIEVE_BEGS_BLR_C, & SMUMPS_BLR_DEC_AND_RETRIEVE_L, SMUMPS_BLR_RETRIEVE_PANEL_LORU, & SMUMPS_BLR_DEC_AND_TRYFREE_L, SMUMPS_BLR_TRY_FREE_PANEL, & SMUMPS_BLR_FREE_CB_LRB, SMUMPS_BLR_FREE_ALL_PANELS, & SMUMPS_BLR_SAVE_CB_LRB, & SMUMPS_BLR_RETRIEVE_CB_LRB, SMUMPS_BLR_RETRIEVE_BEGSBLR_STA, & SMUMPS_BLR_SAVE_BEGS_BLR_DYN, SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN, & SMUMPS_BLR_RETRIEVE_NB_PANELS, SMUMPS_BLR_EMPTY_PANEL_LORU, & SMUMPS_BLR_SAVE_NFS4FATHER, SMUMPS_BLR_RETRIEVE_NFS4FATHER, & SMUMPS_BLR_SAVE_M_ARRAY, SMUMPS_BLR_RETRIEVE_M_ARRAY, & SMUMPS_BLR_FREE_M_ARRAY & , SMUMPS_BLR_STRUC_TO_MOD, SMUMPS_BLR_MOD_TO_STRUC, BLR_ARRAY #if ! defined(MUMPS_F2003) & , BLR_STRUC_T, blr_panel_type, diag_block_type #endif & , SMUMPS_BLR_SAVE_DIAG_BLOCK, SMUMPS_BLR_RETRIEVE_DIAG_BLOCK & , SMUMPS_SAVE_RESTORE_BLR TYPE blr_panel_type integer :: NB_ACCESSES_LEFT type(LRB_TYPE), pointer :: LRB_PANEL(:) END TYPE blr_panel_type TYPE diag_block_type REAL, POINTER :: DIAG_BLOCK(:) END TYPE diag_block_type TYPE BLR_STRUC_T LOGICAL :: IsSYM, IsT2, IsSLAVE TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_L TYPE(blr_panel_type), DIMENSION (:), POINTER :: PANELS_U TYPE(LRB_TYPE), pointer :: CB_LRB(:,:) TYPE(diag_block_type), DIMENSION (:), POINTER :: DIAG_BLOCKS INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_STATIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: NB_ACCESSES_INIT INTEGER :: NB_PANELS INTEGER :: NFS4FATHER REAL, DIMENSION(:), POINTER :: M_ARRAY END TYPE BLR_STRUC_T type(BLR_STRUC_T), POINTER, DIMENSION(:), SAVE :: BLR_ARRAY TYPE BLR_ARRAY_T type(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY END TYPE BLR_ARRAY_T INTEGER BLR_ARRAY_FREE, PANELS_NOTUSED, PANELS_FREED, & NB_PANELS_NOTINIT, NFS4FATHER_NOTINIT PARAMETER (BLR_ARRAY_FREE=-9999, & PANELS_NOTUSED=-1111, PANELS_FREED=-2222, & NB_PANELS_NOTINIT=-3333, & NFS4FATHER_NOTINIT=-4444 ) CONTAINS SUBROUTINE SMUMPS_BLR_INIT_MODULE(INITIAL_SIZE, INFO) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(BLR_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE NULLIFY(BLR_ARRAY(I)%PANELS_L) NULLIFY(BLR_ARRAY(I)%PANELS_U) NULLIFY(BLR_ARRAY(I)%CB_LRB) NULLIFY(BLR_ARRAY(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(I)%BEGS_BLR_COL) BLR_ARRAY(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY(I)%M_ARRAY) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_INIT_MODULE SUBROUTINE SMUMPS_BLR_END_MODULE(INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) INTEGER, INTENT(IN) :: INFO1 LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER(8) :: KEEP8(150) INTEGER :: I, ILOOP LOGICAL :: IS_FIXME_ALREADY_PRINTED IS_FIXME_ALREADY_PRINTED = .FALSE. IF (.NOT. associated(BLR_ARRAY)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_END_MODULE" CALL MUMPS_ABORT() ENDIF DO I=1, size(BLR_ARRAY) ILOOP= I IF (associated(BLR_ARRAY(I)%PANELS_L).OR. & associated(BLR_ARRAY(I)%PANELS_U).OR. & associated(BLR_ARRAY(I)%CB_LRB).OR. & associated(BLR_ARRAY(I)%DIAG_BLOCKS) & ) THEN IF (present(LRSOLVE_ACT_OPT)) THEN CALL SMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 & , LRSOLVE_ACT_OPT & ) ELSE CALL SMUMPS_BLR_END_FRONT(ILOOP, INFO1, KEEP8 ) ENDIF ENDIF ENDDO DEALLOCATE(BLR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_END_MODULE SUBROUTINE SMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif CHARACTER :: CHAR_ARRAY(1) INTEGER :: CHAR_LENGTH, IERR TYPE(BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF BLR_ARRAY_VAR%BLR_ARRAY => BLR_ARRAY CHAR_LENGTH=size(transfer(BLR_ARRAY_VAR,CHAR_ARRAY)) ALLOCATE(id_BLRARRAY_ENCODING(CHAR_LENGTH), stat=IERR) IF (IERR > 0 ) THEN WRITE(*,*) "Allocation error in MUMPS_BLR_MOD_TO_STRUC" CALL MUMPS_ABORT() ENDIF id_BLRARRAY_ENCODING=transfer(BLR_ARRAY_VAR,CHAR_ARRAY) NULLIFY(BLR_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_MOD_TO_STRUC SUBROUTINE SMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING # endif TYPE (BLR_ARRAY_T) :: BLR_ARRAY_VAR IF (.NOT.associated(id_BLRARRAY_ENCODING)) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_STRUC_TO_MOD" ENDIF BLR_ARRAY_VAR = transfer(id_BLRARRAY_ENCODING,BLR_ARRAY_VAR) BLR_ARRAY => BLR_ARRAY_VAR%BLR_ARRAY DEALLOCATE(id_BLRARRAY_ENCODING) NULLIFY(id_BLRARRAY_ENCODING) RETURN END SUBROUTINE SMUMPS_BLR_STRUC_TO_MOD SUBROUTINE SMUMPS_BLR_INIT_FRONT(IWHANDLER, & INFO, MTK405) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX !$ USE OMP_LIB INTEGER, INTENT(INOUT) :: IWHANDLER, INFO(2) INTEGER, INTENT(IN), OPTIONAL :: MTK405 TYPE(BLR_STRUC_T), POINTER, DIMENSION(:) :: BLR_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE INTEGER :: I INTEGER :: IERR LOGICAL :: NEEDS_THREAD_SAFETY NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF ( NEEDS_THREAD_SAFETY ) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_START_IDX('F', 'INITF', IWHANDLER, INFO) ENDIF IF (IWHANDLER > size(BLR_ARRAY)) THEN OLD_SIZE = size(BLR_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(BLR_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE GOTO 500 ENDIF DO I=1, OLD_SIZE BLR_ARRAY_TMP(I)=BLR_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE NULLIFY(BLR_ARRAY_TMP(I)%PANELS_L) NULLIFY(BLR_ARRAY_TMP(I)%PANELS_U) NULLIFY(BLR_ARRAY_TMP(I)%CB_LRB) NULLIFY(BLR_ARRAY_TMP(I)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_DYNAMIC) BLR_ARRAY_TMP(I)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY_TMP(I)%NB_PANELS = NB_PANELS_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_L) NULLIFY(BLR_ARRAY_TMP(I)%BEGS_BLR_COL) BLR_ARRAY_TMP(I)%NFS4FATHER = NFS4FATHER_NOTINIT NULLIFY(BLR_ARRAY_TMP(I)%M_ARRAY) ENDDO DEALLOCATE(BLR_ARRAY) BLR_ARRAY => BLR_ARRAY_TMP NULLIFY(BLR_ARRAY_TMP) 500 CONTINUE ENDIF RETURN END SUBROUTINE SMUMPS_BLR_INIT_FRONT SUBROUTINE SMUMPS_BLR_SAVE_INIT(IWHANDLER, & IsSYM, IsT2, IsSLAVE, & NB_PANELS, & BEGS_BLR_L, BEGS_BLR_COL, & NB_ACCESSES_INIT, INFO) LOGICAL, INTENT(IN) :: IsSYM, IsT2, IsSLAVE INTEGER, INTENT(IN) :: NB_PANELS, IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(IN) :: NB_ACCESSES_INIT INTEGER, INTENT(IN), DIMENSION(:) :: BEGS_BLR_L INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER :: I INTEGER :: IERR IF (NB_PANELS.EQ.0) THEN WRITE(6,*) " Internal error 1 in SMUMPS_BLR_SAVE_INIT ", & NB_PANELS ENDIF IF (IWHANDLER .LE.0 ) THEN WRITE(6,*) " Internal error 2 in SMUMPS_BLR_SAVE_INIT ", & IWHANDLER ENDIF IF (associated(BEGS_BLR_COL)) THEN ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF ENDIF IF (NB_ACCESSES_INIT.EQ.0) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ALLOCATE( & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=3*size(BEGS_BLR_L) RETURN ENDIF ELSE IF (IsSYM) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & stat=IERR) ELSE ALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L(NB_PANELS), & BLR_ARRAY(IWHANDLER)%PANELS_U(NB_PANELS), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(size(BEGS_BLR_L)), & BLR_ARRAY(IWHANDLER)%BEGS_BLR_L(size(BEGS_BLR_L)), & stat=IERR) ENDIF IF (IERR .GT. 0) THEN INFO(1)=-13 IF (IsSYM) THEN INFO(2)=NB_PANELS+3*size(BEGS_BLR_L) ELSE INFO(2)=NB_PANELS+NB_PANELS+3*size(BEGS_BLR_L) ENDIF RETURN ENDIF IF (.NOT.IsSLAVE) THEN ALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(NB_PANELS), & stat=IERR) IF (IERR .GT. 0) THEN INFO(1)=-13 INFO(2)=NB_PANELS RETURN ENDIF ENDIF DO I=1,NB_PANELS NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L(I)%LRB_PANEL) IF (.NOT.IsSYM) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U(I)%LRB_PANEL) ENDIF IF (.NOT.IsSLAVE) THEN NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(I)%DIAG_BLOCK) ENDIF ENDDO ENDIF BLR_ARRAY(IWHANDLER)%IsSYM = IsSYM BLR_ARRAY(IWHANDLER)%IsT2 = IsT2 BLR_ARRAY(IWHANDLER)%IsSLAVE = IsSLAVE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS BLR_ARRAY(IWHANDLER)%BEGS_BLR_L = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC = BEGS_BLR_L BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC = -999991 IF (NB_ACCESSES_INIT.EQ.0) THEN BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = PANELS_NOTUSED ELSE BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = NB_ACCESSES_INIT ENDIF IF (associated(BEGS_BLR_COL)) THEN DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO ELSE NULLIFY( BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL ) ENDIF RETURN END SUBROUTINE SMUMPS_BLR_SAVE_INIT SUBROUTINE SMUMPS_BLR_END_FRONT(IWHANDLER, INFO1, KEEP8 & , LRSOLVE_ACT_OPT, MTK405 ) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER INTEGER, INTENT(IN) :: INFO1 INTEGER(8) :: KEEP8(150) LOGICAL, OPTIONAL, INTENT(IN) :: LRSOLVE_ACT_OPT INTEGER, OPTIONAL, INTENT(IN) :: MTK405 INTEGER :: IPANEL, JPANEL INTEGER(8) :: MEM_FREED TYPE(blr_panel_type), POINTER :: THEPANEL LOGICAL :: LRSOLVE_ACT, NEEDS_THREAD_SAFETY TYPE(diag_block_type), POINTER :: THEBLOCK LRSOLVE_ACT = .FALSE. IF (present(LRSOLVE_ACT_OPT)) LRSOLVE_ACT = LRSOLVE_ACT_OPT IF (IWHANDLER.LE.0) THEN RETURN ENDIF NEEDS_THREAD_SAFETY = .FALSE. IF (present(MTK405)) THEN IF (MTK405 .EQ. 1 ) THEN NEEDS_THREAD_SAFETY = .TRUE. ENDIF ENDIF IF (IWHANDLER .GT. size(BLR_ARRAY)) THEN RETURN END IF IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ.BLR_ARRAY_FREE) & RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.NE. & PANELS_NOTUSED) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2a in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated", & "NB_ACCESSES_LEFT= ",THEPANEL%NB_ACCESSES_LEFT CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_L) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_L) ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 2b in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF ENDDO IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%PANELS_U) NULLIFY(BLR_ARRAY(IWHANDLER)%PANELS_U) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN IF (INFO1 .GE. 0 & .AND..NOT.LRSOLVE_ACT & ) THEN WRITE(*,*) " Internal Error 3 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "NB_ACCESSES_INIT=", & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT, & "Pointer to panel number ",IPANEL," still associated" CALL MUMPS_ABORT() ELSE DEALLOCATE (THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDIF ENDDO IF ( MEM_FREED .GT. 0_8 ) THEN IF (NEEDS_THREAD_SAFETY) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ELSE KEEP8(71) = KEEP8(71) - MEM_FREED KEEP8(73) = KEEP8(73) - MEM_FREED KEEP8(69) = KEEP8(69) - MEM_FREED ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) NULLIFY(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsT2.OR. & BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN IF (INFO1 .GE. 0) THEN WRITE(*,*) " Internal Error 4 in MUMPS_BLR_END_FRONT ", & IWHANDLER, "CB block still associated", & BLR_ARRAY(IWHANDLER)%IsT2, & BLR_ARRAY(IWHANDLER)%IsSLAVE CALL MUMPS_ABORT() ELSE DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,1) DO JPANEL = 1, size(BLR_ARRAY(IWHANDLER)%CB_LRB,2) CALL DEALLOC_LRB( & BLR_ARRAY(IWHANDLER)%CB_LRB(IPANEL,JPANEL), KEEP8) ENDDO ENDDO DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) ENDIF ENDIF ENDIF ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_L) ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) NULLIFY(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL) ENDIF BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT = BLR_ARRAY_FREE BLR_ARRAY(IWHANDLER)%NB_PANELS = NB_PANELS_NOTINIT BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF IF (NEEDS_THREAD_SAFETY) THEN !$OMP CRITICAL(critical_blr_idx) CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) !$OMP END CRITICAL(critical_blr_idx) ELSE CALL MUMPS_FDM_END_IDX('F', 'ENDF', IWHANDLER) ENDIF RETURN END SUBROUTINE SMUMPS_BLR_END_FRONT SUBROUTINE SMUMPS_BLR_SAVE_PANEL_LORU ( & IWHANDLER, LORU, IPANEL, LRB_PANEL ) type(LRB_TYPE), DIMENSION(:), pointer :: LRB_PANEL INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER, INTENT(IN) :: LORU TYPE(blr_panel_type), POINTER :: THEPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_PANEL_LORU" CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) ELSE THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT THEPANEL%LRB_PANEL => LRB_PANEL RETURN END SUBROUTINE SMUMPS_BLR_SAVE_PANEL_LORU SUBROUTINE SMUMPS_BLR_SAVE_CB_LRB ( & IWHANDLER, CB_LRB ) #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(IN) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_CB_LRB" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%CB_LRB => CB_LRB RETURN END SUBROUTINE SMUMPS_BLR_SAVE_CB_LRB SUBROUTINE SMUMPS_BLR_SAVE_DIAG_BLOCK ( & IWHANDLER, IPANEL, D ) REAL,POINTER :: D(:) INTEGER, INTENT(IN) :: IWHANDLER, IPANEL IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_SAVE_DIAG_BLOCK" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK => D RETURN END SUBROUTINE SMUMPS_BLR_SAVE_DIAG_BLOCK SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_C ( & IWHANDLER, BEGS_BLR_COL, INFO) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_COL INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_SAVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(size(BEGS_BLR_COL)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(BEGS_BLR_COL) RETURN ENDIF DO I=1,size(BEGS_BLR_COL) BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL(I) = BEGS_BLR_COL(I) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_C SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_DYN ( & IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, DIMENSION(:), POINTER :: BEGS_BLR_DYNAMIC INTEGER, INTENT(IN) :: IWHANDLER INTEGER :: I IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_SAVE_BEGS_BLR_DYN" CALL MUMPS_ABORT() ENDIF DO I=1,size(BEGS_BLR_DYNAMIC) BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC(I) = BEGS_BLR_DYNAMIC(I) ENDDO RETURN END SUBROUTINE SMUMPS_BLR_SAVE_BEGS_BLR_DYN SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_L & ( IWHANDLER, BEGS_BLR_L ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGS_BLR_L" CALL MUMPS_ABORT() ENDIF BEGS_BLR_L => BLR_ARRAY(IWHANDLER)%BEGS_BLR_L RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_L SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_STA & ( IWHANDLER, BEGS_BLR_STATIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_STATIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGSBLR_STA" CALL MUMPS_ABORT() ENDIF BEGS_BLR_STATIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_STATIC RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_STA SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN & ( IWHANDLER, BEGS_BLR_DYNAMIC ) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_DYNAMIC #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_DYNAMIC #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN" CALL MUMPS_ABORT() ENDIF BEGS_BLR_DYNAMIC => BLR_ARRAY(IWHANDLER)%BEGS_BLR_DYNAMIC RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_C & ( IWHANDLER, BEGS_BLR_COL, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_COL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_COL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_BEGS_BLR_C" CALL MUMPS_ABORT() ENDIF BEGS_BLR_COL => BLR_ARRAY(IWHANDLER)%BEGS_BLR_COL NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_BEGS_BLR_C SUBROUTINE SMUMPS_BLR_RETRIEVE_NB_PANELS & ( IWHANDLER, NB_PANELS ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NB_PANELS IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_NB_PANELS" CALL MUMPS_ABORT() ENDIF NB_PANELS = BLR_ARRAY(IWHANDLER)%NB_PANELS RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_NB_PANELS SUBROUTINE SMUMPS_BLR_DEC_AND_RETRIEVE_L(IWHANDLER, IPANEL, & BEGS_BLR_L, THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) INTEGER, POINTER, DIMENSION(:), INTENT(OUT) :: BEGS_BLR_L TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) "Internal error 3 in SMUMPS_BLR_DEC_AND_RETRIEVE_L", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_L( IWHANDLER, BEGS_BLR_L ) THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 RETURN END SUBROUTINE SMUMPS_BLR_DEC_AND_RETRIEVE_L LOGICAL FUNCTION SMUMPS_BLR_EMPTY_PANEL_LORU & (IWHANDLER, LorU, IPANEL) INTEGER, INTENT(IN) :: LorU, IPANEL, IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LorU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF SMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 3 in SMUMPS_BLR_EMPTY_PANEL_LORU, ", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF SMUMPS_BLR_EMPTY_PANEL_LORU = .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ENDIF RETURN END FUNCTION SMUMPS_BLR_EMPTY_PANEL_LORU SUBROUTINE SMUMPS_BLR_RETRIEVE_PANEL_LORU & (IWHANDLER, LORU, IPANEL, & THELRBPANEL) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: LORU INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) TYPE(LRB_TYPE), INTENT(OUT), DIMENSION(:), POINTER :: THELRBPANEL #else TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: THELRBPANEL #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF (LORU.EQ.0) THEN IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 3 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%LRB_PANEL ELSE IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN WRITE(*,*) & "Internal error 4 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IWHANDLER=", IWHANDLER CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL) ) & THEN WRITE(*,*) & "Internal error 5 in SMUMPS_BLR_RETRIEVE_PANEL_LORU", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THELRBPANEL => & BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL)%LRB_PANEL ENDIF RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_PANEL_LORU SUBROUTINE SMUMPS_BLR_RETRIEVE_DIAG_BLOCK & (IWHANDLER, IPANEL, & THEBLOCK) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: IPANEL #if defined(MUMPS_F2003) REAL, POINTER, INTENT(OUT) :: THEBLOCK(:) #else REAL, POINTER :: THEBLOCK(:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN WRITE(*,*) & "Internal error 2 in SMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF IF ( .NOT. & associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK)) & THEN WRITE(*,*) & "Internal error 3 in SMUMPS_BLR_RETRIEVE_DIAG_BLOCK", & "IPANEL=", IPANEL CALL MUMPS_ABORT() ENDIF THEBLOCK => & BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL)%DIAG_BLOCK RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_DIAG_BLOCK SUBROUTINE SMUMPS_BLR_RETRIEVE_CB_LRB & (IWHANDLER, THECB) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, INTENT(OUT) :: THECB(:,:) #else TYPE(LRB_TYPE), POINTER :: THECB(:,:) #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF IF ( .NOT. associated(BLR_ARRAY(IWHANDLER)%CB_LRB)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_BLR_RETRIEVE_CB_LRB" CALL MUMPS_ABORT() ENDIF THECB => BLR_ARRAY(IWHANDLER)%CB_LRB RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_CB_LRB SUBROUTINE SMUMPS_BLR_SAVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(IN) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER RETURN END SUBROUTINE SMUMPS_BLR_SAVE_NFS4FATHER SUBROUTINE SMUMPS_BLR_RETRIEVE_NFS4FATHER & ( IWHANDLER, NFS4FATHER ) INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(OUT) :: NFS4FATHER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_BLR_RETRIEVE_NFS4FATHER" CALL MUMPS_ABORT() ENDIF NFS4FATHER = BLR_ARRAY(IWHANDLER)%NFS4FATHER RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_NFS4FATHER SUBROUTINE SMUMPS_BLR_SAVE_M_ARRAY ( & IWHANDLER, M_ARRAY, INFO) REAL, DIMENSION(:), INTENT(IN) :: M_ARRAY INTEGER, INTENT(IN) :: IWHANDLER INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_SAVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF ALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY(size(M_ARRAY)), & stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=size(M_ARRAY) RETURN ENDIF DO I=1,size(M_ARRAY) BLR_ARRAY(IWHANDLER)%M_ARRAY(I) = M_ARRAY(I) ENDDO BLR_ARRAY(IWHANDLER)%NFS4FATHER = size(M_ARRAY) RETURN END SUBROUTINE SMUMPS_BLR_SAVE_M_ARRAY SUBROUTINE SMUMPS_BLR_RETRIEVE_M_ARRAY ( IWHANDLER, M_ARRAY) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) REAL, DIMENSION(:), POINTER, INTENT(OUT) :: M_ARRAY #else REAL, DIMENSION(:), POINTER :: M_ARRAY #endif IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_RETRIEVE_M_ARRAY" CALL MUMPS_ABORT() ENDIF M_ARRAY => BLR_ARRAY(IWHANDLER)%M_ARRAY RETURN END SUBROUTINE SMUMPS_BLR_RETRIEVE_M_ARRAY SUBROUTINE SMUMPS_BLR_FREE_M_ARRAY ( IWHANDLER ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER IF ( IWHANDLER .GT. size(BLR_ARRAY) .OR. IWHANDLER .LE. 0 ) THEN WRITE(*,*) "Internal error 1 in SMUMPS_BLR_FREE_M_ARRAY" CALL MUMPS_ABORT() ENDIF IF (associated(BLR_ARRAY(IWHANDLER)%M_ARRAY)) THEN DEALLOCATE(BLR_ARRAY(IWHANDLER)%M_ARRAY) NULLIFY(BLR_ARRAY(IWHANDLER)%M_ARRAY) ENDIF BLR_ARRAY(IWHANDLER)%NFS4FATHER = NFS4FATHER_NOTINIT RETURN END SUBROUTINE SMUMPS_BLR_FREE_M_ARRAY SUBROUTINE SMUMPS_BLR_DEC_AND_TRYFREE_L( IWHANDLER, IPANEL, & KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT = & BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL)%NB_ACCESSES_LEFT - 1 CALL SMUMPS_BLR_TRY_FREE_PANEL (IWHANDLER, IPANEL, & KEEP8) RETURN END SUBROUTINE SMUMPS_BLR_DEC_AND_TRYFREE_L SUBROUTINE SMUMPS_BLR_TRY_FREE_PANEL( IWHANDLER, IPANEL, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, IPANEL INTEGER(8) :: KEEP8(150) TYPE(blr_panel_type), POINTER :: THEPANEL IF (IWHANDLER.LE.0) RETURN IF ( BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.LT.0) & RETURN THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF ( THEPANEL%NB_ACCESSES_LEFT .EQ. 0 ) THEN IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDIF RETURN END SUBROUTINE SMUMPS_BLR_TRY_FREE_PANEL SUBROUTINE SMUMPS_BLR_FREE_CB_LRB ( IWHANDLER, FREE_ONLY_STRUCT, & KEEP8 ) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER LOGICAL, INTENT(IN) :: FREE_ONLY_STRUCT INTEGER(8) :: KEEP8(150) TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER :: IPANEL, JPANEL TYPE(LRB_TYPE), POINTER :: THELRB IF (BLR_ARRAY(IWHANDLER)%IsT2.AND. & .NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN write(*,*) 'Internal error 1 in SMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF CB_LRB => BLR_ARRAY(IWHANDLER)%CB_LRB IF (.NOT.associated(CB_LRB)) THEN write(*,*) 'Internal error 2 in SMUMPS_BLR_FREE_CB_LRB' CALL MUMPS_ABORT() ENDIF IF (.NOT.FREE_ONLY_STRUCT) THEN DO IPANEL = 1,size(CB_LRB,1) DO JPANEL = 1,size(CB_LRB,2) THELRB => CB_LRB(IPANEL,JPANEL) IF (associated(THELRB)) CALL DEALLOC_LRB(THELRB,KEEP8) ENDDO ENDDO ENDIF DEALLOCATE(BLR_ARRAY(IWHANDLER)%CB_LRB) NULLIFY(BLR_ARRAY(IWHANDLER)%CB_LRB) RETURN END SUBROUTINE SMUMPS_BLR_FREE_CB_LRB SUBROUTINE SMUMPS_BLR_FREE_ALL_PANELS ( IWHANDLER, & LorU, KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: IWHANDLER, LorU INTEGER(8) :: KEEP8(150) INTEGER :: IPANEL TYPE(blr_panel_type), POINTER :: THEPANEL TYPE(diag_block_type), POINTER :: THEBLOCK INTEGER(8) :: MEM_FREED IF (IWHANDLER.LE.0) RETURN IF (BLR_ARRAY(IWHANDLER)%NB_ACCESSES_INIT.EQ. & PANELS_NOTUSED) RETURN IF (LorU.EQ.0.OR.LorU.EQ.2) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_L)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_L) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_L(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (LorU.GE.1.AND..NOT.BLR_ARRAY(IWHANDLER)%IsSYM) THEN IF (associated(BLR_ARRAY(IWHANDLER)%PANELS_U)) THEN DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%PANELS_U) THEPANEL => BLR_ARRAY(IWHANDLER)%PANELS_U(IPANEL) IF (associated(THEPANEL%LRB_PANEL)) THEN IF (size(THEPANEL%LRB_PANEL) .GT.0) THEN CALL DEALLOC_BLR_PANEL(THEPANEL%LRB_PANEL, & size(THEPANEL%LRB_PANEL), KEEP8) ENDIF DEALLOCATE(THEPANEL%LRB_PANEL) NULLIFY(THEPANEL%LRB_PANEL) ENDIF THEPANEL%NB_ACCESSES_LEFT = PANELS_FREED ENDDO ENDIF ENDIF IF (.NOT.BLR_ARRAY(IWHANDLER)%IsSLAVE) THEN IF (associated(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS)) THEN MEM_FREED = 0_8 DO IPANEL = 1, size(BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS) THEBLOCK => BLR_ARRAY(IWHANDLER)%DIAG_BLOCKS(IPANEL) IF (associated(THEBLOCK%DIAG_BLOCK)) THEN DEALLOCATE(THEBLOCK%DIAG_BLOCK) NULLIFY (THEBLOCK%DIAG_BLOCK) MEM_FREED = MEM_FREED + int(size(THEBLOCK%DIAG_BLOCK),8) ENDIF ENDDO IF (MEM_FREED .GT. 0 ) THEN !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - MEM_FREED !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - MEM_FREED !$OMP END ATOMIC ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_BLR_FREE_ALL_PANELS SUBROUTINE SMUMPS_SAVE_RESTORE_BLR(id_BLRARRAY_ENCODING & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_BLR_ARRAY,SIZE_GEST_BLR_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_BLR_ARRAY,SIZE_VARIABLES_BLR_ARRAY_j1 NbRecords=0 SIZE_GEST_BLR_ARRAY=0 SIZE_GEST_BLR_ARRAY_j1=0 SIZE_VARIABLES_BLR_ARRAY=0_8 SIZE_VARIABLES_BLR_ARRAY_j1=0_8 SIZE_GEST=0 SIZE_VARIABLES=0_8 if((trim(mode).EQ."memory_save").OR.(trim(mode).EQ."save")) then call SMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) endif if(trim(mode).EQ."memory_save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 DO j1=1,size(BLR_ARRAY,1) CALL SMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_ARRAY)) THEN NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 write(unit,iostat=err) size(BLR_ARRAY,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(BLR_ARRAY,1) CALL SMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"save" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_ARRAY) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(BLR_ARRAY(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_BLR_STRUC( & BLR_ARRAY(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_BLR_ARRAY_j1 & ,SIZE_VARIABLES_BLR_ARRAY_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_BLR_ARRAY=SIZE_GEST_BLR_ARRAY+ & SIZE_GEST_BLR_ARRAY_j1 SIZE_VARIABLES_BLR_ARRAY=SIZE_VARIABLES_BLR_ARRAY+ & SIZE_VARIABLES_BLR_ARRAY_j1 ENDDO endif endif if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_BLR_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_BLR_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif call SMUMPS_BLR_MOD_TO_STRUC(id_BLRARRAY_ENCODING) 100 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_BLR SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_STRUC(BLR_STRUC & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(BLR_STRUC_T) :: BLR_STRUC INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_STRUC_T PARAMETER (NBVARIABLES_BLR_STRUC_T = 15) CHARACTER(len=30), dimension(NBVARIABLES_BLR_STRUC_T):: & VARIABLES_BLR_STRUC_T CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_STRUC_T):: & SIZE_VARIABLES_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::SIZE_GEST_BLR_STRUC_T INTEGER,dimension(NBVARIABLES_BLR_STRUC_T)::NbRecords_BLR_STRUC_T INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,j1,j2,NbSubRecords,Local_NbRecords INTEGER::SIZE_GEST_PANELS_L,SIZE_GEST_PANELS_L_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_L,SIZE_VARIABLES_PANELS_L_j1 INTEGER::SIZE_GEST_PANELS_U,SIZE_GEST_PANELS_U_j1 INTEGER(8)::SIZE_VARIABLES_PANELS_U,SIZE_VARIABLES_PANELS_U_j1 INTEGER::SIZE_GEST_CB_LRB,SIZE_GEST_CB_LRB_j1j2 INTEGER(8)::SIZE_VARIABLES_CB_LRB,SIZE_VARIABLES_CB_LRB_j1j2 INTEGER::SIZE_GEST_DIAG_BLOCKS,SIZE_GEST_DIAG_BLOCKS_j1 INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS INTEGER(8)::SIZE_VARIABLES_DIAG_BLOCKS_j1 VARIABLES_BLR_STRUC_T(1)="IsSYM" VARIABLES_BLR_STRUC_T(2)="IsT2" VARIABLES_BLR_STRUC_T(3)="IsSLAVE" VARIABLES_BLR_STRUC_T(4)="PANELS_L" VARIABLES_BLR_STRUC_T(5)="PANELS_U" VARIABLES_BLR_STRUC_T(6)="CB_LRB" VARIABLES_BLR_STRUC_T(7)="BEGS_BLR_STATIC" VARIABLES_BLR_STRUC_T(8)="BEGS_BLR_DYNAMIC" VARIABLES_BLR_STRUC_T(9)="BEGS_BLR_L" VARIABLES_BLR_STRUC_T(10)="BEGS_BLR_COL" VARIABLES_BLR_STRUC_T(11)="NB_ACCESSES_INIT" VARIABLES_BLR_STRUC_T(12)="NB_PANELS" VARIABLES_BLR_STRUC_T(13)="DIAG_BLOCKS" VARIABLES_BLR_STRUC_T(14)="NFS4FATHER" VARIABLES_BLR_STRUC_T(15)="M_ARRAY" SIZE_VARIABLES_BLR_STRUC_T(:)=0_8 SIZE_GEST_BLR_STRUC_T(:)=0 NbRecords_BLR_STRUC_T(:)=0 SIZE_GEST_PANELS_L=0 SIZE_GEST_PANELS_L_j1=0 SIZE_VARIABLES_PANELS_L=0_8 SIZE_VARIABLES_PANELS_L_j1=0_8 SIZE_GEST_PANELS_U=0 SIZE_GEST_PANELS_U_j1=0 SIZE_VARIABLES_PANELS_U=0_8 SIZE_VARIABLES_PANELS_U_j1=0_8 SIZE_GEST_CB_LRB=0 SIZE_GEST_CB_LRB_j1j2=0 SIZE_VARIABLES_CB_LRB=0_8 SIZE_VARIABLES_CB_LRB_j1j2=0_8 SIZE_GEST_DIAG_BLOCKS=0 SIZE_GEST_DIAG_BLOCKS_j1=0 SIZE_VARIABLES_DIAG_BLOCKS=0_8 SIZE_VARIABLES_DIAG_BLOCKS_j1=0_8 DO i1=1,NBVARIABLES_BLR_STRUC_T TMP_STRING = VARIABLES_BLR_STRUC_T(i1) SELECT CASE(TMP_STRING) CASE("IsSYM") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSYM if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsT2") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsT2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("IsSLAVE") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL write(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_LOGICAL read(unit,iostat=err) BLR_STRUC%IsSLAVE if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_STATIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_STATIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_STATIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_STATIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_STATIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_STATIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_STATIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_DYNAMIC") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_DYNAMIC)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_DYNAMIC,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_DYNAMIC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_DYNAMIC(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_DYNAMIC endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_L") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_L)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_L,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_L ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_L endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("BEGS_BLR_COL") NbRecords_BLR_STRUC_T(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%BEGS_BLR_COL)) THEN SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)= & size(BLR_STRUC%BEGS_BLR_COL,1)*SIZE_INT write(unit,iostat=err) & size(BLR_STRUC%BEGS_BLR_COL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL ELSE SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%BEGS_BLR_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=size_array1*SIZE_INT allocate(BLR_STRUC%BEGS_BLR_COL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) BLR_STRUC%BEGS_BLR_COL endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_ACCESSES_INIT") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_ACCESSES_INIT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("NB_PANELS") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NB_PANELS if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("PANELS_L") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_L)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_L,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_L,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_L) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_L(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_L(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_L_j1 & ,SIZE_VARIABLES_PANELS_L_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_L=SIZE_GEST_PANELS_L+ & SIZE_GEST_PANELS_L_j1 SIZE_VARIABLES_PANELS_L=SIZE_VARIABLES_PANELS_L+ & SIZE_VARIABLES_PANELS_L_j1 ENDDO endif endif CASE("PANELS_U") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%PANELS_U)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%PANELS_U,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%PANELS_U,1) CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"save" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%PANELS_U) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%PANELS_U(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_BLR_PANEL( & BLR_STRUC%PANELS_U(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_PANELS_U_j1 & ,SIZE_VARIABLES_PANELS_U_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_PANELS_U=SIZE_GEST_PANELS_U+ & SIZE_GEST_PANELS_U_j1 SIZE_VARIABLES_PANELS_U=SIZE_VARIABLES_PANELS_U+ & SIZE_VARIABLES_PANELS_U_j1 ENDDO endif endif CASE("CB_LRB") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"memory_save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%CB_LRB)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%CB_LRB,1),size(BLR_STRUC%CB_LRB,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%CB_LRB,1) DO j2=1,size(BLR_STRUC%CB_LRB,2) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"save" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%CB_LRB) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*3 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%CB_LRB(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 DO j2=1,size_array2 CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_STRUC%CB_LRB(j1,j2) & ,unit,MYID,"restore" & ,SIZE_GEST_CB_LRB_j1j2 & ,SIZE_VARIABLES_CB_LRB_j1j2 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_CB_LRB=SIZE_GEST_CB_LRB+ & SIZE_GEST_CB_LRB_j1j2 SIZE_VARIABLES_CB_LRB=SIZE_VARIABLES_CB_LRB+ & SIZE_VARIABLES_CB_LRB_j1j2 ENDDO ENDDO endif endif CASE("DIAG_BLOCKS") if(trim(mode).EQ."memory_save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL SMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_STRUC%DIAG_BLOCKS)) THEN NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) & size(BLR_STRUC%DIAG_BLOCKS,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif DO j1=1,size(BLR_STRUC%DIAG_BLOCKS,1) CALL SMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_STRUC%DIAG_BLOCKS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords_BLR_STRUC_T(i1)=2 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_STRUC_T(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords_BLR_STRUC_T(i1)=1 SIZE_GEST_BLR_STRUC_T(i1)=SIZE_INT SIZE_VARIABLES_BLR_STRUC_T(i1)=0 allocate(BLR_STRUC%DIAG_BLOCKS(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_DIAG_BLOCK( & BLR_STRUC%DIAG_BLOCKS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_DIAG_BLOCKS_j1 & ,SIZE_VARIABLES_DIAG_BLOCKS_j1 & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_DIAG_BLOCKS=SIZE_GEST_DIAG_BLOCKS+ & SIZE_GEST_DIAG_BLOCKS_j1 SIZE_VARIABLES_DIAG_BLOCKS= & SIZE_VARIABLES_DIAG_BLOCKS+ & SIZE_VARIABLES_DIAG_BLOCKS_j1 ENDDO endif endif CASE("NFS4FATHER") NbRecords_BLR_STRUC_T(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT write(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_STRUC_T(i1)=SIZE_INT read(unit,iostat=err) BLR_STRUC%NFS4FATHER if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF (INFO(1) .LT. 0 ) GOTO 100 endif CASE("M_ARRAY") if(trim(mode).EQ."restore") then nullify(BLR_STRUC%M_ARRAY) endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_STRUC_T(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_STRUC_T(i1)=NbRecords_BLR_STRUC_T(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_STRUC_T(i1) size_read=size_read+SIZE_VARIABLES_BLR_STRUC_T(i1) & +int(SIZE_GEST_BLR_STRUC_T(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_STRUC_T(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_STRUC_T) & +SIZE_VARIABLES_PANELS_L & +SIZE_VARIABLES_PANELS_U & +SIZE_VARIABLES_CB_LRB & +SIZE_VARIABLES_DIAG_BLOCKS Local_SIZE_GEST=sum(SIZE_GEST_BLR_STRUC_T) & +SIZE_GEST_PANELS_L & +SIZE_GEST_PANELS_U & +SIZE_GEST_CB_LRB & +SIZE_GEST_DIAG_BLOCKS #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_STRUC_T) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 100 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_STRUC SUBROUTINE SMUMPS_SAVE_RESTORE_LRB(LRB_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(LRB_TYPE) :: LRB_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_LRB_TYPE PARAMETER (NBVARIABLES_LRB_TYPE = 6) CHARACTER(len=30), dimension(NBVARIABLES_LRB_TYPE):: & VARIABLES_LRB_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_LRB_TYPE):: & SIZE_VARIABLES_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & SIZE_GEST_LRB_TYPE INTEGER,dimension(NBVARIABLES_LRB_TYPE):: & NbRecords_LRB_TYPE INTEGER:: size_array1,size_array2,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_LRB_TYPE(1)="Q" VARIABLES_LRB_TYPE(2)="R" VARIABLES_LRB_TYPE(3)="K" VARIABLES_LRB_TYPE(4)="M" VARIABLES_LRB_TYPE(5)="N" VARIABLES_LRB_TYPE(6)="ISLR" SIZE_VARIABLES_LRB_TYPE(:)=0_8 SIZE_GEST_LRB_TYPE(:)=0 NbRecords_LRB_TYPE(:)=0 DO i1=1,NBVARIABLES_LRB_TYPE TMP_STRING = VARIABLES_LRB_TYPE(i1) SELECT CASE(TMP_STRING) CASE("Q") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%Q)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%Q,1)*size(LRB_T%Q,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%Q,1),size(LRB_T%Q,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%Q ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%Q) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%Q(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%Q endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("R") NbRecords_LRB_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(LRB_T%R)) THEN SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size(LRB_T%R,1)*size(LRB_T%R,2) & * SIZE_ARITH_DEP write(unit,iostat=err) size(LRB_T%R,1),size(LRB_T%R,2) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) LRB_T%R ELSE SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 write(unit,iostat=err) -999,-998 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then nullify(LRB_T%R) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(size_array1.EQ.-999) then SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*3 SIZE_VARIABLES_LRB_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_LRB_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_LRB_TYPE(i1)= & size_array1*size_array2*SIZE_ARITH_DEP allocate(LRB_T%R(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif read(unit,iostat=err) LRB_T%R endif IF ( INFO(1) .LT. 0 ) GOTO 300 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("K") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%K if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%K if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("M") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%M if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%M if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("N") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT write(unit,iostat=err) LRB_T%N if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_INT read(unit,iostat=err) LRB_T%N if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE("ISLR") NbRecords_LRB_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL write(unit,iostat=err) LRB_T%ISLR if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_LRB_TYPE(i1)=SIZE_LOGICAL read(unit,iostat=err) LRB_T%ISLR if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 300 endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_LRB_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_LRB_TYPE(i1)= & NbRecords_LRB_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_LRB_TYPE(i1) size_read=size_read+SIZE_VARIABLES_LRB_TYPE(i1) & +int(SIZE_GEST_LRB_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_LRB_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_LRB_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_LRB_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_LRB_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 300 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_LRB SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_PANEL(BLR_PANEL_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(blr_panel_type) :: BLR_PANEL_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_BLR_PANEL_TYPE PARAMETER (NBVARIABLES_BLR_PANEL_TYPE = 2) CHARACTER(len=30), dimension(NBVARIABLES_BLR_PANEL_TYPE):: & VARIABLES_BLR_PANEL_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_VARIABLES_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & SIZE_GEST_BLR_PANEL_TYPE INTEGER,dimension(NBVARIABLES_BLR_PANEL_TYPE):: & NbRecords_BLR_PANEL_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,j1,NbSubRecords,Local_NbRecords INTEGER:: SIZE_GEST_LRB_PANEL_j1,SIZE_GEST_LRB_PANEL INTEGER(8)::SIZE_VARIABLES_LRB_PANEL_j1,SIZE_VARIABLES_LRB_PANEL VARIABLES_BLR_PANEL_TYPE(1)="NB_ACCESSES_LEFT" VARIABLES_BLR_PANEL_TYPE(2)="LRB_PANEL" SIZE_VARIABLES_BLR_PANEL_TYPE(:)=0_8 SIZE_GEST_BLR_PANEL_TYPE(:)=0 NbRecords_BLR_PANEL_TYPE(:)=0 SIZE_GEST_LRB_PANEL_j1=0 SIZE_GEST_LRB_PANEL=0 SIZE_VARIABLES_LRB_PANEL_j1=0_8 SIZE_VARIABLES_LRB_PANEL=0_8 DO i1=1,NBVARIABLES_BLR_PANEL_TYPE TMP_STRING = VARIABLES_BLR_PANEL_TYPE(i1) SELECT CASE(TMP_STRING) CASE("NB_ACCESSES_LEFT") NbRecords_BLR_PANEL_TYPE(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT elseif(trim(mode).EQ."save") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT write(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=SIZE_INT read(unit,iostat=err) BLR_PANEL_T%NB_ACCESSES_LEFT if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 endif CASE("LRB_PANEL") if(trim(mode).EQ."memory_save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(BLR_PANEL_T%LRB_PANEL)) THEN NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) size(BLR_PANEL_T%LRB_PANEL,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 DO j1=1,size(BLR_PANEL_T%LRB_PANEL,1) CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"save" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) IF ( INFO(1) .LT. 0 ) GOTO 400 ENDDO ELSE NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 ENDIF elseif(trim(mode).EQ."restore") then nullify(BLR_PANEL_T%LRB_PANEL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 if(size_array1.EQ.-999) then NbRecords_BLR_PANEL_TYPE(i1)=2 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 400 else NbRecords_BLR_PANEL_TYPE(i1)=1 SIZE_GEST_BLR_PANEL_TYPE(i1)=SIZE_INT SIZE_VARIABLES_BLR_PANEL_TYPE(i1)=0 allocate(BLR_PANEL_T%LRB_PANEL(size_array1) & , stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size_array1 CALL SMUMPS_SAVE_RESTORE_LRB( & BLR_PANEL_T%LRB_PANEL(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_LRB_PANEL_j1 & ,SIZE_VARIABLES_LRB_PANEL_j1 & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_LRB_PANEL=SIZE_GEST_LRB_PANEL+ & SIZE_GEST_LRB_PANEL_j1 SIZE_VARIABLES_LRB_PANEL=SIZE_VARIABLES_LRB_PANEL+ & SIZE_VARIABLES_LRB_PANEL_j1 ENDDO endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_BLR_PANEL_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_BLR_PANEL_TYPE(i1)= & NbRecords_BLR_PANEL_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_BLR_PANEL_TYPE(i1) size_read=size_read+SIZE_VARIABLES_BLR_PANEL_TYPE(i1) & +int(SIZE_GEST_BLR_PANEL_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_BLR_PANEL_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_BLR_PANEL_TYPE)+ & SIZE_VARIABLES_LRB_PANEL Local_SIZE_GEST=sum(SIZE_GEST_BLR_PANEL_TYPE)+ & SIZE_GEST_LRB_PANEL #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_BLR_PANEL_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 400 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_BLR_PANEL SUBROUTINE SMUMPS_SAVE_RESTORE_DIAG_BLOCK(DIAG_BLOCK_T & ,unit,MYID,mode & ,Local_SIZE_GEST,Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) INCLUDE 'mpif.h' TYPE(diag_block_type) :: DIAG_BLOCK_T INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER :: NBVARIABLES_DIAG_BLOCK_TYPE PARAMETER (NBVARIABLES_DIAG_BLOCK_TYPE = 1) CHARACTER(len=30), dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & VARIABLES_DIAG_BLOCK_TYPE CHARACTER(len=30) :: TMP_STRING INTEGER(8),dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_VARIABLES_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & SIZE_GEST_DIAG_BLOCK_TYPE INTEGER,dimension(NBVARIABLES_DIAG_BLOCK_TYPE):: & NbRecords_DIAG_BLOCK_TYPE INTEGER:: size_array1,dummy,allocok INTEGER:: err,i1,NbSubRecords,Local_NbRecords VARIABLES_DIAG_BLOCK_TYPE(1)="DIAG_BLOCK" SIZE_VARIABLES_DIAG_BLOCK_TYPE(:)=0_8 SIZE_GEST_DIAG_BLOCK_TYPE(:)=0 NbRecords_DIAG_BLOCK_TYPE(:)=0 DO i1=1,NBVARIABLES_DIAG_BLOCK_TYPE TMP_STRING = VARIABLES_DIAG_BLOCK_TYPE(i1) SELECT CASE(TMP_STRING) CASE("DIAG_BLOCK") NbRecords_DIAG_BLOCK_TYPE(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 ENDIF elseif(trim(mode).EQ."save") then IF(associated(DIAG_BLOCK_T%DIAG_BLOCK)) THEN SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size(DIAG_BLOCK_T%DIAG_BLOCK,1) & * SIZE_ARITH_DEP write(unit,iostat=err) size(DIAG_BLOCK_T%DIAG_BLOCK,1) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK ELSE SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 elseif(trim(mode).EQ."restore") then nullify(DIAG_BLOCK_T%DIAG_BLOCK) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 200 if(size_array1.EQ.-999) then SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT*2 SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)=0 read(unit,iostat=err) dummy else SIZE_GEST_DIAG_BLOCK_TYPE(i1)=SIZE_INT SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)= & size_array1*SIZE_ARITH_DEP allocate(DIAG_BLOCK_T%DIAG_BLOCK(size_array1), & stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 200 endif read(unit,iostat=err) DIAG_BLOCK_T%DIAG_BLOCK endif if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 200 endif endif CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_DIAG_BLOCK_TYPE(i1)= & NbRecords_DIAG_BLOCK_TYPE(i1) & +NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+ & SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) size_read=size_read+SIZE_VARIABLES_DIAG_BLOCK_TYPE(i1) & +int(SIZE_GEST_DIAG_BLOCK_TYPE(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords_DIAG_BLOCK_TYPE(i1),kind=8) #endif endif ENDDO if(trim(mode).EQ."memory_save") then Local_SIZE_VARIABLES=sum(SIZE_VARIABLES_DIAG_BLOCK_TYPE) Local_SIZE_GEST=sum(SIZE_GEST_DIAG_BLOCK_TYPE) #if !defined(MUMPS_F2003) Local_NbRecords=sum(NbRecords_DIAG_BLOCK_TYPE) Local_SIZE_GEST=Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords #endif endif 200 continue RETURN END SUBROUTINE SMUMPS_SAVE_RESTORE_DIAG_BLOCK END MODULE SMUMPS_LR_DATA_M MUMPS_5.4.1/src/ana_blk_m.F0000664000175000017500000000174714102210475015534 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_ANA_BLK_M TYPE COL_LMATRIX_T INTEGER :: NBINCOL INTEGER, POINTER :: IRN(:) => null() END TYPE COL_LMATRIX_T TYPE LMATRIX_T INTEGER :: NBCOL INTEGER(8) :: NZL TYPE(COL_LMATRIX_T), POINTER :: COL(:) => null() END TYPE LMATRIX_T TYPE COMPACT_GRAPH_T INTEGER(8) :: NZG, SIZEADJALLOCATED INTEGER :: NG INTEGER(8), POINTER :: IPE(:) => null() INTEGER, POINTER :: ADJ(:) => null() END TYPE COMPACT_GRAPH_T END MODULE MUMPS_ANA_BLK_M MUMPS_5.4.1/src/sfac_process_maprow.F0000664000175000017500000020714614102210521017661 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_DATA_M USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR USE SMUMPS_FAC_FRONT_AUX_M, & ONLY : SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (SMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER REAL :: ADummy(1) REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL SMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in SMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL SMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL SMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2( & NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN SMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN SMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN SMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL SMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL SMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN CALL SMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL SMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL SMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL SMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE SMUMPS_MAPLIG SUBROUTINE SMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_FAC_LR, ONLY: SMUMPS_DECOMPRESS_PANEL USE SMUMPS_FAC_FRONT_AUX_M, & ONLY : SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT USE SMUMPS_LR_DATA_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR & , SMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I, ISTCHK, ISTCHK_LOC INTEGER NBROWS_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE REAL, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP REAL :: ADummy(1) REAL, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in SMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in SMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in SMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in SMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in SMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL SMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_BLR_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT, & 1:NB_BLR_COLS-NB_BLR_SHIFT), & 0, 'V', 5, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN IF (NELIM.EQ.0) THEN POSROW = IACHK + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF (CB_IS_LR) THEN CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS) ELSE CALL SMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during SMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL SMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL SMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL SMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL SMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL SMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL SMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING SMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING SMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING SMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in SMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL SMUMPS_DM_FREE_BLOCK( SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL SMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL SMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL SMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE SMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE SMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE SMUMPS_BUF, ONLY: SMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_LR_DATA_M USE SMUMPS_FAC_LR, ONLY: SMUMPS_DECOMPRESS_PANEL USE SMUMPS_LOAD, ONLY : SMUMPS_LOAD_POOL_UPD_NEW_POOL USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR & , SMUMPS_DM_SET_PTR, SMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) REAL, intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW REAL :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(N) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS REAL, DIMENSION(:), POINTER :: SON_A REAL, DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER(8) :: LA_TEMP REAL, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL SMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL SMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL SMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_COL_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT, & 1:NB_BLR_COLS-NB_COL_SHIFT), & 0, 'V', 6, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = IACHK+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE IF (CB_IS_LR) THEN CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS ) ELSE CALL SMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON ) ENDIF ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (CB_IS_LR.AND.SON_NIV.EQ.1) & NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ( (IS_ofType5or6) .AND. & ( & ( KEEP(50).EQ.0) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.PACKED_CB) ) & ) & ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE IF (CB_IS_LR) THEN CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ELSE CALL SMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) ENDIF IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL SMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/SMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL SMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL SMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL SMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL SMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in SMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL SMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_FREE_BLOCK( SON_A_MASTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL SMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL SMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE SMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.4.1/src/smumps_sol_es.F0000664000175000017500000007012614102210522016507 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_SOL_ES PRIVATE PUBLIC:: PRUNED_SIZE_LOADED PUBLIC:: SMUMPS_CHAIN_PRUN_NODES PUBLIC:: SMUMPS_CHAIN_PRUN_NODES_STATS PUBLIC:: SMUMPS_INITIALIZE_RHS_BOUNDS PUBLIC:: SMUMPS_PROPAGATE_RHS_BOUNDS PUBLIC:: SMUMPS_TREE_PRUN_NODES PUBLIC:: SMUMPS_TREE_PRUN_NODES_STATS PUBLIC:: SMUMPS_SOL_ES_INIT INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK INTEGER(8) :: PRUNED_SIZE_LOADED INCLUDE 'mumps_headers.h' CONTAINS SUBROUTINE SMUMPS_SOL_ES_INIT(SIZE_OF_BLOCK_ARG, KEEP201) IMPLICIT NONE INTEGER, INTENT(IN) :: KEEP201 INTEGER(8), POINTER, DIMENSION(:,:) :: SIZE_OF_BLOCK_ARG IF (KEEP201 > 0) THEN SIZE_OF_BLOCK => SIZE_OF_BLOCK_ARG ELSE NULLIFY(SIZE_OF_BLOCK) ENDIF RETURN END SUBROUTINE SMUMPS_SOL_ES_INIT SUBROUTINE SMUMPS_TREE_PRUN_NODES( & fill, & DAD, NE_STEPS, FRERE, KEEP28, & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N, KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28),NE_STEPS(KEEP28),FRERE(KEEP28) INTEGER, INTENT(IN) :: FILS(N), STEP(N) INTEGER, INTENT(IN) :: nodes_RHS(KEEP28), nb_nodes_RHS INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP, TMPsave LOGICAL :: FILS_VISITED nb_prun_nodes = 0 nb_prun_leaves = 0 TO_PROCESS(:) = .FALSE. DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) TMPsave = TMP ISTEP = STEP(TMP) DO WHILE(.NOT.TO_PROCESS(ISTEP)) TO_PROCESS(ISTEP) = .TRUE. nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = TMP END IF IN = FILS(TMP) DO WHILE(IN.GT.0) IN = FILS(IN) END DO FILS_VISITED = .FALSE. IF (IN.LT.0) THEN FILS_VISITED = TO_PROCESS(STEP(-IN)) ENDIF IF ( IN.LT.0.and..NOT.FILS_VISITED) & THEN TMP = -IN ISTEP = STEP(TMP) ELSE IF (IN.EQ.0) THEN nb_prun_leaves = nb_prun_leaves + 1 IF (fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF ELSE TMP = -IN ISTEP = STEP(TMP) ENDIF DO WHILE (TMP.NE.TMPsave) TMP = abs(FRERE(ISTEP)) IF(TMP.NE.0) THEN ISTEP = STEP(TMP) ELSE exit END IF IF (.NOT.TO_PROCESS(ISTEP)) exit END DO END IF END DO END DO nb_prun_roots = 0 DO I=1,nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF(DAD(ISTEP).NE.0) THEN IF(.NOT.TO_PROCESS(STEP(DAD(ISTEP)))) THEN nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF ELSE nb_prun_roots = nb_prun_roots + 1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF END IF END DO RETURN END SUBROUTINE SMUMPS_TREE_PRUN_NODES SUBROUTINE SMUMPS_CHAIN_PRUN_NODES( & fill, & DAD, KEEP28, & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes,nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: fill INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: KEEP28 INTEGER, INTENT(IN) :: DAD(KEEP28) INTEGER, INTENT(IN) :: nb_nodes_RHS INTEGER, INTENT(IN) :: nodes_RHS(nb_nodes_RHS) INTEGER :: nb_prun_nodes INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_List(nb_prun_nodes) INTEGER :: nb_prun_roots INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Roots(nb_prun_roots) INTEGER :: nb_prun_leaves INTEGER, OPTIONAL, INTENT(INOUT):: Pruned_Leaves(nb_prun_leaves) INTEGER :: Pruned_SONS(KEEP28) LOGICAL :: TO_PROCESS(KEEP28) INTEGER :: IN, I, ISTEP, TMP nb_prun_nodes = 0 nb_prun_roots = 0 TO_PROCESS(:) = .FALSE. Pruned_SONS(:) = -1 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) TO_PROCESS(ISTEP) = .TRUE. IF (Pruned_SONS(ISTEP) .eq. -1) THEN Pruned_SONS(ISTEP) = 0 nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = nodes_RHS(I) END IF IN = nodes_RHS(I) IN = DAD(STEP(IN)) DO WHILE (IN.NE.0) TO_PROCESS(STEP(IN)) = .TRUE. IF (Pruned_SONS(STEP(IN)).eq.-1) THEN nb_prun_nodes = nb_prun_nodes + 1 IF(fill) THEN Pruned_List(nb_prun_nodes) = IN END IF Pruned_SONS(STEP(IN)) = 1 TMP = IN IN = DAD(STEP(IN)) ELSE Pruned_SONS(STEP(IN)) = Pruned_SONS(STEP(IN)) + 1 GOTO 201 ENDIF ENDDO nb_prun_roots = nb_prun_roots +1 IF(fill) THEN Pruned_Roots(nb_prun_roots) = TMP END IF ENDIF 201 CONTINUE ENDDO nb_prun_leaves = 0 DO I = 1, nb_nodes_RHS TMP = nodes_RHS(I) ISTEP = STEP(TMP) IF (Pruned_SONS(ISTEP).EQ.0) THEN nb_prun_leaves = nb_prun_leaves +1 IF(fill) THEN Pruned_Leaves(nb_prun_leaves) = TMP END IF END IF ENDDO RETURN END SUBROUTINE SMUMPS_CHAIN_PRUN_NODES SUBROUTINE SMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, K242, K243, & UNS_PERM_INV, SIZE_UNS_PERM_INV, K23, & RHS_BOUNDS, NSTEPS, & nb_sparse, MYID, & mode) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, N, NSTEPS, K242, K243, K23 INTEGER, INTENT(IN) :: JBEG_RHS, SIZE_PERM_RHS, nb_sparse INTEGER, INTENT(IN) :: NBCOL, NZ_RHS, SIZE_UNS_PERM_INV INTEGER, INTENT(IN) :: STEP(N), PERM_RHS(SIZE_PERM_RHS) INTEGER, INTENT(IN) :: IRHS_PTR(NBCOL+1),IRHS_SPARSE(NZ_RHS) INTEGER, INTENT(IN) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER, INTENT(IN) :: mode INTEGER :: I, ICOL, JPTR, J, JAM1, node, bound RHS_BOUNDS = 0 ICOL = 0 DO I = 1, NBCOL IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE ICOL = ICOL + 1 bound = ICOL - mod(ICOL, nb_sparse) + 1 IF(mod(ICOL, nb_sparse).EQ.0) bound = bound - nb_sparse IF(mode.EQ.0) THEN IF ((K242.NE.0).OR.(K243.NE.0)) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF node = abs(STEP(JAM1)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF ELSE DO JPTR = IRHS_PTR(I), IRHS_PTR(I+1)-1 J = IRHS_SPARSE(JPTR) IF ( mode .EQ. 1 ) THEN IF (K23.NE.0) J = UNS_PERM_INV(J) ENDIF node = abs(STEP(J)) IF(RHS_BOUNDS(2*node - 1).EQ.0) THEN RHS_BOUNDS(2*node - 1) = bound RHS_BOUNDS(2*node) = bound + nb_sparse - 1 ELSE RHS_BOUNDS(2*node) = bound + nb_sparse - 1 END IF END DO END IF END DO RETURN END SUBROUTINE SMUMPS_INITIALIZE_RHS_BOUNDS SUBROUTINE SMUMPS_PROPAGATE_RHS_BOUNDS( & pruned_leaves, nb_pruned_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, NSTEPS, & MYID, COMM, KEEP485, & IW, LIW, PTRIST, KIXSZ,OOC_FCT_LOC, PHASE, LDLT, K38) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INTEGER, INTENT(IN) :: nb_pruned_leaves, N, NSTEPS INTEGER, INTENT(IN) :: STEP(N), DAD(NSTEPS), Pruned_SONS(NSTEPS) INTEGER, INTENT(IN) :: MYID, COMM, KEEP485 INTEGER, INTENT(IN) :: pruned_leaves(nb_pruned_leaves) INTEGER, INTENT(IN) :: LIW, IW(LIW), PTRIST(NSTEPS) INTEGER, INTENT(IN) :: KIXSZ, OOC_FCT_LOC, PHASE, LDLT, K38 INTEGER, INTENT(INOUT):: RHS_BOUNDS(2*NSTEPS) INTEGER :: I, node, father, size_pool, next_size_pool INTEGER :: IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: POOL, NBSONS ALLOCATE(POOL(nb_pruned_leaves), & NBSONS(NSTEPS), & STAT=IERR) IF (IERR.NE.0) THEN WRITE(6,*)'Allocation problem in SMUMPS_PROPAGATE_RHS_BOUNDS' CALL MUMPS_ABORT() END IF size_pool = nb_pruned_leaves POOL = pruned_leaves NBSONS = Pruned_SONS DO WHILE (size_pool.ne.0) next_size_pool =0 DO I=1, size_pool node = STEP(POOL(I)) IF (DAD(node).NE.0) THEN father = STEP(DAD(node)) NBSONS(father) = NBSONS(father)-1 IF (RHS_BOUNDS(2*father-1).EQ.0) THEN RHS_BOUNDS(2*father-1) = RHS_BOUNDS(2*node-1) RHS_BOUNDS(2*father) = RHS_BOUNDS(2*node) ELSE RHS_BOUNDS(2*father-1) = min(RHS_BOUNDS(2*father-1), & RHS_BOUNDS(2*node-1)) RHS_BOUNDS(2*father) = max(RHS_BOUNDS(2*father), & RHS_BOUNDS(2*node)) END IF IF(NBSONS(father).EQ.0) THEN next_size_pool = next_size_pool+1 POOL(next_size_pool) = DAD(node) END IF END IF END DO size_pool = next_size_pool END DO DEALLOCATE(POOL, NBSONS) RETURN END SUBROUTINE SMUMPS_PROPAGATE_RHS_BOUNDS INTEGER(8) FUNCTION SMUMPS_LOCAL_FACTOR_SIZE(IW,LIW,PTR, & PHASE, LDLT, IS_ROOT) INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB IF (IS_ROOT) THEN SMUMPS_LOCAL_FACTOR_SIZE = int(IW(PTR+1),8) * & int(IW(PTR+2),8) / 2_8 RETURN ENDIF IF (NCB.GE.0_8) THEN IF (PHASE.EQ.0 & .OR. (PHASE.EQ.1.AND.LDLT.NE.0) & ) THEN SMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV-1_8)/2_8 + (NROW-NPIV)*NPIV ELSE SMUMPS_LOCAL_FACTOR_SIZE = & NPIV*(NPIV+1_8)/2_8 + (LIELL-NPIV)*NPIV ENDIF ELSE SMUMPS_LOCAL_FACTOR_SIZE = & -NCB*NELIM END IF RETURN END FUNCTION SMUMPS_LOCAL_FACTOR_SIZE INTEGER(8) FUNCTION SMUMPS_LOCAL_FACTOR_SIZE_BLR(IW,LIW,PTR, & LRSTATUS, IWHANDLER, & PHASE, LDLT, IS_ROOT) USE SMUMPS_LR_DATA_M USE SMUMPS_LR_TYPE INTEGER, INTENT(IN) :: LIW, PTR, PHASE, LDLT INTEGER, INTENT(IN) :: LRSTATUS, IWHANDLER INTEGER, INTENT(IN) :: IW(LIW) LOGICAL, INTENT(IN) :: IS_ROOT INTEGER(8) :: NCB, NELIM, LIELL, NPIV, NROW, FACTOR_SIZE INTEGER :: NB_PANELS, IPANEL, LorU, IBLOCK LOGICAL :: LR_ACTIVATED TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: LRB_PANEL NCB = int(IW(PTR),8) NELIM = int(IW(PTR+1),8) NROW = int(IW(PTR+2),8) NPIV = int(IW(PTR+3),8) LIELL = NPIV + NCB LR_ACTIVATED=(LRSTATUS.GE.2) IF (LR_ACTIVATED) THEN FACTOR_SIZE = 0_8 CALL SMUMPS_BLR_RETRIEVE_NB_PANELS(IWHANDLER, NB_PANELS) IF (LDLT.EQ.0) THEN LorU = PHASE ELSE LorU = 0 ENDIF DO IPANEL=1,NB_PANELS IF (IS_ROOT.AND.IPANEL.EQ.NB_PANELS) THEN CYCLE ENDIF IF (SMUMPS_BLR_EMPTY_PANEL_LORU(IWHANDLER, LorU, IPANEL)) & THEN CYCLE ENDIF CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU(IWHANDLER, LorU, & IPANEL, LRB_PANEL) IF (size(LRB_PANEL).GT.0) THEN IF (PHASE.EQ.0) THEN FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)-1_8)/2_8 ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(1)%N,8)*(int(LRB_PANEL(1)%N,8)+1_8)/2_8 ENDIF ENDIF DO IBLOCK=1,size(LRB_PANEL) IF (LRB_PANEL(IBLOCK)%ISLR) THEN FACTOR_SIZE = FACTOR_SIZE + int(LRB_PANEL(IBLOCK)%K,8)* & int(LRB_PANEL(IBLOCK)%M+LRB_PANEL(IBLOCK)%M,8) ELSE FACTOR_SIZE = FACTOR_SIZE + & int(LRB_PANEL(IBLOCK)%M*LRB_PANEL(IBLOCK)%N,8) ENDIF ENDDO ENDDO SMUMPS_LOCAL_FACTOR_SIZE_BLR = FACTOR_SIZE ELSE SMUMPS_LOCAL_FACTOR_SIZE_BLR = & SMUMPS_LOCAL_FACTOR_SIZE(IW, LIW, PTR, PHASE, LDLT, IS_ROOT) ENDIF RETURN END FUNCTION SMUMPS_LOCAL_FACTOR_SIZE_BLR SUBROUTINE SMUMPS_TREE_PRUN_NODES_STATS(MYID, N, KEEP28, KEEP201, & FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC) INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, MYID, N INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INTEGER I, ISTEP INTEGER(8) :: Pruned_Size IF (KEEP201 .GT. 0) THEN Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDDO PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF RETURN END SUBROUTINE SMUMPS_TREE_PRUN_NODES_STATS SUBROUTINE SMUMPS_CHAIN_PRUN_NODES_STATS & (MYID, N, KEEP28, KEEP201, KEEP485, FR_FACT, & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_LOC & ) IMPLICIT NONE INTEGER, intent(in) :: KEEP28, KEEP201, OOC_FCT_TYPE_LOC, N, & KEEP485 INTEGER(8), intent(in) :: FR_FACT INTEGER, intent(in) :: nb_prun_nodes, MYID INTEGER, intent(in) :: Pruned_List(nb_prun_nodes) INTEGER, intent(in) :: STEP(N) INCLUDE 'mpif.h' INTEGER I, ISTEP INTEGER(8) :: Pruned_Size Pruned_Size = 0_8 DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) IF (KEEP201 .GT. 0) THEN Pruned_Size = Pruned_Size + SIZE_OF_BLOCK & (ISTEP, OOC_FCT_TYPE_LOC) ENDIF ENDDO IF (KEEP201.GT.0) THEN IF (FR_FACT .NE. 0_8) THEN PRUNED_SIZE_LOADED = PRUNED_SIZE_LOADED +Pruned_Size ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_CHAIN_PRUN_NODES_STATS END MODULE SMUMPS_SOL_ES SUBROUTINE SMUMPS_PERMUTE_RHS_GS & (LP, LPOK, PROKG, MPG, PERM_STRAT, & SYM_PERM, N, NRHS, & IRHS_PTR, SIZE_IRHS_PTR, & IRHS_SPARSE, NZRHS, & PERM_RHS, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: LP, MPG, PERM_STRAT, N, NRHS, & SIZE_IRHS_PTR, & NZRHS LOGICAL, INTENT(IN) :: LPOK, PROKG INTEGER, INTENT(IN) :: SYM_PERM(N) INTEGER, INTENT(IN) :: IRHS_PTR(SIZE_IRHS_PTR) INTEGER, INTENT(IN) :: IRHS_SPARSE(NZRHS) INTEGER, INTENT(OUT) :: PERM_RHS(NRHS) INTEGER, INTENT(OUT) :: IERR INTEGER :: I,J,K, POSINPERMRHS, JJ, & KPOS INTEGER, ALLOCATABLE :: ROW_REFINDEX(:) IERR = 0 IF ((PERM_STRAT.NE.-1).AND.(PERM_STRAT.NE.1)) THEN IERR=-1 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -1 in ", & " SMUMPS_PERMUTE_RHS_GS, PERM_STRAT =", PERM_STRAT, & " is out of range " RETURN ENDIF IF (PERM_STRAT.EQ.-1) THEN DO I=1,NRHS PERM_RHS(I) = I END DO GOTO 490 ENDIF ALLOCATE(ROW_REFINDEX(NRHS), STAT=IERR) IF (IERR.GT.0) THEN IERR=-1 IF (LPOK) THEN WRITE(LP,*) " ERROR -2 : ", & " ALLOCATE IN SMUMPS_PERMUTE_RHS_GS OF SIZE :", & NRHS ENDIF RETURN ENDIF DO I=1,NRHS IF (IRHS_PTR(I+1)-IRHS_PTR(I).LE.0) THEN IERR = 1 IF (I.EQ.1) THEN ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ELSE ROW_REFINDEX(I) = ROW_REFINDEX(I-1) ENDIF ELSE ROW_REFINDEX(I) = IRHS_SPARSE(IRHS_PTR(I)) ENDIF END DO POSINPERMRHS = 0 DO I=1,NRHS KPOS = N+1 JJ = 0 DO J=1,NRHS K = ROW_REFINDEX(J) IF (K.LE.0) CYCLE IF (SYM_PERM(K).LT.KPOS) THEN KPOS = SYM_PERM(K) JJ = J ENDIF END DO IF (JJ.EQ.0) THEN IERR = -3 IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -3 in ", & " SMUMPS_PERMUTE_RHS_GS " GOTO 500 ENDIF POSINPERMRHS = POSINPERMRHS + 1 PERM_RHS(POSINPERMRHS) = JJ ROW_REFINDEX(JJ) = -ROW_REFINDEX(JJ) END DO IF (POSINPERMRHS.NE.NRHS) THEN IF (LPOK) & WRITE(LP,*) " INTERNAL ERROR -4 in ", & " SMUMPS_PERMUTE_RHS_GS ", maxval(ROW_REFINDEX) IERR = -4 GOTO 500 ENDIF 490 CONTINUE 500 CONTINUE IF (allocated(ROW_REFINDEX)) DEALLOCATE(ROW_REFINDEX) END SUBROUTINE SMUMPS_PERMUTE_RHS_GS SUBROUTINE SMUMPS_PERMUTE_RHS_AM1 & (PERM_STRAT, SYM_PERM, & IRHS_PTR, NHRS, & PERM_RHS, SIZEPERM, IERR & ) IMPLICIT NONE INTEGER, INTENT(IN) :: PERM_STRAT, NHRS, SIZEPERM INTEGER, INTENT(IN) :: SYM_PERM(SIZEPERM) INTEGER, INTENT(IN) :: IRHS_PTR(NHRS) INTEGER, INTENT(OUT):: IERR INTEGER, INTENT(OUT):: PERM_RHS(SIZEPERM) DOUBLE PRECISION :: RAND_NUM INTEGER I, J, STRAT IERR = 0 STRAT = PERM_STRAT IF( (STRAT.NE.-3).AND. & (STRAT.NE.-2).AND. & (STRAT.NE.-1).AND. & (STRAT.NE. 1).AND. & (STRAT.NE. 2).AND. & (STRAT.NE. 6) ) THEN WRITE(*,*)"Warning: incorrect value for the RHS permutation; ", & "defaulting to post-order" STRAT = 1 END IF IF (STRAT .EQ. -3) THEN PERM_RHS(1:SIZEPERM)=0 DO I=1, SIZEPERM CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) DO WHILE (PERM_RHS(J).NE.0) CALL random_number(RAND_NUM) RAND_NUM = RAND_NUM*dble(SIZEPERM) J = ceiling(RAND_NUM) ENDDO PERM_RHS(J)=I ENDDO ELSEIF (STRAT .EQ. -2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM -I +1) = I ENDDO ELSEIF (STRAT .EQ. -1) THEN DO I=1, SIZEPERM PERM_RHS(I) = I ENDDO ELSEIF (STRAT .EQ. 1) THEN DO I=1, SIZEPERM PERM_RHS(SYM_PERM(I)) = I ENDDO ELSEIF (STRAT .EQ. 2) THEN DO I=1, SIZEPERM PERM_RHS(SIZEPERM-SYM_PERM(I)+1) = I ENDDO ENDIF END SUBROUTINE SMUMPS_PERMUTE_RHS_AM1 SUBROUTINE SMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, SIZE_PERM, & IPTR_WORKING, SIZE_IPTR_WORKING, WORKING, SIZE_WORKING, & IRHS_PTR, & STEP, SYM_PERM, N, NBRHS, & PROCNODE, NSTEPS, SLAVEF, KEEP199, & behaviour_L0, reorder, n_select, PROKG, MPG & ) IMPLICIT NONE INTEGER, INTENT(IN) :: SIZE_PERM, & SIZE_IPTR_WORKING, & IPTR_WORKING(SIZE_IPTR_WORKING), & SIZE_WORKING, & WORKING(SIZE_WORKING), & N, & IRHS_PTR(N+1), & STEP(N), & SYM_PERM(N), & NBRHS, & NSTEPS, & PROCNODE(NSTEPS), & SLAVEF, KEEP199, & n_select, MPG LOGICAL, INTENT(IN) :: behaviour_L0, & reorder, PROKG INTEGER, INTENT(INOUT) :: PERM_RHS(SIZE_PERM) INTEGER :: I, J, K, & entry, & node, & SIZE_PERM_WORKING, & NB_NON_EMPTY, & to_be_found, & posintmprhs, & selected, & local_selected, & current_proc, & NPROCS, & n_pass, & pass, & nblocks, & n_select_loc, & IERR INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE, & PERM_PO LOGICAL, ALLOCATABLE, DIMENSION(:) :: USED LOGICAL :: allow_above_L0 INTEGER, EXTERNAL :: MUMPS_TYPENODE_ROUGH NPROCS = SIZE_IPTR_WORKING - 1 ALLOCATE(TMP_RHS(SIZE_PERM), & PTR_PROCS(NPROCS), & LOAD_PROCS(NPROCS), & USED(SIZE_PERM), & IPTR_PERM_WORKING(NPROCS+1), & MYTYPENODE(NSTEPS), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in SMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO I=1, NSTEPS MYTYPENODE(I) = MUMPS_TYPENODE_ROUGH( PROCNODE(I), KEEP199 ) ENDDO NB_NON_EMPTY = 0 DO I=1,SIZE_PERM IF(IRHS_PTR(I+1)-IRHS_PTR(I).NE.0) THEN NB_NON_EMPTY = NB_NON_EMPTY + 1 END IF END DO K = 0 IPTR_PERM_WORKING(1)=1 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 END IF END DO IPTR_PERM_WORKING(I+1) = K+1 END DO SIZE_PERM_WORKING = K ALLOCATE(PERM_WORKING(SIZE_PERM_WORKING), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in SMUMPS_INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF K = 0 DO I=1,NPROCS USED = .FALSE. DO J=IPTR_WORKING(I),IPTR_WORKING(I+1)-1 USED(WORKING(J)) = .TRUE. END DO DO J=1,N IF (USED(abs(STEP(PERM_RHS(J)))).AND. & ((IRHS_PTR(PERM_RHS(J)+1)-IRHS_PTR(PERM_RHS(J))).NE.0)) & THEN K = K + 1 PERM_WORKING(K) = PERM_RHS(J) END IF END DO END DO IF(behaviour_L0) THEN n_pass = 2 allow_above_L0 = .false. to_be_found = 0 DO I=1,SIZE_PERM IF((MYTYPENODE(abs(STEP(I))).LE.1).AND. & (IRHS_PTR(I+1)-IRHS_PTR(I).NE.0)) & THEN to_be_found = to_be_found + 1 END IF END DO ELSE n_pass = 1 allow_above_L0 = .true. to_be_found = NB_NON_EMPTY END IF PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) LOAD_PROCS = 0 USED = .FALSE. current_proc = 1 n_select_loc = n_select IF (n_select_loc.LE.0) THEN n_select_loc = 1 ENDIF posintmprhs = 0 DO pass=1,n_pass selected = 0 DO WHILE(selected.LT.to_be_found) local_selected = 0 DO WHILE(local_selected.LT.n_select_loc) IF(PTR_PROCS(current_proc).EQ. & IPTR_PERM_WORKING(current_proc+1)) & THEN EXIT ELSE entry = PERM_WORKING(PTR_PROCS(current_proc)) node = abs(STEP(entry)) IF(.NOT.USED(entry)) THEN IF(allow_above_L0.OR.(MYTYPENODE(node).LE.1)) THEN USED(entry) = .TRUE. selected = selected + 1 local_selected = local_selected + 1 posintmprhs = posintmprhs + 1 TMP_RHS(posintmprhs) = entry IF(selected.EQ.to_be_found) EXIT END IF END IF PTR_PROCS(current_proc) = PTR_PROCS(current_proc) + 1 END IF END DO current_proc = mod(current_proc,NPROCS)+1 END DO to_be_found = NB_NON_EMPTY - to_be_found allow_above_L0 = .true. PTR_PROCS(1:NPROCS) = IPTR_PERM_WORKING(1:NPROCS) END DO DO I=1,SIZE_PERM IF(IRHS_PTR(PERM_RHS(I)+1)-IRHS_PTR(PERM_RHS(I)).EQ.0) THEN posintmprhs = posintmprhs+1 TMP_RHS(posintmprhs) = PERM_RHS(I) IF(posintmprhs.EQ.SIZE_PERM) EXIT END IF END DO IF(reorder) THEN posintmprhs = 0 ALLOCATE(PERM_PO(N),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Allocation error in INTERLEAVE_RHS_AM1' CALL MUMPS_ABORT() END IF DO J=1,N PERM_PO(SYM_PERM(J))=J END DO nblocks = N/NBRHS DO I = 1, nblocks USED = .FALSE. DO J=1, NBRHS USED(TMP_RHS(NBRHS*(I-1)+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END DO IF(mod(N,NBRHS).NE.0) THEN USED = .FALSE. DO J=1, mod(N,NBRHS) USED(TMP_RHS(NBRHS*nblocks+J))=.TRUE. END DO DO J=1,N IF(USED(PERM_PO(J))) THEN posintmprhs = posintmprhs + 1 PERM_RHS(posintmprhs) = PERM_PO(J) END IF END DO END IF DEALLOCATE(PERM_PO) ELSE PERM_RHS = TMP_RHS END IF DEALLOCATE(TMP_RHS, & PTR_PROCS, & LOAD_PROCS, & USED, & IPTR_PERM_WORKING, & PERM_WORKING, & MYTYPENODE) RETURN END SUBROUTINE SMUMPS_INTERLEAVE_RHS_AM1 MUMPS_5.4.1/src/cfac_mem_compress_cb.F0000664000175000017500000005050414102210523017727 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE CMUMPS_SIZEFREEINREC SUBROUTINE CMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE CMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE CMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE CMUMPS_MOVETONEXTRECORD SUBROUTINE CMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ISHIFT SUBROUTINE CMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT COMPLEX A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_RSHIFT SUBROUTINE CMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP199, PROCNODE_STEPS, DAD) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF, KEEP199 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) COMPLEX, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: CMUMPS_ISBAND EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_REF, TIME_COMP TIME_REF = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL CMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP216) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL CMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP28, KEEP199, & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL CMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL CMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL CMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP216) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL CMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL CMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL CMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in CMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in CMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in CMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = MPI_WTIME() - TIME_REF ACC_TIME = ACC_TIME + real(TIME_COMP) RETURN END SUBROUTINE CMUMPS_COMPRE_NEW SUBROUTINE CMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE CMUMPS_GET_SIZEHOLE SUBROUTINE CMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT COMPLEX A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN CMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in CMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in CMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE CMUMPS_MAKECBCONTIG SUBROUTINE CMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) COMPLEX, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP REAL, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL CMUMPS_COMPRE_NEW_CALLED CMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF CMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.CMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) CMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. CMUMPS_COMPRE_NEW_CALLED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL CMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL CMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in CMUMPS_GET_SIZE_NEEDED ', & 'PB compress... CMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_GET_SIZE_NEEDED MUMPS_5.4.1/src/dmumps_struc_def.F0000664000175000017500000000102414102210522017151 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_STRUC_DEF INCLUDE 'dmumps_struc.h' END MODULE DMUMPS_STRUC_DEF MUMPS_5.4.1/src/zrank_revealing.F0000664000175000017500000001072314102210524016777 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 RETURN END SUBROUTINE ZMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE ZMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE ZMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE ZMUMPS_RR_INIT_POINTERS(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) id NULLIFY(id%root%QR_TAU) NULLIFY(id%root%SVD_U) NULLIFY(id%root%SVD_VT) NULLIFY(id%root%SINGULAR_VALUES) RETURN END SUBROUTINE ZMUMPS_RR_INIT_POINTERS SUBROUTINE ZMUMPS_RR_FREE_POINTERS(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) id IF (associated(id%root%QR_TAU)) THEN DEALLOCATE(id%root%QR_TAU) NULLIFY(id%root%QR_TAU) ENDIF IF (associated(id%root%SVD_U)) THEN DEALLOCATE(id%root%SVD_U) NULLIFY(id%root%SVD_U) ENDIF IF (associated(id%root%SVD_VT)) THEN DEALLOCATE(id%root%SVD_VT) NULLIFY(id%root%SVD_VT) ENDIF IF (associated(id%root%SINGULAR_VALUES)) THEN DEALLOCATE(id%root%SINGULAR_VALUES) NULLIFY(id%root%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE ZMUMPS_RR_FREE_POINTERS MUMPS_5.4.1/src/mumps_config_file_C.c0000664000175000017500000000124614102210474017606 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "mumps_config_file_C.h" #include "mumps_common.h" void MUMPS_CALL MUMPS_CONFIG_FILE_RETURN_C() { /* This feature will be available in the future */ } MUMPS_5.4.1/src/zfac_mem_dynamic.F0000664000175000017500000005253314102210525017111 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE ZMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST COMPLEX(kind=8), INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_F2003) COMPLEX(kind=8), POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #else COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( ZMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL ZMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE ZMUMPS_DM_SET_DYNPTR SUBROUTINE ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (ZMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION ZMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); ZMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); ZMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); ZMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during ZMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION ZMUMPS_DM_ISBAND LOGICAL FUNCTION ZMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) ZMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION ZMUMPS_DM_IS_DYNAMIC SUBROUTINE ZMUMPS_DM_FAC_UPD_DYN_MEMCNTS & ( MEM_COUNT_ALLOCATED, ATOMIC_UPDATES, KEEP8, & IFLAG, IERROR, K69UPD_ARG ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_ALLOCATED INTEGER(8), INTENT(INOUT) :: KEEP8(150) LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER, INTENT(INOUT) :: IFLAG, IERROR LOGICAL, INTENT(IN), OPTIONAL :: K69UPD_ARG LOGICAL K69UPD INTEGER(8) :: KEEP8TMPCOPY K69UPD = .TRUE. IF (present(K69UPD_ARG)) THEN IF ( .NOT. K69UPD_ARG ) THEN K69UPD = .FALSE. ENDIF ENDIF IF (MEM_COUNT_ALLOCATED.GT.0) THEN IF (ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP8(73)) ENDIF IF ( KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8TMPCOPY-KEEP8(75)), IERROR) ENDIF IF ( K69UPD ) THEN IF ( ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8(68) = max(KEEP8(69), KEEP8(68)) ENDIF ENDIF ELSE IF (ATOMIC_UPDATES) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC IF ( K69UPD ) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC ENDIF ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED IF ( K69UPD ) THEN KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_DM_FAC_UPD_DYN_MEMCNTS SUBROUTINE ZMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE ZMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE ZMUMPS_LOAD, ONLY : ZMUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX(kind=8), INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 COMPLEX(kind=8), DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. ZMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in ZMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL ZMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in ZMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL ZMUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL ZMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST COMPLEX(kind=8), DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in ZMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL ZMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL ZMUMPS_DM_FREE_BLOCK( TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE ZMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE ZMUMPS_STATIC_PTR_M, ONLY : ZMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_F2003) COMPLEX(kind=8), DIMENSION(:), POINTER, INTENT(out) :: CBPTR #else COMPLEX(kind=8), DIMENSION(:), POINTER :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL ZMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL ZMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE ZMUMPS_DM_SET_PTR SUBROUTINE ZMUMPS_DM_FREE_BLOCK( DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE COMPLEX(kind=8), POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY DEALLOCATE(DYNPTR) NULLIFY(DYNPTR) CALL ZMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY) RETURN END SUBROUTINE ZMUMPS_DM_FREE_BLOCK END MODULE ZMUMPS_DYNAMIC_MEMORY_M SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL ZMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE ZMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX(kind=8), INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL ZMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE ZMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.4.1/src/ana_blk.F0000664000175000017500000014510114102210475015211 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_AB_FREE_LMAT ( LMAT ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE TYPE(LMATRIX_T) :: LMAT INTEGER :: J IF (associated(LMAT%COL)) THEN DO J = 1,LMAT%NBCOL IF (associated(LMAT%COL(J)%IRN)) THEN DEALLOCATE(LMAT%COL(J)%IRN) NULLIFY(LMAT%COL(J)%IRN) ENDIF ENDDO DEALLOCATE(LMAT%COL) NULLIFY(LMAT%COL) ENDIF RETURN END SUBROUTINE MUMPS_AB_FREE_LMAT SUBROUTINE MUMPS_AB_FREE_GCOMP ( GCOMP ) USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE TYPE(COMPACT_GRAPH_T) :: GCOMP IF (associated(GCOMP%IPE)) THEN DEALLOCATE(GCOMP%IPE) NULLIFY(GCOMP%IPE) ENDIF IF (associated(GCOMP%ADJ)) THEN DEALLOCATE(GCOMP%ADJ) NULLIFY(GCOMP%ADJ) ENDIF RETURN END SUBROUTINE MUMPS_AB_FREE_GCOMP SUBROUTINE MUMPS_AB_COMPUTE_SIZEOFBLOCK ( & NBLK, NDOF, BLKPTR, BLKVAR, & SIZEOFBLOCKS, DOF2BLOCK ) IMPLICIT NONE INTEGER, INTENT(IN) :: NBLK, NDOF INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(NDOF) INTEGER, INTENT(OUT):: SIZEOFBLOCKS(NBLK), DOF2BLOCK(NDOF) INTEGER :: IB, I, IDOF DO IB=1, NBLK SIZEOFBLOCKS(IB)= BLKPTR(IB+1)-BLKPTR(IB) DO I=BLKPTR(IB), BLKPTR(IB+1)-1 IDOF = BLKVAR(I) DOF2BLOCK(IDOF) = IB ENDDO ENDDO RETURN END SUBROUTINE MUMPS_AB_COMPUTE_SIZEOFBLOCK SUBROUTINE MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & IFLAG, IERROR, LP, LPOK, & LMAT) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, NBLK, NDOF INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) INTEGER, INTENT(IN) :: DOF2BLOCK(NDOF) INTEGER :: LP, IFLAG, IERROR LOGICAL, INTENT(IN) :: LPOK TYPE(LMATRIX_T) :: LMAT INTEGER, ALLOCATABLE, DIMENSION(:) :: FLAG INTEGER :: allocok INTEGER :: I, J, JJB, IIB, IB, JB, NB, PT INTEGER(8) :: I8 LMAT%NBCOL = NBLK LMAT%NZL = 0_8 ALLOCATE(LMAT%COL(NBLK),FLAG(NBLK), STAT=allocok) IF (allocok.NE.0) THEN IFLAG = -7 IERROR = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LMAT%COL" END IF RETURN ENDIF DO IB=1,NBLK LMAT%COL(IB)%NBINCOL = 0 FLAG(IB) = 0 ENDDO IERROR = 0 DO I8=1, NNZ I = IRN(I8) J = JCN(I8) IF ( (I.GT.NDOF).OR.(J.GT.NDOF).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IB = DOF2BLOCK(I) JB = DOF2BLOCK(J) JJB = min(IB,JB) IF (IB.NE.JB) THEN LMAT%NZL = LMAT%NZL+1_8 LMAT%COL(JJB)%NBINCOL = LMAT%COL(JJB)%NBINCOL + 1 ENDIF ENDIF ENDDO IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF DO JB=1,NBLK NB = LMAT%COL(JB)%NBINCOL IF (NB.GT.0) THEN ALLOCATE(LMAT%COL(JB)%IRN(NB), STAT=allocok) IF (allocok.NE.0) THEN IFLAG = -7 IERROR = NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LMAT%COL" END IF RETURN ENDIF ENDIF ENDDO DO I8=1, NNZ I = IRN(I8) J = JCN(I8) IF ( (I.LE.NDOF).AND.(J.LE.NDOF).AND.(I.GE.1) & .AND.(J.GE.1)) THEN IB = DOF2BLOCK(I) JB = DOF2BLOCK(J) JJB = min(IB,JB) IIB = max(IB,JB) IF (IIB.NE.JJB) THEN PT = FLAG(JJB)+1 FLAG(JJB) = PT LMAT%COL(JJB)%IRN(PT) = IIB ENDIF ENDIF ENDDO CALL MUMPS_AB_LOCALCLEAN_LMAT ( MYID, & NBLK, LMAT, FLAG(1), IFLAG, IERROR, LP, LPOK & ) DEALLOCATE(FLAG) RETURN END SUBROUTINE MUMPS_AB_COORD_TO_LMAT SUBROUTINE MUMPS_AB_LOCALCLEAN_LMAT ( MYID, & NBLK, LMAT, FLAG, IFLAG, IERROR, LP, LPOK & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, NBLK, LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(OUT) :: FLAG(NBLK) INTEGER, INTENT(INOUT) :: IFLAG, IERROR TYPE(LMATRIX_T), INTENT(INOUT) :: LMAT INTEGER, POINTER, DIMENSION(:) :: PTCLEAN INTEGER :: allocok, IB, JB, NB DO JB=1, NBLK FLAG(JB) = 0 ENDDO LMAT%NZL = 0_8 DO JB=1, NBLK IF ( LMAT%COL(JB)%NBINCOL.EQ.0) CYCLE NB = 0 DO IB=1, LMAT%COL(JB)%NBINCOL IF (FLAG(LMAT%COL(JB)%IRN(IB)).EQ.JB) THEN LMAT%COL(JB)%IRN(IB)=0 ELSE NB = NB+1 LMAT%NZL = LMAT%NZL+1_8 FLAG(LMAT%COL(JB)%IRN(IB)) = JB ENDIF ENDDO IF (NB.GT.0) THEN ALLOCATE(PTCLEAN(NB), STAT=allocok) IF (allocok.NE.0) THEN IFLAG = -7 IERROR = NB IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate PTCLEAN of size", & IERROR END IF RETURN ENDIF NB=0 DO IB=1, LMAT%COL(JB)%NBINCOL IF (LMAT%COL(JB)%IRN(IB).NE.0) THEN NB = NB+1 PTCLEAN(NB)=LMAT%COL(JB)%IRN(IB) ENDIF ENDDO LMAT%COL(JB)%NBINCOL = NB deallocate(LMAT%COL(JB)%IRN) LMAT%COL(JB)%IRN => PTCLEAN NULLIFY(PTCLEAN) ELSE deallocate(LMAT%COL(JB)%IRN) NULLIFY(LMAT%COL(JB)%IRN) ENDIF ENDDO RETURN END SUBROUTINE MUMPS_AB_LOCALCLEAN_LMAT SUBROUTINE MUMPS_AB_LMAT_TO_LUMAT( & LMAT, LUMAT, INFO, ICNTL ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T IMPLICIT NONE TYPE(LMATRIX_T) :: LMAT, LUMAT INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER :: IB, IIB, JB, allocok, LP, MPG, NB, IERR LOGICAL LPOK, PROKG LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. (ICNTL(4).GE.2) ) LUMAT%NBCOL = LMAT%NBCOL LUMAT%NZL = 2_8*LMAT%NZL ALLOCATE( LUMAT%COL(LMAT%NBCOL),STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = LMAT%NBCOL IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating LUMAT%COL " END IF RETURN ENDIF DO JB=1, LMAT%NBCOL LUMAT%COL(JB)%NBINCOL = LMAT%COL(JB)%NBINCOL ENDDO DO JB=1, LMAT%NBCOL DO IB=1, LMAT%COL(JB)%NBINCOL IIB=LMAT%COL(JB)%IRN(IB) LUMAT%COL(IIB)%NBINCOL = LUMAT%COL(IIB)%NBINCOL + 1 ENDDO ENDDO DO JB=1, LMAT%NBCOL NB = LUMAT%COL(JB)%NBINCOL ALLOCATE(LUMAT%COL(JB)%IRN(NB), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NB IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating columns of LUMAT" END IF RETURN ENDIF ENDDO DO JB=1, LMAT%NBCOL LUMAT%COL(JB)%NBINCOL = 0 ENDDO DO JB=1, LMAT%NBCOL DO IB=1, LMAT%COL(JB)%NBINCOL IIB=LMAT%COL(JB)%IRN(IB) NB = LUMAT%COL(JB)%NBINCOL+1 LUMAT%COL(JB)%NBINCOL = NB LUMAT%COL(JB)%IRN(NB)= IIB NB = LUMAT%COL(IIB)%NBINCOL+1 LUMAT%COL(IIB)%NBINCOL = NB LUMAT%COL(IIB)%IRN(NB)= JB ENDDO ENDDO RETURN END SUBROUTINE MUMPS_AB_LMAT_TO_LUMAT SUBROUTINE MUMPS_AB_PRINT_LMATRIX (LMAT, MYID, LP) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE TYPE(LMATRIX_T), INTENT(IN) :: LMAT INTEGER, INTENT(IN) :: MYID, LP INTEGER :: JB write(LP,*) MYID, " ... LMATRIX %NBCOL, %NZL= ", & LMAT%NBCOL, LMAT%NZL IF (LMAT%NBCOL.GE.0.AND.associated(LMAT%COL)) THEN DO JB=1, LMAT%NBCOL IF (LMAT%COL(JB)%NBINCOL.GT.0) THEN WRITE(LP,*) MYID, " ... Column=", JB , " nb entries =", & LMAT%COL(JB)%NBINCOL, " List of entries:", & LMAT%COL(JB)%IRN(1:LMAT%COL(JB)%NBINCOL) ENDIF ENDDO ENDIF RETURN END SUBROUTINE MUMPS_AB_PRINT_LMATRIX SUBROUTINE MUMPS_AB_LMAT_TO_CLEAN_G( MYID, UNFOLD, & READY_FOR_ANA_F, & LMAT, GCOMP, INFO, ICNTL ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T, COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: MYID LOGICAL, INTENT(IN) :: UNFOLD, READY_FOR_ANA_F TYPE(LMATRIX_T) :: LMAT TYPE(COMPACT_GRAPH_T) :: GCOMP INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER :: IB, IIB, JJB, allocok, LP, MPG INTEGER(8) :: JPOS, SIZEGCOMPALLOCATED INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER, ALLOCATABLE, DIMENSION(:) :: WORK INTEGER(8) :: IFIRST, ILAST INTEGER :: L #endif LOGICAL LPOK, PROKG LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. (ICNTL(4).GE.2) ) GCOMP%NG = LMAT%NBCOL IF (UNFOLD) THEN GCOMP%NZG = 2_8*LMAT%NZL SIZEGCOMPALLOCATED = GCOMP%NZG + int(GCOMP%NG,8)+1_8 ELSE IF (READY_FOR_ANA_F) THEN GCOMP%NZG = LMAT%NZL SIZEGCOMPALLOCATED = GCOMP%NZG + int(GCOMP%NG,8)+1_8 ELSE GCOMP%NZG = LMAT%NZL SIZEGCOMPALLOCATED = GCOMP%NZG ENDIF GCOMP%SIZEADJALLOCATED= SIZEGCOMPALLOCATED ALLOCATE( GCOMP%ADJ(SIZEGCOMPALLOCATED), & GCOMP%IPE(GCOMP%NG+1), & IQ(GCOMP%NG),STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( & GCOMP%NZG + 3_8*int(GCOMP%NG,8)+1_8, INFO(2)) IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating graph in", & " MUMPS_AB_LMAT_TO_CLEAN_G" END IF RETURN ENDIF DO JJB=1, GCOMP%NG IQ(JJB)=0_8 ENDDO IF (UNFOLD) THEN DO JJB=1, GCOMP%NG DO IB=1, LMAT%COL(JJB)%NBINCOL IIB=LMAT%COL(JJB)%IRN(IB) IQ(JJB)=IQ(JJB)+1 IQ(IIB)=IQ(IIB)+1 ENDDO ENDDO ELSE DO JJB=1, GCOMP%NG IQ(JJB) = LMAT%COL(JJB)%NBINCOL ENDDO ENDIF GCOMP%IPE(1) = 1_8 DO JJB=1, GCOMP%NG GCOMP%IPE(JJB+1) = GCOMP%IPE(JJB)+IQ(JJB) ENDDO IF (UNFOLD) THEN DO JJB=1, GCOMP%NG IQ(JJB)= GCOMP%IPE(JJB) ENDDO DO JJB=1, GCOMP%NG DO IB=1, LMAT%COL(JJB)%NBINCOL IIB=LMAT%COL(JJB)%IRN(IB) GCOMP%ADJ(IQ(IIB))= JJB IQ(IIB) = IQ(IIB)+1_8 GCOMP%ADJ(IQ(JJB))= IIB IQ(JJB) = IQ(JJB)+1_8 ENDDO ENDDO ELSE DO JJB=1, GCOMP%NG JPOS = GCOMP%IPE(JJB) DO IB=1, LMAT%COL(JJB)%NBINCOL IIB=LMAT%COL(JJB)%IRN(IB) GCOMP%ADJ(JPOS)= IIB JPOS = JPOS+1_8 ENDDO ENDDO ENDIF DEALLOCATE(IQ) #if defined(DETERMINISTIC_PARALLEL_GRAPH) IF (.NOT.READY_FOR_ANA_F) THEN ALLOCATE(WORK(0:GCOMP%NG),stat=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = GCOMP%NG IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocating WORK in", & " MUMPS_AB_LMAT_TO_CLEAN_G" END IF RETURN ENDIF DO JJB=1, GCOMP%NG IFIRST = GCOMP%IPE(JJB) ILAST= GCOMP%IPE(JJB+1)-1 L = int(ILAST-IFIRST+1) IF ( L .GE. 2 ) THEN IF (L .GE. GCOMP%NG ) THEN WRITE(*,*) " Internal error in MUMPS_AB_LMAT_TO_CLEAN_G", & L, GCOMP%NG CALL MUMPS_ABORT() ENDIF CALL MUMPS_MERGESORT( L, & GCOMP%ADJ(IFIRST:ILAST), WORK(0:L+1) ) CALL MUMPS_MERGESWAP1( L, & WORK(0:L+1), GCOMP%ADJ(IFIRST:ILAST) ) ENDIF ENDDO DEALLOCATE(WORK) ENDIF #endif RETURN #if defined(DETERMINISTIC_PARALLEL_GRAPH) CONTAINS SUBROUTINE MUMPS_MERGESORT(N, K, L) INTEGER :: N INTEGER :: K(:), L(0:) INTEGER :: P, Q, S, T CONTINUE L(0) = 1 T = N + 1 DO P = 1,N - 1 IF (K(P) <= K(P+1)) THEN L(P) = P + 1 ELSE L(T) = - (P+1) T = P END IF END DO L(T) = 0 L(N) = 0 IF (L(N+1) == 0) THEN RETURN ELSE L(N+1) = iabs(L(N+1)) END IF 200 CONTINUE S = 0 T = N+1 P = L(S) Q = L(T) IF(Q .EQ. 0) RETURN 300 CONTINUE IF(K(P) .GT. K(Q)) GOTO 600 CONTINUE L(S) = sign(P,L(S)) S = P P = L(P) IF (P .GT. 0) GOTO 300 CONTINUE L(S) = Q S = T DO T = Q Q = L(Q) IF (Q .LE. 0) EXIT END DO GOTO 800 600 CONTINUE L(S) = sign(Q, L(S)) S = Q Q = L(Q) IF (Q .GT. 0) GOTO 300 CONTINUE L(S) = P S = T DO T = P P = L(P) IF (P .LE. 0) EXIT END DO 800 CONTINUE P = -P Q = -Q IF(Q.EQ.0) THEN L(S) = sign(P, L(S)) L(T) = 0 GOTO 200 END IF GOTO 300 END SUBROUTINE MUMPS_MERGESORT SUBROUTINE MUMPS_MERGESWAP1(N, L, A) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A(LP) A(LP) = A(I) A(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE MUMPS_MERGESWAP1 #endif END SUBROUTINE MUMPS_AB_LMAT_TO_CLEAN_G SUBROUTINE MUMPS_AB_COL_DISTRIBUTION ( OPTION, & INFO, ICNTL, COMM, NBLK, MYID, NPROCS, & LMAT, MAPCOL ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER, INTENT(IN) :: OPTION, NBLK INTEGER, INTENT(IN) :: ICNTL(60), COMM, MYID, NPROCS INTEGER :: INFO(80) TYPE(LMATRIX_T) :: LMAT INTEGER, INTENT(OUT):: MAPCOL(NBLK) INTEGER :: LP, SIZE_NZROW, I LOGICAL :: LPOK INTEGER(8) :: NZL, NNZ INTEGER, DIMENSION(:), ALLOCATABLE :: NZ_ROW LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IF (OPTION.EQ.1) THEN NNZ = -9999 SIZE_NZROW = 1 ELSE NZL = LMAT%NZL SIZE_NZROW = NBLK ENDIF ALLOCATE(NZ_ROW(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = SIZE_NZROW IF ( LPOK ) THEN WRITE(LP, *) & " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", INFO(2) END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1).LT.0) GOTO 500 IF (OPTION.NE.1) THEN DO I = 1, NBLK MAPCOL(I) = LMAT%COL(I)%NBINCOL ENDDO CALL MPI_ALLREDUCE(MAPCOL(1), NZ_ROW(1), NBLK, & MPI_INTEGER, MPI_SUM, COMM, IERR) CALL MPI_ALLREDUCE(NZL, NNZ, 1, & MPI_INTEGER8, MPI_SUM, COMM, IERR) ENDIF CALL MUMPS_AB_COMPUTE_MAPCOL (OPTION, INFO, ICNTL, MYID, & NNZ, NZ_ROW(1), SIZE_NZROW, NBLK, NPROCS, MAPCOL(1)) 500 CONTINUE IF (allocated(NZ_ROW)) DEALLOCATE(NZ_ROW) RETURN END SUBROUTINE MUMPS_AB_COL_DISTRIBUTION SUBROUTINE MUMPS_AB_COMPUTE_MAPCOL (OPTION, INFO, ICNTL, & MYID, NNZ, NZ_ROW, SIZE_NZROW, NBLK, NPROCS, MAPCOL ) INTEGER, INTENT(IN) :: OPTION, MYID, SIZE_NZROW, NBLK INTEGER, INTENT(IN) :: ICNTL(60), NPROCS INTEGER :: INFO(80) INTEGER(8) :: NNZ INTEGER, INTENT(IN) :: NZ_ROW(SIZE_NZROW) INTEGER, INTENT(OUT):: MAPCOL(NBLK) INTEGER :: I, J, P, F, LP, IERR LOGICAL :: LPOK INTEGER(8) :: SHARE, T INTEGER, DIMENSION(:), ALLOCATABLE :: FIRST LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) ALLOCATE(FIRST(NPROCS+1), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NPROCS+1 IF ( LPOK ) THEN WRITE(LP, *) & " ERROR allocate in MUMPS_AB_COL_DISTRIBUTION ", INFO(2) END IF GOTO 500 ENDIF DO I=1,NPROCS+1 FIRST(I) = 0 ENDDO IF (OPTION.EQ.1) THEN SHARE = int(NBLK/NPROCS,8) DO I=1, NPROCS FIRST(I) = (I-1)*int(SHARE)+1 END DO FIRST(NPROCS+1)=NBLK+1 ELSE SHARE = (NNZ-1_8)/int(NPROCS,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, NBLK T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((NBLK-I).EQ.(NPROCS-P-1)) .OR. & (I.EQ.NBLK) & ) THEN P = P+1 IF(P.EQ.NPROCS) THEN FIRST(P) = F EXIT ELSE FIRST(P) = F F = I+1 T = 0_8 END IF END IF IF ((I.EQ.NBLK).AND.(P.NE.NPROCS)) THEN DO J=P,NPROCS FIRST(J) = FIRST(P) ENDDO ENDIF END DO FIRST(NPROCS+1) = NBLK+1 ENDIF DO I=1,NPROCS DO J=FIRST(I), FIRST(I+1)-1 MAPCOL(J) = I-1 ENDDO ENDDO IF (allocated(FIRST)) DEALLOCATE(FIRST) 500 CONTINUE RETURN END SUBROUTINE MUMPS_AB_COMPUTE_MAPCOL SUBROUTINE MUMPS_AB_BUILD_DCLEAN_LUMATRIX ( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, SIZEMAPCOL, & STEP, SIZESTEP, & LUMAT) USE MUMPS_ANA_BLK_M IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL, INTENT(IN) :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, SIZEMAPCOL INTEGER, INTENT(IN) :: ICNTL(60), COMM, KEEP(500) INTEGER, INTENT(IN) :: SIZESTEP INTEGER, INTENT(IN) :: STEP(SIZESTEP) INTEGER, INTENT(INOUT) :: INFO(80) TYPE(LMATRIX_T), INTENT(IN) :: LMAT INTEGER, INTENT(INOUT) :: MAPCOL(SIZEMAPCOL) TYPE(LMATRIX_T), INTENT(OUT) :: LUMAT INTEGER :: NBLKloc, IERR, JB, IB, LP, NB, I, & NBRECORDS INTEGER(8) :: NNZ, NZ_locMAX8, NSEND8, NLOCAL8 LOGICAL :: LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL INTEGER OPTION PARAMETER (OPTION=2) NBLKloc = LMAT%NBCOL IF (NBLKloc.NE.NBLK) THEN write(6,*) "Internal error in MUMPS_AB_BUILD_DCLEAN_LUMATRIX ", & "NBLKloc, NBLK=", NBLKloc, NBLK ENDIF LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) ALLOCATE(WT(NBLK), WNBINCOL(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL; WT" END IF GOTO 500 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 DO JB=1, NBLK WT(JB) = LMAT%COL(JB)%NBINCOL ENDDO DO JB=1,NBLK IF ( LMAT%COL(JB)%NBINCOL.EQ.0) CYCLE DO IB=1, LMAT%COL(JB)%NBINCOL I = LMAT%COL(JB)%IRN(IB) WT(I)= WT(I)+1 ENDDO ENDDO CALL MPI_ALLREDUCE(WT(1), WNBINCOL(1), NBLK, & MPI_INTEGER, MPI_SUM, COMM, IERR) IF (allocated(WT)) DEALLOCATE(WT) IF (MAPCOLonLUMAT) THEN NNZ = 0_8 DO I=1, NBLK NNZ=NNZ+WNBINCOL(I) ENDDO CALL MUMPS_AB_COMPUTE_MAPCOL (OPTION, INFO, ICNTL, & MYID, NNZ, WNBINCOL(1), NBLK, & NBLK, NPROCS, MAPCOL(1)) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF LUMAT%NBCOL = NBLK LUMAT%NZL = 0_8 ALLOCATE(LUMAT%COL(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL; WT" END IF ENDIF IF ( INFO(1) .GE. 0 ) THEN DO JB=1,NBLK NB = WNBINCOL(JB) IF (MAPCOL_IN_NSTEPS) THEN IF (MAPCOL(abs(STEP(JB))).EQ.MYID) THEN LUMAT%NZL = LUMAT%NZL + int(NB,8) ELSE NB = 0 ENDIF ELSE IF (MAPCOL(JB).EQ.MYID) THEN LUMAT%NZL = LUMAT%NZL + int(NB,8) ELSE NB = 0 ENDIF ENDIF LUMAT%COL(JB)%NBINCOL = NB IF (NB.GT.0) THEN ALLOCATE(LUMAT%COL(JB)%IRN(NB), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NB IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LMAT%COL" END IF EXIT ENDIF ENDIF ENDDO ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) CALL MPI_ALLREDUCE(LUMAT%NZL, NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, COMM, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL MUMPS_AB_DIST_LMAT_TO_LUMAT ( & .TRUE., & MAPCOL_IN_NSTEPS, & INFO, ICNTL, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, SIZEMAPCOL, STEP, SIZESTEP, & LUMAT, NBRECORDS, NSEND8, NLOCAL8 & ) CALL MUMPS_AB_FREE_LMAT(LMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ALLOCATE(WT(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT%COL; WT" END IF GOTO 500 ENDIF CALL MUMPS_AB_LOCALCLEAN_LMAT ( MYID, & NBLK, LUMAT, WT(1), INFO(1), INFO(2), LP, LPOK & ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 DEALLOCATE(WT) GOTO 600 500 CONTINUE IF (allocated(WT)) DEALLOCATE(WT) IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) 600 CONTINUE RETURN END SUBROUTINE MUMPS_AB_BUILD_DCLEAN_LUMATRIX SUBROUTINE MUMPS_INIALIZE_REDIST_LUMAT ( & INFO, ICNTL, KEEP, COMM, MYID, NBLK, & LUMAT, PROCNODE_STEPS, NSTEPS, MAPCOL, & LUMAT_REMAP, NBRECORDS, STEP & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER PARAMETER (MASTER=0) INTEGER, INTENT(IN) :: MYID, NBLK, NSTEPS, KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60), COMM INTEGER :: INFO(80) INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS) TYPE(LMATRIX_T), INTENT(IN) :: LUMAT INTEGER, INTENT(IN) :: STEP(NBLK) TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT_REMAP INTEGER, INTENT(OUT) :: NBRECORDS INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS) INTEGER :: LP, MP, ISTEP, JB, NB LOGICAL :: LPOK INTEGER, ALLOCATABLE, DIMENSION(:) :: WT, WNBINCOL INTEGER MUMPS_PROCNODE INTEGER(8) :: NZ_locMAX8 LP = ICNTL( 1 ) MP = ICNTL( 2 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) ALLOCATE(WT(NBLK), WNBINCOL(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = 2*NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate WT" END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 DO JB=1, NBLK WT(JB) = LUMAT%COL(JB)%NBINCOL ENDDO CALL MPI_ALLREDUCE(WT(1), WNBINCOL(1), NBLK, & MPI_INTEGER, MPI_SUM, COMM, IERR) IF (allocated(WT)) DEALLOCATE(WT) IF (MYID.EQ.MASTER) THEN DO ISTEP=1, NSTEPS MAPCOL(ISTEP) = & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) ENDDO ENDIF CALL MPI_BCAST( MAPCOL(1), NSTEPS, MPI_INTEGER, & MASTER, COMM, IERR ) CALL MPI_BCAST( STEP(1), NBLK, MPI_INTEGER, & MASTER, COMM, IERR ) LUMAT_REMAP%NBCOL = NBLK ALLOCATE(LUMAT_REMAP%COL(NBLK), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT_REMAP%COL" END IF ENDIF IF ( INFO(1) .GE. 0 ) THEN LUMAT_REMAP%NZL = 0_8 DO JB=1,NBLK NB = WNBINCOL(JB) IF (MAPCOL(abs(STEP(JB))).EQ.MYID) THEN LUMAT_REMAP%NZL = LUMAT_REMAP%NZL + int(NB,8) ELSE NB = 0 ENDIF LUMAT_REMAP%COL(JB)%NBINCOL = NB IF (NB.GT.0) THEN ALLOCATE(LUMAT_REMAP%COL(JB)%IRN(NB), STAT=IERR) IF (IERR.NE.0) THEN INFO(1) = -7 INFO(2) = NB IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate of LUMAT_REMAP%COL" END IF EXIT ENDIF ENDIF ENDDO ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) CALL MPI_ALLREDUCE(LUMAT_REMAP%NZL, NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, COMM, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF GOTO 600 500 CONTINUE IF (allocated(WT)) DEALLOCATE(WT) IF (allocated(WNBINCOL)) DEALLOCATE(WNBINCOL) 600 CONTINUE RETURN END SUBROUTINE MUMPS_INIALIZE_REDIST_LUMAT SUBROUTINE MUMPS_AB_DCOORD_TO_DCOMPG ( & MYID, NPROCS, COMM, & NBLK, NDOF, NNZ, & IRN, JCN, DOF2BLOCK, & ICNTL, INFO, KEEP, & LUMAT, GCOMP, READY_FOR_ANA_F) USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T, COMPACT_GRAPH_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) LOGICAL, INTENT(IN) :: READY_FOR_ANA_F INTEGER, INTENT(INOUT) :: DOF2BLOCK(NDOF) INTEGER, INTENT(IN) :: ICNTL(60), COMM INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80) TYPE(COMPACT_GRAPH_T) :: GCOMP TYPE(LMATRIX_T) :: LUMAT TYPE(LMATRIX_T) :: LMAT INTEGER :: IDUMMY_ARRAY(1) INTEGER :: allocok, LP, MPG LOGICAL :: LPOK, PROKG INTEGER, DIMENSION(:), ALLOCATABLE :: MAPCOL LOGICAL :: MAPCOLonLUMAT, MAPCOL_IN_NSTEPS INTEGER OPTION PARAMETER (OPTION=2) LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. MYID .eq. MASTER ) MAPCOLonLUMAT = .FALSE. MAPCOL_IN_NSTEPS = .FALSE. IF (KEEP(14).EQ.1) THEN CALL MUMPS_ABORT() ENDIF IF (KEEP(14).EQ.0) THEN CALL MPI_BCAST( DOF2BLOCK, NDOF, MPI_INTEGER, MASTER, & COMM, IERR ) ENDIF CALL MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ALLOCATE(MAPCOL(NBLK), STAT=allocok) IF (allocok.NE.0) THEN INFO(1) = -7 INFO(2) = NBLK IF ( LPOK ) THEN WRITE(LP, *) " ERROR allocate MAPCOL of size", & INFO(2) END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (.NOT.MAPCOLonLUMAT) THEN CALL MUMPS_AB_COL_DISTRIBUTION (OPTION, & INFO, ICNTL, COMM, NBLK, MYID, NPROCS, & LMAT, MAPCOL) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF CALL MUMPS_AB_BUILD_DCLEAN_LUMATRIX ( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, NBLK, & IDUMMY_ARRAY, 1, & LUMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) CALL MUMPS_AB_LMAT_TO_CLEAN_G ( MYID, .FALSE., & READY_FOR_ANA_F, & LUMAT, GCOMP, INFO, ICNTL & ) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (KEEP(494).EQ.0) THEN CALL MUMPS_AB_FREE_LMAT(LUMAT) ENDIF GOTO 600 500 CONTINUE IF (allocated(MAPCOL)) DEALLOCATE(MAPCOL) CALL MUMPS_AB_FREE_LMAT(LMAT) CALL MUMPS_AB_FREE_LMAT(LUMAT) 600 CONTINUE RETURN END SUBROUTINE MUMPS_AB_DCOORD_TO_DCOMPG SUBROUTINE MUMPS_AB_DCOORD_TO_DTREE_LUMAT ( & MYID, NPROCS, COMM, & NBLK, NDOF, NNZ, & IRN, JCN, & PROCNODE_STEPS, NSTEPS, STEP, & ICNTL, INFO, KEEP, & MAPCOL, LUMAT) USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T, COMPACT_GRAPH_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER, INTENT(IN) :: MYID, NPROCS, NBLK, NDOF, NSTEPS INTEGER(8), INTENT(IN) :: NNZ INTEGER, INTENT(IN) :: IRN(max(1_8,NNZ)), JCN(max(1_8,NNZ)) INTEGER, INTENT(IN) :: ICNTL(60), COMM INTEGER, INTENT(IN) :: PROCNODE_STEPS(NSTEPS) INTEGER, INTENT(IN) :: STEP(NBLK) INTEGER, INTENT(INOUT) :: KEEP(500), INFO(80) INTEGER, INTENT(OUT) :: MAPCOL(NSTEPS) TYPE(LMATRIX_T) :: LUMAT INTEGER, DIMENSION(:), allocatable:: DOF2BLOCK TYPE(LMATRIX_T) :: LMAT INTEGER :: allocok, LP LOGICAL :: LPOK INTEGER :: IDOF, ISTEP LOGICAL :: MAPCOL_IN_NSTEPS, MAPCOLonLUMAT INTEGER OPTION PARAMETER (OPTION=2) INTEGER MUMPS_PROCNODE LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MAPCOLonLUMAT = .FALSE. MAPCOL_IN_NSTEPS = .TRUE. IF (KEEP(14).EQ.1) THEN CALL MUMPS_ABORT() ENDIF allocate(DOF2BLOCK(NDOF), STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = NDOF IF ( LPOK ) WRITE(LP, 150) ' DOF2BLOCK' ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 DO IDOF=1, NDOF DOF2BLOCK(IDOF) = IDOF ENDDO CALL MUMPS_AB_COORD_TO_LMAT ( MYID, & NBLK, NDOF, NNZ, IRN, JCN, & DOF2BLOCK, & INFO(1), INFO(2), LP, LPOK, & LMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) IF (MYID.EQ.MASTER) THEN DO ISTEP=1, NSTEPS MAPCOL(ISTEP) = & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199)) ENDDO ENDIF CALL MPI_BCAST( MAPCOL(1), NSTEPS, MPI_INTEGER, & MASTER, COMM, IERR ) CALL MPI_BCAST( STEP(1), NBLK, MPI_INTEGER, & MASTER, COMM, IERR ) CALL MUMPS_AB_BUILD_DCLEAN_LUMATRIX( & MAPCOLonLUMAT, MAPCOL_IN_NSTEPS, & INFO, ICNTL, KEEP, COMM, MYID, NBLK, NPROCS, & LMAT, MAPCOL, NSTEPS, & STEP, NBLK, LUMAT) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 GOTO 600 500 CONTINUE IF (allocated(DOF2BLOCK)) DEALLOCATE(DOF2BLOCK) CALL MUMPS_AB_FREE_LMAT(LMAT) CALL MUMPS_AB_FREE_LMAT(LUMAT) 600 CONTINUE RETURN 150 FORMAT( & /' ** FAILURE IN MUMPS_AB_DCOORD_TO_DTREE_LUMAT, ', & ' DYNAMIC ALLOCATION OF ', & A30) END SUBROUTINE MUMPS_AB_DCOORD_TO_DTREE_LUMAT SUBROUTINE MUMPS_AB_DIST_LMAT_TO_LUMAT ( & UNFOLD, & MAPCOL_IN_NSTEPS, & INFO, ICNTL, COMM, MYID, NBLK, SLAVEF, & LMAT, MAPCOL, SIZEMAPCOL, STEP, SIZESTEP, & LUMAT, NBRECORDS, NSEND8, NLOCAL8 & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR, MASTER, MSGSOU PARAMETER (MASTER=0) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT(IN) :: UNFOLD, MAPCOL_IN_NSTEPS INTEGER, INTENT(IN) :: MYID, SLAVEF, NBLK INTEGER, INTENT(IN) :: SIZEMAPCOL, SIZESTEP INTEGER, INTENT(IN) :: ICNTL(60), COMM, NBRECORDS INTEGER :: INFO(80) TYPE(LMATRIX_T), INTENT(IN) :: LMAT INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(IN) :: STEP(SIZESTEP) TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER :: LP, MP, allocok INTEGER :: IB, JB, I, II, ISEND, JSEND, ITOSEND LOGICAL :: LPOK INTEGER :: NBTOSEND INTEGER END_MSG_2_RECV INTEGER KPROBE, FREQPROBE INTEGER, ALLOCATABLE, DIMENSION(:) :: PTLOC INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE INTEGER :: DEST LOGICAL :: FLAG LP = ICNTL( 1 ) MP = ICNTL( 2 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IF (UNFOLD) THEN NBTOSEND = 2 ELSE NBTOSEND = 1 ENDIF NSEND8 = 0_8 NLOCAL8 = 0_8 END_MSG_2_RECV = SLAVEF-1 ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -7 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -7 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -7 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -7 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -7 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( PTLOC( NBLK ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -7 INFO(2) = NBLK GOTO 20 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO DO I = 1, NBLK PTLOC(I) = 0 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) DO JB=1,NBLK IF ( LMAT%COL(JB)%NBINCOL.EQ.0) CYCLE DO II=1, LMAT%COL(JB)%NBINCOL KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, LMATDIST, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, LMATDIST, COMM, STATUS, IERR ) CALL MUMPS_AB_LMAT_TREAT_RECV_BUF( & MYID, BUFRECI(1), NBRECORDS, LUMAT, & NBLK, PTLOC(1), END_MSG_2_RECV & ) END IF END IF IB = LMAT%COL(JB)%IRN(II) DO ITOSEND=1,NBTOSEND IF (ITOSEND.EQ.1) THEN IF (MAPCOL_IN_NSTEPS) THEN DEST = MAPCOL(abs(STEP(JB))) ELSE DEST = MAPCOL(JB) ENDIF ISEND = IB JSEND = JB ELSE IF (MAPCOL_IN_NSTEPS) THEN DEST = MAPCOL(abs(STEP(IB))) ELSE DEST = MAPCOL(IB) ENDIF ISEND = JB JSEND = IB ENDIF IF (DEST.EQ.MYID) THEN LUMAT%COL(JSEND)%IRN(1+PTLOC(JSEND))= ISEND PTLOC(JSEND) = PTLOC(JSEND) + 1 NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 CALL MUMPS_AB_LMAT_FILL_BUFFER( & DEST, ISEND, JSEND, NBLK, & BUFI, BUFRECI, PTLOC, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV & ) ENDIF ENDDO ENDDO ENDDO DEST = -3 CALL MUMPS_AB_LMAT_FILL_BUFFER(DEST, ISEND, JSEND, & NBLK, BUFI, BUFRECI, PTLOC, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV & ) DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, LMATDIST, COMM, STATUS, IERR ) CALL MUMPS_AB_LMAT_TREAT_RECV_BUF( & MYID, BUFRECI(1), NBRECORDS, LUMAT, & NBLK, PTLOC(1), END_MSG_2_RECV & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) END IF END DO 100 CONTINUE IF (ALLOCATED(PTLOC)) DEALLOCATE( PTLOC ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN END SUBROUTINE MUMPS_AB_DIST_LMAT_TO_LUMAT SUBROUTINE MUMPS_AB_LMAT_TREAT_RECV_BUF ( & MYID, BUFI, NBRECORDS, LUMAT, & NBLK, PTLOC, END_MSG_2_RECV & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, INTENT(IN) :: NBLK, MYID, NBRECORDS INTEGER, INTENT(IN) :: BUFI( NBRECORDS * 2 + 1 ) INTEGER, INTENT(INOUT):: END_MSG_2_RECV, PTLOC(NBLK) TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT INTEGER :: IREC, NB_REC, IB, JB NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) RETURN DO IREC = 1, NB_REC IB = BUFI( IREC * 2 ) JB = BUFI( IREC * 2 + 1 ) LUMAT%COL(JB)%IRN(1+PTLOC(JB))= IB PTLOC(JB) = PTLOC(JB) + 1 ENDDO RETURN END SUBROUTINE MUMPS_AB_LMAT_TREAT_RECV_BUF SUBROUTINE MUMPS_AB_LMAT_FILL_BUFFER ( & DEST, ISEND, JSEND, NBLK, & BUFI, BUFRECI, PTLOC, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, & SEND_ACTIVE, LMAT, LUMAT, END_MSG_2_RECV & ) USE MUMPS_ANA_BLK_M, ONLY : LMATRIX_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: DEST, ISEND, JSEND, SLAVEF, COMM, MYID, & NBRECORDS, NBLK INTEGER, INTENT(INOUT) :: END_MSG_2_RECV, PTLOC(NBLK) TYPE(LMATRIX_T), INTENT(IN) :: LMAT TYPE(LMATRIX_T), INTENT(INOUT) :: LUMAT LOGICAL, INTENT(INOUT) :: SEND_ACTIVE(SLAVEF) INTEGER, INTENT(INOUT) :: IREQI(SLAVEF), IACT(SLAVEF) INTEGER, INTENT(INOUT) :: BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) INTEGER, INTENT(INOUT) :: BUFRECI( NBRECORDS * 2 + 1) INTEGER :: IBEG, IEND, ISLAVE, TAILLE_SEND_I, IREQ, MSGSOU, & NBREC, IERR LOGICAL :: FLAG IF ( DEST .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST + 1 IEND = DEST + 1 END IF DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQI( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, LMATDIST, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, LMATDIST, COMM, & STATUS, IERR ) CALL MUMPS_AB_LMAT_TREAT_RECV_BUF( & MYID, BUFRECI, NBRECORDS, LUMAT, & NBLK, PTLOC(1), END_MSG_2_RECV & ) END IF ELSE SEND_ACTIVE( ISLAVE ) = .FALSE. END IF END DO IF ( ISLAVE - 1 .ne. MYID ) THEN TAILLE_SEND_I = NBREC * 2 + 1 CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, LMATDIST, COMM, & IREQI( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. ELSE IF (NBREC.NE.0) THEN write(*,*) " Internal error in ", & " MUMPS_AB_LMAT_FILL_BUFFER " CALL MUMPS_ABORT() ENDIF END IF IACT( ISLAVE ) = 3 - IACT( ISLAVE ) BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 END IF IF ( DEST .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND END IF ENDDO RETURN END SUBROUTINE MUMPS_AB_LMAT_FILL_BUFFER SUBROUTINE MUMPS_AB_GATHER_GRAPH ( & ICNTL, KEEP, COMM, MYID, NPROCS, INFO, & GCOMP_DIST, GCOMP) USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) TYPE(COMPACT_GRAPH_T), INTENT(IN) :: GCOMP_DIST INTEGER, INTENT(IN) :: MYID, NPROCS, ICNTL(60), COMM, & KEEP(500) INTEGER, INTENT(INOUT) :: INFO(80) TYPE(COMPACT_GRAPH_T) :: GCOMP INTEGER :: NG, allocok, LP, MPG, I, J, K INTEGER :: INDX, NB_BLOCK_SENT, MAX_NBBLOCK_loc, NRECV, & BLOCKSIZE, SIZE_SENT, NB_BLOCKS, NBNONEMPTY, & FIRSTNONEMPTY, LASTNONEMPTY, NBBLOCK_loc INTEGER(4) :: IOVFLO INTEGER(8) :: NZG, NZG_CENT, I8, IBEG8, IEND8, & SIZEGCOMPALLOCATED LOGICAL :: LPOK, PROKG INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IQ INTEGER, ALLOCATABLE :: REQPTR(:) INTEGER(8), ALLOCATABLE :: GPTR(:), GPTR_cp(:) LP = ICNTL( 1 ) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MPG = ICNTL( 3 ) PROKG = ( MPG .GT. 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(ICNTL(4).GE.2)) IOVFLO = huge(IOVFLO) BLOCKSIZE = int(max(100000_8,int(IOVFLO,8)/200_8)) NZG = GCOMP_DIST%NZG NG = GCOMP_DIST%NG CALL MPI_REDUCE( NZG, NZG_CENT, 1, MPI_INTEGER8, & MPI_SUM, MASTER, COMM, IERR ) IF (MYID.EQ.MASTER) THEN GCOMP%NZG = NZG_CENT GCOMP%NG = NG SIZEGCOMPALLOCATED = NZG_CENT+int(NG,8)+1_8 GCOMP%SIZEADJALLOCATED = SIZEGCOMPALLOCATED ALLOCATE( GCOMP%ADJ(SIZEGCOMPALLOCATED), & GCOMP%IPE(NG+1), & GPTR( NPROCS ), & GPTR_cp( NPROCS ), & REQPTR( NPROCS-1 ), & IQ(NG+1),STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR( & NZG_CENT + 3_8*int(NG,8)+3_8+3_8*int(NPROCS,8)-1_8, & INFO(2)) IF ( LPOK ) & WRITE(LP, *) " ERROR allocating graph in", & " MUMPS_AB_GATHER_GRAPH" ENDIF ELSE ALLOCATE( IQ(NG+1), STAT=allocok) IF (allocok.NE.0) THEN INFO( 1 ) = -7 INFO( 2 ) = NG+1 IF ( LPOK ) & WRITE(LP, *) " ERROR allocating pointers", & " MUMPS_AB_GATHER_GRAPH" END IF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1).LT.0) GOTO 500 FIRSTNONEMPTY = 0 LASTNONEMPTY = -1 DO I=1,NG IQ(I) = int(GCOMP_DIST%IPE(I+1)-GCOMP_DIST%IPE(I)) IF (IQ(I).NE.0) THEN IF (FIRSTNONEMPTY.EQ.0) FIRSTNONEMPTY=I LASTNONEMPTY = I ENDIF ENDDO NBNONEMPTY = LASTNONEMPTY-FIRSTNONEMPTY+1 IF (MYID.EQ.MASTER) THEN DO J=1, NG GCOMP%IPE(J) = 0 ENDDO J=FIRSTNONEMPTY IF (NBNONEMPTY.GT.0) THEN DO I=FIRSTNONEMPTY, LASTNONEMPTY GCOMP%IPE(J) = IQ(I) J = J+1 ENDDO ENDIF DO I = 1, NPROCS - 1 CALL MPI_RECV( NBNONEMPTY, 1, & MPI_INTEGER, I, & GATHERG_NB, COMM, STATUS, IERR ) IF (NBNONEMPTY.GT.0) THEN CALL MPI_RECV( J, 1, & MPI_INTEGER, I, & GATHERG_FIRST, COMM, STATUS, IERR ) CALL MPI_RECV( GCOMP%IPE(J), NBNONEMPTY, & MPI_INTEGER8, I, & GATHERG_IPE, COMM, STATUS, IERR ) ENDIF ENDDO ELSE CALL MPI_SEND( NBNONEMPTY, 1, MPI_INTEGER, MASTER, & GATHERG_NB, COMM, IERR ) IF (NBNONEMPTY.GT.0) THEN CALL MPI_SEND( FIRSTNONEMPTY, 1, MPI_INTEGER, MASTER, & GATHERG_FIRST, COMM, IERR ) CALL MPI_SEND( IQ(FIRSTNONEMPTY), NBNONEMPTY, & MPI_INTEGER8, MASTER, & GATHERG_IPE, COMM, IERR ) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IQ(1) = 1_8 DO I=1,NG IQ(I+1) = IQ(I) + GCOMP%IPE(I) GCOMP%IPE(I) = IQ(I) ENDDO GCOMP%IPE(NG+1) = IQ(NG+1) DEALLOCATE(IQ) ELSE DEALLOCATE(IQ) ENDIF IF (MYID.EQ.MASTER) THEN NB_BLOCK_SENT = 0 MAX_NBBLOCK_loc = 0 DO I = 1, NPROCS - 1 CALL MPI_RECV( GPTR( I+1 ), 1, & MPI_INTEGER8, I, & GATHERG_NZG, COMM, STATUS, IERR ) NBBLOCK_loc = ceiling(dble(GPTR(I+1))/dble(BLOCKSIZE)) MAX_NBBLOCK_loc = max(MAX_NBBLOCK_loc, NBBLOCK_loc) NB_BLOCK_SENT = NB_BLOCK_SENT + NBBLOCK_loc ENDDO GPTR( 1 ) = NZG + 1_8 DO I = 2, NPROCS GPTR( I ) = GPTR( I ) + GPTR( I-1 ) END DO ELSE CALL MPI_SEND( NZG, 1, MPI_INTEGER8, MASTER, & GATHERG_NZG, COMM, IERR ) ENDIF IF (MYID.EQ.MASTER) THEN DO I=1, NPROCS GPTR_cp(I) = GPTR(I) ENDDO IF (NZG.GT.0_8) THEN DO I8=1, NZG GCOMP%ADJ(I8) = GCOMP_DIST%ADJ(I8) ENDDO ENDIF NB_BLOCKS = 0 DO K = 1, MAX_NBBLOCK_loc NRECV = 0 DO I = 1, NPROCS - 1 IBEG8 = GPTR_cp( I ) IF ( IBEG8 .LT. GPTR(I+1)) THEN NRECV = NRECV + 1 IEND8 = min(IBEG8+int(BLOCKSIZE,8)-1_8, & GPTR(I+1)-1_8) GPTR_cp( I ) = IEND8 + 1_8 SIZE_SENT = int(IEND8 - IBEG8 + 1_8) NB_BLOCKS = NB_BLOCKS + 1 CALL MPI_IRECV( GCOMP%ADJ(IBEG8), SIZE_SENT, & MPI_INTEGER, & I, GATHERG_ADJ, COMM, REQPTR(I), IERR ) ELSE REQPTR( I ) = MPI_REQUEST_NULL ENDIF END DO DO I = 1, NRECV CALL MPI_WAITANY & ( NPROCS-1, REQPTR, INDX, & STATUS, IERR ) ENDDO END DO DEALLOCATE( REQPTR ) DEALLOCATE( GPTR ) DEALLOCATE( GPTR_cp ) ELSE IF (NZG.EQ.0) GOTO 600 DO I8=1_8, NZG, int(BLOCKSIZE,8) SIZE_SENT = BLOCKSIZE IF (NZG-I8+1_8.LT.int(BLOCKSIZE,8)) THEN SIZE_SENT = int(NZG-I8+1_8) ENDIF CALL MPI_SEND( & GCOMP_DIST%ADJ(I8), SIZE_SENT, & MPI_INTEGER, MASTER, & GATHERG_ADJ, COMM, IERR ) ENDDO ENDIF GOTO 600 500 CONTINUE IF (MYID.EQ.MASTER) THEN IF (associated(GCOMP%ADJ)) THEN DEALLOCATE(GCOMP%ADJ) nullify(GCOMP%ADJ) ENDIF IF (associated(GCOMP%IPE)) THEN DEALLOCATE(GCOMP%IPE) nullify(GCOMP%IPE) ENDIF ENDIF 600 CONTINUE IF (allocated(IQ)) DEALLOCATE(IQ) RETURN END SUBROUTINE MUMPS_AB_GATHER_GRAPH MUMPS_5.4.1/src/zmumps_config_file.F0000664000175000017500000000103314102210525017470 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_CONFIG_FILE_RETURN() RETURN END SUBROUTINE ZMUMPS_CONFIG_FILE_RETURN MUMPS_5.4.1/src/mumps_size.h0000664000175000017500000000143114102210474016053 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SIZE_H #define MUMPS_SIZE_H #include "mumps_common.h" #include "mumps_c_types.h" #define MUMPS_SIZE_C \ F_SYMBOL(size_c, SIZE_C) void MUMPS_CALL MUMPS_SIZE_C(char *a, char *b, MUMPS_INT8 *diff); #define MUMPS_ADDR_C \ F_SYMBOL(addr_c, ADDR_C) void MUMPS_CALL MUMPS_ADDR_C(char *a, MUMPS_INT8 *addr); #endif MUMPS_5.4.1/src/dfac_lastrtnelind.F0000664000175000017500000001766314102210522017306 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL DMUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'DMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL DMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL DMUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'DMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ELSE CALL DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL DMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL DMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_LAST_RTNELIND MUMPS_5.4.1/src/dsol_bwd_aux.F0000664000175000017500000020631614102210522016273 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE DMUMPS_OOC USE DMUMPS_BUF USE DMUMPS_SOL_LR, only : DMUMPS_SOL_BWD_LR_SU INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION :: A(LA), W(LWC) DOUBLE PRECISION :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR = 0_8 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) CALL DMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 DMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR = PTRACB(STEP( INODE )) - 1_8 CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL DMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL DMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) ELSE IPOSINRHSCOMP = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB_PANEL = PTWCB + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL DMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL dgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE CALL dtrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ELSE CALL dtrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL DMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL dgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL dgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL dgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSCOMP,8) & + int(IPOSINRHSCOMP,8) CALL DMUMPS_SOLVE_BWD_TRSOLVE( A(1), LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSCOMP(1,1), KEEP8(25), LRHSCOMP, PPIV_COURANT, & MTYPE, KEEP) ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL DMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE )) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL DMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE DMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC DOUBLE PRECISION W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL DMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE DMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE DMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE DMUMPS_OOC USE DMUMPS_SOL_LR, ONLY: DMUMPS_SOL_SLAVE_LR_U, & DMUMPS_SOL_BWD_LR_SU USE DMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC DOUBLE PRECISION W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG DOUBLE PRECISION ZERO, ALPHA, ONE PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL DMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_DOUBLE_PRECISION, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSCOMP = abs( POSINRHSCOMP_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF ( (IPOSINRHSCOMP.EQ.0) .OR. & ( IPOSINRHSCOMP.GT.N ) ) CYCLE RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_DOUBLE_PRECISION, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL DMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL DMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL DMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_DOUBLE_PRECISION, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN CALL DMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( LIELL*NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 260 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 260 END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - LIELL*NRHS_B PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTRACB(STEP(INODE))+NPIV-1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR8 = IFR8 + J2-KEEP(253)-J1+1 IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, & NROW_L, NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL=NPANELS,1,-1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) PTWCB_PANEL = PTRACB(STEP(INODE)) + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL DMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL dgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL dgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF CALL dtrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL dgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+NPIV ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF CALL dtrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL DMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(1) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NRHS_B == 1 ) THEN CALL dgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE CALL dgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE #endif CALL dtrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(IPOS)) IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL DMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IN))) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, KEEP, & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL DMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE DMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE DMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in DMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE DMUMPS_BUILD_PANEL_POS MUMPS_5.4.1/src/zfac_sispointers_m.F0000664000175000017500000000152214102210526017516 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C ZMUMPS_FAC_DRIVER and ZMUMPS_FAC_B C ---------------------------------- TYPE S_IS_POINTERS_T COMPLEX(kind=8), POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE S_IS_POINTERS_T END MODULE ZMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.4.1/src/zana_aux.F0000664000175000017500000041202614102210524015426 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) DOUBLE PRECISION :: CNTL4 DOUBLE PRECISION, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED, WEIGHTREQUESTED LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB EXTERNAL MUMPS_ANA_H, ZMUMPS_ANA_J, & ZMUMPS_ANA_K, ZMUMPS_ANA_GNEW, & ZMUMPS_ANA_LNEW, ZMUMPS_ANA_M #if defined(OLDDFS) EXTERNAL ZMUMPS_ANA_L #endif EXTERNAL ZMUMPS_GNEW_SCHUR EXTERNAL ZMUMPS_LDLT_COMPRESS, ZMUMPS_EXPAND_PERMUTATION, & ZMUMPS_SET_CONSTRAINTS IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF ( (LIWALLOC.EQ.0_8).AND.(.not.GCOMP_PROVIDED)) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.2) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL ZMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: ZMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0D0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF IF (PROK) & WRITE(MP,*) 'Setting static pivoting ON, COMPRESS =', & COMPRESS ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL ZMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL ZMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL ZMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, & WEIGHTUSED, WEIGHTREQUESTED) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL ZMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL ZMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL ZMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL ZMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.3) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL ZMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF (KEEP(106).EQ.3.AND.KEEP(60).EQ.0) THEN ELSE ALLOCATE( WTEMP ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF ELSE CALL ZMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL ZMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) IF (KEEP(60) .EQ. 0) THEN IF (KEEP(60) .EQ. 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF ENDIF ENDIF #if defined(OLDDFS) CALL ZMUMPS_ANA_L & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ, INFO(6), FILS(1), FRERE(1), PTRAR(1,3), & NEMIN, KEEP(60)) #else IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (present(SIZEOFBLOCKS)) THEN CALL ZMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .TRUE. , SIZEOFBLOCKS, N & ) ELSE CALL ZMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .FALSE., IDUMMY, LIDUMMY ) ENDIF DEALLOCATE(WTEMP) #endif IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL ZMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL ZMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) THEN KEEP(210)=0 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) THEN KEEP(210)=1 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) THEN KEEP(210)=2 ENDIF IF (KEEP(210).EQ.2) THEN KEEP8(79)=huge(KEEP8(79)) ENDIF IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL ZMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 INFO(1) = -4 INFO(2) = K GOTO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE ZMUMPS_ANA_F SUBROUTINE ZMUMPS_ANA_N_DIST( id, PTRAR ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(ZMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER(8), POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => PTRAR(id%N+1:id%N+id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N) IWORK2 => PTRAR(id%N+1:id%N+id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1_8 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1_8 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1_8 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1_8 END IF ENDIF ENDIF 70 CONTINUE END IF IF (id%KEEP(54) .EQ. 3) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(id%N+1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR(1), 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE ZMUMPS_ANA_N_DIST SUBROUTINE ZMUMPS_ANA_O( N, NZ, MTRANS, PERM, IKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN COMPLEX(kind=8), POINTER, DIMENSION(:) :: idA DOUBLE PRECISION, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER, TARGET :: IKEEPALLOC(3*N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) DOUBLE PRECISION CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT DOUBLE PRECISION THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK DOUBLE PRECISION ZERO,TWO,ONE PARAMETER(ZERO = 0.0D0,TWO = 2.0D0,ONE = 1.0D0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) ) THEN MTRANS = 0 KEEP(95) =1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS=0 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(N+1:2*N) CALL ZMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*KEEP(10) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8*N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8*N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2*N+1:3*N) IF(MTRANSLOC.NE.1) THEN CALL ZMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL ZMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL ZMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) GO TO 400 IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC(N+1:2*N) FLAG => IKEEPALLOC(2*N+1:3*N) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL ZMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in ZMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in ZMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE ZMUMPS_ANA_O END MODULE ZMUMPS_ANA_AUX_M SUBROUTINE ZMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL ZMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_K SUBROUTINE ZMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max0(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM ZMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE ZMUMPS_ANA_J SUBROUTINE ZMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE ZMUMPS_ANA_D #if defined(OLDDFS) SUBROUTINE ZMUMPS_ANA_L(N, IPE, NV, IPS, NE, NA, NFSIZ, & NSTEPS, & FILS, FRERE,NDD,NEMIN, KEEP60) INTEGER N,NSTEPS INTEGER NDD(N) INTEGER FILS(N), FRERE(N) INTEGER IPS(N), NE(N), NA(N), NFSIZ(N) INTEGER IPE(N), NV(N) INTEGER NEMIN, KEEP60 INTEGER I,IF,IS,NR,NR1,INS,INL,INB,INF,INFS,INSW INTEGER K,L,ISON,IN,INP,IFSON,INC,INO INTEGER INOS,IB,IL DO 10 I=1,N IPS(I) = 0 NE(I) = 0 10 CONTINUE DO 20 I=1,N IF (NV(I).GT.0) GO TO 20 IF = -IPE(I) IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I 20 CONTINUE NR = N + 1 DO 50 I=1,N IF (NV(I).LE.0) GO TO 50 IF = -IPE(I) IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF 50 CONTINUE DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (IPE(INS).LT.0) THEN INS = -IPE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (IPE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = IPE(INS) IF (NV(INB).EQ.0) THEN INS = INB GO TO 1070 ENDIF IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = IPE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB IPE(INS) = IPE(INB) IPE(INB) = INS INS = INB GO TO 1070 ENDIF INSW = INFS 1100 INFS = IPE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF IPE(INS) = IPE(INB) IPE(INB) = INS IPE(INSW)= INB INS =INB GO TO 1070 1151 CONTINUE DO 51 I=1,N FRERE(I) = IPE(I) FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IL = 0 DO 160 K=1,N IF (I.GT.0) GO TO 60 I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 60 DO 70 L=1,N IF (IPS(I).GE.0) GO TO 80 ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE 80 IPS(I) = K NE(IS) = NE(IS) + 1 IF (NV(I).GT.0) GO TO 89 IN = I 81 IN = FRERE(IN) IF (IN.GT.0) GO TO 81 IF = -IN IN = IF 82 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 82 IFSON = -IN FILS(INL) = I IN = I 83 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 83 IF (IFSON .EQ. I) GO TO 86 FILS(INP) = -IFSON IN = IFSON 84 INC =IN IN = FRERE(IN) IF (IN.NE.I) GO TO 84 FRERE(INC) = FRERE(I) GO TO 120 86 IF (FRERE(I).LT.0) FILS(INP) = 0 IF (FRERE(I).GT.0) FILS(INP) = -FRERE(I) GO TO 120 89 IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) NDD(IS) = NV(I) NFSIZ(I) = NV(I) IF (NA(IS).LT.1) GO TO 110 IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.NDD(IS)) ) GOTO 110 IF (NDD(IS-1)-NE(IS-1).EQ.NDD(IS)) GO TO 100 IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(NDD(IS)-NDD(IS-1)+NE(IS-1)).GE. & ((NDD(IS)+NE(IS-1))* & (NDD(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 NDD(IS-1) = NDD(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 IN=I 101 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 101 IFSON = -IN IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 FILS(INL) = INO NFSIZ(I) = NDD(IS-1) IN = INO 103 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 103 INOS = -IN IF (IFSON.EQ.INO) GO TO 107 IN = IFSON FILS(INP) = -IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) FRERE(INS) = -I IF (INOS.NE.0) FRERE(INS) = INOS IF (INOS.EQ.0) GO TO 109 107 IN = INOS IF (IN.EQ.0) GO TO 109 108 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -I 109 CONTINUE GO TO 120 110 IS = IS + 1 120 IB = IPE(I) IF (IB.LT.0) GOTO 150 IF (IB.EQ.0) GOTO 140 NA(IL) = 0 140 I = IB GO TO 160 150 I = -IB IL = IL + 1 160 CONTINUE NSTEPS = IS - 1 DO 170 I=1,N K = FILS(I) IF (K.GT.0) THEN FRERE(K) = N + 1 NFSIZ(K) = 0 ENDIF 170 CONTINUE RETURN END SUBROUTINE ZMUMPS_ANA_L #else SUBROUTINE ZMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 ENDIF DO 70 L=1,N IF (IPS(I).GE.0) EXIT ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE #if ! defined(NOAMALGTOFATHER) DADI = -IPE(I) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF IF ( (NV(I).GT. 50*NV(DADI)).AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. 0.2 ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & NODE(I) * 900 .LE. NV(DADI) - NAMALG(DADI)) THEN IF ( NAMALG(DADI) < (NV(DADI)-NAMALG(DADI))/50 ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_LNEW #endif SUBROUTINE ZMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE ZMUMPS_ANA_M SUBROUTINE ZMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ANA_R SUBROUTINE ZMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(80), ICNTL(60), INFOG(80) INTEGER(8) KEEP8(150) DOUBLE PRECISION RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN WRITE(MPG, 99992) INFO(1), INFO(2), & KEEP8(109), KEEP8(111), INFOG(4), & INFOG(5), KEEP(28), INFOG(32), INFOG(7), KEEP(23), & ICNTL(7), KEEP(12), & ICNTL(18), & KEEP(56), KEEP(61), RINFOG(1) IF (KEEP(95).GT.1) & WRITE(MPG, 99993) KEEP(95) IF (KEEP(54).GT.0) WRITE(MPG, 99994) KEEP(54) IF (KEEP(60).GT.0) WRITE(MPG, 99995) KEEP(60) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' Number of level 2 nodes =',I16/ & ' Number of split nodes =',I16/ & ' RINFOG(1) Operations during elimination (estim)=', & 1PD10.3) 99993 FORMAT(' Ordering compressed/constrained (ICNTL(12)) =',I16) 99994 FORMAT(' Distributed matrix entry format (ICNTL(18)) =',I16) 99995 FORMAT(' Effective Schur option (ICNTL(19)) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) END SUBROUTINE ZMUMPS_DIAG_ANA SUBROUTINE ZMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER NFRONT, K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( dble( NSLAVES - 1 ) ) & / log(2.0D0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) INODE = abs(IPOOL(1)) NFRONT = NFSIZ( INODE ) K79 = max( & int(NFRONT,8)*int(NFRONT,8)/(int(K82+1,8)*int(K82+1,8)), & 9_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL ZMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE ZMUMPS_CUTNODES RECURSIVE SUBROUTINE ZMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM DOUBLE PRECISION WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( dble(NSLAVESMAX-NSLAVESMIN)/dble(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667D0 * & dble(NPIV)*dble(NPIV)*dble(NPIV) + & dble(NPIV)*dble(NPIV)*dble(NCB) WK_SLAVE = dble( NPIV ) * dble( NCB ) * & ( 2.0D0 * dble(NFRONT) - dble(NPIV) ) & / dble(NSLAVES_ESTIM) ELSE WK_MASTER = dble(NPIV)*dble(NPIV)*dble(NPIV) / dble(3) WK_SLAVE = & (dble(NPIV)*dble(NCB)*dble(NFRONT)) & / dble(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( dble( 100 + STRAT ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ELSE IF ( dble( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL ZMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL ZMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE ZMUMPS_SPLIT_1NODE SUBROUTINE ZMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0D0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE ZMUMPS_ANA_GNEW SUBROUTINE ZMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE ZMUMPS_SET_K821_SURFACE SUBROUTINE ZMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) DOUBLE PRECISION :: A(LA) DOUBLE PRECISION :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K DOUBLE PRECISION :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) EXTERNAL ZMUMPS_MTRANSZ,ZMUMPS_MTRANSB,ZMUMPS_MTRANSR, & ZMUMPS_MTRANSS,ZMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/dble(2*N) RINF3 = 0.0D0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = int(4*N + M,8) IF (JOB.EQ.2) K = int(N + 2*M,8) IF (JOB.EQ.3) K = int(8*N + 2*M + NE,8) IF (JOB.EQ.4) K = int(N + M,8) IF (JOB.EQ.5) K = int(3*N + 2*M,8) IF (JOB.EQ.6) K = int(3*N + 2*M + NE,8) IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int( M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = int( 2*M,8) IF (JOB.EQ.5) K = int(N + 2*M,8) IF (JOB.EQ.6) K = int(N + 3*M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL ZMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL ZMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(N+1),IW(N+M+1),DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL ZMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL ZMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1), & IW(NE+N+1),IW(NE+2*N+1),IW(NE+3*N+1),IW(NE+4*N+1), & IW(NE+5*N+1),IW(NE+5*N+M+1),FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(M+N+N), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 INFOMUMPS(2) = M+N+N GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL ZMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3*N+2*M+K) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2*M+N+I) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2*M+N+I)) THEN DW(2*M+N+I) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2*M+N+I).NE.ZERO) THEN DW(2*M+N+I) = 1.0D0/DW(2*M+N+I) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2*M+N+I) * A(K) 65 CONTINUE 66 CONTINUE CALL ZMUMPS_MTRANSR(N,NE,IP,IW(3*N+2*M+1),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL ZMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL ZMUMPS_MTRANSW(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2*M+N+I).NE.0.0D0) THEN DW(I) = DW(I) + log(DW(2*M+N+I)) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2*M+J).NE.ZERO) THEN DW(M+J) = DW(M+J) - log(DW(2*M+J)) ELSE DW(M+J) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5D0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(M+J),J=1,min(10,N)) ENDIF ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,M) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,M) WRITE(ICNTL(3),9034) (DW(M+J),J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in ZMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from ZMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for ZMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for ZMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE ZMUMPS_MTRANS_DRIVER SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) DOUBLE PRECISION, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE ZMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE ZMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE ZMUMPS_SORT_PERM SUBROUTINE ZMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, LRGROUPS_OLD, LRGROUPS_NEW, & K20, K38 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(NBLK) INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(N) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20, K38 INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_EXPAND_TREE_STEPS SUBROUTINE ZMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) DOUBLE PRECISION PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE ZMUMPS_DIST_AVOID_COPIES SUBROUTINE ZMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE ZMUMPS_SET_PROCNODE MUMPS_5.4.1/src/mumps_metis_int.h0000664000175000017500000000132314102210474017074 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_METIS_INT_H #define MUMPS_METIS_INT_H #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #define MUMPS_METIS_IDXSIZE \ F_SYMBOL(metis_idxsize,METIS_IDXSIZE) void MUMPS_CALL MUMPS_METIS_IDXSIZE(MUMPS_INT *metis_idx_size); #endif MUMPS_5.4.1/src/dend_driver.F0000664000175000017500000003735114102210525016112 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_END_DRIVER( id ) USE DMUMPS_OOC USE DMUMPS_STRUC_DEF USE DMUMPS_BUF IMPLICIT NONE include 'mpif.h' TYPE( DMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR INTEGER MASTER PARAMETER ( MASTER = 0 ) C Explicit needed because of pointer arguments INTERFACE SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES END INTERFACE I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C ---------------------------------- C Special stuff for implementations C where MPI_CANCEL does not exist or C is not correctly implemented. C At the moment, this is only C required for the slaves. C ---------------------------------- IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL DMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. id%root%yes ) THEN CALL blacs_gridexit( id%root%CNTXT_BLACS ) id%root%gridinit_done = .FALSE. END IF END IF IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. (This was the case on the C old SP2 in Bonn.) CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF C ----------------------------------- C Right-hand-side is always user data C We do not free it. C ----------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C C C C --------------------------------- C Allocated by DMUMPS, Used by user. C DMUMPS deallocates. User should C use them before DMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) C C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C ------------------------------------------------ C For hybrid host and element entry, C and DBLARR have not been allocated C on the master except if there was scaing. C ------------------------------------------------ IF (id%KEEP(46).eq.1 .and. & id%KEEP(55).ne.0 .and. & id%MYID .eq. MASTER .and. & id%KEEP(52) .eq. 0 ) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF IF (associated(id%INTARR)) THEN DEALLOCATE(id%INTARR) NULLIFY(id%INTARR) ENDIF IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF C IPIV is used both for ScaLAPACK and RR C Keep it outside DMUMPS_RR_FREE_POINTERS IF (associated(id%root%IPIV)) THEN DEALLOCATE(id%root%IPIV) NULLIFY(id%root%IPIV) ENDIF IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(id%root%RHS_ROOT))THEN DEALLOCATE(id%root%RHS_ROOT) NULLIFY(id%root%RHS_ROOT) ENDIF CALL DMUMPS_RR_FREE_POINTERS(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C id%CANDIDATES,id%I_AM_CAND and id%ISTEP_TO_INIV2 C can be allocated on non-working master C in the case of arrowheads distribution IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF c IF (id%KEEP(201).GT.0) THEN IF(associated (id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated (id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated (id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated (id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF IF(associated (id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF c ENDIF ! IF(id%KEEP(486).NE.0) THEN IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF CALL DMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%MPITOOMP_PROCS_MAP)) THEN DEALLOCATE(id%MPITOOMP_PROCS_MAP) NULLIFY(id%MPITOOMP_PROCS_MAP) ENDIF IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C ---------------------------------------------- C Deallocate S only after finishing the receives C (S is normally the largest memory available) C ---------------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) DEALLOCATE(id%S) ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL DMUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL DMUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C Mapping information used during solve IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF RETURN END SUBROUTINE DMUMPS_END_DRIVER SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE DMUMPS_LR_DATA_M, only : DMUMPS_BLR_STRUC_TO_MOD, & DMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL DMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL DMUMPS_BLR_END_MODULE(0, KEEP8, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE DMUMPS_FREE_ID_DATA_MODULES MUMPS_5.4.1/src/cfac_lastrtnelind.F0000664000175000017500000001761414102210523017302 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, IROOT, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER IROOT INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER(8) :: LA INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND(KEEP(28)), FRERE(KEEP(28)) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, & IROW_SON, ICOL_SON, ISLAVE, IERR, & NELIM_SENT, IPOS_STATREC, TYPE_SON INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' NB_CONTRI_GLOBAL = KEEP(41) NUMORG = root%ROOT_SIZE NELIM = KEEP(42) NFRONT = NUMORG + KEEP(42) DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( PDEST .NE. MYID ) THEN CALL CMUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'CMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ENDIF END DO END DO CALL CMUMPS_PROCESS_ROOT2SLAVE( NFRONT, & NB_CONTRI_GLOBAL, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) IF (IFLAG < 0 ) RETURN HF = 6 + KEEP(IXSZ) IOLDPS = PTLUST_S(STEP(IROOT)) IN = IROOT DEB_ROW = IOLDPS + HF ILOC_ROW = DEB_ROW DO WHILE (IN.GT.0) IW(ILOC_ROW) = IN IW(ILOC_ROW+NFRONT) = IN ILOC_ROW = ILOC_ROW + 1 IN = FILS(IN) END DO IFSON = -IN ILOC_ROW = IOLDPS + HF + NUMORG ILOC_COL = ILOC_ROW + NFRONT IF ( NELIM.GT.0 ) THEN IN = IFSON DO WHILE (IN.GT.0) IPOS_SON = PIMASTER(STEP(IN)) IF (IPOS_SON .EQ. 0) GOTO 100 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) if (NELIM_SON.eq.0) then write(6,*) ' error 1 in process_last_rtnelind' CALL MUMPS_ABORT() endif NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) HS = 6 + NSLAVES_SON + KEEP(IXSZ) IROW_SON = IPOS_SON + HS ICOL_SON = IROW_SON + NELIM_SON DO I = 1, NELIM_SON IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) ENDDO DO I = 1, NELIM_SON IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) ENDDO NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 DO ISLAVE = 0,NSLAVES_SON IF (ISLAVE.EQ.0) THEN PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),KEEP(199)) ELSE PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) ENDIF IF (PDEST.NE.MYID) THEN CALL CMUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, & PDEST, COMM, KEEP, IERR ) if (IERR.lt.0) then write(6,*) ' error detected by ', & 'CMUMPS_BUF_SEND_ROOT2SLAVE' CALL MUMPS_ABORT() endif ELSE CALL CMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & IN, NELIM_SENT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( ISLAVE .NE. 0 ) THEN IF (KEEP(50) .EQ. 0) THEN IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) ELSE IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) ENDIF IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN IW(IPOS_STATREC) = S_ROOT2SON_CALLED ELSE IF (NSLAVES_SON .EQ. 0) THEN TYPE_SON = 1 ELSE TYPE_SON = 2 ENDIF CALL CMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) ENDIF ENDIF IPOS_SON = PIMASTER(STEP(IN)) ENDIF END DO CALL CMUMPS_FREE_BLOCK_CB_STATIC( & .FALSE., MYID, N, IPOS_SON, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) ILOC_ROW = ILOC_ROW + NELIM_SON ILOC_COL = ILOC_COL + NELIM_SON 100 CONTINUE IN = FRERE(STEP(IN)) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_LAST_RTNELIND MUMPS_5.4.1/src/cstatic_ptr_m.F0000664000175000017500000000205514102210523016447 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_STATIC_PTR_M PUBLIC :: CMUMPS_TMP_PTR, CMUMPS_GET_TMP_PTR COMPLEX, DIMENSION(:), POINTER, SAVE :: CMUMPS_TMP_PTR CONTAINS SUBROUTINE CMUMPS_SET_STATIC_PTR(ARRAY) COMPLEX, DIMENSION(:), TARGET :: ARRAY CMUMPS_TMP_PTR => ARRAY RETURN END SUBROUTINE CMUMPS_SET_STATIC_PTR SUBROUTINE CMUMPS_GET_TMP_PTR(PTR) #if defined(MUMPS_F2003) COMPLEX, DIMENSION(:), POINTER, INTENT(OUT) :: PTR #else COMPLEX, DIMENSION(:), POINTER :: PTR #endif PTR => CMUMPS_TMP_PTR RETURN END SUBROUTINE CMUMPS_GET_TMP_PTR END MODULE CMUMPS_STATIC_PTR_M MUMPS_5.4.1/src/dini_driver.F0000664000175000017500000002222214102210525016112 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_INI_DRIVER( id ) USE DMUMPS_STRUC_DEF C C Purpose: C ======= C C Initialize an instance of the DMUMPS package. C USE DMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL DMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) id%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is DMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in DMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in DMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C C Module needs to know the size of an INTEGER CALL DMUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) C This number, 18, corresponds to METIS_OPTIONS_NUMBERING which C tells METIS to use fortran numbering and is found in metis.h C In Metis 5.0.3 and Parmetis 4.0.2, METIS_OPTIONS_NUMBERING C was METIS_OPTIONS(17). MUMPS doesnot support those versions anymore. C To use them, just change METIS_OPTIONS(18) into METIS_OPTIONS(17) C like that: METIS_OPTIONS(17) = 1 id%METIS_OPTIONS(18) = 1 #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%INTARR) NULLIFY(id%DBLARR) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSCOMP) NULLIFY(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MPITOOMP_PROCS_MAP) C Must be nullified because of routine C DMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the root C NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_ROOT) NULLIFY(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_COL) NULLIFY(id%root%IPIV) NULLIFY(id%root%SCHUR_POINTER) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) CALL DMUMPS_RR_INIT_POINTERS(id) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C DMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF RETURN END SUBROUTINE DMUMPS_INI_DRIVER MUMPS_5.4.1/src/sana_aux_par.F0000664000175000017500000030335414102210521016261 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_PARALLEL_ANALYSIS USE SMUMPS_STRUC_DEF USE MUMPS_MEMORY_MOD USE MUMPS_ANA_ORD_WRAPPERS INCLUDE 'mpif.h' PUBLIC SMUMPS_ANA_F_PAR INTERFACE SMUMPS_ANA_F_PAR MODULE PROCEDURE SMUMPS_ANA_F_PAR END INTERFACE PRIVATE TYPE ORD_TYPE INTEGER :: CBLKNBR, N INTEGER, POINTER :: PERMTAB(:) => null() INTEGER, POINTER :: PERITAB(:) => null() INTEGER, POINTER :: RANGTAB(:) => null() INTEGER, POINTER :: TREETAB(:) => null() INTEGER, POINTER :: BROTHER(:) => null() INTEGER, POINTER :: SON(:) => null() INTEGER, POINTER :: NW(:) => null() INTEGER, POINTER :: FIRST(:) => null() INTEGER, POINTER :: LAST(:) => null() INTEGER, POINTER :: TOPNODES(:) => null() INTEGER :: COMM, COMM_NODES, NPROCS, NSLAVES, MYID INTEGER :: TOPSTRAT, SUBSTRAT, ORDTOOL, TOPVARS LOGICAL :: IDO END TYPE ORD_TYPE TYPE GRAPH_TYPE INTEGER(8) :: NZ_LOC INTEGER :: N, COMM INTEGER, POINTER :: IRN_LOC(:) => null() INTEGER, POINTER :: JCN_LOC(:) => null() END TYPE GRAPH_TYPE TYPE ARRPNT INTEGER, POINTER :: BUF(:) => null() END TYPE ARRPNT INTEGER :: MP, MPG, LP, NRL, TOPROWS INTEGER(8) :: MEMCNT, MAXMEM LOGICAL :: PROK, PROKG, LPOK CONTAINS SUBROUTINE SMUMPS_ANA_F_PAR(id, WORK1, WORK2, NFSIZ, FILS, & FRERE) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER, TARGET :: WORK1(:), WORK2(:) INTEGER :: NFSIZ(:), FILS(:), FRERE(:) TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: IPE(:), NV(:), & NE(:), NA(:), NODE(:), & ND(:), SUBORD(:), NAMALG(:), & IPS(:), CUMUL(:), & SAVEIRN(:), SAVEJCN(:) INTEGER :: MYID, NPROCS, IERR, NEMIN, LDIAG LOGICAL :: SPLITROOT INTEGER(8), PARAMETER :: K79REF=12000000_8 INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) DOUBLE PRECISION :: TIMEB nullify(IPE, NV, NE, NA, NODE, ND, SUBORD, NAMALG, IPS, & CUMUL, SAVEIRN, SAVEJCN) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) LP = id%ICNTL(1) MP = id%ICNTL(2) MPG = id%ICNTL(3) PROK = (MP.GT.0) PROKG = (MPG.GT.0) .AND. (MYID .EQ. 0) LPOK = (LP.GT.0) .AND. (id%ICNTL(4).GE.1) LDIAG = id%ICNTL(4) ord%PERMTAB => WORK1(1 : id%N) ord%PERITAB => WORK1(id%N+1 : 2*id%N) ord%TREETAB => WORK1(2*id%N+1 : 3*id%N) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN SAVEIRN => id%IRN_loc SAVEJCN => id%JCN_loc id%IRN_loc => id%IRN id%JCN_loc => id%JCN id%KEEP8(29) = id%KEEP8(28) ELSE id%KEEP8(29)=0_8 END IF END IF MAXMEM=0 IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_SET_PAR_ORD(id, ord) id%INFOG(7) = id%KEEP(245) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF (PROKG) CALL MUMPS_SECDEB( TIMEB ) CALL SMUMPS_DO_PAR_ORD(id, ord, WORK2) IF (PROKG) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE(*,'(" ELAPSED time in parallel ordering =",F12.4)') & TIMEB ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF(id%MYID .EQ. 0) THEN CALL MUMPS_REALLOC(IPE, id%N, id%INFO, LP, FORCE=.FALSE., & COPY=.FALSE., STRING='', & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, id%N, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT END IF ord%SUBSTRAT = 0 ord%TOPSTRAT = 0 CALL SMUMPS_PARSYMFACT(id, ord, IPE, NV, WORK2) IF(id%KEEP(54) .NE. 3) THEN IF(MYID.EQ.0) THEN id%IRN_loc => SAVEIRN id%JCN_loc => SAVEJCN END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN NULLIFY(ord%PERMTAB) NULLIFY(ord%PERITAB) NULLIFY(ord%TREETAB) CALL MUMPS_IDEALLOC(ord%FIRST, ord%LAST, MEMCNT=MEMCNT) IF (MYID .EQ. 0) THEN IPS => WORK1(1:id%N) NE => WORK1(id%N+1 : 2*id%N) NA => WORK1(2*id%N+1 : 3*id%N) NODE => WORK2(1 : id%N ) ND => WORK2(id%N+1 : 2*id%N) SUBORD => WORK2(2*id%N+1 : 3*id%N) NAMALG => WORK2(3*id%N+1 : 4*id%N) CALL MUMPS_REALLOC(CUMUL, id%N, id%INFO, LP, & STRING='CUMUL', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT NEMIN = id%KEEP(1) CALL SMUMPS_ANA_LNEW(id%N, IPE(1), NV(1), IPS(1), NE(1), & NA(1), NFSIZ(1), NODE(1), id%INFOG(6), FILS(1), FRERE(1), & ND(1), NEMIN, SUBORD(1), id%KEEP(60), id%KEEP(20), & id%KEEP(38), NAMALG(1), id%KEEP(104), CUMUL(1), & id%KEEP(50), id%ICNTL(13), id%KEEP(37), id%NSLAVES, & id%KEEP(250).EQ.1, .FALSE., IDUMMY, LIDUMMY) CALL MUMPS_DEALLOC(CUMUL, NV, IPE, MEMCNT=MEMCNT) CALL SMUMPS_ANA_M(NE(1), ND(1), id%INFOG(6), id%INFOG(5), & id%KEEP(2), id%KEEP(50), id%KEEP8(101), id%KEEP(108), & id%KEEP(5), id%KEEP(6), id%KEEP(226), id%KEEP(253)) IF ( id%KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT(id%N, FRERE(1), FILS(1), NFSIZ(1), & id%KEEP(20)) END IF IF ( (id%KEEP(48) == 4 .AND. id%KEEP8(21).GT.0_8) & .OR. & (id%KEEP (48)==5 .AND. id%KEEP8(21) .GT. 0_8 ) & .OR. & (id%KEEP(24).NE.0.AND.id%KEEP8(21).GT.0_8) ) THEN CALL SMUMPS_SET_K821_SURFACE(id%KEEP8(21), id%KEEP(2), & id%KEEP(48), id%KEEP(50), id%NSLAVES) END IF IF ((id%KEEP(210).LT.0) .OR. (id%KEEP(210).GT.2)) & id%KEEP(210)=0 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).GT.0)) & id%KEEP(210)=1 IF ((id%KEEP(210).EQ.0) .AND. (id%KEEP(201).EQ.0)) & id%KEEP(210)=2 IF (id%KEEP(210).EQ.2) id%KEEP8(79)=huge(id%KEEP8(79)) IF ((id%KEEP(210).EQ.1) .AND. (id%KEEP8(79).LE.0_8)) THEN id%KEEP8(79)=K79REF * int(id%NSLAVES,8) ENDIF IF ( (id%KEEP(79).EQ.0).OR.(id%KEEP(79).EQ.2).OR. & (id%KEEP(79).EQ.3).OR.(id%KEEP(79).EQ.5).OR. & (id%KEEP(79).EQ.6) & ) THEN IF (id%KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( id%KEEP(62).GE.1) THEN IDUMMY(1) = -1 CALL SMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), & NFSIZ(1), IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), SPLITROOT, & MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF ENDIF ENDIF SPLITROOT = (((id%ICNTL(13).GT.0) .AND. & (id%NSLAVES.GT.id%ICNTL(13))) .OR. & (id%ICNTL(13).EQ.-1)) .AND. (id%KEEP(60).EQ.0) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL SMUMPS_CUTNODES(id%N, FRERE(1), FILS(1), NFSIZ(1), & IDUMMY, LIDUMMY, id%INFOG(6), & id%NSLAVES, id%KEEP(1), id%KEEP8(1), & SPLITROOT, MP, LDIAG, id%INFOG(1), id%INFOG(2)) IF (id%INFOG(1).LT.0) RETURN ENDIF END IF RETURN END SUBROUTINE SMUMPS_ANA_F_PAR SUBROUTINE SMUMPS_SET_PAR_ORD(id, ord) TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: IERR #if defined(parmetis) || defined(parmetis3) INTEGER :: I, COLOR, BASE, WORKERS LOGICAL :: IDO #endif IF(id%MYID .EQ. 0) id%KEEP(245) = id%ICNTL(29) CALL MPI_BCAST( id%KEEP(245), 1, & MPI_INTEGER, 0, id%COMM, IERR ) IF ((id%KEEP(245) .LT. 0) .OR. (id%KEEP(245) .GT. 2)) THEN id%KEEP(245) = 0 END IF IF (id%KEEP(245) .EQ. 0) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) id%KEEP(245) = 1 IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to PT-SCOTCH.")') RETURN #endif #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, & ord%COMM_NODES, IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '("Parallel ordering tool set to ParMETIS.")') id%KEEP(245) = 2 RETURN #endif id%INFO(1) = -38 id%INFOG(1) = -38 IF(id%MYID .EQ.0 ) THEN WRITE(LP, & '("No parallel ordering tools available.")') WRITE(LP, & '("Please install PT-SCOTCH or ParMETIS.")') END IF RETURN ELSE IF (id%KEEP(245) .EQ. 1) THEN #if defined(ptscotch) IF(id%NSLAVES .LT. 2) THEN IF(PROKG) WRITE(MPG,'("Warning: older versions &of PT-SCOTCH require at least 2 processors.")') END IF ord%ORDTOOL = 1 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%COMM = id%COMM ord%COMM_NODES = id%COMM_NODES ord%NPROCS = id%NPROCS ord%NSLAVES = id%NSLAVES ord%MYID = id%MYID ord%IDO = (id%MYID .GE. 1) .OR. (id%KEEP(46) .EQ. 1) IF(PROKG) WRITE(MPG, & '(" Using PT-SCOTCH for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" PT-SCOTCH not available")') RETURN #endif ELSE IF (id%KEEP(245) .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) IF(id%N.LE.100) THEN WORKERS = 2 ELSE WORKERS = min(id%NSLAVES,id%N/16) END IF I=1 DO IF (I .GT. WORKERS) EXIT ord%NSLAVES = I I = I*2 END DO BASE = id%NPROCS-id%NSLAVES ord%NPROCS = ord%NSLAVES + BASE IDO = (id%MYID .GE. BASE) .AND. & (id%MYID .LE. BASE+ord%NSLAVES-1) ord%IDO = IDO IF ( IDO ) THEN COLOR = 1 ELSE COLOR = MPI_UNDEFINED END IF CALL MPI_COMM_SPLIT( id%COMM, COLOR, 0, ord%COMM_NODES, & IERR ) ord%ORDTOOL = 2 ord%TOPSTRAT = 0 ord%SUBSTRAT = 0 ord%MYID = id%MYID IF(PROKG) WRITE(MPG, & '(" Using ParMETIS for parallel ordering")') RETURN #else id%INFOG(1) = -38 id%INFO(1) = -38 IF(id%MYID .EQ.0 ) WRITE(LP, & '(" ParMETIS not available.")') RETURN #endif END IF END SUBROUTINE SMUMPS_SET_PAR_ORD SUBROUTINE SMUMPS_DO_PAR_ORD(id, ord, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: WORK(:) #if defined(parmetis) || defined(parmetis3) INTEGER :: IERR #endif IF (ord%ORDTOOL .EQ. 1) THEN #if defined(ptscotch) CALL SMUMPS_PTSCOTCH_ORD(id, ord, WORK) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'PT-SCOTCH not available. Aborting...' CALL MUMPS_ABORT() #endif ELSE IF (ord%ORDTOOL .EQ. 2) THEN #if defined(parmetis) || defined(parmetis3) CALL SMUMPS_PARMETIS_ORD(id, ord, WORK) if(ord%IDO) CALL MPI_COMM_FREE(ord%COMM_NODES, IERR) #else id%INFOG(1) = -38 id%INFO(1) = -38 WRITE(LP,*)'ParMETIS not available. Aborting...' CALL MUMPS_ABORT() #endif END IF RETURN END SUBROUTINE SMUMPS_DO_PAR_ORD #if defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_PARMETIS_ORD(id, ord, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: I, MYID, NPROCS, IERR, BASE, METIS_IDX_SIZE INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & OPTIONS(10) INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:), RCVCNTS(:) INTEGER(8) :: EDGELOCNBR INTEGER, POINTER :: SIZES(:), ORDER(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB, RCVCNTS, & SIZES, ORDER) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IERR=0 IF(size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_PARMETIS_ORD")') CALL MUMPS_ABORT() END IF IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT BASEVAL = 1 BASE = id%NPROCS-id%NSLAVES CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL SMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 OPTIONS(:) = 0 ORDER => WORK(1:id%N) CALL MUMPS_REALLOC(SIZES, 2*ord%NSLAVES, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 1 ELSE CALL MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ENDIF ELSE IF (METIS_IDX_SIZE.EQ.64) THEN CALL MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, ord%COMM_NODES, IERR) ELSE WRITE(*,*) & "Internal error in PARMETIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() END IF END IF CALL MUMPS_IDEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(VERTLOCTAB) IF(IERR.GT.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 20 CALL MPI_BCAST(SIZES(1), 2*ord%NSLAVES, MPI_INTEGER, & BASE, id%COMM, IERR) ord%CBLKNBR = 2*ord%NSLAVES-1 CALL MUMPS_REALLOC(RCVCNTS, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, id%NPROCS RCVCNTS(I) = max(LAST(I)-FIRST(I)+1,0) END DO FIRST = FIRST-1 IF(FIRST(1) .LT. 0) THEN FIRST(1) = 0 END IF CALL MPI_ALLGATHERV ( ORDER(1), VERTLOCNBR, MPI_INTEGER, & ord%PERMTAB(1), & RCVCNTS(1), FIRST(1), MPI_INTEGER, id%COMM, IERR ) DO I=1, id%N ord%PERITAB(ord%PERMTAB(I)) = I END DO CALL MUMPS_REALLOC(ord%RANGTAB, 2*ord%NSLAVES, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_BUILD_TREETAB(ord%TREETAB, ord%RANGTAB, & SIZES, ord%CBLKNBR) CALL MUMPS_DEALLOC(SIZES, FIRST, LAST, & RCVCNTS, MEMCNT=MEMCNT) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_BUILD_TREE(ord) ord%N = id%N ord%COMM = id%COMM RETURN 20 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(SIZES , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE SMUMPS_PARMETIS_ORD #endif #if defined(ptscotch) SUBROUTINE SMUMPS_PTSCOTCH_ORD(id, ord, WORK) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, TARGET :: WORK(:) INTEGER :: MYID, NPROCS, IERR INTEGER, POINTER :: FIRST(:), & LAST(:), SWORK(:) INTEGER :: BASEVAL, VERTLOCNBR, & BASE, SCOTCH_INT_SIZE INTEGER(8) :: EDGELOCNBR INTEGER(8), POINTER :: VERTLOCTAB(:) INTEGER, POINTER :: EDGELOCTAB(:) nullify(FIRST, LAST, SWORK, VERTLOCTAB, EDGELOCTAB) IF (size(WORK) .LT. id%N*3) THEN WRITE(LP, & '("Insufficient workspace inside SMUMPS_PTSCOTCH_ORD")') CALL MUMPS_ABORT() END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) BASE = id%NPROCS-id%NSLAVES BASEVAL = 1 CALL MUMPS_REALLOC(FIRST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, NPROCS+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL SMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK(1: 2*id%N), TYPE=2) VERTLOCNBR = LAST(MYID+1)-FIRST(MYID+1) + 1 CALL MUMPS_I8REALLOC(VERTLOCTAB, VERTLOCNBR+1, id%INFO, & LP, STRING='VERTLOCTAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT SWORK => WORK(id%N+1:3*id%N) CALL SMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, VERTLOCTAB, & EDGELOCTAB, SWORK) IF(id%INFO(1).LT.0) RETURN EDGELOCNBR = VERTLOCTAB(VERTLOCNBR+1)-1_8 CALL MUMPS_REALLOC(ord%PERMTAB, id%N, id%INFO, & LP, STRING='PERMTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%PERITAB, id%N, id%INFO, & LP, STRING='PERITAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%RANGTAB, id%N+1, id%INFO, & LP, STRING='RANGTAB', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%TREETAB, id%N, id%INFO, & LP, STRING='TREETAB', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IF(ord%IDO) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF(SCOTCH_INT_SIZE.EQ.32) THEN IF (id%KEEP(10).EQ.1) THEN id%INFO(1) = -52 id%INFO(2) = 2 ELSE CALL MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) ENDIF ELSE CALL MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) END IF END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 11 CALL MPI_BCAST (ord%CBLKNBR, 1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERMTAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%PERITAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%RANGTAB(1), id%N+1, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MPI_BCAST (ord%TREETAB(1), id%N, MPI_INTEGER, & BASE, id%COMM, IERR) CALL MUMPS_REALLOC(ord%SON, ord%CBLKNBR, id%INFO, & LP, STRING='SON', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%BROTHER, ord%CBLKNBR, id%INFO, & LP, STRING='BROTHER', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%NW, ord%CBLKNBR, id%INFO, & LP, STRING='NW', MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_BUILD_TREE(ord) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ord%N = id%N ord%COMM = id%COMM CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(VERTLOCTAB, MEMCNT=MEMCNT) RETURN 11 CONTINUE CALL MUMPS_DEALLOC(FIRST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LAST , MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ord%RANGTAB, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(EDGELOCTAB, MEMCNT=MEMCNT) RETURN END SUBROUTINE SMUMPS_PTSCOTCH_ORD #endif FUNCTION SMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, RPROC, & ALIST, LIST, PEAKMEM, NNODES, CHECKMEM) IMPLICIT NONE LOGICAL :: SMUMPS_STOP_DESCENT INTEGER :: NACTIVE, RPROC, ANODE, PEAKMEM, NNODES INTEGER :: ALIST(NNODES), LIST(NNODES) TYPE(ORD_TYPE) :: ord TYPE(SMUMPS_STRUC) :: id LOGICAL, OPTIONAL :: CHECKMEM INTEGER :: IPEAKMEM, BIG, MAX_NROWS, MIN_NROWS INTEGER :: TOPROWS, NRL, HOSTMEM, SUBMEM INTEGER :: I, NZ_ROW, WEIGHT LOGICAL :: ICHECKMEM INTEGER :: NZ4 IF(present(CHECKMEM)) THEN ICHECKMEM = CHECKMEM ELSE ICHECKMEM = .FALSE. END IF SMUMPS_STOP_DESCENT = .FALSE. IF(NACTIVE .GE. RPROC) THEN SMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(NACTIVE .EQ. 0) THEN SMUMPS_STOP_DESCENT = .TRUE. RETURN END IF IF(.NOT. ICHECKMEM) RETURN BIG = ALIST(NACTIVE) IF(NACTIVE .GT. 1) THEN MAX_NROWS = ord%NW(ALIST(NACTIVE-1)) MIN_NROWS = ord%NW(ALIST(1)) ELSE MAX_NROWS = 0 MIN_NROWS = id%N END IF DO I=1, ANODE WEIGHT = ord%NW(LIST(I)) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT END DO I = ord%SON(BIG) DO WEIGHT = ord%NW(I) IF(WEIGHT .GT. MAX_NROWS) MAX_NROWS = WEIGHT IF(WEIGHT .LT. MIN_NROWS) MIN_NROWS = WEIGHT IF(ord%BROTHER(I) .EQ. -1) EXIT I = ord%BROTHER(I) END DO TOPROWS = ord%TOPNODES(2)+ord%RANGTAB(BIG+1)-ord%RANGTAB(BIG) SUBMEM = 7 *id%N HOSTMEM = 12*id%N NZ4=int(id%KEEP8(28)) NZ_ROW = 2*(NZ4/id%N) IF(id%KEEP(46) .EQ. 0) THEN NRL = 0 ELSE NRL = MIN_NROWS END IF HOSTMEM = HOSTMEM + 2*TOPROWS*NZ_ROW HOSTMEM = HOSTMEM +NRL HOSTMEM = HOSTMEM + max(NRL,TOPROWS)*(NZ_ROW+2) HOSTMEM = HOSTMEM + 6*max(NRL,TOPROWS) HOSTMEM = HOSTMEM + 3*TOPROWS NRL = MAX_NROWS SUBMEM = SUBMEM +NRL SUBMEM = SUBMEM + NRL*(NZ_ROW+2) SUBMEM = SUBMEM + 6*NRL IPEAKMEM = max(HOSTMEM, SUBMEM) IF((IPEAKMEM .GT. PEAKMEM) .AND. & (PEAKMEM .NE. 0)) THEN SMUMPS_STOP_DESCENT = .TRUE. RETURN ELSE SMUMPS_STOP_DESCENT = .FALSE. PEAKMEM = IPEAKMEM RETURN END IF END FUNCTION SMUMPS_STOP_DESCENT FUNCTION SMUMPS_CNT_KIDS(NODE, ord) IMPLICIT NONE INTEGER :: SMUMPS_CNT_KIDS INTEGER :: NODE TYPE(ORD_TYPE) :: ord INTEGER :: CURR SMUMPS_CNT_KIDS = 0 IF(ord%SON(NODE) .EQ. -1) THEN RETURN ELSE SMUMPS_CNT_KIDS = 1 CURR = ord%SON(NODE) DO IF(ord%BROTHER(CURR) .NE. -1) THEN SMUMPS_CNT_KIDS = SMUMPS_CNT_KIDS+1 CURR = ord%BROTHER(CURR) ELSE EXIT END IF END DO END IF RETURN END FUNCTION SMUMPS_CNT_KIDS SUBROUTINE SMUMPS_GET_SUBTREES(ord, id) IMPLICIT NONE TYPE(ORD_TYPE) :: ord TYPE(SMUMPS_STRUC) :: id INTEGER, ALLOCATABLE :: ALIST(:), AWEIGHTS(:), LIST(:), WORK(:) INTEGER :: NNODES, BIG, CURR, ND, NACTIVE, RPROC, ANODE, BASE, I, & NK, PEAKMEM, allocok LOGICAL :: SD NNODES = ord%NSLAVES CALL MUMPS_REALLOC(ord%TOPNODES, 2*max(NNODES,2), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%FIRST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ord%LAST, id%NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(ALIST(NNODES), AWEIGHTS(NNODES), LIST(NNODES), & WORK(0:NNODES+1), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=4*NNODES+2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 NACTIVE = 0 DO I=1, ord%CBLKNBR IF (ord%TREETAB(I).EQ.-1) THEN NACTIVE = NACTIVE+1 IF(NACTIVE.LE.NNODES) THEN ALIST(NACTIVE) = I AWEIGHTS(NACTIVE) = ord%NW(I) END IF END IF END DO IF((ord%CBLKNBR .EQ. 1) .OR. & (NACTIVE.GT.NNODES) .OR. & ( NNODES .LT. SMUMPS_CNT_KIDS(ord%CBLKNBR, ord) )) THEN ord%TOPNODES(1) = 1 ord%TOPNODES(2) = ord%RANGTAB(ord%CBLKNBR+1) - ord%RANGTAB(1) ord%TOPNODES(3) = ord%RANGTAB(1) ord%TOPNODES(4) = ord%RANGTAB(ord%CBLKNBR+1)-1 ord%FIRST = 0 ord%LAST = -1 RETURN END IF CALL SMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL SMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) RPROC = NNODES ANODE = 0 PEAKMEM = 0 ord%TOPNODES = 0 DO IF(NACTIVE .EQ. 0) EXIT BIG = ALIST(NACTIVE) NK = SMUMPS_CNT_KIDS(BIG, ord) IF((NK .GT. (RPROC-NACTIVE+1)) .OR. (NK .EQ. 0)) THEN ANODE = ANODE+1 LIST(ANODE) = BIG NACTIVE = NACTIVE-1 RPROC = RPROC-1 CYCLE END IF SD = SMUMPS_STOP_DESCENT(id, ord, NACTIVE, ANODE, & RPROC, ALIST, LIST, PEAKMEM, NNODES, CHECKMEM=.TRUE.) IF ( SD ) & THEN IF(NACTIVE.GT.0) THEN LIST(ANODE+1:ANODE+NACTIVE) = ALIST(1:NACTIVE) ANODE = ANODE+NACTIVE END IF EXIT END IF ord%TOPNODES(1) = ord%TOPNODES(1)+1 ord%TOPNODES(2) = ord%TOPNODES(2) + & ord%RANGTAB(BIG+1) - ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+1) = ord%RANGTAB(BIG) ord%TOPNODES(2+2*(ord%TOPNODES(1)-1)+2) = & ord%RANGTAB(BIG+1)-1 CURR = ord%SON(BIG) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) DO IF(ord%BROTHER(CURR) .EQ. -1) EXIT NACTIVE = NACTIVE+1 CURR = ord%BROTHER(CURR) ALIST(NACTIVE) = CURR AWEIGHTS(NACTIVE) = ord%NW(CURR) END DO CALL SMUMPS_MERGESORT(NACTIVE, AWEIGHTS(1:NACTIVE), & WORK(0:NACTIVE+1)) CALL SMUMPS_MERGESWAP(NACTIVE, WORK(0:NACTIVE+1), & AWEIGHTS(1:NACTIVE), & ALIST(1:NACTIVE)) END DO DO I=1, ANODE AWEIGHTS(I) = ord%NW(LIST(I)) END DO CALL SMUMPS_MERGESORT(ANODE, AWEIGHTS(1:ANODE), WORK(0:ANODE+1)) CALL SMUMPS_MERGESWAP(ANODE, WORK(0:ANODE+1), AWEIGHTS(1:ANODE), & ALIST(1:ANODE)) IF (id%KEEP(46) .EQ. 1) THEN BASE = 0 ELSE ord%FIRST(1) = 0 ord%LAST(1) = -1 BASE = 1 END IF DO I=1, ANODE CURR = LIST(I) ND = CURR IF(ord%SON(ND) .NE. -1) THEN ND = ord%SON(ND) DO IF((ord%SON(ND) .EQ. -1) .AND. & (ord%BROTHER(ND).EQ.-1)) THEN EXIT ELSE IF(ord%BROTHER(ND) .EQ. -1) THEN ND = ord%SON(ND) ELSE ND = ord%BROTHER(ND) END IF END DO END IF ord%FIRST(BASE+I) = ord%RANGTAB(ND) ord%LAST(BASE+I) = ord%RANGTAB(CURR+1)-1 END DO DO I=ANODE+1, id%NSLAVES ord%FIRST(BASE+I) = id%N+1 ord%LAST(BASE+I) = id%N END DO DEALLOCATE(LIST, ALIST, AWEIGHTS, WORK) 90 continue RETURN END SUBROUTINE SMUMPS_GET_SUBTREES SUBROUTINE SMUMPS_PARSYMFACT(id, ord, GPE, GNV, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER, POINTER :: GPE(:), GNV(:) INTEGER, TARGET :: WORK(:) TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:), IPET(:), & BUF_PE1(:), BUF_PE2(:), TMP1(:) INTEGER, POINTER :: PE(:), & LENG(:), I_HALO_MAP(:) INTEGER, POINTER :: NDENSE(:), LAST(:), & DEGREE(:), W(:), PERM(:), & LISTVAR_SCHUR(:), NEXT(:), & HEAD(:), NV(:), ELEN(:), & RCVCNT(:), LSTVAR(:) INTEGER, POINTER :: MYLIST(:), & LPERM(:), & LIPERM(:), & NVT(:), BUF_NV1(:), & BUF_NV2(:), ROOTPERM(:), & TMP2(:), BWORK(:), NCLIQUES(:) INTEGER :: MYNCLIQUES, MYMAXVARS, ICLIQUES, & TOTNCLIQUES INTEGER(8) :: MYNVARS, TOTNVARS INTEGER(8), POINTER :: LVARPT(:) INTEGER :: HIDX, NCMPA, I, J, SIZE_SCHUR, MYID, & NPROCS, IERR, NROWS_LOC, GLOB_IDX, TMP, & NTVAR, TGSIZE, MAXS, RHANDPE, & RHANDNV, RIDX, PROC, JOB, K INTEGER(8) :: PFREES, PFS_SAVE, PELEN, PFREET, PFT_SAVE INTEGER :: STATUSPE(MPI_STATUS_SIZE) INTEGER :: STATUSNV(MPI_STATUS_SIZE) INTEGER :: STATUSCLIQUES(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30 LOGICAL :: AGG6 INTEGER :: THRESH nullify(PE, IPE, LENG, I_HALO_MAP, NCLIQUES) nullify(NDENSE, LAST, DEGREE, W, PERM, LISTVAR_SCHUR, & NEXT, HEAD, NV, ELEN, RCVCNT, LSTVAR) nullify(MYLIST, LVARPT, & LPERM, LIPERM, IPET, NVT, BUF_PE1, BUF_PE2, & BUF_NV1, BUF_NV2, ROOTPERM, TMP1, TMP2, BWORK) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(size(WORK) .LT. 4*id%N) THEN WRITE(LP,*)'Insufficient workspace in SMUMPS_PARSYMFACT' CALL MUMPS_ABORT() ELSE HEAD => WORK( 1 : id%N) ELEN => WORK( id%N+1 : 2*id%N) LENG => WORK(2*id%N+1 : 3*id%N) PERM => WORK(3*id%N+1 : 4*id%N) END IF CALL SMUMPS_GET_SUBTREES(ord, id) CALL MUMPS_IDEALLOC(ord%SON, ord%BROTHER, ord%NW, & ord%RANGTAB, MEMCNT=MEMCNT) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 NRL = NROWS_LOC TOPROWS = ord%TOPNODES(2) BWORK => WORK(1 : 2*id%N) CALL SMUMPS_BUILD_LOC_GRAPH(id, ord, HIDX, IPE, PE, LENG, & I_HALO_MAP, top_graph, BWORK) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF(id%INFO(1).lt.0) RETURN TMP = id%N DO I=1, NPROCS TMP = TMP-(ord%LAST(I)-ord%FIRST(I)+1) END DO TMP = ceiling(real(TMP)*1.10E0) IF(MYID .EQ. 0) THEN TMP = max(max(TMP, HIDX),1) ELSE TMP = max(HIDX,1) END IF SIZE_SCHUR = HIDX - NROWS_LOC CALL MUMPS_REALLOC(NDENSE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NV, TMP, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(SIZE_SCHUR,1), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, SIZE_SCHUR LISTVAR_SCHUR(I) = NROWS_LOC+I END DO THRESH = -1 AGG6 = .FALSE. PFREES = IPE(NROWS_LOC+1) PFS_SAVE = PFREES PELEN = PFREES-1 + 2_8*int(NROWS_LOC+ord%TOPNODES(2),8) DO I=1, HIDX PERM(I) = I END DO IF(SIZE_SCHUR.EQ.0) THEN JOB = 0 ELSE JOB = 1 END IF IF(HIDX .GT.0) CALL MUMPS_SYMQAMD_NEW(JOB, THRESH, NDENSE(1), & HIDX, PELEN, IPE(1), PFREES, LENG(1), PE(1), NV(1), & ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), NEXT(1), & W(1), PERM(1), LISTVAR_SCHUR(1), SIZE_SCHUR, AGG6) MYNCLIQUES = 0 MYNVARS = 0 MYMAXVARS = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN MYMAXVARS = MAX(MYMAXVARS,LENG(I)) MYNVARS = MYNVARS+LENG(I) MYNCLIQUES = MYNCLIQUES+1 END IF END DO CALL MPI_REDUCE(MYNVARS, TOTNVARS, 1, MPI_INTEGER8, & MPI_SUM, 0, id%COMM, IERR) CALL MUMPS_REALLOC(NCLIQUES, NPROCS, id%INFO, & LP, STRING='NCLIQUES', MEMCNT=MEMCNT, ERRCODE=-7) CALL MPI_GATHER(MYNCLIQUES, 1, MPI_INTEGER, NCLIQUES(1), 1, & MPI_INTEGER, 0, id%COMM, IERR) IF(id%MYID.EQ.0) THEN TOTNCLIQUES = sum(NCLIQUES) CALL MUMPS_I8REALLOC(LVARPT, TOTNCLIQUES+1, id%INFO, & LP, STRING='LVARPT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(LSTVAR, TOTNVARS, id%INFO, & LP, STRING='LSTVAR', MEMCNT=MEMCNT, ERRCODE=-7) LVARPT(1) = 1_8 ICLIQUES = 0 DO I=1, HIDX IF(IPE(I) .GT. 0) THEN ICLIQUES = ICLIQUES+1 LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+LENG(I) DO J=0, LENG(I)-1 LSTVAR(LVARPT(ICLIQUES)+J) = & I_HALO_MAP(PE(IPE(I)+J)-NROWS_LOC) END DO END IF END DO DO PROC=1, NPROCS-1 DO I=1, NCLIQUES(PROC+1) ICLIQUES = ICLIQUES+1 CALL MPI_RECV(K, 1, MPI_INTEGER, PROC, ITAG, id%COMM, & STATUSCLIQUES, IERR) LVARPT(ICLIQUES+1) = LVARPT(ICLIQUES)+K CALL MPI_RECV(LSTVAR(LVARPT(ICLIQUES)), K, MPI_INTEGER, & PROC, ITAG, id%COMM, STATUSCLIQUES, IERR) END DO END DO LPERM => WORK(3*id%N+1 : 4*id%N) NTVAR = ord%TOPNODES(2) CALL SMUMPS_MAKE_LOC_IDX(id, ord%TOPNODES, LPERM, LIPERM, ord) CALL SMUMPS_ASSEMBLE_TOP_GRAPH(id, ord%TOPNODES(2), LPERM, & top_graph, TOTNCLIQUES, LSTVAR, LVARPT, IPET, PE, & LENG, ELEN) TGSIZE = ord%TOPNODES(2)+TOTNCLIQUES PFREET = IPET(TGSIZE+1) PFT_SAVE = PFREET nullify(LPERM) ELSE CALL MUMPS_REALLOC(MYLIST, MYMAXVARS, id%INFO, & LP, STRING='MYLIST', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, HIDX IF(IPE(I) .GT. 0) THEN DO J=1, LENG(I) MYLIST(J) = I_HALO_MAP(PE(IPE(I)+J-1)-NROWS_LOC) END DO CALL MPI_SEND(LENG(I), 1, MPI_INTEGER, 0, ITAG, & id%COMM, IERR) CALL MPI_SEND(MYLIST(1), LENG(I), MPI_INTEGER, 0, ITAG, & id%COMM, IERR) END IF END DO END IF CALL MUMPS_IDEALLOC(top_graph%IRN_LOC, & top_graph%JCN_LOC, ord%TOPNODES, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN CALL MUMPS_IREALLOC8(PE, max(PFREET+int(TGSIZE,8),1_8),id%INFO, & LP, COPY=.TRUE., STRING='J2:PE', MEMCNT=MEMCNT, & ERRCODE=-7) CALL MUMPS_REALLOC(NDENSE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NDENSE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NVT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NVT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LAST, max(TGSIZE,1), id%INFO, LP, & STRING='J2:LAST', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(DEGREE, max(TGSIZE,1), id%INFO, LP, & STRING='J2:DEGREE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(NEXT, max(TGSIZE,1), id%INFO, LP, & STRING='J2:NEXT', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(W, max(TGSIZE,1), id%INFO, LP, & STRING='J2:W', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LISTVAR_SCHUR, max(TOTNCLIQUES,1), id%INFO, & LP, STRING='J2:LVSCH', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TOTNCLIQUES LISTVAR_SCHUR(I) = NTVAR+I END DO THRESH = -1 CALL MUMPS_REALLOC(HEAD, max(TGSIZE,1), id%INFO, & LP, STRING='J2:HEAD', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(PERM, max(TGSIZE,1), id%INFO, & LP, COPY=.TRUE., STRING='J2:PERM', & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT DO I=1, TGSIZE PERM(I) = I END DO PELEN = max(PFREET+int(TGSIZE,8),1_8) IF(TGSIZE.GT.0) CALL MUMPS_SYMQAMD_NEW(2, -1, NDENSE(1), & TGSIZE, PELEN, IPET(1), PFREET, LENG(1), PE(1), & NVT(1), ELEN(1), LAST(1), NCMPA, DEGREE(1), HEAD(1), & NEXT(1), W(1), PERM(1), LISTVAR_SCHUR(1), TOTNCLIQUES, & AGG6) END IF CALL MPI_BARRIER(id%COMM, IERR) CALL MPI_BARRIER(id%COMM, IERR) CALL MUMPS_DEALLOC(LISTVAR_SCHUR, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, MEMCNT=MEMCNT) IF(MYID .EQ. 0) THEN MAXS = NROWS_LOC DO I=2, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) & MAXS = (ord%LAST(I)-ord%FIRST(I)+1) END DO CALL MUMPS_I8REALLOC(BUF_PE1, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(BUF_PE2, max(MAXS,1), id%INFO, & LP, STRING='BUF_PE2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV1, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV1', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(BUF_NV2, max(MAXS,1), id%INFO, & LP, STRING='BUF_NV2', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GPE, id%N, id%INFO, & LP, STRING='GPE', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(GNV, id%N, id%INFO, & LP, STRING='GNV', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ROOTPERM, TOTNCLIQUES, id%INFO, & LP, STRING='ROOTPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RIDX = 0 TMP1 => BUF_PE1 TMP2 => BUF_NV1 NULLIFY(BUF_PE1, BUF_NV1) BUF_PE1 => IPE BUF_NV1 => NV DO PROC=0, NPROCS-2 CALL MPI_IRECV(BUF_PE2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER8, PROC+1, PROC+1, & id%COMM, RHANDPE, IERR) CALL MPI_IRECV(BUF_NV2(1), ord%LAST(PROC+2)- & ord%FIRST(PROC+2)+1, MPI_INTEGER, PROC+1, PROC+1, & id%COMM, RHANDNV, IERR) DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO CALL MPI_WAIT(RHANDPE, STATUSPE, IERR) CALL MPI_WAIT(RHANDNV, STATUSNV, IERR) IF(PROC .NE. 0) THEN TMP1 => BUF_PE1 TMP2 => BUF_NV1 END IF BUF_PE1 => BUF_PE2 BUF_NV1 => BUF_NV2 NULLIFY(BUF_PE2, BUF_NV2) BUF_PE2 => TMP1 BUF_NV2 => TMP2 NULLIFY(TMP1, TMP2) END DO DO I=1, ord%LAST(PROC+1)-ord%FIRST(PROC+1)+1 GLOB_IDX = ord%PERITAB(I+ord%FIRST(PROC+1)-1) IF(BUF_PE1(I) .GT. 0) THEN RIDX=RIDX+1 ROOTPERM(RIDX) = GLOB_IDX GNV(GLOB_IDX) = BUF_NV1(I) ELSE IF (BUF_PE1(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = BUF_NV1(I) ELSE GPE(GLOB_IDX) = -ord%PERITAB(-BUF_PE1(I)+ & ord%FIRST(PROC+1)-1) GNV(GLOB_IDX) = BUF_NV1(I) END IF END DO DO I=1, NTVAR GLOB_IDX = LIPERM(I) IF(IPET(I) .EQ. 0) THEN GPE(GLOB_IDX) = 0 GNV(GLOB_IDX) = NVT(I) ELSE GPE(GLOB_IDX) = -LIPERM(-IPET(I)) GNV(GLOB_IDX) = NVT(I) END IF END DO DO I=1, TOTNCLIQUES GLOB_IDX = ROOTPERM(I) GPE(GLOB_IDX) = -LIPERM(-IPET(NTVAR+I)) END DO ELSE CALL MPI_SEND(IPE(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER8, 0, MYID, id%COMM, IERR) CALL MPI_SEND(NV(1), ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1, & MPI_INTEGER, 0, MYID, id%COMM, IERR) END IF CALL MUMPS_DEALLOC(BUF_NV1, BUF_NV2, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(BUF_PE1, BUF_PE2, IPE, IPET, & TMP1, LVARPT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(PE, I_HALO_MAP, NDENSE, & LAST, DEGREE, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(W, LISTVAR_SCHUR, NEXT, & NV, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LSTVAR, NCLIQUES, MYLIST, & MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(LPERM, LIPERM, NVT, MEMCNT=MEMCNT) CALL MUMPS_DEALLOC(ROOTPERM, TMP2, MEMCNT=MEMCNT) NULLIFY(HEAD, ELEN, LENG, PERM, RCVCNT) RETURN END SUBROUTINE SMUMPS_PARSYMFACT SUBROUTINE SMUMPS_MAKE_LOC_IDX(id, TOPNODES, LPERM, LIPERM, ord) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER, POINTER :: TOPNODES(:), LPERM(:), LIPERM(:) TYPE(ORD_TYPE) :: ord INTEGER :: I, J, K, GIDX CALL MUMPS_REALLOC(LPERM , ord%N, id%INFO, & LP, STRING='LIDX:LPERM', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(LIPERM, TOPNODES(2), id%INFO, & LP, STRING='LIDX:LIPERM', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LPERM = 0 K = 1 DO I=TOPNODES(1), 1, -1 DO J=TOPNODES(2*I+1), TOPNODES(2*I+2) GIDX = ord%PERITAB(J) LPERM(GIDX) = K LIPERM(K) = GIDX K = K+1 END DO END DO RETURN END SUBROUTINE SMUMPS_MAKE_LOC_IDX SUBROUTINE SMUMPS_ASSEMBLE_TOP_GRAPH(id, NLOCVARS, LPERM, & top_graph, NCLIQUES, LSTVAR, LVARPT, IPE, PE, LENG, ELEN) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(GRAPH_TYPE) :: top_graph INTEGER, POINTER :: LPERM(:), LSTVAR(:), & PE(:), LENG(:), ELEN(:) INTEGER(8) :: LVARPT(:) INTEGER :: NCLIQUES INTEGER(8), POINTER :: IPE(:) INTEGER :: I, IDX, NLOCVARS INTEGER(8) :: INNZ, PNT, SAVEPNT CALL MUMPS_REALLOC(LENG, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:LENG', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(ELEN, max(NLOCVARS+NCLIQUES,1) , id%INFO, & LP, STRING='ATG:ELEN', MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(IPE , NLOCVARS+NCLIQUES+1, id%INFO, & LP, STRING='ATG:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 END DO END DO IPE(1) = 1 DO I=1, NLOCVARS+NCLIQUES IPE(I+1) = IPE(I)+int(LENG(I),8)+int(ELEN(I),8) END DO CALL MUMPS_IREALLOC8(PE, IPE(NLOCVARS+NCLIQUES+1)+ & int(NLOCVARS,8)+int(NCLIQUES,8), & id%INFO, LP, STRING='ATG:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG = 0 ELEN = 0 DO I=1, NCLIQUES DO INNZ=LVARPT(I), LVARPT(I+1)-1 IDX = LPERM(LSTVAR(INNZ)) PE(IPE(IDX)+int(ELEN(IDX),8)) = NLOCVARS+I PE(IPE(NLOCVARS+I)+int(LENG(NLOCVARS+I),8)) = IDX ELEN(LPERM(LSTVAR(INNZ))) = ELEN(LPERM(LSTVAR(INNZ)))+1 LENG(NLOCVARS+I) = LENG(NLOCVARS+I)+1 end do end do DO INNZ=1, top_graph%NZ_LOC IF((LPERM(top_graph%JCN_LOC(INNZ)) .NE. 0) .AND. & (top_graph%JCN_LOC(INNZ) .NE. top_graph%IRN_LOC(INNZ))) & THEN PE(IPE(LPERM(top_graph%IRN_LOC(INNZ)))+ & ELEN(LPERM(top_graph%IRN_LOC(INNZ))) + & LENG(LPERM(top_graph%IRN_LOC(INNZ)))) = & LPERM(top_graph%JCN_LOC(INNZ)) LENG(LPERM(top_graph%IRN_LOC(INNZ))) = & LENG(LPERM(top_graph%IRN_LOC(INNZ))) + 1 END IF END DO DO I=1, NLOCVARS+NCLIQUES LENG(I) = LENG(I)+ELEN(I) END DO SAVEPNT = 1 PNT = 0 LPERM(1:NLOCVARS+NCLIQUES) = 0 DO I=1, NLOCVARS+NCLIQUES DO INNZ=IPE(I), IPE(I+1)-1 IF(LPERM(PE(INNZ)) .EQ. I) THEN LENG(I) = LENG(I)-1 ELSE LPERM(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NLOCVARS+NCLIQUES+1) = SAVEPNT RETURN END SUBROUTINE SMUMPS_ASSEMBLE_TOP_GRAPH #if defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_BUILD_TREETAB(TREETAB, RANGTAB, SIZES, CBLKNBR) INTEGER, POINTER :: TREETAB(:), RANGTAB(:), SIZES(:) INTEGER :: CBLKNBR,allocok INTEGER :: LCHILD, RCHILD, K, I INTEGER, POINTER :: PERM(:) ALLOCATE(PERM(CBLKNBR),stat=allocok) if(allocok.GT.0) then write(*,*) "Allocation error of PERM in SMUMPS_BUILD_TREETAB" return endif TREETAB(CBLKNBR) = -1 IF(CBLKNBR .EQ. 1) THEN DEALLOCATE(PERM) TREETAB(1) = -1 RANGTAB(1) = 1 RANGTAB(2)= SIZES(1)+1 RETURN END IF LCHILD = CBLKNBR - (CBLKNBR+1)/2 RCHILD = CBLKNBR-1 K = 1 PERM(CBLKNBR) = CBLKNBR PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = CBLKNBR TREETAB(LCHILD) = CBLKNBR IF(CBLKNBR .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & LCHILD, CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (CBLKNBR-1)/2, & RCHILD, CBLKNBR, 2*K) END IF RANGTAB(1)=1 DO I=1, CBLKNBR RANGTAB(I+1) = RANGTAB(I)+SIZES(PERM(I)) END DO DEALLOCATE(PERM) RETURN CONTAINS RECURSIVE SUBROUTINE REC_TREETAB(TREETAB, PERM, SUBNODES, & ROOTN, CBLKNBR, K) INTEGER, POINTER :: TREETAB(:), PERM(:) INTEGER :: SUBNODES, ROOTN, K, CBLKNBR INTEGER :: LCHILD, RCHILD LCHILD = ROOTN - (SUBNODES+1)/2 RCHILD = ROOTN-1 PERM(LCHILD) = CBLKNBR+1 - (2*K+1) PERM(RCHILD) = CBLKNBR+1 - (2*K) TREETAB(RCHILD) = ROOTN TREETAB(LCHILD) = ROOTN IF(SUBNODES .GT. 3) THEN CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, LCHILD, & CBLKNBR, 2*K+1) CALL REC_TREETAB(TREETAB, PERM, (SUBNODES-1)/2, RCHILD, & CBLKNBR, 2*K) END IF END SUBROUTINE REC_TREETAB END SUBROUTINE SMUMPS_BUILD_TREETAB #endif #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_BUILD_DIST_GRAPH(id, FIRST, LAST, IPE, & PE, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: FIRST(:), LAST(:), PE(:), & WORK(:) INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, OFFDIAG, & RCVPNT, PNT, SAVEPNT, DUPS, TOTDUPS INTEGER :: NROWS_LOC INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, POINTER :: MAPTAB(:), SDISPL(:) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: RDISPL(:), BUFLEVEL(:), & SIPES(:,:), LENG(:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER, PARAMETER :: ITAG=30 LOGICAL :: FLAG DOUBLE PRECISION :: SYMMETRY INTEGER(KIND=8) :: TLEN #if defined(DETERMINISTIC_PARALLEL_GRAPH) INTEGER :: L #endif nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL) nullify(RDISPL, MSGCNT, SIPES, LENG, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_SCOTCH_GRAPH")') CALL MUMPS_ABORT() END IF CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 BUFSIZE = 1000 BUFSIZE = id%KEEP(39) LOCNNZ = id%KEEP8(29) NROWS_LOC = LAST(MYID+1)-FIRST(MYID+1)+1 MAPTAB => WORK( 1 : id%N) LENG => WORK(id%N+1 : 2*id%N) MAXS = 0 DO I=1, NPROCS IF((LAST(I)-FIRST(I)+1) .GT. MAXS) THEN MAXS = LAST(I)-FIRST(I)+1 END IF DO J=FIRST(I), LAST(I) MAPTAB(J) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 OFFDIAG=0 SIPES=0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN OFFDIAG = OFFDIAG+1 PROC = MAPTAB(id%IRN_loc(INNZ)) LOC_ROW = id%IRN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 PROC = MAPTAB(id%JCN_loc(INNZ)) LOC_ROW = id%JCN_loc(INNZ)-FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END DO CALL MPI_ALLREDUCE (OFFDIAG, id%KEEP8(127), 1, MPI_INTEGER8, & MPI_SUM, id%COMM, IERR) id%KEEP8(127) = id%KEEP8(127)+3*id%N id%KEEP8(126) = id%KEEP8(127)-2*id%N CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(PE, max(IPE(NROWS_LOC+1)-1_8,1_8), id%INFO, & LP, STRING='PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ+RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO RCVPNT = 1 BUFLEVEL = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE,8)/10_8) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%IRN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%JCN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF PROC = MAPTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = id%JCN_loc(INNZ)- & FIRST(PROC)+1 APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = id%IRN_loc(INNZ) BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END DO CALL SMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO CALL MPI_REDUCE( DUPS, TOTDUPS, 1, MPI_INTEGER8, MPI_SUM, & 0, id%COMM, IERR ) IF(MYID .EQ. 0) THEN SYMMETRY = dble(TOTDUPS)/(dble(id%KEEP8(28))-dble(id%N)) SYMMETRY = min(SYMMETRY,1.0d0) IF(id%KEEP(50) .GE. 1) SYMMETRY = 1.d0 IF(PROKG) WRITE(MPG,'(" Structural symmetry is:",i3,"%")') & ceiling(SYMMETRY*100.d0) id%INFOG(8) = ceiling(SYMMETRY*100.0d0) END IF IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) #if defined(DETERMINISTIC_PARALLEL_GRAPH) DO I=1, LAST(MYID+1)-FIRST(MYID+1)+1 L = int(IPE(I+1)-IPE(I)) CALL SMUMPS_MERGESORT(L, & PE(IPE(I):IPE(I+1)-1), & WORK(:)) CALL SMUMPS_MERGESWAP1(L, WORK(:), & PE(IPE(I):IPE(I+1)-1)) END DO #endif 90 continue RETURN END SUBROUTINE SMUMPS_BUILD_DIST_GRAPH #endif SUBROUTINE SMUMPS_BUILD_LOC_GRAPH(id, ord, GSIZE, IPE, PE, LENG, & I_HALO_MAP, top_graph, WORK) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord TYPE(GRAPH_TYPE) :: top_graph INTEGER(8), POINTER :: IPE(:) INTEGER, POINTER :: PE(:), LENG(:), & I_HALO_MAP(:), WORK(:) INTEGER :: GSIZE INTEGER :: IERR, MYID, NPROCS INTEGER :: I, PROC, J, LOC_ROW INTEGER(8) :: LOCNNZ, INNZ, NEW_LOCNNZ, TOP_CNT, TIDX, & RCVPNT INTEGER :: IIDX,JJDX INTEGER :: HALO_SIZE, NROWS_LOC, DUPS INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER(8), POINTER :: MSGCNT(:), SNDCNT(:), RCVCNT(:) INTEGER, POINTER :: MAPTAB(:), & SDISPL(:), HALO_MAP(:), BUFLEVEL(:) INTEGER, POINTER :: RDISPL(:), & SIPES(:,:) INTEGER, POINTER :: PCNT(:), TSENDI(:), & TSENDJ(:), RCVBUF(:) TYPE(ARRPNT), POINTER :: APNT(:) INTEGER :: BUFSIZE, SOURCE, MAXS, allocok INTEGER(8) :: PNT, SAVEPNT INTEGER, PARAMETER :: ITAG=30 INTEGER(KIND=8) :: TLEN LOGICAL :: FLAG nullify(MAPTAB, SNDCNT, RCVCNT, SDISPL, HALO_MAP) nullify(RDISPL, MSGCNT, SIPES, BUFLEVEL) nullify(PCNT, TSENDI, TSENDJ, RCVBUF, APNT) CALL MPI_COMM_RANK (id%COMM, MYID, IERR) CALL MPI_COMM_SIZE (id%COMM, NPROCS, IERR) IF(MUMPS_GETSIZE(WORK) .LT. id%N*2) THEN WRITE(LP, & '("Insufficient workspace inside BUILD_LOC_GRAPH")') CALL MUMPS_ABORT() END IF MAPTAB => WORK( 1 : id%N) HALO_MAP => WORK(id%N+1 : 2*id%N) CALL MUMPS_I8REALLOC(SNDCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(RCVCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_I8REALLOC(MSGCNT, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_REALLOC(RDISPL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT ALLOCATE(APNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SNDCNT = 0 TOP_CNT = 0 BUFSIZE = 10000 LOCNNZ = id%KEEP8(29) NROWS_LOC = ord%LAST(MYID+1)-ord%FIRST(MYID+1)+1 MAPTAB = 0 MAXS = 0 DO I=1, NPROCS IF((ord%LAST(I)-ord%FIRST(I)+1) .GT. MAXS) THEN MAXS = ord%LAST(I)-ord%FIRST(I)+1 END IF DO J=ord%FIRST(I), ord%LAST(I) MAPTAB(ord%PERITAB(J)) = I END DO END DO ALLOCATE(SIPES(max(1,MAXS), NPROCS), stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=max(1,MAXS)*NPROCS ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 SIPES(:,:) = 0 TOP_CNT = 0 DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TOP_CNT = TOP_CNT+1 ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) LOC_ROW = IIDX-ord%FIRST(PROC)+1 SIPES(LOC_ROW, PROC) = SIPES(LOC_ROW, PROC)+1 SNDCNT(PROC) = SNDCNT(PROC)+1 END IF END IF END DO CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, id%COMM, IERR) I = ceiling(real(MAXS)*1.20E0) CALL MUMPS_REALLOC(LENG, max(I,1), id%INFO, & LP, STRING='B_L_G:LENG', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_I8DEALLOC(SNDCNT, MEMCNT=MEMCNT) RDISPL(:) = MAXS CALL MPI_REDUCE_SCATTER ( SIPES(1,1), LENG(1), RDISPL(1), & MPI_INTEGER, MPI_SUM, id%COMM, IERR ) DEALLOCATE(SIPES) I = ceiling(real(NROWS_LOC+1)*1.20E0) CALL MUMPS_I8REALLOC(IPE, max(I,1), id%INFO, & LP, STRING='B_L_G:IPE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT TLEN = 0_8 IPE(1) = 1_8 DO I=1, NROWS_LOC IPE(I+1) = IPE(I) + int(LENG(I),8) TLEN = TLEN+int(LENG(I),8) END DO CALL MUMPS_IREALLOC8(TSENDI, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(TSENDJ, max(TOP_CNT,1_8), id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT LENG(:) = 0 CALL MUMPS_REALLOC(BUFLEVEL, NPROCS, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) NEW_LOCNNZ = 0 DO I=1, NPROCS NEW_LOCNNZ = NEW_LOCNNZ + RCVCNT(I) MSGCNT(I) = RCVCNT(I)/int(BUFSIZE,8) END DO CALL MUMPS_IREALLOC8(PE, max(NEW_LOCNNZ+ & 2_8*int(NROWS_LOC+ord%TOPNODES(2),8),1_8), & id%INFO, LP, STRING='B_L_G:PE', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT RCVPNT = 1 BUFLEVEL = 0 TIDX = 0 DO INNZ=1, LOCNNZ IF(mod(INNZ,int(BUFSIZE/10,8)) .EQ. 0) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, id%COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, SOURCE, & ITAG, id%COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 RCVPNT = RCVPNT + BUFSIZE END IF END IF IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN PROC = MAPTAB(id%IRN_loc(INNZ)) IF((MAPTAB(id%JCN_loc(INNZ)).NE.PROC) .AND. & (MAPTAB(id%JCN_loc(INNZ)).NE.0) .AND. & (PROC.NE.0)) THEN IERR = -50 id%INFO(1) = IERR END IF IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%IRN_loc(INNZ) TSENDJ(TIDX) = id%JCN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%IRN_loc(INNZ)) JJDX = ord%PERMTAB(id%JCN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1)=IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%JCN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF PROC = MAPTAB(id%JCN_loc(INNZ)) IF(PROC .EQ. 0) THEN TIDX = TIDX+1 TSENDI(TIDX) = id%JCN_loc(INNZ) TSENDJ(TIDX) = id%IRN_loc(INNZ) ELSE IIDX = ord%PERMTAB(id%JCN_loc(INNZ)) JJDX = ord%PERMTAB(id%IRN_loc(INNZ)) APNT(PROC)%BUF(2*BUFLEVEL(PROC)+1) = & IIDX-ord%FIRST(PROC)+1 IF( (JJDX .GE. ord%FIRST(PROC)) .AND. & (JJDX .LE. ord%LAST(PROC)) ) THEN APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = & JJDX-ord%FIRST(PROC)+1 ELSE APNT(PROC)%BUF(2*BUFLEVEL(PROC)+2) = -id%IRN_loc(INNZ) END IF BUFLEVEL(PROC) = BUFLEVEL(PROC)+1 IF(BUFLEVEL(PROC) .EQ. BUFSIZE) THEN CALL SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, & PE, LENG, RCVBUF, MSGCNT, BUFLEVEL, id%COMM) END IF END IF END IF END DO CALL SMUMPS_SEND_BUF(APNT, -1, NPROCS, BUFSIZE, IPE, PE, LENG, & RCVBUF, MSGCNT, BUFLEVEL, id%COMM) DUPS = 0 PNT = 0 SAVEPNT = 1 MAPTAB(:) = 0 HALO_MAP(:) = 0 HALO_SIZE = 0 DO I=1, NROWS_LOC DO INNZ=IPE(I),IPE(I+1)-1 IF(PE(INNZ) .LT. 0) THEN IF(HALO_MAP(-PE(INNZ)) .EQ. 0) THEN HALO_SIZE = HALO_SIZE+1 HALO_MAP(-PE(INNZ)) = NROWS_LOC+HALO_SIZE END IF PE(INNZ) = HALO_MAP(-PE(INNZ)) END IF IF(MAPTAB(PE(INNZ)) .EQ. I) THEN DUPS = DUPS+1 LENG(I) = LENG(I)-1 ELSE MAPTAB(PE(INNZ)) = I PNT = PNT+1 PE(PNT) = PE(INNZ) END IF END DO IPE(I) = SAVEPNT SAVEPNT = PNT+1 END DO IPE(NROWS_LOC+1) = SAVEPNT CALL MUMPS_REALLOC(I_HALO_MAP, HALO_SIZE, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT J=0 DO I=1, id%N IF(HALO_MAP(I) .GT. 0) THEN J = J+1 I_HALO_MAP(HALO_MAP(I)-NROWS_LOC) = I END IF IF(J .EQ. HALO_SIZE) EXIT END DO CALL MUMPS_REALLOC(LENG, max(NROWS_LOC+HALO_SIZE,1), id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:leng', MEMCNT=MEMCNT, ERRCODE=-7) LENG(NROWS_LOC+1:NROWS_LOC+HALO_SIZE) = 0 CALL MUMPS_I8REALLOC(IPE, NROWS_LOC+HALO_SIZE+1, id%INFO, & LP, COPY=.TRUE., & STRING='lcgrph:ipe', MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT IPE(NROWS_LOC+2:NROWS_LOC+HALO_SIZE+1) = IPE(NROWS_LOC+1) GSIZE = NROWS_LOC + HALO_SIZE CALL MPI_GATHER(TOP_CNT, 1, MPI_INTEGER8, RCVCNT(1), 1, & MPI_INTEGER8, 0, id%COMM, IERR) IF(MYID.EQ.0) THEN NEW_LOCNNZ = sum(RCVCNT) top_graph%NZ_LOC = NEW_LOCNNZ top_graph%COMM = id%COMM CALL MUMPS_IREALLOC8(top_graph%IRN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_IREALLOC8(top_graph%JCN_LOC, max(1_8,NEW_LOCNNZ), & id%INFO, LP, MEMCNT=MEMCNT, ERRCODE=-7) IF(MEMCNT .GT. MAXMEM) MAXMEM=MEMCNT CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 ELSE ALLOCATE(top_graph%IRN_LOC(1), top_graph%JCN_LOC(1), & stat=allocok) IF(allocok.GT.0) THEN id%INFO(1)=-13 id%INFO(2)=2 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), id%COMM, id%MYID) IF ( id%INFO(1) .LT. 0 ) GO TO 90 END IF IF(MYID.EQ.0) THEN top_graph%IRN_LOC(1:TOP_CNT) = TSENDI(1:TOP_CNT) top_graph%JCN_LOC(1:TOP_CNT) = TSENDJ(1:TOP_CNT) DO PROC=2, NPROCS DO WHILE (RCVCNT(PROC) .GT. 0) I = int(min(int(BUFSIZE,8), RCVCNT(PROC))) CALL MPI_RECV(top_graph%IRN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) CALL MPI_RECV(top_graph%JCN_LOC(TOP_CNT+1), I, & MPI_INTEGER, PROC-1, ITAG, id%COMM, STATUS, IERR) RCVCNT(PROC) = RCVCNT(PROC)-I TOP_CNT = TOP_CNT+I END DO END DO ELSE DO WHILE (TOP_CNT .GT. 0) I = int(MIN(int(BUFSIZE,8), TOP_CNT)) CALL MPI_SEND(TSENDI(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) CALL MPI_SEND(TSENDJ(TOP_CNT-I+1), I, & MPI_INTEGER, 0, ITAG, id%COMM, IERR) TOP_CNT = TOP_CNT-I END DO END IF CALL MUMPS_DEALLOC(BUFLEVEL, RDISPL, TSENDI, & TSENDJ, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(MSGCNT, SNDCNT, RCVCNT, MEMCNT=MEMCNT) DEALLOCATE(APNT) 90 continue RETURN END SUBROUTINE SMUMPS_BUILD_LOC_GRAPH SUBROUTINE SMUMPS_SEND_BUF(APNT, PROC, NPROCS, BUFSIZE, IPE, PE, & LENG, RCVBUF, MSGCNT, SNDCNT, COMM) IMPLICIT NONE INTEGER :: NPROCS, PROC, COMM, allocok TYPE(ARRPNT) :: APNT(:) INTEGER :: BUFSIZE INTEGER, POINTER :: RCVBUF(:), LENG(:), PE(:) INTEGER :: SNDCNT(:) INTEGER(8) :: MSGCNT(:), IPE(:) LOGICAL, SAVE :: INIT = .TRUE. INTEGER, POINTER, SAVE :: SPACE(:,:,:) LOGICAL, POINTER, SAVE :: PENDING(:) INTEGER, POINTER, SAVE :: REQ(:), CPNT(:) INTEGER :: IERR, MYID, I, SOURCE INTEGER(8) :: TOTMSG LOGICAL :: FLAG, TFLAG INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: TSTATUS(MPI_STATUS_SIZE) INTEGER, PARAMETER :: ITAG=30, FTAG=31 INTEGER, POINTER :: TMPI(:), RCVCNT(:) CALL MPI_COMM_RANK (COMM, MYID, IERR) CALL MPI_COMM_SIZE (COMM, NPROCS, IERR) IF(INIT) THEN ALLOCATE(SPACE(2*BUFSIZE, 2, NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of SPACE in SMUMPS_SEND_BUF" return ENDIF ALLOCATE(RCVBUF(2*BUFSIZE), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVBUF in SMUMPS_SEND_BUF" return ENDIF ALLOCATE(PENDING(NPROCS), CPNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of PENDING/CPNT" & ," in SMUMPS_SEND_BUF" return ENDIF ALLOCATE(REQ(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of REQ in SMUMPS_SEND_BUF" return ENDIF PENDING = .FALSE. DO I=1, NPROCS APNT(I)%BUF => SPACE(:,1,I) CPNT(I) = 1 END DO INIT = .FALSE. RETURN END IF IF(PROC .EQ. -1) THEN TOTMSG = sum(MSGCNT) DO IF(TOTMSG .EQ. 0) EXIT CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, ITAG, COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) SOURCE = STATUS(MPI_SOURCE) TOTMSG = TOTMSG-1 MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END DO DO I=1, NPROCS IF(PENDING(I)) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO ALLOCATE(RCVCNT(NPROCS), stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of RCVCNT in SMUMPS_SEND_BUF" return ENDIF CALL MPI_ALLTOALL(SNDCNT(1), 1, MPI_INTEGER, RCVCNT(1), 1, & MPI_INTEGER, COMM, IERR) DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN TMPI => APNT(I)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*SNDCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, REQ(I), IERR) END IF END DO DO I=1, NPROCS IF(RCVCNT(I) .GT. 0) THEN CALL MPI_RECV(RCVBUF(1), 2*RCVCNT(I), MPI_INTEGER, I-1, & FTAG, COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(RCVCNT(I), RCVBUF, & IPE, PE, LENG) END IF END DO DO I=1, NPROCS IF(SNDCNT(I) .GT. 0) THEN CALL MPI_WAIT(REQ(I), TSTATUS, IERR) END IF END DO DEALLOCATE(SPACE) DEALLOCATE(PENDING, CPNT) DEALLOCATE(REQ) DEALLOCATE(RCVBUF, RCVCNT) nullify(SPACE, PENDING, CPNT, REQ, RCVBUF, RCVCNT) INIT = .TRUE. RETURN END IF IF(PENDING(PROC)) THEN DO CALL MPI_TEST(REQ(PROC), TFLAG, TSTATUS, IERR) IF(TFLAG) THEN PENDING(PROC) = .FALSE. EXIT ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, ITAG, COMM, & FLAG, STATUS, IERR ) IF(FLAG) THEN SOURCE = STATUS(MPI_SOURCE) CALL MPI_RECV(RCVBUF(1), 2*BUFSIZE, MPI_INTEGER, & SOURCE, ITAG, COMM, STATUS, IERR) CALL SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, & PE, LENG) MSGCNT(SOURCE+1)=MSGCNT(SOURCE+1)-1 END IF END IF END DO END IF TMPI => APNT(PROC)%BUF(:) CALL MPI_ISEND(TMPI(1), 2*BUFSIZE, MPI_INTEGER, PROC-1, & ITAG, COMM, REQ(PROC), IERR) PENDING(PROC) = .TRUE. CPNT(PROC) = mod(CPNT(PROC),2)+1 APNT(PROC)%BUF => SPACE(:,CPNT(PROC),PROC) SNDCNT(PROC) = 0 RETURN END SUBROUTINE SMUMPS_SEND_BUF SUBROUTINE SMUMPS_ASSEMBLE_MSG(BUFSIZE, RCVBUF, IPE, PE, LENG) IMPLICIT NONE INTEGER :: BUFSIZE INTEGER :: RCVBUF(:), PE(:), LENG(:) INTEGER(8) :: IPE(:) INTEGER :: I, ROW, COL DO I=1, 2*BUFSIZE, 2 ROW = RCVBUF(I) COL = RCVBUF(I+1) PE(IPE(ROW)+LENG(ROW)) = COL LENG(ROW) = LENG(ROW) + 1 END DO RETURN END SUBROUTINE SMUMPS_ASSEMBLE_MSG #if defined(ptscotch) || defined(parmetis) || defined(parmetis3) SUBROUTINE SMUMPS_BUILD_TREE(ord) TYPE(ORD_TYPE) :: ord INTEGER :: I ord%SON = -1 ord%BROTHER = -1 ord%NW = 0 DO I=1, ord%CBLKNBR ord%NW(I) = ord%NW(I)+ord%RANGTAB(I+1) - ord%RANGTAB(I) IF (ord%TREETAB(I) .NE. -1) THEN IF (ord%SON(ord%TREETAB(I)) .EQ. -1) THEN ord%SON(ord%TREETAB(I)) = I ELSE ord%BROTHER(I) = ord%SON(ord%TREETAB(I)) ord%SON(ord%TREETAB(I)) = I END IF ord%NW(ord%TREETAB(I)) = ord%NW(ord%TREETAB(I))+ ord%NW(I) END IF END DO RETURN END SUBROUTINE SMUMPS_BUILD_TREE SUBROUTINE SMUMPS_GRAPH_DIST(id, ord, FIRST, & LAST, BASE, NPROCS, WORK, TYPE) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: FIRST(:), LAST(:), BASE, NPROCS, TYPE INTEGER, TARGET :: WORK(:) INTEGER, POINTER :: TMP(:), NZ_ROW(:) INTEGER :: I, IERR, P, F, J INTEGER(8) :: LOCNNZ, INNZ, LOCOFFDIAG, & OFFDIAG, T, SHARE DO I=0, BASE-1 FIRST(I+1) = 0 LAST(I+1) = -1 END DO IF(TYPE.EQ.1) THEN SHARE = int(id%N/ord%NSLAVES,8) DO I=1, ord%NSLAVES FIRST(BASE+I) = (I-1)*int(SHARE)+1 LAST (BASE+I) = (I)*int(SHARE) END DO LAST(BASE+ord%NSLAVES) = MAX(LAST(BASE+ord%NSLAVES), id%N) DO I = ord%NSLAVES+1, id%NSLAVES+1 FIRST(BASE+I) = id%N+1 LAST (BASE+I) = id%N END DO ELSE IF (TYPE.EQ.2) THEN TMP => WORK(1:id%N) NZ_ROW => WORK(id%N+1:2*id%N) TMP = 0 LOCOFFDIAG = 0_8 LOCNNZ = id%KEEP8(29) DO INNZ=1, LOCNNZ IF(id%IRN_loc(INNZ) .NE. id%JCN_loc(INNZ)) THEN TMP(id%IRN_loc(INNZ)) = TMP(id%IRN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 IF(id%SYM.GT.0) THEN TMP(id%JCN_loc(INNZ)) = TMP(id%JCN_loc(INNZ))+1 LOCOFFDIAG = LOCOFFDIAG+1 END IF END IF END DO CALL MPI_ALLREDUCE(TMP(1), NZ_ROW(1), id%N, & MPI_INTEGER, MPI_SUM, id%COMM, IERR) CALL MPI_ALLREDUCE(LOCOFFDIAG, OFFDIAG, 1, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR) nullify(TMP) SHARE = (OFFDIAG-1_8)/int(ord%NSLAVES,8) + 1_8 P = 0 T = 0_8 F = 1 DO I=1, id%N T = T+int(NZ_ROW(I),8) IF ( & (T .GE. SHARE) .OR. & ((id%N-I).EQ.(ord%NSLAVES-P-1)) .OR. & (I.EQ.id%N) & ) THEN P = P+1 IF(P.EQ.ord%NSLAVES) THEN FIRST(BASE+P) = F LAST(BASE+P) = id%N EXIT ELSE FIRST(BASE+P) = F LAST(BASE+P) = I F = I+1 T = 0_8 END IF END IF END DO DO J=P+1, NPROCS+1-BASE FIRST(BASE+J) = id%N+1 LAST(BASE+J) = id%N END DO END IF RETURN END SUBROUTINE SMUMPS_GRAPH_DIST #endif SUBROUTINE SMUMPS_MERGESWAP(N, L, A1, A2) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A1(:), A2(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A1(LP) A1(LP) = A1(I) A1(I) = ISWAP ISWAP = A2(LP) A2(LP) = A2(I) A2(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE SMUMPS_MERGESWAP #if defined(DETERMINISTIC_PARALLEL_GRAPH) SUBROUTINE SMUMPS_MERGESWAP1(N, L, A) INTEGER :: I, LP, ISWAP, N INTEGER :: L(0:), A(:) LP = L(0) I = 1 DO IF ((LP==0).OR.(I>N)) EXIT DO IF (LP >= I) EXIT LP = L(LP) END DO ISWAP = A(LP) A(LP) = A(I) A(I) = ISWAP ISWAP = L(LP) L(LP) = L(I) L(I) = LP LP = ISWAP I = I + 1 ENDDO END SUBROUTINE SMUMPS_MERGESWAP1 #endif SUBROUTINE SMUMPS_MERGESORT(N, K, L) INTEGER :: N INTEGER :: K(:), L(0:) INTEGER :: P, Q, S, T CONTINUE L(0) = 1 T = N + 1 DO P = 1,N - 1 IF (K(P) <= K(P+1)) THEN L(P) = P + 1 ELSE L(T) = - (P+1) T = P END IF END DO L(T) = 0 L(N) = 0 IF (L(N+1) == 0) THEN RETURN ELSE L(N+1) = iabs(L(N+1)) END IF 200 CONTINUE S = 0 T = N+1 P = L(S) Q = L(T) IF(Q .EQ. 0) RETURN 300 CONTINUE IF(K(P) .GT. K(Q)) GOTO 600 CONTINUE L(S) = sign(P,L(S)) S = P P = L(P) IF (P .GT. 0) GOTO 300 CONTINUE L(S) = Q S = T DO T = Q Q = L(Q) IF (Q .LE. 0) EXIT END DO GOTO 800 600 CONTINUE L(S) = sign(Q, L(S)) S = Q Q = L(Q) IF (Q .GT. 0) GOTO 300 CONTINUE L(S) = P S = T DO T = P P = L(P) IF (P .LE. 0) EXIT END DO 800 CONTINUE P = -P Q = -Q IF(Q.EQ.0) THEN L(S) = sign(P, L(S)) L(T) = 0 GOTO 200 END IF GOTO 300 END SUBROUTINE SMUMPS_MERGESORT FUNCTION MUMPS_GETSIZE(A) INTEGER, POINTER :: A(:) INTEGER :: MUMPS_GETSIZE IF(associated(A)) THEN MUMPS_GETSIZE = size(A) ELSE MUMPS_GETSIZE = 0_8 END IF RETURN END FUNCTION MUMPS_GETSIZE #if defined(parmetis) || defined(parmetis3) SUBROUTINE MUMPS_PARMETIS_MIXEDto32(id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER, POINTER :: VERTLOCTAB_I4(:) IF( VERTLOCTAB(VERTLOCNBR+1).GT.huge(VERTLOCNBR)) THEN id%INFO(1) = -51 CALL MUMPS_SET_IERROR( & VERTLOCTAB(VERTLOCNBR+1), id%INFO(2)) RETURN END IF nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) CALL MUMPS_PARMETIS(FIRST(1+BASE), VERTLOCTAB_I4(1), & EDGELOCTAB(1), BASEVAL, OPTIONS(1), ORDER(1), & SIZES(1), COMM, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto32 SUBROUTINE MUMPS_PARMETIS_MIXEDto64 & (id, BASE, VERTLOCNBR, FIRST, & VERTLOCTAB, EDGELOCTAB, BASEVAL, OPTIONS, ORDER, & SIZES, COMM, IERR) IMPLICIT NONE TYPE(SMUMPS_STRUC) :: id INTEGER :: FIRST(:), EDGELOCTAB(:), OPTIONS(:) INTEGER :: SIZES(:), ORDER(:) INTEGER(8) :: VERTLOCTAB(:) INTEGER :: VERTLOCNBR, BASEVAL, IERR, COMM, BASE INTEGER(8), POINTER :: FIRST_I8(:), EDGELOCTAB_I8(:), & SIZES_I8(:), ORDER_I8(:) #if defined(parmetis) INTEGER(8), POINTER :: OPTIONS_I8(:) INTEGER(8) :: BASEVAL_I8 nullify(OPTIONS_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC(OPTIONS_I8, size(OPTIONS), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(OPTIONS(1), size(OPTIONS) & , OPTIONS_I8(1)) BASEVAL_I8 = int(BASEVAL,8) END IF #endif nullify(FIRST_I8, EDGELOCTAB_I8, SIZES_I8, ORDER_I8) IF (id%KEEP(10).EQ.1) THEN CALL MUMPS_PARMETIS_64(FIRST(1+BASE), VERTLOCTAB(1), & EDGELOCTAB(1), & BASEVAL, OPTIONS(1), & ORDER(1), & SIZES(1), COMM, IERR) ELSE CALL MUMPS_I8REALLOC(FIRST_I8, size(FIRST), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(SIZES_I8, size(SIZES), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(ORDER_I8, size(ORDER), id%INFO, & id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64(FIRST(1), size(FIRST), FIRST_I8(1)) CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) CALL MUMPS_PARMETIS_64(FIRST_I8(1+BASE), VERTLOCTAB(1), & EDGELOCTAB_I8(1), #if defined(parmetis3) & BASEVAL, OPTIONS(1), #else & BASEVAL_I8, OPTIONS_I8(1), #endif & ORDER_I8(1), & SIZES_I8(1), COMM, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL MUMPS_ICOPY_64TO32(ORDER_I8(1), & size(ORDER), ORDER(1)) CALL MUMPS_ICOPY_64TO32(SIZES_I8(1), & size(SIZES), SIZES(1)) 10 CONTINUE CALL MUMPS_I8DEALLOC(FIRST_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(SIZES_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(ORDER_I8, MEMCNT=MEMCNT) #if defined(parmetis) CALL MUMPS_I8DEALLOC(OPTIONS_I8, MEMCNT=MEMCNT) #endif RETURN END SUBROUTINE MUMPS_PARMETIS_MIXEDto64 #endif #if defined(ptscotch) SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER, POINTER :: VERTLOCTAB_I4(:) INTEGER :: EDGELOCNBR_I4, MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 nullify(VERTLOCTAB_I4) CALL MUMPS_REALLOC(VERTLOCTAB_I4, VERTLOCNBR+1, id%INFO, LP, & MEMCNT=MEMCNT, ERRCODE=-7) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_64TO32(VERTLOCTAB(1), & VERTLOCNBR+1, VERTLOCTAB_I4(1)) EDGELOCNBR_I4 = int(EDGELOCNBR) IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB_I4(1), VERTLOCTAB_I4(2), & VERTLOCTAB_I4(1), VERTLOCTAB_I4(1), EDGELOCNBR_I4, & EDGELOCNBR_I4, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1), ord%TREETAB(1), IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) & CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE CALL MUMPS_DEALLOC(VERTLOCTAB_I4, MEMCNT=MEMCNT) RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto32 SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64(id, ord, & BASEVAL, & VERTLOCNBR, VERTLOCTAB, & EDGELOCNBR, EDGELOCTAB, & IERR) IMPLICIT NONE INCLUDE 'ptscotchf.h' TYPE(SMUMPS_STRUC) :: id TYPE(ORD_TYPE) :: ord INTEGER :: BASEVAL, VERTLOCNBR INTEGER(8) :: EDGELOCNBR INTEGER(8) :: VERTLOCTAB(:) INTEGER :: EDGELOCTAB(:) INTEGER :: IERR INTEGER :: MYWORKID DOUBLE PRECISION :: GRAPHDAT(SCOTCH_DGRAPHDIM), & ORDEDAT(SCOTCH_DORDERDIM), STRADAT(SCOTCH_STRATDIM), & CORDEDAT(SCOTCH_ORDERDIM) CHARACTER STRSTRING*1024 INTEGER(8), POINTER :: EDGELOCTAB_I8(:), PERMTAB_I8(:), & PERITAB_I8(:), RANGTAB_I8(:), TREETAB_I8(:) INTEGER(8) :: CBLKNBR_I8, VERTLOCNBR_I8, BASEVAL_I8 IF(ord%SUBSTRAT .NE. 0) THEN STRSTRING='n{sep=m{asc=b{width=3,strat=q{strat=f}},'// & 'low=q{strat=h},vert=1000,dvert=100,dlevl=0,'// & 'proc=1,seq=q{strat=m{type=h,vert=100,'// & 'low=h{pass=10},asc=b{width=3,bnd=f{bal=0.2},'// & 'org=h{pass=10}f{bal=0.2}}}}},ole=s,ose=s,osq=s}' END IF IF(ord%IDO) THEN CALL MPI_COMM_RANK (ord%COMM_NODES, MYWORKID, IERR) ELSE MYWORKID = -1 END IF nullify(EDGELOCTAB_I8, PERMTAB_I8, PERITAB_I8, & RANGTAB_I8, TREETAB_I8) IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8REALLOC8(EDGELOCTAB_I8, & VERTLOCTAB(VERTLOCNBR+1)-1_8, & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 IF (MYWORKID .EQ. 0) THEN CALL MUMPS_I8REALLOC(PERMTAB_I8, size(ord%PERMTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(PERITAB_I8, size(ord%PERITAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(TREETAB_I8, size(ord%TREETAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) IF ( id%INFO(1) .LT. 0 ) GOTO 5 CALL MUMPS_I8REALLOC(RANGTAB_I8, size(ord%RANGTAB), & id%INFO, id%ICNTL(1), MEMCNT=MEMCNT, ERRCODE=-7) END IF 5 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_ICOPY_32TO64_64C(EDGELOCTAB(1), & VERTLOCTAB(VERTLOCNBR+1)-1_8, EDGELOCTAB_I8(1)) BASEVAL_I8 = int(BASEVAL,8) VERTLOCNBR_I8 = int(VERTLOCNBR,8) ENDIF CALL MUMPS_DGRAPHINIT(GRAPHDAT, ord%COMM_NODES, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL_I8, VERTLOCNBR_I8, & VERTLOCNBR_I8, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB_I8(1), EDGELOCTAB_I8(1), & EDGELOCTAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHBUILD(GRAPHDAT, BASEVAL, VERTLOCNBR, & VERTLOCNBR, VERTLOCTAB(1), VERTLOCTAB(2), & VERTLOCTAB(1), VERTLOCTAB(1), EDGELOCNBR, & EDGELOCNBR, EDGELOCTAB(1), EDGELOCTAB(1), & EDGELOCTAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFSTRATINIT(STRADAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(ord%SUBSTRAT .NE. 0) THEN CALL SCOTCHFSTRATDGRAPHORDER(STRADAT, STRSTRING, IERR) END IF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERINIT(GRAPHDAT, ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDERCOMPUTE(GRAPHDAT, ORDEDAT, STRADAT, & IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN IF (id%KEEP(10).NE.1) THEN CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & PERMTAB_I8(1), PERITAB_I8(1), CBLKNBR_I8, RANGTAB_I8(1), & TREETAB_I8(1), IERR) ELSE CALL SCOTCHFDGRAPHCORDERINIT(GRAPHDAT, CORDEDAT, & ord%PERMTAB(1), ord%PERITAB(1), ord%CBLKNBR, & ord%RANGTAB(1),ord%TREETAB(1), IERR) ENDIF IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & CORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF ELSE CALL SCOTCHFDGRAPHORDERGATHER(GRAPHDAT, ORDEDAT, & ORDEDAT, IERR) IF(IERR.NE.0) THEN id%INFO(1:2) = -50 END IF END IF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & ord%COMM_NODES, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 10 CALL SCOTCHFDGRAPHORDEREXIT(GRAPHDAT, ORDEDAT) CALL SCOTCHFSTRATEXIT(STRADAT) CALL SCOTCHFDGRAPHEXIT(GRAPHDAT) 10 CONTINUE IF (id%KEEP(10).NE.1) THEN CALL MUMPS_I8DEALLOC(EDGELOCTAB_I8, MEMCNT=MEMCNT) IF(MYWORKID .EQ. 0) THEN CALL SCOTCHFDGRAPHCORDEREXIT(GRAPHDAT, CORDEDAT) CALL MUMPS_ICOPY_64TO32(PERMTAB_I8(1), & size(ord%PERMTAB), ord%PERMTAB(1)) CALL MUMPS_ICOPY_64TO32(PERITAB_I8(1), & size(ord%PERITAB), ord%PERITAB(1)) CALL MUMPS_ICOPY_64TO32(TREETAB_I8(1), & size(ord%TREETAB), ord%TREETAB(1)) CALL MUMPS_ICOPY_64TO32(RANGTAB_I8(1), & size(ord%RANGTAB), ord%RANGTAB(1)) ord%CBLKNBR = int(CBLKNBR_I8) CALL MUMPS_I8DEALLOC(PERMTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(PERITAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(RANGTAB_I8, MEMCNT=MEMCNT) CALL MUMPS_I8DEALLOC(TREETAB_I8, MEMCNT=MEMCNT) END IF ENDIF RETURN END SUBROUTINE MUMPS_PTSCOTCH_MIXEDto64 #endif END MODULE MUMPS_5.4.1/src/comp_tps_m.F0000664000175000017500000000101714102210524015752 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE CMUMPS_TPS_M_RETURN MUMPS_5.4.1/src/zsol_aux.F0000664000175000017500000013466114102210524015472 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX(kind=8) W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE ZMUMPS_FREETOPSO SUBROUTINE ZMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) COMPLEX(kind=8) W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE ZMUMPS_COMPSO SUBROUTINE ZMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER N, I, J, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8) KEEP8(150) INTEGER IRN(NZ8), ICN(NZ8) COMPLEX(kind=8) A(NZ8) DOUBLE PRECISION Z(N) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SOL_X SUBROUTINE ZMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8), INTENT(IN) :: A(NZ8) DOUBLE PRECISION, INTENT(IN) :: COLSCA(N) DOUBLE PRECISION, INTENT(OUT) :: Z(N) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER :: I, J INTEGER(8) :: K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_SCAL_X SUBROUTINE ZMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) COMPLEX(kind=8), INTENT(IN) :: A(NZ8), RHS(N), X(N) DOUBLE PRECISION, INTENT(OUT) :: W(N) COMPLEX(kind=8), INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 COMPLEX(kind=8) D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SOL_Y SUBROUTINE ZMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N DOUBLE PRECISION, intent(in) :: W(N) COMPLEX(kind=8), intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOL_MULR SUBROUTINE ZMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) COMPLEX(kind=8) W(N), X(N) DOUBLE PRECISION, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, real, sign INTEGER ZMUMPS_IXAMAX EXTERNAL ZMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN DOUBLE PRECISION TEMP SAVE ITER, J, JLAST, JUMP COMPLEX(kind=8) ZERO, ONE PARAMETER( ZERO = (0.0D0,0.0D0) ) PARAMETER( ONE = (1.0D0,0.0D0) ) DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / dble(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = cmplx( sign(RONE,dble(X(I))), kind=kind(X)) IW(I) = nint(dble(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = ZMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, dble(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = cmplx( sign(RONE, dble(X(I))), kind=kind(X) ) IW(I) = nint(dble(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = ZMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = cmplx(ALTSGN * (RONE + dble(I - 1) / dble(N - 1)), & kind=kind(X)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0D0 * TEMP / dble(3 * N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE ZMUMPS_SOL_B SUBROUTINE ZMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8), INTENT(IN) :: ASPK( NZ8 ) COMPLEX(kind=8), INTENT(IN) :: LHS( N ), WRHS( N ) COMPLEX(kind=8), INTENT(OUT):: RHS( N ) DOUBLE PRECISION, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_QD2 SUBROUTINE ZMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) A_ELT(NA_ELT8) COMPLEX(kind=8) LHS( N ), WRHS( N ), RHS( N ) DOUBLE PRECISION W(N) CALL ZMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL ZMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE ZMUMPS_ELTQD2 SUBROUTINE ZMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) A_ELT(NA_ELT8) DOUBLE PRECISION TEMP DOUBLE PRECISION W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_X_ELT SUBROUTINE ZMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION COLSCA(N) COMPLEX(kind=8) A_ELT(NA_ELT8) DOUBLE PRECISION W(N) DOUBLE PRECISION TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_SCALX_ELT SUBROUTINE ZMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) COMPLEX(kind=8) A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) DOUBLE PRECISION W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR DOUBLE PRECISION ZERO COMPLEX(kind=8) TEMP DOUBLE PRECISION TEMP2 PARAMETER( ZERO = 0.0D0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE ZMUMPS_ELTYD SUBROUTINE ZMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE ZMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR COMPLEX(kind=8) A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=ZMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL ZMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL ZMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE ZMUMPS_BUILD_MAPPING_INFO(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(ZMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE ZMUMPS_BUILD_MAPPING_INFO SUBROUTINE ZMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) COMPLEX(kind=8) RHS(N) COMPLEX(kind=8) X(N), Y(N) DOUBLE PRECISION R_W(N,2) COMPLEX(kind=8) C_W(N) INTEGER LP, NOITER LOGICAL TESTConv DOUBLE PRECISION OMEGA(2) DOUBLE PRECISION ARRET INTEGER, intent(in) :: GRAIN DOUBLE PRECISION, PARAMETER :: CGCE=0.2D0 DOUBLE PRECISION, PARAMETER :: CTAU=1.0D3 INTEGER I, IMAX DOUBLE PRECISION OM1, OM2, DXMAX DOUBLE PRECISION TAU, DD DOUBLE PRECISION OLDOMG(2) DOUBLE PRECISION, PARAMETER :: ZERO=0.0D0 DOUBLE PRECISION, PARAMETER :: ONE=1.0D0 INTEGER ZMUMPS_IXAMAX INTRINSIC abs, max SAVE OM1, OLDOMG IMAX = ZMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * dble(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOL_OMEGA SUBROUTINE ZMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) COMPLEX(kind=8) RHS(N) COMPLEX(kind=8) X(N), Y(N) DOUBLE PRECISION D(N) DOUBLE PRECISION R_W(N,2) COMPLEX(kind=8) C_W(N) INTEGER LP DOUBLE PRECISION COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX DOUBLE PRECISION ERX, DXMAX DOUBLE PRECISION DXIMAX DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 INTEGER ZMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = ZMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = ZMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL ZMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL ZMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL ZMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL ZMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE ZMUMPS_SOL_LCOND SUBROUTINE ZMUMPS_SOL_CPY_FS2RHSCOMP( JBDEB, JBFIN, NBROWS, & KEEP, RHSCOMP, NRHS, LRHSCOMP, FIRST_ROW_RHSCOMP, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSCOMP INTEGER :: FIRST_ROW_RHSCOMP INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LD_W, FIRST_ROW_W COMPLEX(kind=8) :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSCOMP(FIRST_ROW_RHSCOMP+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_SOL_CPY_FS2RHSCOMP SUBROUTINE ZMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSCOMP INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) COMPLEX(kind=8) :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSCOMP(IPOSINRHSCOMP,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_SOL_BWD_GTHR SUBROUTINE ZMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) RES(N),LHS(N) COMPLEX(kind=8) WRHS(N) DOUBLE PRECISION W(N) DOUBLE PRECISION RESMAX,RESL2,XNORM, SCLNRM DOUBLE PRECISION ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0D0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (MAX-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (MAX-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (MAX-NORM)=',1PD9.2) RETURN END SUBROUTINE ZMUMPS_SOL_Q SUBROUTINE ZMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE ZMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ztrsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL ztrsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE ZMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE ZMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY COMPLEX(kind=8), INTENT(IN) :: A(LA) COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8), INTENT(IN) :: COEF_Y COMPLEX(kind=8) ALPHA, ZERO, ONE PARAMETER (ZERO=(0.0D0,0.0D0), ONE=(1.0D0,0.0D0), & ALPHA=(-1.0D0,0.0D0)) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL zgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL zgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL zgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE ZMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) USE ZMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) COMPLEX(kind=8), INTENT(IN) :: WCB( LWCB ), A( LA ) COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: TempNROW, J1, J3, PANEL_SIZE, TYPEF INTEGER :: IPOSINRHSCOMP, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 COMPLEX(kind=8) :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL TYPEF= TYPEF_U ENDIF PANEL_SIZE = ZMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_LD_AND_RELOAD SUBROUTINE ZMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_DOUBLE_PRECISION, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_SCALING_LOC MUMPS_5.4.1/src/sfac_mem_dynamic.F0000664000175000017500000005235514102210521017100 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE SMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST REAL, INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_F2003) REAL, POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #else REAL, POINTER, DIMENSION(:) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( SMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL SMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE SMUMPS_DM_SET_DYNPTR SUBROUTINE SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (SMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE SMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION SMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); SMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); SMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); SMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during SMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION SMUMPS_DM_ISBAND LOGICAL FUNCTION SMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) SMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION SMUMPS_DM_IS_DYNAMIC SUBROUTINE SMUMPS_DM_FAC_UPD_DYN_MEMCNTS & ( MEM_COUNT_ALLOCATED, ATOMIC_UPDATES, KEEP8, & IFLAG, IERROR, K69UPD_ARG ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_ALLOCATED INTEGER(8), INTENT(INOUT) :: KEEP8(150) LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER, INTENT(INOUT) :: IFLAG, IERROR LOGICAL, INTENT(IN), OPTIONAL :: K69UPD_ARG LOGICAL K69UPD INTEGER(8) :: KEEP8TMPCOPY K69UPD = .TRUE. IF (present(K69UPD_ARG)) THEN IF ( .NOT. K69UPD_ARG ) THEN K69UPD = .FALSE. ENDIF ENDIF IF (MEM_COUNT_ALLOCATED.GT.0) THEN IF (ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP8(73)) ENDIF IF ( KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8TMPCOPY-KEEP8(75)), IERROR) ENDIF IF ( K69UPD ) THEN IF ( ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8(68) = max(KEEP8(69), KEEP8(68)) ENDIF ENDIF ELSE IF (ATOMIC_UPDATES) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC IF ( K69UPD ) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC ENDIF ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED IF ( K69UPD ) THEN KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED ENDIF ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_DM_FAC_UPD_DYN_MEMCNTS SUBROUTINE SMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE SMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE SMUMPS_LOAD, ONLY : SMUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS REAL, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 REAL, DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. SMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in SMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL SMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in SMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL SMUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL SMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST REAL, DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL SMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in SMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL SMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL SMUMPS_DM_FREE_BLOCK( TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE SMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE SMUMPS_STATIC_PTR_M, ONLY : SMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_F2003) REAL, DIMENSION(:), POINTER, INTENT(out) :: CBPTR #else REAL, DIMENSION(:), POINTER :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL SMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL SMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE SMUMPS_DM_SET_PTR SUBROUTINE SMUMPS_DM_FREE_BLOCK( DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE REAL, POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY DEALLOCATE(DYNPTR) NULLIFY(DYNPTR) CALL SMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY) RETURN END SUBROUTINE SMUMPS_DM_FREE_BLOCK END MODULE SMUMPS_DYNAMIC_MEMORY_M SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL SMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE SMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS REAL, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL SMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE SMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.4.1/src/sfac_front_LU_type2.F0000664000175000017500000011464014102210521017465 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC2_LU_M CONTAINS SUBROUTINE SMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, & UU, NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, & PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP,PIVNUL_LIST,LPN_LIST & , LRGROUPS & ) !$ USE OMP_LIB USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_FAC_FRONT_TYPE2_AUX_M USE SMUMPS_OOC USE SMUMPS_BUF, ONLY : SMUMPS_BUF_TEST USE SMUMPS_FAC_LR USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M !$ USE OMP_LIB USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW INTEGER, intent(inout) :: NOFFW, NPVW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER(8) :: LA INTEGER IW( LIW ) REAL A( LA ) REAL UU, SEUIL TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER LPTRAR, NELT INTEGER ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) INTEGER NBFIN, SLAVEF, & IFLAG, IERROR, LEAF, LPOOL INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N), & PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL AVOID_DELAYED INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER :: IBEG_BLOCK_FOR_IPIV INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv LOGICAL LASTBL INTEGER(8) :: POSELT INTEGER IOLDPS, allocok, K263,J INTEGER idummy REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC INTEGER , ALLOCATABLE, DIMENSION ( : ) :: IPIV INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER CURRENT_BLR, NELIM LOGICAL LR_ACTIVATED, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: IROW_L, NVSCHUR, NSLAVES INTEGER :: PIVOT_OPTION, LAST_COL, FIRST_COL INTEGER :: PARPIV_T1 INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER :: INFO_TMP(2) INTEGER :: MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR, END_I INTEGER MAXI_CLUSTER, LWORK TYPE(LRB_TYPE), DIMENSION(1), TARGET :: BLR_DUMMY INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L, BLR_U, BLR_SEND REAL, POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP, BEGS_BLR_STATIC INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, IP, MEM, & MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL, ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: OMP_NUM INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM INTEGER :: NOMP INCLUDE 'mumps_headers.h' NULLIFY(BLR_L,BLR_U) NULLIFY(PTDummy) NULLIFY(ACC_LUA) NULLIFY(BEGS_BLR) NULLIFY(BLR_L, BLR_U, BLR_SEND) NULLIFY(DIAG) NULLIFY(BLR_PANEL) NULLIFY( BEGS_BLR_TMP, BEGS_BLR_STATIC) IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF NOMP=1 !$ NOMP=OMP_GET_MAX_THREADS() idummy = 0 IOLDPS = PTLUST_S(STEP( INODE )) POSELT = PTRAST(STEP( INODE )) XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) PARPIV_T1 = 0 INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN NSLAVES = IW(IOLDPS+5+XSIZE) IROW_L = IOLDPS+6+XSIZE+NSLAVES+NASS CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IF (LR_ACTIVATED) THEN K263 = 1 ELSE K263 = KEEP(263) IF (K263 .NE. 0 .AND. NASS/NBLR_ORIG < 4) THEN IF ( NBLR_ORIG .GT. NBKJIB_ORIG * 4 ) THEN NBLR_ORIG = max(NBKJIB_ORIG, (NASS+3)/4) ELSE K263 = 0 ENDIF ENDIF ENDIF PIVOT_OPTION = KEEP(468) IF ( UUTEMP == 0.0E0 .AND. & .NOT.( & OOC_EFFECTIVE_ON_FRONT & ) & ) THEN IF (K263.EQ.1.AND.(.NOT.LR_ACTIVATED)) THEN PIVOT_OPTION = 0 ENDIF ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 ALLOCATE( IPIV( NASS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) MYID,' : SMUMPS_FAC2_LU :failed to allocate ', & NASS, ' integers' IFLAG = -13 IERROR =NASS GO TO 490 END IF CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 2 MonBloc%NROW = NASS MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -68877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN PIVOT_OPTION = 4 IF (KEEP(475).EQ.1) THEN PIVOT_OPTION = 3 ELSEIF (KEEP(475).EQ.2) THEN PIVOT_OPTION = 2 ELSEIF (KEEP(475).EQ.3) THEN IF (UUTEMP == 0.0E0) THEN PIVOT_OPTION = 0 ELSE PIVOT_OPTION = 1 ENDIF ENDIF CNT_NODES = CNT_NODES + 1 ENDIF HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 480 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 480 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) & ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_INIT_FRONT(IW(IOLDPS+XXF), INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF LASTBL = .FALSE. DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED)THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE IF (K263.EQ.0) THEN IBEG_BLOCK_FOR_IPIV = IBEG_BLOCK ELSE IBEG_BLOCK_FOR_IPIV = IBEG_BLR ENDIF CALL SMUMPS_FAC_I(NFRONT,NASS,NASS, & IBEG_BLOCK_FOR_IPIV,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, & TIPIV=IPIV & ) IF (IFLAG.LT.0) GOTO 490 IF (INOPV.EQ.1) THEN IF (STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF (INOPV .LE. 0) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 NPVW = NPVW + 1 IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB .EQ. -1) THEN LASTBL = .TRUE. ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF (K263.EQ.0) THEN NELIM = IEND_BLR - NPIV CALL SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLOCK, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR,DBLARR, & ICNTL,KEEP,KEEP8, & DKEEP,ND,FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, .FALSE. & , NPARTSASS, CURRENT_BLR & , BLR_DUMMY, LRGROUPS & ) END IF IF ( IFLAG .LT. 0 ) GOTO 500 IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN CALL SMUMPS_BUF_TEST() IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED) ENDIF CALL SMUMPS_BUF_TEST() END DO NPIV = IW(IOLDPS+1+XSIZE) IF (LR_ACTIVATED) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NPARTSASS-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSASS-CURRENT_BLR GOTO 490 ENDIF NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NPARTSASS-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF GOTO 101 ENDIF END_I=NB_BLR #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), KEEP(473), BLR_U, & CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, 2, KEEP(483), KEEP8, & END_I_IN=END_I & ) IF (IFLAG.LT.0) GOTO 300 IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') #if defined(BLR_MT) !$OMP END MASTER #endif IF (PIVOT_OPTION.LT.3) THEN IF (PIVOT_OPTION.LT.2) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LAST_BLOCK=NB_BLR CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_U, CURRENT_BLR, & FIRST_BLOCK, LAST_BLOCK, 2, 0, 1, & .FALSE.) ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF 101 CONTINUE IF (LR_ACTIVATED .OR. (K263.NE.0.AND.PIVOT_OPTION.GE.3)) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, NFRONT, & IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF IF (.NOT. LR_ACTIVATED) THEN LAST_COL = NFRONT IF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = NPIV ENDIF IF (IEND_BLR.LT.NASS .OR. PIVOT_OPTION.LT.3) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, LAST_COL, & A, LA, POSELT, FIRST_COL, .TRUE., (PIVOT_OPTION.LT.3), & .TRUE., (KEEP(377).EQ.1), & LR_ACTIVATED) ENDIF IF (K263.NE.0 .AND. PIVOT_OPTION.LT.3) THEN NELIM = IEND_BLR - NPIV BLR_SEND=>BLR_DUMMY IF (associated(BLR_U)) THEN BLR_SEND=>BLR_U ENDIF CALL SMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, & NFRONT, IBEG_BLR, NPIV, IPIV, NASS,LASTBL, idummy, & COMM, MYID, BUFR, LBUFR, LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, STEP, & PIMASTER, PAMASTER, NSTK_S,PERM,PROCNODE_STEPS, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED & , NPARTSASS, CURRENT_BLR & , BLR_SEND, LRGROUPS & ) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 600 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 600 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (KEEP(475).EQ.0) THEN IF (IEND_BLR.LT.NFRONT) THEN CALL SMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & -77777, & A, LA, POSELT, & -77777, & .TRUE., .FALSE., .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NPARTSASS, DKEEP(8), KEEP(466), KEEP(473), & BLR_L, & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8 & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ((KEEP(480).NE.0.AND.NB_BLR.GT.CURRENT_BLR) & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NPARTSASS, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NPARTSASS, 2, 0, 0, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8 & ) IF (IFLAG.LT.0) GOTO 442 CALL SMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 2, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, KEEP8, & END_I_IN=END_I & ) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL SMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NPARTSASS, & BLR_U, NB_BLR, NELIM, .FALSE., 0, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(475).GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 IF (KEEP(486).EQ.2.AND.UU.EQ.0) THEN LAST_BLOCK = CURRENT_BLR ELSE LAST_BLOCK = NPARTSASS ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NPARTSASS, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (KEEP(475).GE.2) THEN IF (KEEP(475).EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = END_I ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_U, CURRENT_BLR, 'H', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 490 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & 0, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0.OR.NB_BLR.EQ.CURRENT_BLR) THEN CALL DEALLOC_BLR_PANEL(BLR_U, NB_BLR-CURRENT_BLR, & KEEP8) CALL DEALLOC_BLR_PANEL(BLR_L, NPARTSASS-CURRENT_BLR, & KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_TRY_WRITE MonBloc%LastPiv = NPIV LAST_CALL= .FALSE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+XSIZE) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 490 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF IF ( & (KEEP(486).EQ.2) & ) THEN MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM) #endif #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(68) = max(KEEP8(69), KEEP8(68)) !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(70) = max(KEEP8(71), KEEP8(70)) !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) !$OMP END ATOMIC KEEP8(74) = max(KEEP8(74), KEEP8(73)) IF ( KEEP8(74) .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8(74)-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 460 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), KEEP(473), & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 2, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 460 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF ENDIF IF ( (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NELIM) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NASS-NELIM, 0, 2) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 2) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 490 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 700 480 CONTINUE 490 CONTINUE 500 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 700 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM), KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) & THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8) ENDIF ENDIF DEALLOCATE( IPIV ) RETURN END SUBROUTINE SMUMPS_FAC2_LU END MODULE SMUMPS_FAC2_LU_M MUMPS_5.4.1/src/zfac_front_type2_aux.F0000664000175000017500000007102114102210525017750 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE ZMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE ZMUMPS_FAC_FRONT_AUX_M IMPLICIT NONE INTEGER SIZEDIAG_ORIG DOUBLE PRECISION DIAG_ORIG(SIZEDIAG_ORIG) DOUBLE PRECISION GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA COMPLEX(kind=8) A(LA) DOUBLE PRECISION UU, UULOC, SEUIL COMPLEX(kind=8) CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF DOUBLE PRECISION RMAX,AMAX,TMAX,RMAX_NORELAX DOUBLE PRECISION MAXPIV, ABS_PIVOT DOUBLE PRECISION RMAX_NOSLAVE, TMAX_NOSLAVE COMPLEX(kind=8) PIVOT,DETPIV DOUBLE PRECISION ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK DOUBLE PRECISION :: GROWTH, RSWOP DOUBLE PRECISION :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 COMPLEX(kind=8) ZERO, ONE PARAMETER( ZERO = (0.0D0,0.0D0) ) PARAMETER( ONE = (1.0D0,0.0D0) ) DOUBLE PRECISION PIVNUL, VALTMP COMPLEX(kind=8) FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L DOUBLE PRECISION GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (ABS_PIVOT.EQ.RZERO) GO TO 630 CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0D10*RMAX, sqrt(huge(RMAX))/1.0D8) A(POSPV1) = cmplx(VALTMP,kind=kind(A)) ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1,dble(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL ZMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE ZMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8) VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 COMPLEX(kind=8) ONE, ALPHA COMPLEX(kind=8) ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL zcopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL zcopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE ZMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_BLOCK, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_TYPE USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTBL COMPLEX(kind=8) A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(N) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in ZMUMPS_SEND_FACTORED_BLK ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_BLOCK + 1 NCOL = LDA_FS - IBEG_BLOCK + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) IF (IBEG_BLOCK > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_BLOCK-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL ZMUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTBL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL ZMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, & NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_SEND_FACTORED_BLK END MODULE ZMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.4.1/src/dana_aux.F0000664000175000017500000041202714102210522015377 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_ANA_AUX_M IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_ANA_F(N, NZ8, IRN, ICN, LIWALLOC, & IKEEP1, IKEEP2, IKEEP3, & IORD, NFSIZ, FILS, FRERE, LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, NSLAVES, PIV, & CNTL4, COLSCA, ROWSCA #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & , NORIG_ARG, SIZEOFBLOCKS, GCOMP_PROVIDED_IN, GCOMP & ) USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY : COMPACT_GRAPH_T IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR, NSLAVES INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: LIWALLOC INTEGER, INTENT(in) :: LISTVAR_SCHUR(:) INTEGER, POINTER :: IRN(:), ICN(:) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(:), FILS(:), FRERE(:) INTEGER, INTENT(INOUT) :: PIV(:) INTEGER, INTENT(INOUT) :: IKEEP1(:), IKEEP2(:), IKEEP3(:) DOUBLE PRECISION :: CNTL4 DOUBLE PRECISION, POINTER :: COLSCA(:), ROWSCA(:) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER, INTENT(IN), OPTIONAL :: NORIG_ARG INTEGER, INTENT(IN), OPTIONAL :: SIZEOFBLOCKS(N) LOGICAL, INTENT(IN), OPTIONAL :: GCOMP_PROVIDED_IN TYPE(COMPACT_GRAPH_T), OPTIONAL :: GCOMP INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: IWALLOC INTEGER, DIMENSION(:), POINTER :: IW INTEGER(8), DIMENSION(:), ALLOCATABLE, TARGET :: IPEALLOC INTEGER(8), DIMENSION(:), POINTER :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER, DIMENSION(:,:), ALLOCATABLE :: PTRAR INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:), ALLOCATABLE :: IWL1 INTEGER NBBUCK INTEGER, DIMENSION(:), ALLOCATABLE :: WTEMP INTEGER IERR INTEGER I, K, NCMPA, IN, IFSON INTEGER(8) :: J8, I8 INTEGER :: NORIG INTEGER(8) :: IFIRST, ILAST INTEGER(8) IWFR8 INTEGER NEMIN, LP, MP, LDIAG, ITEMP, symmetry INTEGER NBQD, AvgDens LOGICAL PROK, COMPRESS_SCHUR, LPOK, COMPUTE_PERM #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER NUMFLAG #endif INTEGER METIS_IDX_SIZE INTEGER OPT_METIS_SIZE #endif #if defined(scotch) || defined(ptscotch) INTEGER :: SCOTCH_INT_SIZE #endif #if defined(pord) INTEGER :: PORD_INT_SIZE #endif DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COLSCA_TEMP INTEGER THRESH, IVersion LOGICAL AGG6 INTEGER MINSYM PARAMETER (MINSYM=50) INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER MTRANS, COMPRESS,NCMP,IERROR,J,JPERM,NCST INTEGER TOTEL #if defined(pord) INTEGER TOTW #endif INTEGER WEIGHTUSED, WEIGHTREQUESTED LOGICAL IDENT,SPLITROOT LOGICAL FREE_CENTRALIZED_MATRIX LOGICAL GCOMP_PROVIDED LOGICAL INPLACE64_GRAPH_COPY, INPLACE64_RESTORE_GRAPH INTEGER(8) :: LIW8, NZG8 DOUBLE PRECISION TIMEB EXTERNAL MUMPS_ANA_H, DMUMPS_ANA_J, & DMUMPS_ANA_K, DMUMPS_ANA_GNEW, & DMUMPS_ANA_LNEW, DMUMPS_ANA_M #if defined(OLDDFS) EXTERNAL DMUMPS_ANA_L #endif EXTERNAL DMUMPS_GNEW_SCHUR EXTERNAL DMUMPS_LDLT_COMPRESS, DMUMPS_EXPAND_PERMUTATION, & DMUMPS_SET_CONSTRAINTS IF (LIWALLOC.GT.0_8) THEN ALLOCATE( IWALLOC (LIWALLOC), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 CALL MUMPS_SET_IERROR(LIWALLOC,INFO(2)) GOTO 90 ENDIF ENDIF ALLOCATE( IWL1 (N), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF ALLOCATE( IPEALLOC(N+1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PTRAR (N,3), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 3*N GOTO 90 ENDIF symmetry = INFO(8) NBQD = 0 GCOMP_PROVIDED=.FALSE. WEIGHTUSED = 0 NORIG = N IF (present(NORIG_ARG)) THEN NORIG=NORIG_ARG ENDIF IF (present(GCOMP_PROVIDED_IN)) & GCOMP_PROVIDED = GCOMP_PROVIDED_IN IF (GCOMP_PROVIDED.AND.(.NOT. present(GCOMP))) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & GCOMP_PROVIDED_IN, present(GCOMP) INFO(2) = 1 RETURN ENDIF IF ( (LIWALLOC.EQ.0_8).AND.(.not.GCOMP_PROVIDED)) THEN INFO(1) = -900 WRITE(6,*) " INTERNAL ERROR in MUMPS(ANA_F) ", & "LIWALLOC, GCOMP_PROVIDED=", LIWALLOC, GCOMP_PROVIDED INFO(2) = 2 RETURN ENDIF IF (GCOMP_PROVIDED) THEN NZG8 = GCOMP%NZG LIW8 = NZG8 + int(GCOMP%NG,8)+1_8 IW => GCOMP%ADJ(1:LIW8) IPE => GCOMP%IPE(1:GCOMP%NG+1) DO I=1,GCOMP%NG PTRAR(I,2) = int(IPE(I+1)-IPE(I)) ENDDO ELSE LIW8 = LIWALLOC NZG8 = NZ8 IW => IWALLOC(1:LIW8) IPE => IPEALLOC(1:N+1) ENDIF LP = ICNTL(1) MP = ICNTL(3) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) COMPRESS_SCHUR = .FALSE. IF (PROK) THEN IF (present(GCOMP)) THEN WRITE(MP,'(A,I10,A,I13,A)') " Processing a graph of size:", N & ," with ", GCOMP%NZG, " edges" ELSE WRITE(MP,'(A,I10)') " Processing a graph of size:", N ENDIF ENDIF IF (GCOMP_PROVIDED) THEN FREE_CENTRALIZED_MATRIX = .FALSE. ELSE FREE_CENTRALIZED_MATRIX = ( & (KEEP(54).EQ.3).AND. & (KEEP(494).EQ.0).AND. & (KEEP(106).NE.2) & ) ENDIF INPLACE64_GRAPH_COPY = .FALSE. INPLACE64_RESTORE_GRAPH = .TRUE. IF (KEEP(1).LT.0) KEEP(1) = 0 NEMIN = KEEP(1) IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (present(SIZEOFBLOCKS)) THEN K = min(10,GCOMP%NG) IF (LDIAG.EQ.4) K = GCOMP%NG WRITE (MP,99909) N, NZG8, INFO(1) I8= 0_8 WRITE(MP,'(A)') " Graph adjacency " DO J=1, K IFIRST = GCOMP%IPE(J) ILAST= min(GCOMP%IPE(J+1)-1,GCOMP%IPE(J)+K-1) write(MP,'(A,I10)') " .... node/column:", J write(MP,'(8X,10I9)') & (GCOMP%ADJ(I8),I8=IFIRST,ILAST) ENDDO ELSE J8 = min(NZG8, 10_8) IF (LDIAG .EQ.4) J8 = NZG8 WRITE (MP,99999) N, NZG8, LIW8, INFO(1) IF (J8.GT.0_8) WRITE (MP,99998) (IRN(I8),ICN(I8),I8=1_8,J8) ENDIF K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP1(I),I=1,K) ENDIF ENDIF NCMP = N IF (KEEP(60).NE.0) THEN IF ((SIZE_SCHUR.LE.0 ).OR. & (SIZE_SCHUR.GE.N) ) GOTO 90 ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( ( KEEP(60).NE.0).AND.(SIZE_SCHUR.GT.0) & .AND. & ((IORD.EQ.7).OR.(IORD.EQ.5)) & )THEN COMPRESS_SCHUR=.TRUE. NCMP = N-SIZE_SCHUR ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_GNEW_SCHUR(N,NCMP,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, & KEEP(264), KEEP(265), & LISTVAR_SCHUR(1), SIZE_SCHUR, FRERE(1), FILS(1), & INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) IORD = 5 KEEP(95) = 1 NBQD = 0 ELSE #endif IF (GCOMP_PROVIDED) THEN IWFR8 = GCOMP%NZG+1_8 ELSE ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL DMUMPS_ANA_GNEW(N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, & KEEP(50), NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE., INPLACE64_GRAPH_COPY) INFO(8) = symmetry INPLACE64_GRAPH_COPY = INPLACE64_GRAPH_COPY.AND. & (.NOT.FREE_CENTRALIZED_MATRIX) DEALLOCATE(IPQ8) ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IF(NBQD .GT. 0) THEN IF( KEEP(50) .EQ. 2 .AND. ICNTL(12) .EQ. 0 ) THEN IF(KEEP(95) .NE. 1) THEN IF ( PROK ) & WRITE( MP,*) & 'Compressed/constrained ordering set OFF' KEEP(95) = 1 ENDIF ENDIF ENDIF IF ( (KEEP(60).NE.0) .AND. (IORD.GT.1) .AND. & .NOT. COMPRESS_SCHUR ) THEN IORD = 0 ENDIF IF ( (KEEP(50).EQ.2) & .AND. (KEEP(95) .EQ. 3) & .AND. (IORD .EQ. 7) ) THEN IORD = 2 ENDIF CALL MUMPS_SET_ORDERING( NORIG, KEEP, & KEEP(50), NSLAVES, IORD, & NBQD, AvgDens, & PROK, MP ) IF(KEEP(50) .EQ. 2) THEN IF(KEEP(95) .EQ. 3 .AND. IORD .NE. 2) THEN IF (PROK) WRITE(MP,*) & 'WARNING: DMUMPS_ANA_F constrained ordering not '// & ' available with selected ordering. Move to' // & ' compressed ordering.' KEEP(95) = 2 ENDIF ELSE KEEP(95) = 1 ENDIF MTRANS = KEEP(23) COMPRESS = KEEP(95) - 1 IF(COMPRESS .GT. 0 .AND. KEEP(52) .EQ. -2) THEN IF(CNTL4 .GE. 0.0D0) THEN IF (KEEP(1).LE.8) THEN NEMIN = 16 ELSE NEMIN = 2*KEEP(1) ENDIF IF (PROK) & WRITE(MP,*) 'Setting static pivoting ON, COMPRESS =', & COMPRESS ENDIF ENDIF IF(MTRANS .GT. 0 .AND. KEEP(50) .EQ. 2) THEN KEEP(23) = 0 ENDIF IF (COMPRESS .EQ. 2) THEN IF (IORD.NE.2) THEN WRITE(*,*) "IORD not compatible with COMPRESS:", & IORD, COMPRESS CALL MUMPS_ABORT() ENDIF CALL DMUMPS_SET_CONSTRAINTS( & N,PIV(1),FRERE(1),FILS(1),NFSIZ(1),IKEEP1(1), & NCST,KEEP,KEEP8, ROWSCA(1) & ) ENDIF IF ( IORD .NE. 1 ) THEN IF (COMPRESS .GE. 1) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_LDLT_COMPRESS( & N, NZ8, IRN(1), ICN(1), PIV(1), & NCMP, IW(1), LIW8, IPE(1), PTRAR(1,2), IPQ8, & IWL1, FILS(1), IWFR8, & IERROR, KEEP, KEEP8, ICNTL, INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) symmetry = 100 ENDIF IF ( (symmetry.LT.MINSYM).AND.(KEEP(50).EQ.0) ) THEN IF(KEEP(23) .EQ. 7 ) THEN KEEP(23) = -5 GOTO 90 ELSE IF(KEEP(23) .EQ. -9876543) THEN IDENT = .TRUE. KEEP(23) = 5 IF (PROK) WRITE(MP,'(A)') & ' ... Apply column permutation (already computed)' DO J=1,N JPERM = PIV(J) FILS(JPERM) = J IF (JPERM.NE.J) IDENT = .FALSE. ENDDO IF (.NOT.IDENT) THEN DO J8=1_8,NZ8 J = ICN(J8) IF ((J.LE.0).OR.(J.GT.N)) CYCLE ICN(J8) = FILS(J) ENDDO ALLOCATE(COLSCA_TEMP(N), stat=IERR) IF ( IERR > 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO J = 1, N COLSCA_TEMP(J)=COLSCA(J) ENDDO DO J=1, N COLSCA(FILS(J))=COLSCA_TEMP(J) ENDDO DEALLOCATE(COLSCA_TEMP) IF (PROK) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_ANA_GNEW & (N,NZ8,IRN(1), ICN(1), IW(1), LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264), KEEP(265), & .TRUE.,INPLACE64_GRAPH_COPY) INFO(8) = symmetry DEALLOCATE(IPQ8) NCMP = N ELSE KEEP(23) = 0 ENDIF ENDIF ELSE IF (KEEP(23) .EQ. 7 .OR. KEEP(23) .EQ. -9876543 ) THEN IF (PROK) WRITE(MP,'(A)') & ' ... No column permutation' KEEP(23) = 0 ENDIF ENDIF IF (FREE_CENTRALIZED_MATRIX & .AND.COMPRESS.EQ.0.AND.(.NOT.COMPRESS_SCHUR)) THEN deallocate(IRN) NULLIFY(IRN) deallocate(ICN) NULLIFY(ICN) ENDIF INPLACE64_RESTORE_GRAPH = & INPLACE64_RESTORE_GRAPH.AND.(COMPRESS.NE.1) ALLOCATE( PARENT ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (IORD.NE.1 .AND. IORD.NE.5) THEN IF ( KEEP(60) .NE. 0 ) THEN IORD = 0 ENDIF IF (PROK) THEN IF (IORD.EQ.2) THEN WRITE(MP,'(A)') ' Ordering based on AMF ' #if defined(scotch) || defined(ptscotch) ELSE IF (IORD.EQ.3) THEN WRITE(MP,'(A)') ' Ordering based on SCOTCH ' #endif #if defined(pord) ELSE IF (IORD.EQ.4) THEN WRITE(MP,'(A)') ' Ordering based on PORD ' #endif ELSE IF (IORD.EQ.6) THEN WRITE(MP,'(A)') ' Ordering based on QAMD ' ELSE WRITE(MP,'(A)') ' Ordering based on AMD ' ENDIF ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF IF ( KEEP(60) .NE. 0 ) THEN CALL MUMPS_HAMD(N, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), & PTRAR, PTRAR(1,3), & PARENT, & LISTVAR_SCHUR(1), SIZE_SCHUR) IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ELSE IF ( .FALSE. ) THEN #if defined(pord) ELSEIF (IORD .EQ. 4) THEN CALL MUMPS_PORD_INTSIZE(PORD_INT_SIZE) TOTW = N IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN TOTW = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF IF (PORD_INT_SIZE .EQ. 64) THEN CALL MUMPS_PORDF_WND_MIXEDto64(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE .EQ. 32) THEN CALL MUMPS_PORDF_WND_MIXEDto32(NCMP, IWFR8-1_8, & IPE, IW, & IWL1, NCMPA, TOTW, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT.0) GOTO 90 IF (COMPRESS.EQ.1) THEN CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF ELSE IF (PORD_INT_SIZE.EQ.64) THEN CALL MUMPS_PORDF_MIXEDto64(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY & ) ELSE IF (PORD_INT_SIZE.EQ.32) THEN CALL MUMPS_PORDF_MIXEDto32(NCMP, IWFR8-1_8, IPE, & IW, & IWL1, NCMPA, PARENT, & INFO(1), LP, LPOK, KEEP(10)) ELSE WRITE(*,*) & "Internal error in PORD wrappers, PORD_INT_SIZE=", & PORD_INT_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( NCMPA .NE. 0 ) THEN write(6,*) ' Out PORD, NCMPA=', NCMPA INFO( 1 ) = -9999 INFO( 2 ) = 4 GOTO 90 ENDIF IF (INFO(1) .LT. 0) GOTO 90 #endif #if defined(scotch) || defined(ptscotch) ELSEIF (IORD .EQ. 3) THEN CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_INT_SIZE) IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) & ) THEN WEIGHTREQUESTED=1 IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO ELSE IF & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) ) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ELSE WEIGHTREQUESTED = 0 DO I= 1, N IWL1(I) = 1 ENDDO ENDIF IF (SCOTCH_INT_SIZE.EQ.32) THEN IF (KEEP(10).EQ.1) THEN INFO(1) = -52 INFO(2) = 2 ELSE CALL MUMPS_SCOTCH_MIXEDto32(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, & WEIGHTUSED, WEIGHTREQUESTED) ENDIF ELSE IF (SCOTCH_INT_SIZE.EQ.64) THEN CALL MUMPS_SCOTCH_MIXEDto64(NCMP, & IWFR8-1_8, IPE, & PARENT, IWFR8, & PTRAR(1,2), IW, IWL1, IKEEP1, & IKEEP2, NCMPA, INFO, LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY, & WEIGHTUSED, WEIGHTREQUESTED) ELSE WRITE(*,*) & "Internal error in SCOTCH wrappers, SCOTCH_INT_SIZE=", & SCOTCH_INT_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 IF ( (COMPRESS .EQ. 1) & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS).AND. & (WEIGHTUSED.EQ.0) ) & ) THEN CALL DMUMPS_GET_ELIM_TREE(NCMP,PARENT,IWL1,FILS(1)) CALL DMUMPS_GET_PERM_FROM_PE(NCMP,PARENT,IKEEP1(1), & FRERE(1),PTRAR(1,1)) DO I=1,NCMP IKEEP2(IKEEP1(I))=I ENDDO ENDIF #endif ELSEIF (IORD .EQ. 2) THEN NBBUCK = 2*N COMPUTE_PERM=.FALSE. IF(COMPRESS .GE. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.GE.1) THEN CALL MUMPS_ABORT() ENDIF NBBUCK = max(NBBUCK, NORIG-N) NBBUCK = max(NBBUCK, 2*NORIG) NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF ALLOCATE( WTEMP ( 0: NBBUCK + 1), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = NBBUCK+2 GOTO 90 ENDIF IF(COMPRESS .LE. 1) THEN CALL MUMPS_HAMF4 & (TOTEL, NCMP, COMPUTE_PERM, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, PARENT(1)) ELSE IF(PROK) WRITE(MP,'(A)') & ' Constrained Ordering based on AMF' CALL MUMPS_CST_AMF(NCMP, NBBUCK, LIW8, IPE(1), & IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), WTEMP, & NFSIZ(1), FRERE(1), PARENT(1)) ENDIF DEALLOCATE(WTEMP) ELSEIF (IORD .EQ. 6) THEN ALLOCATE( WTEMP ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF THRESH = 1 IVersion = 2 COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_QAMD & (TOTEL,COMPUTE_PERM,IVersion, THRESH, WTEMP, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) DEALLOCATE(WTEMP) ELSE COMPUTE_PERM=.FALSE. IF(COMPRESS .EQ. 1) THEN COMPUTE_PERM=.TRUE. DO I=1,KEEP(93)/2 IWL1(I) = 2 ENDDO DO I=1+KEEP(93)/2,NCMP IWL1(I) = 1 ENDDO TOTEL = KEEP(93)+KEEP(94) ELSE IWL1(1) = -1 TOTEL = N ENDIF IF (present(SIZEOFBLOCKS)) THEN IF (COMPRESS.EQ.1) THEN CALL MUMPS_ABORT() ENDIF NCMP = N TOTEL = NORIG DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL MUMPS_ANA_H(TOTEL, COMPUTE_PERM, & NCMP, LIW8, IPE(1), IWFR8, PTRAR(1,2), & IW(1), IWL1, IKEEP1(1), IKEEP2(1), NCMPA, FILS(1), & IKEEP3(1), PTRAR, PTRAR(1,3), PARENT(1)) ENDIF ENDIF IF(COMPRESS .GE. 1) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94),KEEP(93), & PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) #if defined(scotch) || defined(ptscotch) IF (IORD.EQ.3) THEN WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN SCOTCH reordering =', TIMEB ENDIF #endif ENDIF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MP,'(A)') ' Ordering based on METIS' ENDIF IF ( PROK ) THEN CALL MUMPS_SECDEB( TIMEB ) ENDIF CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else OPT_METIS_SIZE = 40 #endif IF (COMPRESS .EQ. 1) THEN DO I=1,KEEP(93)/2 FRERE(I) = 2 ENDDO DO I=KEEP(93)/2+1,NCMP FRERE(I) = 1 ENDDO #if defined(metis4) || defined(parmetis3) IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF ((NORIG.NE.N).AND.present(SIZEOFBLOCKS)) THEN DO I=1, N FRERE(I) = SIZEOFBLOCKS(I) ENDDO IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEWND_MIXEDto32( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEWND_MIXEDto64( & NCMP, IPE, IW, FRERE, & NUMFLAG, METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK, KEEP(10), & INPLACE64_GRAPH_COPY ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ELSE IF (METIS_IDX_SIZE .EQ.32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ.64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, NUMFLAG, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF ENDIF ENDIF #else ELSE IF (present(SIZEOFBLOCKS)) THEN DO I=1,N FRERE(I) = SIZEOFBLOCKS(I) ENDDO ELSE DO I=1,NCMP FRERE(I) = 1 ENDDO ENDIF ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP, LPOK ) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64( & NCMP, IPE, IW, FRERE, & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP2, IKEEP1, INFO(1), LP,LPOK,KEEP(10), & LIW8, INPLACE64_GRAPH_COPY, & INPLACE64_RESTORE_GRAPH) ELSE IF (LPOK) WRITE(LP,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF #endif IF (INFO(1) .LT.0) GOTO 90 IF ( PROK ) THEN CALL MUMPS_SECFIN( TIMEB ) WRITE( MP, '(A,F12.4)' ) & ' ELAPSED TIME SPENT IN METIS reordering =', TIMEB ENDIF IF ( COMPRESS_SCHUR ) THEN CALL DMUMPS_EXPAND_PERM_SCHUR( & N, NCMP, IKEEP1(1),IKEEP2(1), & LISTVAR_SCHUR(1), SIZE_SCHUR, FILS(1)) COMPRESS = -1 ENDIF IF (COMPRESS .EQ. 1) THEN CALL DMUMPS_EXPAND_PERMUTATION(N,NCMP,KEEP(94), & KEEP(93),PIV(1),IKEEP1(1),IKEEP2(1)) COMPRESS = -1 ENDIF ENDIF #endif IF (PROK) THEN IF (IORD.EQ.1) THEN WRITE(MP,'(A)') ' Ordering given is used' ENDIF ENDIF IF (IORD.EQ.1 .OR. IORD.EQ.5 .OR. COMPRESS.EQ.-1 & .OR. & ( (NORIG.NE.N).AND.present(SIZEOFBLOCKS) .AND.(IORD.EQ.3) & .AND. (WEIGHTUSED.EQ.0) & ) & ) THEN IF ((KEEP(106).EQ.1).OR.(KEEP(106).EQ.3) & .OR.(KEEP(60).NE.0)) THEN IF ( COMPRESS .EQ. -1 ) THEN ALLOCATE(IPQ8(N),stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N*KEEP(10) ENDIF CALL DMUMPS_ANA_GNEW(N,NZ8,IRN(1),ICN(1),IW(1),LIW8, & IPE(1), PTRAR(1,2), & IPQ8, IWL1, IWFR8, KEEP8(126), KEEP8(127), & INFO(1), INFO(2), ICNTL, symmetry, KEEP(50), & NBQD, AvgDens, KEEP(264),KEEP(265), .TRUE., & INPLACE64_GRAPH_COPY) DEALLOCATE(IPQ8) ENDIF COMPRESS = 0 IF (KEEP(106).EQ.3.AND.KEEP(60).EQ.0) THEN ELSE ALLOCATE( WTEMP ( 2*N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 2*N GOTO 90 ENDIF THRESH = -1 IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60)==1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF AGG6 =.FALSE. IF (present(SIZEOFBLOCKS)) THEN DO I=1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO TOTEL = NORIG ELSE IWL1(1) = -1 TOTEL = N ENDIF CALL MUMPS_SYMQAMD(THRESH, WTEMP, & N, TOTEL, LIW8, IPE(1), IWFR8, PTRAR(1,2), IW(1), & IWL1(1), WTEMP(N+1), & IKEEP2(1), NCMPA, FILS(1), IKEEP3(1), PTRAR, & PTRAR(1,3),IKEEP1(1), LISTVAR_SCHUR(1), ITEMP, & AGG6, PARENT) DEALLOCATE(WTEMP) ENDIF ELSE CALL DMUMPS_ANA_J(N, NZ8, IRN(1), ICN(1), IKEEP1(1), IW(1), & LIW8, IPE(1), & PTRAR(1,2), IWL1, IWFR8, & INFO(1),INFO(2), MP) IF (KEEP(60) .EQ. 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR ENDIF CALL DMUMPS_ANA_K(N, IPE(1), IW(1), LIW8, IWFR8, IKEEP1(1), & IKEEP2(1), IWL1, & PTRAR, NCMPA, ITEMP, PARENT) IF (KEEP(60) .EQ. 0) THEN IF (KEEP(60) .EQ. 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSE KEEP(38) = LISTVAR_SCHUR(1) ENDIF ENDIF ENDIF ENDIF #if defined(OLDDFS) CALL DMUMPS_ANA_L & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ, INFO(6), FILS(1), FRERE(1), PTRAR(1,3), & NEMIN, KEEP(60)) #else IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) ALLOCATE(WTEMP(N), stat=IERR) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF IF (present(SIZEOFBLOCKS)) THEN CALL DMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .TRUE. , SIZEOFBLOCKS, N & ) ELSE CALL DMUMPS_ANA_LNEW & (N, PARENT, IWL1, IKEEP1(1), IKEEP2(1), IKEEP3(1), & NFSIZ(1), PTRAR, INFO(6), FILS(1), FRERE(1), & PTRAR(1,3), NEMIN, WTEMP, KEEP(60), & KEEP(20),KEEP(38),PTRAR(1,2),KEEP(104),IW(1),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1 & , .FALSE., IDUMMY, LIDUMMY ) ENDIF DEALLOCATE(WTEMP) #endif IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL DMUMPS_ANA_M(IKEEP2(1), & PTRAR(1,3), INFO(6), & INFO(5), KEEP(2), KEEP(50), & KEEP8(101), KEEP(108), KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) KEEP(59) = INFO(5) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) END IF IF ( (KEEP(48) == 4 .AND. KEEP8(21).GT.0_8) & .OR. & (KEEP (48)==5 .AND. KEEP8(21) .GT. 0_8 ) & .OR. & (KEEP(24).NE.0.AND.KEEP8(21).GT.0_8) ) THEN CALL DMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) THEN KEEP(210)=0 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) THEN KEEP(210)=1 ENDIF IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) THEN KEEP(210)=2 ENDIF IF (KEEP(210).EQ.2) THEN KEEP8(79)=huge(KEEP8(79)) ENDIF IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF ( (KEEP(79).EQ.0).OR.(KEEP(79).EQ.2).OR. & (KEEP(79).EQ.3).OR.(KEEP(79).EQ.5).OR. & (KEEP(79).EQ.6) & ) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IWL1(1) = -1 IF (present(SIZEOFBLOCKS)) THEN DO I= 1, N IWL1(I) = SIZEOFBLOCKS(I) ENDDO ENDIF CALL DMUMPS_CUTNODES(N, FRERE(1), FILS(1), NFSIZ(1), & IWL1(1), N, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE(1), FILS(1), NFSIZ(1), & KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 INFO(1) = -4 INFO(2) = K GOTO 90 90 CONTINUE IF (INFO(1) .NE. 0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,99996) INFO(1), INFO(2) ENDIF IF (allocated(IWALLOC)) DEALLOCATE(IWALLOC) IF (allocated(IWL1)) DEALLOCATE(IWL1) IF (allocated(IPEALLOC)) DEALLOCATE(IPEALLOC) IF (allocated(PTRAR)) DEALLOCATE(PTRAR) IF (allocated(PARENT)) DEALLOCATE(PARENT) RETURN 99999 FORMAT (/'Entering ordering phase with ...'/ & ' N NNZ LIW INFO(1)'/, & 6X, I10, I11, I12, I10) 99998 FORMAT ('Matrix entries: IRN() ICN()'/ & (I12, I9, I12, I9, I12, I9)) 99909 FORMAT (/'Entering ordering phase with graph dimensions ...'/ & ' |V| |E| INFO(1)'/, & 10X, I10, I13, I10) 99997 FORMAT ('IKEEP1(.)=', 10I8/(12X, 10I8)) 99996 FORMAT & (/'** Error/warning return ** from Analysis * INFO(1:2)= ', & (I3, I16)) 99989 FORMAT ('FILS (.) =', 10I9/(11X, 10I9)) 99988 FORMAT ('FRERE(.) =', 10I9/(11X, 10I9)) 99987 FORMAT ('NFSIZ(.) =', 10I9/(11X, 10I9)) END SUBROUTINE DMUMPS_ANA_F SUBROUTINE DMUMPS_ANA_N_DIST( id, PTRAR ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_STRUC IMPLICIT NONE include 'mpif.h' TYPE(DMUMPS_STRUC), INTENT(INOUT), TARGET :: id INTEGER(8), INTENT(OUT), TARGET :: PTRAR(:) INTEGER :: IERR, allocok INTEGER :: IOLD, JOLD, INEW, JNEW INTEGER(8) :: K, INZ INTEGER, POINTER :: IIRN(:), IJCN(:) INTEGER(8), POINTER :: IWORK1(:), IWORK2(:) LOGICAL :: IDO IF(id%KEEP(54) .EQ. 3) THEN IIRN => id%IRN_loc IJCN => id%JCN_loc INZ = id%KEEP8(29) IWORK1 => PTRAR(id%N+1:id%N+id%N) allocate(IWORK2(id%N),stat=allocok) IF (allocok > 0 ) THEN id%INFO(1) = -7 id%INFO(2) = id%N RETURN ENDIF IDO = .TRUE. ELSE IIRN => id%IRN IJCN => id%JCN INZ = id%KEEP8(28) IWORK1 => PTRAR(1:id%N) IWORK2 => PTRAR(id%N+1:id%N+id%N) IDO = id%MYID .EQ. 0 END IF DO 50 IOLD=1,id%N IWORK1(IOLD) = 0_8 IWORK2(IOLD) = 0_8 50 CONTINUE IF(IDO) THEN DO 70 K=1_8,INZ IOLD = IIRN(K) JOLD = IJCN(K) IF ( (IOLD.GT.id%N).OR.(JOLD.GT.id%N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) GOTO 70 IF (IOLD.NE.JOLD) THEN INEW = id%SYM_PERM(IOLD) JNEW = id%SYM_PERM(JOLD) IF ( id%KEEP( 50 ) .EQ. 0 ) THEN IF (INEW.LT.JNEW) THEN IWORK2(IOLD) = IWORK2(IOLD) + 1_8 ELSE IWORK1(JOLD) = IWORK1(JOLD) + 1_8 ENDIF ELSE IF ( INEW .LT. JNEW ) THEN IWORK1( IOLD ) = IWORK1( IOLD ) + 1_8 ELSE IWORK1( JOLD ) = IWORK1( JOLD ) + 1_8 END IF ENDIF ENDIF 70 CONTINUE END IF IF (id%KEEP(54) .EQ. 3) THEN CALL MPI_ALLREDUCE(IWORK1(1), PTRAR(1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) CALL MPI_ALLREDUCE(IWORK2(1), PTRAR(id%N+1), id%N, & MPI_INTEGER8, MPI_SUM, id%COMM, IERR ) deallocate(IWORK2) ELSE CALL MPI_BCAST( PTRAR(1), 2*id%N, MPI_INTEGER8, & 0, id%COMM, IERR ) END IF RETURN END SUBROUTINE DMUMPS_ANA_N_DIST SUBROUTINE DMUMPS_ANA_O( N, NZ, MTRANS, PERM, IKEEPALLOC, & idIRN, idJCN, idA, idROWSCA, idCOLSCA, WORK2, KEEP, & ICNTL, INFO, INFOG ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ INTEGER, INTENT(OUT) :: PERM(:) INTEGER, POINTER, DIMENSION(:) :: idIRN, idJCN DOUBLE PRECISION, POINTER, DIMENSION(:) :: idA DOUBLE PRECISION, POINTER, DIMENSION(:) :: idROWSCA, idCOLSCA INTEGER, TARGET :: IKEEPALLOC(3*N) INTEGER, INTENT(INOUT) :: MTRANS INTEGER :: KEEP(500) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(INOUT) :: INFOG(80) INTEGER, TARGET :: WORK2(N) INTEGER :: allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: IW DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: S2 TARGET :: S2 INTEGER ICNTL64(10), INFO64(10) INTEGER ICNTL_SYM_MWM(10),INFO_SYM_MWM(10) DOUBLE PRECISION CNTL64(10) INTEGER MPRINT,LP, MP INTEGER JPERM INTEGER NUMNZ, I, J, JPOS LOGICAL PROK, IDENT, DUPPLI INTEGER K50, KER_SIZE, NZER_DIAG, MTRANSLOC,RZ_DIAG INTEGER(8) :: LIWG INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPQ8 INTEGER :: LSC INTEGER(8) :: NZTOT, NZREAL, IPIW, LIW, LIWMIN, NZsave, & K, KPOS, LDW, LDWMIN, IRNW, RSPOS, CSPOS, & LS2,J8, N8 LOGICAL SCALINGLOC INTEGER,POINTER,DIMENSION(:) :: ZERODIAG INTEGER,POINTER,DIMENSION(:) :: STR_KER INTEGER,POINTER,DIMENSION(:) :: MARKED INTEGER,POINTER,DIMENSION(:) :: FLAG INTEGER,POINTER,DIMENSION(:) :: PIV_OUT DOUBLE PRECISION THEMIN, THEMAX, COLNORM,MAXDBL, ABSAK DOUBLE PRECISION ZERO,TWO,ONE PARAMETER(ZERO = 0.0D0,TWO = 2.0D0,ONE = 1.0D0) N8 = int(N,8) MPRINT = ICNTL(3) LP = ICNTL(1) MP = ICNTL(2) PROK = ((MPRINT.GT.0).AND.(ICNTL(4).GE.2)) K50 = KEEP(50) SCALINGLOC = .FALSE. IF(KEEP(52) .EQ. -2) THEN IF(.not.associated(idA)) THEN ELSE SCALINGLOC = .TRUE. ENDIF ELSE IF(KEEP(52) .EQ. 77) THEN SCALINGLOC = .TRUE. IF( MTRANS .NE. 5 .AND. MTRANS .NE. 6 & .AND. MTRANS .NE. 7) THEN SCALINGLOC = .FALSE. ENDIF IF(.not.associated(idA)) THEN SCALINGLOC = .FALSE. IF (PROK) & WRITE(MPRINT,*) 'Analysis: auto scaling OFF because ', & 'A not provided at analysis ' ENDIF ENDIF IF ( (KEEP(50).EQ.2).AND.(ICNTL(8).NE.-2).AND. & (MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) ) THEN ZERODIAG => IKEEPALLOC(1:N) ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF (I.NE.J) CYCLE IF ( (J.LE.N).AND.(J.GE.1) ) THEN IF(ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ENDIF NZER_DIAG = NZER_DIAG - 1 ENDIF ENDIF ENDDO IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) ) THEN MTRANS = 0 KEEP(95) =1 GOTO 500 ENDIF ENDIF IF(SCALINGLOC) THEN IF (PROK) WRITE(MPRINT,*) & 'Scaling will be computed during analysis' ENDIF IF( MTRANS.NE.0 .AND. (.NOT.associated(idA)) ) MTRANS=1 MTRANSLOC = MTRANS IF (MTRANS.LT.0 .OR. MTRANS.GT.7) GO TO 500 IF (K50 .EQ. 0) THEN IF(.NOT. SCALINGLOC .AND. MTRANS .EQ. 7) THEN GO TO 500 ENDIF IF(SCALINGLOC) THEN IF (MTRANSLOC.NE.6) THEN MTRANSLOC = 5 ENDIF ENDIF ELSE IF (MTRANS .EQ. 7) MTRANSLOC = 5 ENDIF IF(SCALINGLOC .AND. MTRANSLOC .NE. 5 .AND. & MTRANSLOC .NE. 6 ) THEN IF (PROK) WRITE(MPRINT,*) & 'WARNING scaling required: set MTRANS option to 5' MTRANSLOC = 5 ENDIF IF (N.EQ.1) THEN MTRANS=0 GO TO 500 ENDIF IF(K50 .NE. 0) THEN NZTOT = 2_8*NZ+N8 ELSE NZTOT = NZ ENDIF ZERODIAG => IKEEPALLOC(1:N) STR_KER => IKEEPALLOC(N+1:2*N) CALL DMUMPS_MTRANSI(ICNTL64,CNTL64) ICNTL64(1) = ICNTL(1) ICNTL64(2) = ICNTL(2) ICNTL64(3) = ICNTL(3) ICNTL64(4) = -1 IF (ICNTL(4).EQ.3) ICNTL64(4) = 0 IF (ICNTL(4).EQ.4) ICNTL64(4) = 1 ICNTL64(5) = -1 IF (PROK) THEN WRITE(MPRINT,'(A,I3)') & 'Compute maximum matching (Maximum Transversal):', & MTRANSLOC IF (MTRANSLOC.EQ.1) & WRITE(MPRINT,'(A,I3)')' ... JOB =',MTRANSLOC IF (MTRANSLOC.EQ.2) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK THESIS' IF (MTRANSLOC.EQ.3) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': BOTTLENECK SIMAX' IF (MTRANSLOC.EQ.4) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC,': MAXIMIZE SUM DIAGONAL' IF (MTRANSLOC.EQ.5 .OR. MTRANSLOC.EQ.6) & WRITE(MPRINT,'(A,I3,A)') & ' ... JOB =',MTRANSLOC, & ': MAXIMIZE PRODUCT DIAGONAL AND SCALE' ENDIF INFOG(23) = MTRANSLOC CNTL64(2) = huge(CNTL64(2)) IRNW = 1 IPIW = IRNW + NZTOT IF (MTRANSLOC.EQ.1) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.2) LIWMIN = 3_8*N8 IF (MTRANSLOC.EQ.3) LIWMIN = 10_8*N8 + NZTOT IF (MTRANSLOC.EQ.4) LIWMIN = 2_8*N8 IF (MTRANSLOC.EQ.5) LIWMIN = 5_8*N8 IF (MTRANSLOC.EQ.6) LIWMIN = 5_8*N8 + NZTOT LIW = LIWMIN LIWG = LIW + NZTOT ALLOCATE(IW(LIWG), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 410 ENDIF ALLOCATE( IPQ8(N), IPE(N+1), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (2*N+1)*KEEP(10) GOTO 500 ENDIF IF (MTRANSLOC.EQ.1) THEN LDWMIN = N8+3_8 ENDIF IF (MTRANSLOC.EQ.2) LDWMIN = max( N8+NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.3) LDWMIN = max( NZTOT+1_8 , N8+3_8 ) IF (MTRANSLOC.EQ.4) LDWMIN = 2_8 * N8 + & max( NZTOT , N8+3_8 ) IF (MTRANSLOC.EQ.5) LDWMIN = 3_8*N8 + NZTOT IF (MTRANSLOC.EQ.6) LDWMIN = 4_8*N8 + NZTOT LDW = LDWMIN ALLOCATE(S2(LDW), stat=allocok) IF (allocok .GT. 0 ) THEN GOTO 430 ENDIF IF(MTRANSLOC .NE. 1) LDW = LDW-NZTOT RSPOS = NZTOT CSPOS = RSPOS+N8 NZREAL = 0_8 DO 5 J=1,N IPQ8(J) = 0_8 5 CONTINUE IF(K50 .EQ. 0) THEN DO 10 K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 ENDIF 10 CONTINUE ELSE ZERODIAG = 0 NZER_DIAG = N RZ_DIAG = 0 DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1).AND. & (I.LE.N).AND.(I.GE.1) ) THEN IPQ8(J) = IPQ8(J) + 1_8 NZREAL = NZREAL + 1_8 IF(I .NE. J) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ELSE IF (ZERODIAG(I) .EQ. 0) THEN ZERODIAG(I) = 1 IF(associated(idA)) THEN ABSAK= abs(idA(K)) IF(ABSAK .EQ. dble(0.0D0)) THEN RZ_DIAG = RZ_DIAG + 1 ENDIF ZERODIAG(I) = exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF NZER_DIAG = NZER_DIAG - 1 ELSE IF(associated(idA)) THEN ABSAK= abs(idA(K)) ZERODIAG(I) = ZERODIAG(I)+ exponent(ABSAK) if ( ZERODIAG(I).EQ.0) ZERODIAG(I)=1 ENDIF ENDIF ENDIF ENDIF ENDDO IF(MTRANSLOC .GE. 4) THEN DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN IPQ8(I) = IPQ8(I) + 1_8 NZREAL = NZREAL + 1_8 ENDIF ENDDO ENDIF ENDIF IPE(1) = 1 DO 20 J=1,N IPE(J+1) = IPE(J)+IPQ8(J) 20 CONTINUE DO 25 J=1, N IPQ8(J ) = IPE(J) 25 CONTINUE IF(K50 .EQ. 0) THEN IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ELSE IF ( .not.associated(idA)) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 ENDIF END DO ENDIF ELSE IF (MTRANSLOC.EQ.1) THEN DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1) = I IPQ8(J) = IPQ8(J) + 1_8 IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO ELSE IF ( .not.associated(idA) ) THEN INFO(1) = -22 INFO(2) = 4 GOTO 500 ENDIF THEMAX = ZERO THEMIN = huge(THEMIN) DO K=1,NZ I = idIRN(K) J = idJCN(K) IF ( (J.LE.N).AND.(J.GE.1) .AND. & (I.LE.N).AND.(I.GE.1)) THEN KPOS = IPQ8(J) IW(IRNW+KPOS-1_8) = I S2(KPOS) = abs(idA(K)) IPQ8(J) = IPQ8(J) + 1_8 IF(abs(idA(K)) .GT. THEMAX) THEN THEMAX = abs(idA(K)) ELSE IF(abs(idA(K)) .LT. THEMIN & .AND. abs(idA(K)).GT. ZERO) THEN THEMIN = abs(idA(K)) ENDIF IF(I.NE.J) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = J S2(KPOS) = abs(idA(K)) IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDIF ENDDO DO I =1, N IF(ZERODIAG(I) .EQ. 0) THEN KPOS = IPQ8(I) IW(IRNW+KPOS-1) = I S2(KPOS) = ZERO IPQ8(I) = IPQ8(I) + 1_8 ENDIF ENDDO IF ( THEMAX .NE. ZERO ) THEN CNTL64(2) = (log(THEMAX/THEMIN))*(dble(N)) & - log(THEMIN) + ONE ENDIF ENDIF ENDIF DUPPLI = .FALSE. NZsave = NZREAL FLAG => IKEEPALLOC(2*N+1:3*N) IF(MTRANSLOC.NE.1) THEN CALL DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZREAL,IPE(1),IW(IRNW),S2, & PERM(1),IPQ8(1)) ELSE CALL DMUMPS_SUPPRESS_DUPPLI_STR(N,NZREAL,IPE(1),IW(IRNW), & PERM(1)) ENDIF IF(NZREAL .NE. NZsave) DUPPLI = .TRUE. LS2 = NZTOT IF ( MTRANSLOC .EQ. 1 ) THEN LS2 = 1_8 LDW = 1_8 ENDIF CALL DMUMPS_MTRANS_DRIVER(MTRANSLOC ,N, N, NZREAL, & IPE, IW(IRNW), S2(1), LS2, & NUMNZ, PERM(1), LIW, IW(IPIW), LDW, S2(LS2+1), & IPQ8, & ICNTL64, CNTL64, INFO64, INFO) IF (INFO(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' Not enough memory in MAXTRANS INFO(1)=',INFO(1) GOTO 500 ENDIF IF (INFO64(1).LT.0) THEN IF (LP.GT.0 .AND. ICNTL(4).GE.1) & WRITE(LP,'(A,I5)') & ' INTERNAL ERROR in MAXTRANS INFO(1)=',INFO64(1) INFO(1) = -9964 INFO(2) = INFO64(1) GO TO 500 ENDIF IF (INFO64(1).GT.0) THEN IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(A,I5)') & ' WARNING in MAXTRANS INFO(1)=',INFO64(1) ENDIF KER_SIZE = 0 IF(K50 .EQ. 2) THEN DO I=1,N IF(ZERODIAG(I) .EQ. 0) THEN IF(PERM(I) .EQ. I) THEN KER_SIZE = KER_SIZE + 1 PERM(I) = -I STR_KER(KER_SIZE) = I ENDIF ENDIF ENDDO ENDIF IF (NUMNZ.LT.N) GO TO 400 IF(K50 .EQ. 0) THEN IDENT = .TRUE. IF (MTRANS .EQ. 0 ) GOTO 102 DO 80 J=1,N JPERM = PERM(J) IW(IRNW+int(JPERM-1,8)) = J IF (JPERM.NE.J) IDENT = .FALSE. 80 CONTINUE IF(IDENT) THEN MTRANS = 0 ELSE IF(MTRANS .EQ. 7) THEN MTRANS = -9876543 GOTO 102 ENDIF IF (PROK) WRITE(MPRINT,'(A)') & ' ... Apply column permutation' DO 100 K=1,NZ J = idJCN(K) IF ((J.LE.0).OR.(J.GT.N)) GO TO 100 idJCN(K) = IW(IRNW+int(J-1,8)) 100 CONTINUE IF (MP.GT.0 .AND. ICNTL(4).GE.2) & WRITE(MP,'(/A)') & ' WARNING input matrix data modified' ENDIF 102 CONTINUE IF (SCALINGLOC) THEN IF ( associated(idCOLSCA)) & DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) & DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N IF(S2(RSPOS+J) .GT. MAXDBL) THEN S2(RSPOS+J) = ZERO ENDIF IF(S2(CSPOS+J) .GT. MAXDBL) THEN S2(CSPOS+J)= ZERO ENDIF ENDDO DO 105 J=1,N J8 = int(J,8) idROWSCA(J) = exp(S2(RSPOS+J8)) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF IF ( MTRANS .EQ. -9876543 .OR. MTRANS.EQ. 0 ) THEN idCOLSCA(J)= exp(S2(CSPOS+J8)) IF(idCOLSCA(J) .EQ. ZERO) THEN idCOLSCA(J) = ONE ENDIF ELSE idCOLSCA(IW(IRNW+J8-1_8))= exp(S2(CSPOS+J8)) IF(idCOLSCA(IW(IRNW+J8-1_8)) .EQ. ZERO) THEN idCOLSCA(IW(IRNW+J8-1_8)) = ONE ENDIF ENDIF 105 CONTINUE ENDIF ELSE IDENT = .FALSE. IF(SCALINGLOC) THEN IF ( associated(idCOLSCA)) DEALLOCATE( idCOLSCA ) IF ( associated(idROWSCA)) DEALLOCATE( idROWSCA ) ALLOCATE( idCOLSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of COLSCA' GOTO 500 ENDIF ENDIF ALLOCATE( idROWSCA(N), stat=allocok) IF (allocok .GT.0) THEN INFO(1)=-5 INFO(2)=N IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') & '** Failure during allocation of ROWSCA' GOTO 500 ENDIF ENDIF KEEP(52) = -2 KEEP(74) = 1 MAXDBL = log(huge(MAXDBL)) DO J=1,N J8 = int(J,8) IF(S2(RSPOS+J8)+S2(CSPOS+J8) .GT. MAXDBL) THEN S2(RSPOS+J8) = ZERO S2(CSPOS+J8)= ZERO ENDIF ENDDO DO J=1,N J8 = int(J,8) IF(PERM(J) .GT. 0) THEN idROWSCA(J) = & exp((S2(RSPOS+J8)+S2(CSPOS+J8))/TWO) IF(idROWSCA(J) .EQ. ZERO) THEN idROWSCA(J) = ONE ENDIF idCOLSCA(J)= idROWSCA(J) ENDIF ENDDO DO JPOS=1,KER_SIZE I = STR_KER(JPOS) COLNORM = ZERO DO K = IPE(I),IPE(I+1) - 1 IF ( PERM( IW( IRNW+K-1_8) ) > 0 ) THEN COLNORM = max(COLNORM,S2(J)) ENDIF ENDDO COLNORM = exp(COLNORM) idROWSCA(I) = ONE / COLNORM idCOLSCA(I) = idROWSCA(I) ENDDO ENDIF IF(MTRANS .EQ. 7 .OR. KEEP(95) .EQ. 0) THEN IF( (NZER_DIAG+RZ_DIAG) .LT. (N/10) & .AND. KEEP(95) .EQ. 0) THEN MTRANS = 0 KEEP(95) = 1 GOTO 390 ELSE IF(KEEP(95) .EQ. 0) THEN IF(SCALINGLOC) THEN KEEP(95) = 3 ELSE KEEP(95) = 2 ENDIF ENDIF IF(MTRANS .EQ. 7) MTRANS = 5 ENDIF ENDIF IF(MTRANS .EQ. 0) GOTO 390 ICNTL_SYM_MWM = 0 INFO_SYM_MWM = 0 IF(MTRANS .EQ. 5 .OR. MTRANS .EQ. 6 .OR. & MTRANS .EQ. 7) THEN ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ELSE IF(MTRANS .EQ. 4) THEN ICNTL_SYM_MWM(1) = 2 ICNTL_SYM_MWM(2) = 1 ELSE ICNTL_SYM_MWM(1) = 0 ICNTL_SYM_MWM(2) = 1 ENDIF MARKED => IKEEPALLOC(N+1:2*N) FLAG => IKEEPALLOC(2*N+1:3*N) PIV_OUT => WORK2(1:N) IF(MTRANSLOC .LT. 4) THEN LSC = 1 ELSE LSC = 2*N ENDIF CALL DMUMPS_SYM_MWM( & N, NZREAL, IPE, IW(IRNW), S2(1),LSC, PERM(1), & ZERODIAG(1), & ICNTL_SYM_MWM, S2(LSC+1),MARKED(1),FLAG(1), & PIV_OUT(1), INFO_SYM_MWM) IF(INFO_SYM_MWM(1) .NE. 0) THEN WRITE(*,*) '** Error in DMUMPS_ANA_O' RETURN ENDIF IF(INFO_SYM_MWM(3) .EQ. N) THEN IDENT = .TRUE. ELSEIF ( (ICNTL(12).EQ.0).AND. & ( (N-INFO_SYM_MWM(4)-INFO_SYM_MWM(3)) .GT. N/10 ) & ) THEN IDENT = .TRUE. KEEP(95) = 1 ELSE DO I=1,N PERM(I) = PIV_OUT(I) ENDDO ENDIF KEEP(93) = INFO_SYM_MWM(4) KEEP(94) = INFO_SYM_MWM(3) IF (IDENT) MTRANS=0 ENDIF 390 IF(MTRANS .EQ. 0) THEN KEEP(95) = 1 IF (PROK) THEN WRITE (MPRINT,'(A)') & ' ... Column permutation not used' ENDIF ENDIF GO TO 500 400 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) & WRITE (LP,'(/A)') '** Error: Matrix is structurally singular' INFO(1) = -6 INFO(2) = NUMNZ GOTO 500 410 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A,I14)') & '** Failure during allocation of INTEGER array of size ', & LIWG ENDIF INFO(1) = -7 CALL MUMPS_SET_IERROR(LIWG,INFO(2)) GOTO 500 430 IF ((LP.GE.0).AND.(ICNTL(4).GE.1)) THEN WRITE (LP,'(/A)') '** Error in DMUMPS_ANA_O' WRITE (LP,'(A)') '** Failure during allocation of S2' ENDIF INFO(1) = -5 CALL MUMPS_SET_IERROR(LDW,INFO(2)) 500 CONTINUE IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(S2)) DEALLOCATE(S2) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(IPQ8)) DEALLOCATE(IPQ8) RETURN END SUBROUTINE DMUMPS_ANA_O END MODULE DMUMPS_ANA_AUX_M SUBROUTINE DMUMPS_ANA_K(N,IPE, IW, LW, IWFR, IPS, IPV, & NV, FLAG, & NCMPA, SIZE_SCHUR, PARENT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_SCHUR INTEGER, INTENT(IN) :: IPS(N) INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: IPV(N), NV(N), PARENT(N) INTEGER(8), INTENT(INOUT) :: IWFR INTEGER(8), INTENT(INOUT) :: IPE(N) INTEGER, INTENT(INOUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER I,J,ML,MS,ME,MINJS,IE,KDUMMY INTEGER LN,JS,JE INTEGER(8) :: JP, JP1, JP2, LWFR, IP DO 10 I=1,N FLAG(I) = 0 NV(I) = 0 J = IPS(I) IPV(J) = I 10 CONTINUE NCMPA = 0 DO 100 ML=1,N-SIZE_SCHUR MS = IPV(ML) ME = MS FLAG(MS) = ME IP = IWFR MINJS = N IE = ME DO 70 KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 60 LN = IW(JP) DO 50 JP1=1_8,int(LN,8) JP = JP + 1_8 JS = IW(JP) IF (FLAG(JS).EQ.ME) GO TO 50 FLAG(JS) = ME IF (IWFR.LT.LW) GO TO 40 IPE(IE) = JP IW(JP) = LN - int(JP1) CALL DMUMPS_ANA_D(N, IPE, IW, IP-1_8, LWFR, NCMPA) JP2 = IWFR - 1 IWFR = LWFR IF (IP.GT.JP2) GO TO 30 DO 20 JP=IP,JP2 IW(IWFR) = IW(JP) IWFR = IWFR + 1_8 20 CONTINUE 30 IP = LWFR JP = IPE(IE) 40 IW(IWFR) = JS MINJS = min0(MINJS,IPS(JS)+0) IWFR = IWFR + 1_8 50 CONTINUE 60 IPE(IE) = int(-ME,8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 80 70 CONTINUE 80 IF (IWFR.GT.IP) GO TO 90 IPE(ME) = 0_8 NV(ME) = 1 GO TO 100 90 MINJS = IPV(MINJS) NV(ME) = NV(MINJS) NV(MINJS) = ME IW(IWFR) = IW(IP) IW(IP) = int(IWFR - IP) IPE(ME) = IP IWFR = IWFR + 1_8 100 CONTINUE IF (SIZE_SCHUR == 0) GOTO 500 DO ML = N-SIZE_SCHUR+1,N ME = IPV(ML) IE = ME DO KDUMMY=1,N JP = IPE(IE) LN = 0 IF (JP.LE.0_8) GO TO 160 LN = IW(JP) 160 IPE(IE) = int(-IPV(N-SIZE_SCHUR+1),8) JE = NV(IE) NV(IE) = LN + 1 IE = JE IF (IE.EQ.0) GO TO 190 ENDDO 190 NV(ME) = 0 IPE(ME) = int(-IPV(N-SIZE_SCHUR+1),8) ENDDO ME = IPV(N-SIZE_SCHUR+1) IPE(ME) = 0_8 NV(ME) = SIZE_SCHUR 500 DO I=1,N PARENT(I) = int(IPE(I)) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_K SUBROUTINE DMUMPS_ANA_J(N, NZ, IRN, ICN, PERM, & IW, LW, IPE, IQ, FLAG, & IWFR, IFLAG, IERROR, MP) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: PERM(N) INTEGER, INTENT(IN) :: MP INTEGER(8), INTENT(OUT):: IWFR INTEGER, INTENT(OUT) :: IERROR INTEGER, INTENT(OUT) :: IQ(N) INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER, INTENT(OUT) :: IW(LW) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER, INTENT(INOUT) :: IFLAG INTEGER :: I,J,LBIG,IN,LEN,JDUMMY,L1 INTEGER(8) :: K, K1, K2, KL, KID IERROR = 0 DO 10 I=1,N IQ(I) = 0 10 CONTINUE DO 80 K=1_8,NZ I = IRN(K) J = ICN(K) IW(K) = -I IF (I.EQ.J) GOTO 40 IF (I.GT.J) GOTO 30 IF (I.GE.1 .AND. J.LE.N) GO TO 60 GO TO 50 30 IF (J.GE.1 .AND. I.LE.N) GO TO 60 GO TO 50 40 IW(K) = 0 IF (I.GE.1 .AND. I.LE.N) GO TO 80 50 IERROR = IERROR + 1 IW(K) = 0 IF (IERROR.LE.1 .AND. MP.GT.0) WRITE (MP,99999) IF (IERROR.LE.10 .AND. MP.GT.0) WRITE (MP,99998) K, I, J GO TO 80 60 IF (PERM(J).GT.PERM(I)) GO TO 70 IQ(J) = IQ(J) + 1 GO TO 80 70 IQ(I) = IQ(I) + 1 80 CONTINUE IF (IERROR.GE.1) THEN IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 ENDIF IWFR = 1_8 LBIG = 0 DO 100 I=1,N L1 = IQ(I) LBIG = max0(L1,LBIG) IWFR = IWFR + int(L1,8) IPE(I) = IWFR - 1_8 100 CONTINUE DO 140 K=1_8,NZ I = -IW(K) IF (I.LE.0) GO TO 140 KL = K IW(K) = 0 DO 130 KID=1,NZ J = ICN(KL) IF (PERM(I).LT.PERM(J)) GO TO 110 KL = IPE(J) IPE(J) = KL - 1_8 IN = IW(KL) IW(KL) = I GO TO 120 110 KL = IPE(I) IPE(I) = KL - 1_8 IN = IW(KL) IW(KL) = J 120 I = -IN IF (I.LE.0) GO TO 140 130 CONTINUE 140 CONTINUE K = IWFR - 1_8 KL = K + int(N,8) IWFR = KL + 1_8 DO 170 I=1,N FLAG(I) = 0 J = N + 1 - I LEN = IQ(J) IF (LEN.LE.0) GO TO 160 DO 150 JDUMMY=1,LEN IW(KL) = IW(K) K = K - 1_8 KL = KL - 1_8 150 CONTINUE 160 IPE(J) = KL KL = KL - 1_8 170 CONTINUE IF (LBIG.GE.huge(N)) GO TO 190 DO 180 I=1,N K = IPE(I) IW(K) = IQ(I) IF (IQ(I).EQ.0) IPE(I) = 0_8 180 CONTINUE GO TO 230 190 IWFR = 1_8 DO 220 I=1,N K1 = IPE(I) + 1_8 K2 = IPE(I) + int(IQ(I),8) IF (K1.LE.K2) GO TO 200 IPE(I) = 0_8 GO TO 220 200 IPE(I) = IWFR IWFR = IWFR + 1_8 DO 210 K=K1,K2 J = IW(K) IF (FLAG(J).EQ.I) GO TO 210 IW(IWFR) = J IWFR = IWFR + 1_8 FLAG(J) = I 210 CONTINUE K = IPE(I) IW(K) = int(IWFR - K - 1_8) 220 CONTINUE 230 RETURN 99999 FORMAT (' *** WARNING MESSAGE FROM DMUMPS_ANA_J ***' ) 99998 FORMAT (I6, ' NON-ZERO (IN ROW, I6, 11H AND COLUMN ', I6, & ') IGNORED') END SUBROUTINE DMUMPS_ANA_J SUBROUTINE DMUMPS_ANA_D(N, IPE, IW, LW, IWFR,NCMPA) INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(INOUT):: IPE(N) INTEGER, INTENT(INOUT) :: NCMPA INTEGER, INTENT(INOUT) :: IW(LW) INTEGER :: I, IR INTEGER(8) :: K1, K, K2, LWFR NCMPA = NCMPA + 1 DO 10 I=1,N K1 = IPE(I) IF (K1.LE.0_8) GO TO 10 IPE(I) = int(IW(K1), 8) IW(K1) = -I 10 CONTINUE IWFR = 1_8 LWFR = IWFR DO 60 IR=1,N IF (LWFR.GT.LW) GO TO 70 DO 20 K=LWFR,LW IF (IW(K).LT.0) GO TO 30 20 CONTINUE GO TO 70 30 I = -IW(K) IW(IWFR) = int(IPE(I)) IPE(I) = int(IWFR,8) K1 = K + 1_8 K2 = K + int(IW(IWFR),8) IWFR = IWFR + 1_8 IF (K1.GT.K2) GO TO 50 DO 40 K=K1,K2 IW(IWFR) = IW(K) IWFR = IWFR + 1_8 40 CONTINUE 50 LWFR = K2 + 1_8 60 CONTINUE 70 RETURN END SUBROUTINE DMUMPS_ANA_D #if defined(OLDDFS) SUBROUTINE DMUMPS_ANA_L(N, IPE, NV, IPS, NE, NA, NFSIZ, & NSTEPS, & FILS, FRERE,NDD,NEMIN, KEEP60) INTEGER N,NSTEPS INTEGER NDD(N) INTEGER FILS(N), FRERE(N) INTEGER IPS(N), NE(N), NA(N), NFSIZ(N) INTEGER IPE(N), NV(N) INTEGER NEMIN, KEEP60 INTEGER I,IF,IS,NR,NR1,INS,INL,INB,INF,INFS,INSW INTEGER K,L,ISON,IN,INP,IFSON,INC,INO INTEGER INOS,IB,IL DO 10 I=1,N IPS(I) = 0 NE(I) = 0 10 CONTINUE DO 20 I=1,N IF (NV(I).GT.0) GO TO 20 IF = -IPE(I) IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I 20 CONTINUE NR = N + 1 DO 50 I=1,N IF (NV(I).LE.0) GO TO 50 IF = -IPE(I) IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) IPE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF 50 CONTINUE DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (IPE(INS).LT.0) THEN INS = -IPE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (IPE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = IPE(INS) IF (NV(INB).EQ.0) THEN INS = INB GO TO 1070 ENDIF IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = IPE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB IPE(INS) = IPE(INB) IPE(INB) = INS INS = INB GO TO 1070 ENDIF INSW = INFS 1100 INFS = IPE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF IPE(INS) = IPE(INB) IPE(INB) = INS IPE(INSW)= INB INS =INB GO TO 1070 1151 CONTINUE DO 51 I=1,N FRERE(I) = IPE(I) FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IL = 0 DO 160 K=1,N IF (I.GT.0) GO TO 60 I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 60 DO 70 L=1,N IF (IPS(I).GE.0) GO TO 80 ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE 80 IPS(I) = K NE(IS) = NE(IS) + 1 IF (NV(I).GT.0) GO TO 89 IN = I 81 IN = FRERE(IN) IF (IN.GT.0) GO TO 81 IF = -IN IN = IF 82 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 82 IFSON = -IN FILS(INL) = I IN = I 83 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 83 IF (IFSON .EQ. I) GO TO 86 FILS(INP) = -IFSON IN = IFSON 84 INC =IN IN = FRERE(IN) IF (IN.NE.I) GO TO 84 FRERE(INC) = FRERE(I) GO TO 120 86 IF (FRERE(I).LT.0) FILS(INP) = 0 IF (FRERE(I).GT.0) FILS(INP) = -FRERE(I) GO TO 120 89 IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) NDD(IS) = NV(I) NFSIZ(I) = NV(I) IF (NA(IS).LT.1) GO TO 110 IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.NDD(IS)) ) GOTO 110 IF (NDD(IS-1)-NE(IS-1).EQ.NDD(IS)) GO TO 100 IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(NDD(IS)-NDD(IS-1)+NE(IS-1)).GE. & ((NDD(IS)+NE(IS-1))* & (NDD(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 NDD(IS-1) = NDD(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 IN=I 101 INL = IN IN = FILS(IN) IF (IN.GT.0) GO TO 101 IFSON = -IN IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 FILS(INL) = INO NFSIZ(I) = NDD(IS-1) IN = INO 103 INP = IN IN = FILS(IN) IF (IN.GT.0) GO TO 103 INOS = -IN IF (IFSON.EQ.INO) GO TO 107 IN = IFSON FILS(INP) = -IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) FRERE(INS) = -I IF (INOS.NE.0) FRERE(INS) = INOS IF (INOS.EQ.0) GO TO 109 107 IN = INOS IF (IN.EQ.0) GO TO 109 108 INT = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT) = -I 109 CONTINUE GO TO 120 110 IS = IS + 1 120 IB = IPE(I) IF (IB.LT.0) GOTO 150 IF (IB.EQ.0) GOTO 140 NA(IL) = 0 140 I = IB GO TO 160 150 I = -IB IL = IL + 1 160 CONTINUE NSTEPS = IS - 1 DO 170 I=1,N K = FILS(I) IF (K.GT.0) THEN FRERE(K) = N + 1 NFSIZ(K) = 0 ENDIF 170 CONTINUE RETURN END SUBROUTINE DMUMPS_ANA_L #else SUBROUTINE DMUMPS_ANA_LNEW(N, IPE, NV, IPS, NE, NA, NFSIZ, & NODE, NSTEPS, & FILS, FRERE, ND, NEMIN, SUBORD, KEEP60, & KEEP20, KEEP38, NAMALG,NAMALGMAX, & CUMUL,KEEP50, ICNTL13, KEEP37, NSLAVES, & ALLOW_AMALG_TINY_NODES & , BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS & ) IMPLICIT NONE INTEGER N, NSTEPS, KEEP60, KEEP20, KEEP38, KEEP50 INTEGER ND(N), NFSIZ(N) INTEGER IPE(N), FILS(N), FRERE(N), SUBORD(N) INTEGER NV(N), IPS(N), NE(N), NA(N), NODE(N) INTEGER NEMIN,AMALG_COUNT INTEGER NAMALG(N),NAMALGMAX, CUMUL(N) DOUBLE PRECISION SIZE_DADI_AMALGAMATED, PERCENT_FILL DOUBLE PRECISION ACCU, FLOPS_FATHER, FLOPS_SON, & FLOPS_AVANT, FLOPS_APRES INTEGER ICNTL13, KEEP37, NSLAVES LOGICAL ALLOW_AMALG_TINY_NODES LOGICAL, INTENT(IN) :: BLKON INTEGER, INTENT(IN) :: LSIZEOFBLOCKS INTEGER, INTENT(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) #if defined(NOAMALGTOFATHER) #else #endif INTEGER I,IF,IS,NR,INS INTEGER K,L,ISON,IN,IFSON,INO INTEGER INOS,IB,IL INTEGER IPERM INTEGER MAXNODE #if defined(NOAMALGTOFATHER) INTEGER INB,INF,INFS,INL,INSW,INT1,NR1 #else INTEGER DADI #endif LOGICAL AMALG_TO_father_OK AMALG_COUNT = 0 DO 10 I=1,N CUMUL(I)= 0 IPS(I) = 0 NE(I) = 0 SUBORD(I) = 0 NAMALG(I) = 0 10 CONTINUE DO I=1,N IF (BLKON) THEN NODE(I) = SIZEOFBLOCKS(I) ELSE NODE(I) = 1 ENDIF ENDDO FRERE(1:N) = IPE(1:N) NR = N + 1 MAXNODE = 1 DO 50 I=1,N IF = -FRERE(I) IF (NV(I).EQ.0) THEN IF (SUBORD(IF).NE.0) SUBORD(I) = SUBORD(IF) SUBORD(IF) = I IF (BLKON) THEN NODE(IF) = NODE(IF)+SIZEOFBLOCKS(I) ELSE NODE(IF) = NODE(IF)+1 ENDIF MAXNODE = max(NODE(IF),MAXNODE) ELSE IF (IF.NE.0) THEN IS = -IPS(IF) IF (IS.GT.0) FRERE(I) = IS IPS(IF) = -I ELSE NR = NR - 1 NE(NR) = I ENDIF ENDIF 50 CONTINUE MAXNODE = int(dble(MAXNODE)*dble(NEMIN) / dble(100)) MAXNODE = max(MAXNODE,2000) #if defined(NOAMALGTOFATHER) DO 999 I=1,N FILS(I) = IPS(I) 999 CONTINUE NR1 = NR INS = 0 1000 IF (NR1.GT.N) GO TO 1151 INS = NE(NR1) NR1 = NR1 + 1 1070 INL = FILS(INS) IF (INL.LT.0) THEN INS = -INL GO TO 1070 ENDIF 1080 IF (FRERE(INS).LT.0) THEN INS = -FRERE(INS) FILS(INS) = 0 GO TO 1080 ENDIF IF (FRERE(INS).EQ.0) THEN INS = 0 GO TO 1000 ENDIF INB = FRERE(INS) IF (NV(INB).GE.NV(INS)) THEN INS = INB GO TO 1070 ENDIF INF = INB 1090 INF = FRERE(INF) IF (INF.GT.0) GO TO 1090 INF = -INF INFS = -FILS(INF) IF (INFS.EQ.INS) THEN FILS(INF) = -INB IPS(INF) = -INB FRERE(INS) = FRERE(INB) FRERE(INB) = INS ELSE INSW = INFS 1100 INFS = FRERE(INSW) IF (INFS.NE.INS) THEN INSW = INFS GO TO 1100 ENDIF FRERE(INS) = FRERE(INB) FRERE(INB) = INS FRERE(INSW)= INB ENDIF INS = INB GO TO 1070 1151 CONTINUE #endif DO 51 I=1,N FILS(I) = IPS(I) 51 CONTINUE IS = 1 I = 0 IPERM = 1 DO 160 K=1,N AMALG_TO_father_OK=.FALSE. IF (I.LE.0) THEN IF (NR.GT.N) EXIT I = NE(NR) NE(NR) = 0 NR = NR + 1 IL = N NA(N) = 0 ENDIF DO 70 L=1,N IF (IPS(I).GE.0) EXIT ISON = -IPS(I) IPS(I) = 0 I = ISON IL = IL - 1 NA(IL) = 0 70 CONTINUE #if ! defined(NOAMALGTOFATHER) DADI = -IPE(I) IF ( (DADI.NE.0) .AND. & ( & (KEEP60.EQ.0).OR. & ( (KEEP20.NE.DADI).AND.(KEEP38.NE.DADI) ) & ) & ) THEN ACCU = dble(2)*dble(NODE(I))*dble(NV(DADI)-NV(I)+NODE(I)) SIZE_DADI_AMALGAMATED = & dble(NV(DADI)+NODE(I)) * & dble(NV(DADI)+NODE(I)) PERCENT_FILL = dble(100) * ACCU / SIZE_DADI_AMALGAMATED ACCU = ACCU + dble(CUMUL(I)) AMALG_TO_father_OK = ( & ( (NODE(I).LE.MAXNODE).AND.(NODE(DADI).LE.MAXNODE) ) & .OR. & ( (NODE(I).LE.NEMIN.and. NODE(DADI).GT. MAXNODE) & .OR.(NODE(DADI).LE.NEMIN .and. NODE(I).GT.MAXNODE))) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( PERCENT_FILL < dble(NEMIN) ) ) AMALG_TO_father_OK = ( AMALG_TO_father_OK .AND. & ( ACCU / SIZE_DADI_AMALGAMATED .LE. dble(NEMIN)) ) IF (AMALG_TO_father_OK) THEN CALL MUMPS_GET_FLOPS_COST(NV(I),NODE(I),NODE(I), & KEEP50,1,FLOPS_SON) CALL MUMPS_GET_FLOPS_COST(NV(DADI),NODE(DADI), & NODE(DADI), & KEEP50,1,FLOPS_FATHER) FLOPS_AVANT = FLOPS_FATHER+FLOPS_SON & + max(dble(200.0) * dble(NV(I)-NODE(I)) & * dble(NV(I)-NODE(I)), & dble(10000.0)) CALL MUMPS_GET_FLOPS_COST(NV(DADI)+NODE(I), & NODE(DADI)+NODE(I), & NODE(DADI)+NODE(I), & KEEP50,1,FLOPS_APRES) IF (FLOPS_APRES.GT.FLOPS_AVANT* & (dble(1)+dble(max(8,NEMIN)-8)/dble(100))) THEN AMALG_TO_father_OK = .FALSE. ENDIF ENDIF IF ( (NV(I).GT. 50*NV(DADI)).AND. (NSLAVES.GT.1) & .AND. (ICNTL13.LE.0) & .AND. (NV(I).GT. KEEP37) ) THEN IF ( ( ACCU / SIZE_DADI_AMALGAMATED ) .LT. 0.2 ) THEN AMALG_TO_father_OK = .TRUE. ENDIF ENDIF IF ( ALLOW_AMALG_TINY_NODES .AND. & NODE(I) * 900 .LE. NV(DADI) - NAMALG(DADI)) THEN IF ( NAMALG(DADI) < (NV(DADI)-NAMALG(DADI))/50 ) THEN AMALG_TO_father_OK = .TRUE. NAMALG(DADI) = NAMALG(DADI) + NODE(I) ENDIF ENDIF IF ( DADI .EQ. -FRERE(I) & .AND. -FILS(DADI).EQ.I & ) THEN AMALG_TO_father_OK = ( AMALG_TO_father_OK .OR. & ( NV(I)-NODE(I).EQ.NV(DADI)) ) ENDIF IF (AMALG_TO_father_OK) THEN CUMUL(DADI)=CUMUL(DADI)+nint(ACCU) NAMALG(DADI) = NAMALG(DADI) + NAMALG(I) AMALG_COUNT = AMALG_COUNT+1 IN = DADI 75 IF (SUBORD(IN).EQ.0) GOTO 76 IN = SUBORD(IN) GOTO 75 76 CONTINUE SUBORD(IN) = I NV(I) = 0 IFSON = -FILS(DADI) IF (IFSON.EQ.I) THEN IF (FILS(I).LT.0) THEN FILS(DADI) = FILS(I) GOTO 78 ELSE IF (FRERE(I).GT.0) THEN FILS(DADI) = -FRERE(I) ELSE FILS(DADI) = 0 ENDIF GOTO 90 ENDIF ENDIF IN = IFSON 77 INS = IN IN = FRERE(IN) IF (IN.NE.I) GOTO 77 IF (FILS(I) .LT.0) THEN FRERE(INS) = -FILS(I) ELSE FRERE(INS) = FRERE(I) GOTO 90 ENDIF 78 CONTINUE IN = -FILS(I) 79 INO = IN IN = FRERE(IN) IF (IN.GT.0) GOTO 79 FRERE(INO) = FRERE(I) 90 CONTINUE NODE(DADI) = NODE(DADI)+ NODE(I) NV(DADI) = NV(DADI) + NODE(I) NA(IL+1) = NA(IL+1) + NA(IL) GOTO 120 ENDIF ENDIF #endif NE(IS) = NE(IS) + NODE(I) IF (IL.LT.N) NA(IL+1) = NA(IL+1) + 1 NA(IS) = NA(IL) ND(IS) = NV(I) NODE(I) = IS IPS(I) = IPERM IPERM = IPERM + 1 IN = I 777 IF (SUBORD(IN).EQ.0) GO TO 778 IN = SUBORD(IN) NODE(IN) = IS IPS(IN) = IPERM IPERM = IPERM + 1 GO TO 777 778 IF (NA(IS).LE.0) GO TO 110 #if defined(NOAMALGTOFATHER) IF ( (KEEP60.NE.0).AND. & (NE(IS).EQ.ND(IS)) ) GOTO 110 IF (ND(IS-1)-NE(IS-1).EQ.ND(IS)) THEN GO TO 100 ENDIF IF(NAMALG(IS-1) .GE. NAMALGMAX) THEN GOTO 110 ENDIF IF ((NE(IS-1).GE.NEMIN).AND. & (NE(IS).GE.NEMIN) ) GO TO 110 IF (2*NE(IS-1)*(ND(IS)-ND(IS-1)+NE(IS-1)).GE. & ((ND(IS)+NE(IS-1))* & (ND(IS)+NE(IS-1))*NEMIN/100)) GO TO 110 NAMALG(IS-1) = NAMALG(IS-1)+1 100 NA(IS-1) = NA(IS-1) + NA(IS) - 1 ND(IS-1) = ND(IS) + NE(IS-1) NE(IS-1) = NE(IS) + NE(IS-1) NE(IS) = 0 NODE(I) = IS-1 IFSON = -FILS(I) IN = IFSON 102 INO = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 102 NV(INO) = 0 IN = I 888 IF (SUBORD(IN).EQ.0) GO TO 889 IN = SUBORD(IN) GO TO 888 889 SUBORD(IN) = INO INOS = -FILS(INO) IF (IFSON.EQ.INO) THEN FILS(I) = -INOS GO TO 107 ENDIF IN = IFSON 105 INS = IN IN = FRERE(IN) IF (IN.NE.INO) GO TO 105 IF (INOS.EQ.0) THEN FRERE(INS) = -I GO TO 120 ELSE FRERE(INS) = INOS ENDIF 107 IN = INOS IF (IN.EQ.0) GO TO 120 108 INT1 = IN IN = FRERE(IN) IF (IN.GT.0) GO TO 108 FRERE(INT1) = -I GO TO 120 #endif 110 IS = IS + 1 120 IB = FRERE(I) IF (IB.GE.0) THEN IF (IB.GT.0) NA(IL) = 0 I = IB ELSE I = -IB IL = IL + 1 ENDIF 160 CONTINUE NSTEPS = IS - 1 DO I=1, N IF (NV(I).EQ.0) THEN FRERE(I) = N+1 NFSIZ(I) = 0 ELSE NFSIZ(I) = ND(NODE(I)) IF (SUBORD(I) .NE.0) THEN INOS = -FILS(I) INO = I DO WHILE (SUBORD(INO).NE.0) IS = SUBORD(INO) FILS(INO) = IS INO = IS END DO FILS(INO) = -INOS ENDIF ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ANA_LNEW #endif SUBROUTINE DMUMPS_ANA_M(NE, ND, NSTEPS, & MAXFR, MAXELIM, K50, SIZEFAC_TOT, MAXNPIV, & K5,K6,PANEL_SIZE,K253) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS, K50, K253, K5, K6 INTEGER, INTENT(in) :: NE(NSTEPS), ND(NSTEPS) INTEGER, INTENT(out) :: MAXNPIV, PANEL_SIZE INTEGER, INTENT(out) :: MAXFR, MAXELIM INTEGER(8), INTENT(out):: SIZEFAC_TOT INTEGER ITREE, NFR, NELIM INTEGER LKJIB INTEGER(8) :: SIZEFAC LKJIB = max(K5,K6) MAXFR = 0 MAXELIM = 0 MAXNPIV = 0 PANEL_SIZE = 0 SIZEFAC_TOT = 0_8 DO ITREE=1,NSTEPS NELIM = NE(ITREE) NFR = ND(ITREE) + K253 IF (NFR.GT.MAXFR) MAXFR = NFR IF (NFR-NELIM.GT.MAXELIM) MAXELIM = NFR - NELIM IF (NELIM .GT. MAXNPIV) THEN MAXNPIV = NELIM ENDIF IF (K50.EQ.0) THEN SIZEFAC = (2_8*int(NFR,8) - int(NELIM,8))*int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NFR*(LKJIB+1)) ELSE SIZEFAC = int(NFR,8) * int(NELIM,8) PANEL_SIZE = max(PANEL_SIZE, NELIM*(LKJIB+1)) PANEL_SIZE = max(PANEL_SIZE, (NFR-NELIM)*(LKJIB+1)) ENDIF SIZEFAC_TOT = SIZEFAC_TOT + SIZEFAC END DO RETURN END SUBROUTINE DMUMPS_ANA_M SUBROUTINE DMUMPS_ANA_R( N, FILS, FRERE, & NSTK, NA ) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: NSTK(N), NA(N) INTEGER NBROOT, NBLEAF, ILEAF, I, IN, ISON NA = 0 NSTK = 0 NBROOT = 0 ILEAF = 1 DO 11 I=1,N IF (FRERE(I).EQ. N+1) CYCLE IF (FRERE(I).EQ.0) NBROOT = NBROOT + 1 IN = I 12 IN = FILS(IN) IF (IN.GT.0) GO TO 12 IF (IN.EQ.0) THEN NA(ILEAF) = I ILEAF = ILEAF + 1 CYCLE ENDIF ISON = -IN 13 NSTK(I) = NSTK(I) + 1 ISON = FRERE(ISON) IF (ISON.GT.0) GO TO 13 11 CONTINUE NBLEAF = ILEAF-1 IF (N.GT.1) THEN IF (NBLEAF.GT.N-2) THEN IF (NBLEAF.EQ.N-1) THEN NA(N-1) = -NA(N-1)-1 NA(N) = NBROOT ELSE NA(N) = -NA(N)-1 ENDIF ELSE NA(N-1) = NBLEAF NA(N) = NBROOT ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_ANA_R SUBROUTINE DMUMPS_DIAG_ANA &( MYID, COMM, KEEP,KEEP8, INFO, INFOG, RINFO, RINFOG, ICNTL ) IMPLICIT NONE INTEGER COMM, MYID, KEEP(500), INFO(80), ICNTL(60), INFOG(80) INTEGER(8) KEEP8(150) DOUBLE PRECISION RINFO(40), RINFOG(40) INCLUDE 'mpif.h' INTEGER MASTER, MPG PARAMETER( MASTER = 0 ) MPG = ICNTL(3) IF ( MYID.eq.MASTER.and.MPG.GT.0.AND.ICNTL(4).GE.2) THEN WRITE(MPG, 99992) INFO(1), INFO(2), & KEEP8(109), KEEP8(111), INFOG(4), & INFOG(5), KEEP(28), INFOG(32), INFOG(7), KEEP(23), & ICNTL(7), KEEP(12), & ICNTL(18), & KEEP(56), KEEP(61), RINFOG(1) IF (KEEP(95).GT.1) & WRITE(MPG, 99993) KEEP(95) IF (KEEP(54).GT.0) WRITE(MPG, 99994) KEEP(54) IF (KEEP(60).GT.0) WRITE(MPG, 99995) KEEP(60) IF (KEEP(253).GT.0) WRITE(MPG, 99996) KEEP(253) ENDIF RETURN 99992 FORMAT(/'Leaving analysis phase with ...'/ & ' INFOG(1) =',I16/ & ' INFOG(2) =',I16/ & ' -- (20) Number of entries in factors (estim.) =',I16/ & ' -- (3) Real space for factors (estimated) =',I16/ & ' -- (4) Integer space for factors (estimated) =',I16/ & ' -- (5) Maximum frontal size (estimated) =',I16/ & ' -- (6) Number of nodes in the tree =',I16/ & ' -- (32) Type of analysis effectively used =',I16/ & ' -- (7) Ordering option effectively used =',I16/ & ' ICNTL (6) Maximum transversal option =',I16/ & ' ICNTL (7) Pivot order option =',I16/ & ' ICNTL(14) Percentage of memory relaxation =',I16/ & ' ICNTL(18) Distributed input matrix (on if >0) =',I16/ & ' Number of level 2 nodes =',I16/ & ' Number of split nodes =',I16/ & ' RINFOG(1) Operations during elimination (estim)=', & 1PD10.3) 99993 FORMAT(' Ordering compressed/constrained (ICNTL(12)) =',I16) 99994 FORMAT(' Distributed matrix entry format (ICNTL(18)) =',I16) 99995 FORMAT(' Effective Schur option (ICNTL(19)) =',I16) 99996 FORMAT(' Forward solution during factorization, NRHS =',I16) END SUBROUTINE DMUMPS_DIAG_ANA SUBROUTINE DMUMPS_CUTNODES & ( N, FRERE, FILS, NFSIZ, SIZEOFBLOCKS, LSIZEOFBLOCKS, & NSTEPS, NSLAVES, & KEEP, KEEP8, SPLITROOT, MP, LDIAG, INFO1, INFO2 ) IMPLICIT NONE INTEGER N, NSTEPS, NSLAVES, KEEP(500) INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) LOGICAL SPLITROOT INTEGER MP, LDIAG INTEGER INFO1, INFO2 INTEGER, DIMENSION(:), ALLOCATABLE :: IPOOL INTEGER INODE, DEPTH, I, IBEG, IEND, IIPOOL, NROOT INTEGER MAX_DEPTH, ISON, TOT_CUT, MAX_CUT, STRAT INTEGER(8) :: K79 INTEGER NFRONT, K82, allocok LOGICAL BLKON BLKON = .NOT.(SIZEOFBLOCKS(1).EQ.-1) K79 = KEEP8(79) K82 = abs(KEEP(82)) STRAT= KEEP(62) IF (KEEP(210).EQ.1) THEN MAX_DEPTH = 2*NSLAVES*K82 STRAT = STRAT/4 ELSE IF (( NSLAVES .eq. 1 ).AND. (.NOT. SPLITROOT) ) RETURN IF (NSLAVES.EQ.1) THEN MAX_DEPTH=1 ELSE MAX_DEPTH = int( log( dble( NSLAVES - 1 ) ) & / log(2.0D0) ) ENDIF ENDIF ALLOCATE(IPOOL(NSTEPS+1), stat=allocok) IF (allocok.GT.0) THEN INFO1= -7 INFO2= NSTEPS+1 RETURN ENDIF NROOT = 0 DO INODE = 1, N IF ( FRERE(INODE) .eq. 0 ) THEN NROOT = NROOT + 1 IPOOL( NROOT ) = INODE END IF END DO IBEG = 1 IEND = NROOT IIPOOL = NROOT + 1 IF (SPLITROOT) THEN MAX_DEPTH=0 ENDIF DO DEPTH = 1, MAX_DEPTH DO I = IBEG, IEND INODE = IPOOL( I ) ISON = INODE DO WHILE ( ISON .GT. 0 ) ISON = FILS( ISON ) END DO ISON = - ISON DO WHILE ( ISON .GT. 0 ) IPOOL( IIPOOL ) = ISON IIPOOL = IIPOOL + 1 ISON = FRERE( ISON ) END DO END DO IPOOL( IBEG ) = -IPOOL( IBEG ) IBEG = IEND + 1 IEND = IIPOOL - 1 END DO IPOOL( IBEG ) = -IPOOL( IBEG ) TOT_CUT = 0 IF (SPLITROOT) THEN MAX_CUT = NROOT*max(K82,2) INODE = abs(IPOOL(1)) NFRONT = NFSIZ( INODE ) K79 = max( & int(NFRONT,8)*int(NFRONT,8)/(int(K82+1,8)*int(K82+1,8)), & 9_8) IF (KEEP(53).NE.0) THEN MAX_CUT = NFRONT K79 = 121_8*121_8 ELSE K79 = min(2000_8*2000_8,K79) IF (KEEP(376) .EQ. 1) THEN K79 = min(int(KEEP(9)+1,8)*int(KEEP(9)+1,8),K79) ENDIF ENDIF ELSE MAX_CUT = 2 * NSLAVES IF (KEEP(210).EQ.1) THEN MAX_CUT = 4 * (MAX_CUT + 4) ENDIF ENDIF DEPTH = -1 DO I = 1, IIPOOL - 1 INODE = IPOOL( I ) IF ( INODE .LT. 0 ) THEN INODE = -INODE DEPTH = DEPTH + 1 END IF CALL DMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, & KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF ( TOT_CUT > MAX_CUT ) EXIT END DO KEEP(61) = TOT_CUT DEALLOCATE(IPOOL) RETURN END SUBROUTINE DMUMPS_CUTNODES RECURSIVE SUBROUTINE DMUMPS_SPLIT_1NODE & ( INODE, N, FRERE, FILS, NFSIZ, NSTEPS, NSLAVES, KEEP,KEEP8, & TOT_CUT, STRAT, DEPTH, K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IMPLICIT NONE INTEGER(8) :: K79 INTEGER INODE, N, NSTEPS, NSLAVES, KEEP(500), STRAT, & DEPTH, TOT_CUT, MP, LDIAG INTEGER(8) KEEP8(150) INTEGER FRERE( N ), FILS( N ), NFSIZ( N ) LOGICAL SPLITROOT LOGICAL BLKON INTEGER LSIZEOFBLOCKS INTEGER SIZEOFBLOCKS(LSIZEOFBLOCKS) INTEGER I, IN, NPIV, NFRONT, NSLAVES_ESTIM DOUBLE PRECISION WK_SLAVE, WK_MASTER INTEGER INODE_SON, INODE_FATH, IN_SON, IN_FATH, IN_GRANDFATH INTEGER NPIV_COMPG, NPIV_SON_COMPG, NPIV_FATH_COMPG INTEGER NPIV_SON, NPIV_FATH, NPIV_TEMP INTEGER NCB, NSLAVESMIN, NSLAVESMAX INTEGER MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX EXTERNAL MUMPS_BLOC2_GET_NSLAVESMIN, & MUMPS_BLOC2_GET_NSLAVESMAX IF ( (KEEP(210).EQ.1.AND.KEEP(60).EQ.0) .OR. & (SPLITROOT) ) THEN IF ( FRERE ( INODE ) .eq. 0 ) THEN NFRONT = NFSIZ( INODE ) NPIV = NFRONT IF (BLKON) THEN IN = INODE NPIV_COMPG = 0 DO WHILE( IN > 0 ) NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) ENDDO ELSE NPIV_COMPG = NPIV ENDIF NCB = 0 IF ( int(NFRONT,8)*int(NFRONT,8).GT.K79 & ) THEN GOTO 333 ENDIF ENDIF ENDIF IF ( FRERE ( INODE ) .eq. 0 ) RETURN NFRONT = NFSIZ( INODE ) IN = INODE NPIV = 0 NPIV_COMPG = 0 DO WHILE( IN > 0 ) IF (BLKON) THEN NPIV = NPIV + SIZEOFBLOCKS(IN) ENDIF NPIV_COMPG = NPIV_COMPG + 1 IN = FILS( IN ) END DO IF (.NOT.BLKON) NPIV = NPIV_COMPG NCB = NFRONT - NPIV IF ( (NFRONT - (NPIV/2)) .LE. KEEP(9)) RETURN IF ((KEEP(50) == 0.and.int(NFRONT,8) * int(NPIV,8) > K79 ) .OR. &(KEEP(50) .NE.0.and.int(NPIV,8) * int(NPIV,8) > K79 )) GOTO 333 IF (KEEP(210).EQ.1) THEN NSLAVESMIN = 1 NSLAVESMAX = 64 NSLAVES_ESTIM = 32+NSLAVES ELSE NSLAVESMIN = MUMPS_BLOC2_GET_NSLAVESMIN & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVESMAX = MUMPS_BLOC2_GET_NSLAVESMAX & ( NSLAVES, KEEP(48), KEEP8(21), KEEP(50), & NFRONT, NCB, KEEP(375), KEEP(119)) NSLAVES_ESTIM = max (1, & nint( dble(NSLAVESMAX-NSLAVESMIN)/dble(3) ) & ) NSLAVES_ESTIM = min (NSLAVES_ESTIM, NSLAVES-1) ENDIF IF ( KEEP(50) .eq. 0 ) THEN WK_MASTER = 0.6667D0 * & dble(NPIV)*dble(NPIV)*dble(NPIV) + & dble(NPIV)*dble(NPIV)*dble(NCB) WK_SLAVE = dble( NPIV ) * dble( NCB ) * & ( 2.0D0 * dble(NFRONT) - dble(NPIV) ) & / dble(NSLAVES_ESTIM) ELSE WK_MASTER = dble(NPIV)*dble(NPIV)*dble(NPIV) / dble(3) WK_SLAVE = & (dble(NPIV)*dble(NCB)*dble(NFRONT)) & / dble(NSLAVES_ESTIM) ENDIF IF (KEEP(210).EQ.1) THEN IF ( dble( 100 + STRAT ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ELSE IF ( dble( 100 + STRAT * max( DEPTH-1, 1 ) ) & * WK_SLAVE / dble(100) .GE. WK_MASTER ) RETURN ENDIF 333 CONTINUE IF (NPIV .LE. 1 ) RETURN NPIV_SON = max(NPIV/2,1) NPIV_FATH = NPIV - NPIV_SON IF (SPLITROOT) THEN IF (NCB .NE .0) THEN WRITE(*,*) "Error splitting" CALL MUMPS_ABORT() ENDIF NPIV_FATH = min(int(sqrt(dble(K79))), int(NPIV/2)) NPIV_SON = NPIV - NPIV_FATH ENDIF INODE_SON = INODE IF (BLKON) THEN NPIV_TEMP = 0 NPIV_SON_COMPG = 0 IN_SON = INODE DO WHILE (IN_SON > 0) NPIV_TEMP = NPIV_TEMP + SIZEOFBLOCKS(IN_SON) NPIV_SON_COMPG = NPIV_SON_COMPG +1 IF (NPIV_TEMP.GE.NPIV_SON) EXIT IN_SON = FILS( IN_SON ) END DO NPIV_FATH_COMPG = NPIV_COMPG - NPIV_SON_COMPG NPIV_SON = NPIV_TEMP NPIV_FATH = NPIV - NPIV_SON ELSE NPIV_SON_COMPG = NPIV_SON NPIV_FATH_COMPG = NPIV_FATH IN_SON = INODE DO I = 1, NPIV_SON_COMPG - 1 IN_SON = FILS( IN_SON ) END DO ENDIF IF (NPIV_FATH_COMPG.EQ.0) RETURN NSTEPS = NSTEPS + 1 TOT_CUT = TOT_CUT + 1 INODE_FATH = FILS( IN_SON ) IF ( INODE_FATH .LT. 0 ) THEN write(*,*) 'Error: INODE_FATH < 0 ', INODE_FATH END IF IN_FATH = INODE_FATH DO WHILE ( FILS( IN_FATH ) > 0 ) IN_FATH = FILS( IN_FATH ) END DO FRERE( INODE_FATH ) = FRERE( INODE_SON ) FRERE( INODE_SON ) = - INODE_FATH FILS ( IN_SON ) = FILS( IN_FATH ) FILS ( IN_FATH ) = - INODE_SON IN = FRERE( INODE_FATH ) DO WHILE ( IN > 0 ) IN = FRERE( IN ) END DO IF ( IN .eq. 0 ) GO TO 10 IN = -IN DO WHILE ( FILS( IN ) > 0 ) IN = FILS( IN ) END DO IN_GRANDFATH = IN IF ( FILS( IN_GRANDFATH ) .eq. - INODE_SON ) THEN FILS( IN_GRANDFATH ) = -INODE_FATH ELSE IN = IN_GRANDFATH IN = - FILS ( IN ) DO WHILE ( FRERE( IN ) > 0 ) IF ( FRERE( IN ) .eq. INODE_SON ) THEN FRERE( IN ) = INODE_FATH GOTO 10 END IF IN = FRERE( IN ) END DO WRITE(*,*) 'ERROR 2 in SPLIT NODE', & IN_GRANDFATH, IN, FRERE(IN) END IF 10 CONTINUE NFSIZ(INODE_SON) = NFRONT NFSIZ(INODE_FATH) = NFRONT - NPIV_SON KEEP(2) = max( KEEP(2), NFRONT - NPIV_SON ) IF (SPLITROOT) THEN RETURN ENDIF CALL DMUMPS_SPLIT_1NODE & ( INODE_FATH, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) IF (.NOT. SPLITROOT) THEN CALL DMUMPS_SPLIT_1NODE & ( INODE_SON, N, FRERE, FILS, NFSIZ, NSTEPS, & NSLAVES, KEEP,KEEP8, TOT_CUT, STRAT, DEPTH, & K79, SPLITROOT, MP, LDIAG, & BLKON, SIZEOFBLOCKS, LSIZEOFBLOCKS ) ENDIF RETURN END SUBROUTINE DMUMPS_SPLIT_1NODE SUBROUTINE DMUMPS_ANA_GNEW & (N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, PRINTSTAT, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: LW INTEGER(8), intent(in) :: NZ INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, intent(inout) :: IFLAG, KEEP264, KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(in) :: PRINTSTAT LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 DOUBLE PRECISION :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IW(L) = I IQ(J) = L + 1 IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int((IQ(I) - IPE(I))) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ELSE KEEP265 = 1 ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = dble(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & dble(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) & THEN KEEP265 = -1 ENDIF symmetry = min(nint (100.0D0*RSYM), 100) IF (PRINTSTAT) THEN IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,I5)') & ' ... Structural symmetry (in percent)=', symmetry ENDIF ELSE ENDIF AvgDens = nint(dble(IWFR-1_8)/dble(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) IF (PRINTSTAT) THEN IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MP,'(A,1I5)') & ' Average density of rows/columns =', AvgDens ENDIF RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE DMUMPS_ANA_GNEW SUBROUTINE DMUMPS_SET_K821_SURFACE & (KEEP821, KEEP2, KEEP48 ,KEEP50, NSLAVES) IMPLICIT NONE INTEGER NSLAVES, KEEP2, KEEP48, KEEP50 INTEGER (8) :: KEEP821 INTEGER(8) KEEP2_SQUARE, NSLAVES8 NSLAVES8= int(NSLAVES,8) KEEP2_SQUARE = int(KEEP2,8) * int(KEEP2,8) KEEP821 = max(KEEP821*int(KEEP2,8),1_8) #if defined(t3e) KEEP821 = min(1500000_8, KEEP821) #elif defined(SP_) KEEP821 = min(3000000_8, KEEP821) #else KEEP821 = min(2000000_8, KEEP821) #endif #if defined(t3e) IF (NSLAVES .GT. 64) THEN KEEP821 = & min(8_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #else IF (NSLAVES.GT.64) THEN KEEP821 = & min(6_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ELSE KEEP821 = & min(4_8*KEEP2_SQUARE/NSLAVES8+1_8, KEEP821) ENDIF #endif IF (KEEP50 .EQ. 0 ) THEN KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ELSE KEEP821 = max(KEEP821,(7_8*KEEP2_SQUARE / & 4_8 / int(max(NSLAVES-1,1),8)) + int(KEEP2,8)) ENDIF IF (KEEP50 .EQ. 0 ) THEN #if defined(t3e) KEEP821 = max(KEEP821,200000_8) #else KEEP821 = max(KEEP821,300000_8) #endif ELSE #if defined(t3e) KEEP821 = max(KEEP821,40000_8) #else KEEP821 = max(KEEP821,80000_8) #endif ENDIF KEEP821 = -KEEP821 RETURN END SUBROUTINE DMUMPS_SET_K821_SURFACE SUBROUTINE DMUMPS_MTRANS_DRIVER(JOB,M,N,NE, & IP,IRN,A,LA,NUM,PERM,LIW,IW,LDW,DW, & IPQ8, & ICNTL,CNTL,INFO, INFOMUMPS) IMPLICIT NONE INTEGER :: NICNTL, NCNTL, NINFO, INFOMUMPS(80) PARAMETER (NICNTL=10, NCNTL=10, NINFO=10) INTEGER :: JOB,M,N,NUM INTEGER(8), INTENT(IN) :: NE, LIW,LDW, LA INTEGER(8) :: IP(N+1), IPQ8(N) INTEGER :: IRN(NE),PERM(M),IW(LIW) INTEGER :: ICNTL(NICNTL),INFO(NINFO) DOUBLE PRECISION :: A(LA) DOUBLE PRECISION :: DW(LDW),CNTL(NCNTL) INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWtemp8 INTEGER :: allocok INTEGER :: I,J,WARN1,WARN2,WARN4 INTEGER(8) :: K DOUBLE PRECISION :: FACT,ZERO,ONE,RINF,RINF2,RINF3 PARAMETER (ZERO=0.0D+00,ONE=1.0D+0) EXTERNAL DMUMPS_MTRANSZ,DMUMPS_MTRANSB,DMUMPS_MTRANSR, & DMUMPS_MTRANSS,DMUMPS_MTRANSW INTRINSIC abs,log RINF = CNTL(2) RINF2 = huge(RINF2)/dble(2*N) RINF3 = 0.0D0 WARN1 = 0 WARN2 = 0 WARN4 = 0 IF (JOB.LT.1 .OR. JOB.GT.6) THEN INFO(1) = -1 INFO(2) = JOB IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'JOB',JOB GO TO 99 ENDIF IF (M.LT.1 .OR. M.LT.N) THEN INFO(1) = -2 INFO(2) = M IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'M',M GO TO 99 ENDIF IF (N.LT.1) THEN INFO(1) = -2 INFO(2) = N IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'N',N GO TO 99 ENDIF IF (NE.LT.1) THEN INFO(1) = -3 CALL MUMPS_SET_IERROR(NE,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9001) INFO(1),'NE',NE GO TO 99 ENDIF IF (JOB.EQ.1) K = int(4*N + M,8) IF (JOB.EQ.2) K = int(N + 2*M,8) IF (JOB.EQ.3) K = int(8*N + 2*M + NE,8) IF (JOB.EQ.4) K = int(N + M,8) IF (JOB.EQ.5) K = int(3*N + 2*M,8) IF (JOB.EQ.6) K = int(3*N + 2*M + NE,8) IF (LIW.LT.K) THEN INFO(1) = -4 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9004) INFO(1),K GO TO 99 ENDIF IF (JOB.GT.1) THEN IF (JOB.EQ.2) K = int( M,8) IF (JOB.EQ.3) K = int(1,8) IF (JOB.EQ.4) K = int( 2*M,8) IF (JOB.EQ.5) K = int(N + 2*M,8) IF (JOB.EQ.6) K = int(N + 3*M,8) IF (LDW .LT. K) THEN INFO(1) = -5 CALL MUMPS_SET_IERROR(K,INFO(2)) IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9005) INFO(1),K GO TO 99 ENDIF ENDIF IF (ICNTL(5).EQ.0) THEN DO 3 I = 1,M IW(I) = 0 3 CONTINUE DO 6 J = 1,N DO 4 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (I.LT.1 .OR. I.GT.M) THEN INFO(1) = -6 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9006) INFO(1),J,I GO TO 99 ENDIF IF (IW(I).EQ.J) THEN INFO(1) = -7 INFO(2) = J IF (ICNTL(1).GE.0) WRITE(ICNTL(1),9007) INFO(1),J,I GO TO 99 ELSE IW(I) = J ENDIF 4 CONTINUE 6 CONTINUE ENDIF IF (ICNTL(3).GT.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9020) JOB,M,N,NE IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,min(10,N+1)) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,min(10_8,NE)) IF (JOB.GT.1) WRITE(ICNTL(3),9023) & (A(K),K=1_8,min(10_8,NE)) ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9021) (IP(J),J=1,N+1) WRITE(ICNTL(3),9022) (IRN(K),K=1_8,NE) IF (JOB.GT.1) WRITE(ICNTL(3),9023) (A(K),K=1_8,NE) ENDIF WRITE(ICNTL(3),9024) (ICNTL(J),J=1,NICNTL) WRITE(ICNTL(3),9025) (CNTL(J),J=1,NCNTL) ENDIF ENDIF DO 8 I=1,NINFO INFO(I) = 0 8 CONTINUE IF (JOB.EQ.1) THEN DO 10 J = 1,N IW(J) = int(IP(J+1) - IP(J)) 10 CONTINUE CALL DMUMPS_MTRANSZ(M,N,IRN,NE,IP,IW(1),PERM,NUM, & IW(N+1),IW(2*N+1),IW(3*N+1),IW(3*N+M+1)) GO TO 90 ENDIF IF (JOB.EQ.2) THEN DW(1) = max(ZERO,CNTL(1)) CALL DMUMPS_MTRANSB(M,N,NE,IP,IRN,A,PERM,NUM, & IW(1),IPQ8,IW(N+1),IW(N+M+1),DW,RINF2) GO TO 90 ENDIF IF (JOB.EQ.3) THEN DO 20 K = 1,NE IW(K) = IRN(K) 20 CONTINUE CALL DMUMPS_MTRANSR(N,NE,IP,IW,A) FACT = max(ZERO,CNTL(1)) CALL DMUMPS_MTRANSS(M,N,NE,IP,IW(1),A,PERM,NUM,IW(NE+1), & IW(NE+N+1),IW(NE+2*N+1),IW(NE+3*N+1),IW(NE+4*N+1), & IW(NE+5*N+1),IW(NE+5*N+M+1),FACT,RINF2) GO TO 90 ENDIF IF ((JOB.EQ.4).OR.(JOB.EQ.5).or.(JOB.EQ.6)) THEN ALLOCATE(IWtemp8(M+N+N), stat=allocok) IF (allocok.GT.0) THEN INFOMUMPS(1) = -7 INFOMUMPS(2) = M+N+N GOTO 90 ENDIF ENDIF IF (JOB.EQ.4) THEN DO 50 J = 1,N FACT = ZERO DO 30 K = IP(J),IP(J+1)-1_8 IF (abs(A(K)).GT.FACT) FACT = abs(A(K)) 30 CONTINUE IF(FACT .GT. RINF3) RINF3 = FACT DO 40 K = IP(J),IP(J+1)-1_8 A(K) = FACT - abs(A(K)) 40 CONTINUE 50 CONTINUE DW(1) = max(ZERO,CNTL(1)) DW(2) = RINF3 IWtemp8(1) = int(JOB,8) CALL DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) DEALLOCATE(IWtemp8) GO TO 90 ENDIF IF (JOB.EQ.5 .or. JOB.EQ.6) THEN RINF3=ONE IF (JOB.EQ.5) THEN DO 75 J = 1,N FACT = ZERO DO 60 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.FACT) FACT = A(K) 60 CONTINUE DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) IF(FACT .GT. RINF3) RINF3=FACT DO 70 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 70 CONTINUE ELSE DO 71 K = IP(J),IP(J+1)-1_8 A(K) = ONE 71 CONTINUE ENDIF 75 CONTINUE ENDIF IF (JOB.EQ.6) THEN DO 175 K = 1,NE IW(3*N+2*M+K) = IRN(K) 175 CONTINUE DO 61 I = 1,M DW(2*M+N+I) = ZERO 61 CONTINUE DO 63 J = 1,N DO 62 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (A(K).GT.DW(2*M+N+I)) THEN DW(2*M+N+I) = A(K) ENDIF 62 CONTINUE 63 CONTINUE DO 64 I = 1,M IF (DW(2*M+N+I).NE.ZERO) THEN DW(2*M+N+I) = 1.0D0/DW(2*M+N+I) ENDIF 64 CONTINUE DO 66 J = 1,N DO 65 K = IP(J),IP(J+1)-1 I = IRN(K) A(K) = DW(2*M+N+I) * A(K) 65 CONTINUE 66 CONTINUE CALL DMUMPS_MTRANSR(N,NE,IP,IW(3*N+2*M+1),A) DO 176 J = 1,N IF (IP(J).NE.IP(J+1)) THEN FACT = A(IP(J)) ELSE FACT = ZERO ENDIF DW(2*M+J) = FACT IF (FACT.NE.ZERO) THEN FACT = log(FACT) DO 170 K = IP(J),IP(J+1)-1_8 IF (A(K).NE.ZERO) THEN A(K) = FACT - log(A(K)) IF(A(K) .GT. RINF3) RINF3=A(K) ELSE A(K) = FACT + RINF ENDIF 170 CONTINUE ELSE DO 171 K = IP(J),IP(J+1)-1_8 A(K) = ONE 171 CONTINUE ENDIF 176 CONTINUE ENDIF DW(1) = max(ZERO,CNTL(1)) RINF3 = RINF3+ONE DW(2) = RINF3 IWtemp8(1) = int(JOB,8) IF (JOB.EQ.5) THEN CALL DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF (JOB.EQ.6) THEN CALL DMUMPS_MTRANSW(M,N,NE,IP,IW(3*N+2*M+1),A,PERM,NUM, & IWtemp8(1),IW(1),IWtemp8(N+1),IPQ8,IW(N+1), & IWtemp8(2*N+1), & DW(1),DW(M+1),RINF2) ENDIF IF ((JOB.EQ.5).or.(JOB.EQ.6)) THEN DEALLOCATE(IWtemp8) ENDIF IF (JOB.EQ.6) THEN DO 79 I = 1,M IF (DW(2*M+N+I).NE.0.0D0) THEN DW(I) = DW(I) + log(DW(2*M+N+I)) ENDIF 79 CONTINUE ENDIF IF (NUM.EQ.N) THEN DO 80 J = 1,N IF (DW(2*M+J).NE.ZERO) THEN DW(M+J) = DW(M+J) - log(DW(2*M+J)) ELSE DW(M+J) = ZERO ENDIF 80 CONTINUE ENDIF FACT = 0.5D0*log(RINF2) DO 86 I = 1,M IF (DW(I).LT.FACT) GO TO 86 WARN2 = 2 GO TO 90 86 CONTINUE DO 87 J = 1,N IF (DW(M+J).LT.FACT) GO TO 87 WARN2 = 2 GO TO 90 87 CONTINUE ENDIF 90 IF (INFOMUMPS(1).LT.0) RETURN IF (NUM.LT.N) WARN1 = 1 IF (JOB.EQ.4 .OR. JOB.EQ.5 .OR. JOB.EQ.6) THEN IF (CNTL(1).LT.ZERO) WARN4 = 4 ENDIF IF (INFO(1).EQ.0) THEN INFO(1) = WARN1 + WARN2 + WARN4 IF (INFO(1).GT.0 .AND. ICNTL(2).GT.0) THEN WRITE(ICNTL(2),9010) INFO(1) IF (WARN1.EQ.1) WRITE(ICNTL(2),9011) IF (WARN2.EQ.2) WRITE(ICNTL(2),9012) IF (WARN4.EQ.4) WRITE(ICNTL(2),9014) ENDIF ENDIF IF (ICNTL(3).GE.0) THEN IF (ICNTL(4).EQ.0 .OR. ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9030) (INFO(J),J=1,2) WRITE(ICNTL(3),9031) NUM IF (ICNTL(4).EQ.0) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,min(10,M)) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,min(10,M)) WRITE(ICNTL(3),9034) (DW(M+J),J=1,min(10,N)) ENDIF ELSEIF (ICNTL(4).EQ.1) THEN WRITE(ICNTL(3),9032) (PERM(J),J=1,M) IF (JOB.EQ.5 .OR. JOB.EQ.6) THEN WRITE(ICNTL(3),9033) (DW(J),J=1,M) WRITE(ICNTL(3),9034) (DW(M+J),J=1,N) ENDIF ENDIF ENDIF ENDIF 99 RETURN 9001 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2, & ' because ',(A),' = ',I14) 9004 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LIW too small, must be at least ',I14) 9005 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' LDW too small, must be at least ',I14) 9006 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains an entry with invalid row index ',I8) 9007 FORMAT (' ****** Error in DMUMPS_MTRANSA. INFO(1) = ',I2/ & ' Column ',I8, & ' contains two or more entries with row index ',I8) 9010 FORMAT (' ****** Warning from DMUMPS_MTRANSA. INFO(1) = ',I2) 9011 FORMAT (' - The matrix is structurally singular.') 9012 FORMAT (' - Some scaling factors may be too large.') 9014 FORMAT (' - CNTL(1) is negative and was treated as zero.') 9020 FORMAT (' ****** Input parameters for DMUMPS_MTRANSA:'/ & ' JOB =',I10/' M =',I10/' N =',I10/' NE =',I14) 9021 FORMAT (' IP(1:N+1) = ',8I8/(15X,8I8)) 9022 FORMAT (' IRN(1:NE) = ',8I8/(15X,8I8)) 9023 FORMAT (' A(1:NE) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9024 FORMAT (' ICNTL(1:10) = ',8I8/(15X,2I8)) 9025 FORMAT (' CNTL(1:10) = ',4(1PD14.4)/(15X,4(1PD14.4))) 9030 FORMAT (' ****** Output parameters for DMUMPS_MTRANSA:'/ & ' INFO(1:2) = ',2I8) 9031 FORMAT (' NUM = ',I8) 9032 FORMAT (' PERM(1:M) = ',8I8/(15X,8I8)) 9033 FORMAT (' DW(1:M) = ',5(F11.3)/(15X,5(F11.3))) 9034 FORMAT (' DW(M+1:M+N) = ',5(F11.3)/(15X,5(F11.3))) END SUBROUTINE DMUMPS_MTRANS_DRIVER SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_VAL(N,NZ,IP,IRN,A,FLAG,POSI) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) DOUBLE PRECISION, INTENT(INOUT) :: A(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER(8), INTENT(OUT) :: POSI(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL, SV_POS FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW A(WR_POS) = A(K) FLAG(ROW) = COL POSI(ROW) = WR_POS WR_POS = WR_POS+1 ELSE SV_POS = POSI(ROW) A(SV_POS) = A(SV_POS) + A(K) ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_VAL SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_STR(N,NZ,IP,IRN,FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(INOUT) :: NZ INTEGER(8), INTENT(INOUT) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NZ) INTEGER, INTENT(OUT) :: FLAG(N) INTEGER :: ROW, COL INTEGER(8) :: K, WR_POS, BEG_COL FLAG = 0 WR_POS = 1_8 DO COL=1,N BEG_COL = WR_POS DO K=IP(COL),IP(COL+1)-1_8 ROW = IRN(K) IF(FLAG(ROW) .NE. COL) THEN IRN(WR_POS) = ROW FLAG(ROW) = COL WR_POS = WR_POS+1_8 ENDIF ENDDO IP(COL) = BEG_COL ENDDO IP(N+1) = WR_POS NZ = WR_POS-1_8 RETURN END SUBROUTINE DMUMPS_SUPPRESS_DUPPLI_STR SUBROUTINE DMUMPS_SORT_PERM( N, NA, LNA, NE_STEPS, & PERM, FILS, & DAD_STEPS, STEP, NSTEPS, & KEEP60, KEEP20, KEEP38, & INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA INTEGER, INTENT(IN) :: FILS( N ), STEP(N), NA(LNA) INTEGER, INTENT(IN) :: DAD_STEPS ( NSTEPS ), NE_STEPS (NSTEPS) INTEGER, INTENT(IN) :: KEEP60, KEEP20, KEEP38 INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(OUT) :: PERM( N ) INTEGER :: IPERM, INODE, IN, ISCHUR INTEGER :: INBLEAF, INBROOT, allocok INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, NSTK INBLEAF = NA(1) INBROOT = NA(2) ALLOCATE(POOL(INBLEAF), NSTK(NSTEPS), stat=allocok) IF (allocok > 0 ) THEN INFO(1) = -7 INFO(2) = INBLEAF + NSTEPS RETURN ENDIF POOL(1:INBLEAF) = NA(3:2+INBLEAF) NSTK(1:NSTEPS) = NE_STEPS(1:NSTEPS) ISCHUR = 0 IF ( KEEP60.GT.0 ) THEN ISCHUR = max (KEEP20, KEEP38) ENDIF IPERM = 1 DO WHILE ( INBLEAF .NE. 0 ) INODE = POOL( INBLEAF ) INBLEAF = INBLEAF - 1 IN = INODE IF (INODE.NE.ISCHUR) THEN DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF IN = DAD_STEPS(STEP( INODE )) IF ( IN .eq. 0 ) THEN INBROOT = INBROOT - 1 ELSE NSTK( STEP(IN) ) = NSTK( STEP(IN) ) - 1 IF ( NSTK( STEP(IN) ) .eq. 0 ) THEN INBLEAF = INBLEAF + 1 POOL( INBLEAF ) = IN END IF END IF END DO IF (IPERM.LE.N) THEN IF (ISCHUR.GT.0) THEN IN = ISCHUR DO WHILE ( IN .GT. 0 ) PERM ( IN ) = IPERM IPERM = IPERM + 1 IN = FILS( IN ) END DO ENDIF ENDIF DEALLOCATE(POOL, NSTK) RETURN END SUBROUTINE DMUMPS_SORT_PERM SUBROUTINE DMUMPS_EXPAND_TREE_STEPS( ICNTL, & N, NBLK, BLKPTR, BLKVAR, & FILS_OLD, FILS_NEW, NSTEPS, & STEP_OLD, STEP_NEW, PAR2_NODES, NB_NIV2, & DAD_STEPS, FRERE_STEPS, & NA, LNA, LRGROUPS_OLD, LRGROUPS_NEW, & K20, K38 & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NBLK, ICNTL(60), NSTEPS, LNA, & NB_NIV2 INTEGER, INTENT(IN) :: BLKPTR(NBLK+1), BLKVAR(N) INTEGER, INTENT(IN) :: FILS_OLD(NBLK), STEP_OLD(NBLK), & LRGROUPS_OLD(NBLK) INTEGER, INTENT(OUT) :: FILS_NEW(N), STEP_NEW(N), & LRGROUPS_NEW(N) INTEGER, INTENT(INOUT) :: DAD_STEPS(NSTEPS), FRERE_STEPS(NSTEPS) INTEGER, INTENT(INOUT) :: NA(LNA), PAR2_NODES(NB_NIV2), K20, K38 INTEGER :: IB, I, IBFS, IBNB, IFS, INB INTEGER NBLEAF, NBROOT, ISTEP, IGROUP INTEGER :: II IF (K20.GT.0) K20 = BLKVAR(BLKPTR(K20)) IF (K38.GT.0) K38 = BLKVAR(BLKPTR(K38)) NBLEAF = NA(1) NBROOT = NA(2) IF (NBLK.GT.1) THEN DO I= 3, 3+NBLEAF+NBROOT-1 IBNB = NA(I) INB = BLKVAR(BLKPTR(IBNB)) NA(I) = INB ENDDO ENDIF IF (PAR2_NODES(1).GT.0) THEN DO I=1, NB_NIV2 IBNB = PAR2_NODES(I) INB = BLKVAR(BLKPTR(IBNB)) PAR2_NODES(I) = INB ENDDO ENDIF DO I= 1, NSTEPS IBNB = DAD_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(IBNB)) ENDIF DAD_STEPS(I) = INB ENDDO DO I= 1, NSTEPS IBNB = FRERE_STEPS(I) IF (IBNB.EQ.0) THEN INB = 0 ELSE INB = BLKVAR(BLKPTR(abs(IBNB))) IF (IBNB.LT.0) INB=-INB ENDIF FRERE_STEPS(I) = INB ENDDO DO IB=1, NBLK IBFS = FILS_OLD(IB) IF (IBFS.EQ.0) THEN IFS = 0 ELSE IFS = BLKVAR(BLKPTR(abs(IBFS))) IF (IBFS.LT.0) IFS=-IFS ENDIF IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 IF (II.LT. BLKPTR(IB+1)-1) THEN FILS_NEW(BLKVAR(II))= BLKVAR(II+1) ELSE FILS_NEW(BLKVAR(II))= IFS ENDIF ENDDO ENDDO DO IB=1, NBLK ISTEP = STEP_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE IF (ISTEP.LT.0) THEN DO II=BLKPTR(IB), BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = ISTEP ENDDO ELSE I = BLKVAR(BLKPTR(IB)) STEP_NEW(I) = ISTEP DO II=BLKPTR(IB)+1, BLKPTR(IB+1)-1 STEP_NEW(BLKVAR(II)) = -ISTEP ENDDO ENDIF ENDDO DO IB=1, NBLK IGROUP = LRGROUPS_OLD(IB) IF (BLKPTR(IB+1)-BLKPTR(IB).EQ.0) CYCLE DO II=BLKPTR(IB), BLKPTR(IB+1)-1 LRGROUPS_NEW(BLKVAR(II)) = IGROUP ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_EXPAND_TREE_STEPS SUBROUTINE DMUMPS_DIST_AVOID_COPIES(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,PEAK,IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) USE MUMPS_STATIC_MAPPING IMPLICIT NONE INTEGER N, NSLAVES, NBSA, IERR INTEGER ICNTL(60),INFOG(80),KEEP(500) INTEGER(8) KEEP8(150) INTEGER NE(N),NFSIZ(N),FRERE(N),FILS(N),PROCNODE(N) INTEGER SSARBR(N) DOUBLE PRECISION PEAK INTEGER, intent(IN) :: LSIZEOFBLOCKS INTEGER, intent(IN) :: SIZEOFBLOCKS(LSIZEOFBLOCKS) CALL MUMPS_DISTRIBUTE(N,NSLAVES, & ICNTL,INFOG, NE, NFSIZ, & FRERE, FILS, & KEEP,KEEP8,PROCNODE, & SSARBR,NBSA,dble(PEAK),IERR & , SIZEOFBLOCKS, LSIZEOFBLOCKS & ) RETURN END SUBROUTINE DMUMPS_DIST_AVOID_COPIES SUBROUTINE DMUMPS_SET_PROCNODE(INODE, PROCNODE, VALUE, FILS, N) INTEGER, intent(in) :: INODE, N, VALUE INTEGER, intent(in) :: FILS(N) INTEGER, intent(inout) :: PROCNODE(N) INTEGER IN IN=INODE DO WHILE ( IN > 0 ) PROCNODE( IN ) = VALUE IN=FILS( IN ) ENDDO RETURN END SUBROUTINE DMUMPS_SET_PROCNODE MUMPS_5.4.1/src/zfac_mem_stack_aux.F0000664000175000017500000001554414102210524017447 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_COMPACT_FACTORS(A, LDA, NPIV, NBROW, K50, & SIZEA ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 INTEGER(8), INTENT(IN) :: SIZEA COMPLEX(kind=8) A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500 IF ( K50.NE.0 ) THEN IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN INEW = INEW + int(NPIV,8) * int(NPIV - 1,8) IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8) ELSE DO I = 1, NPIV - 1 IF ( I .LE. NPIV-2 ) THEN ILAST = I+1 ELSE ILAST = I ENDIF DO J8 = 0_8, int(ILAST,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) END DO ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW ELSE INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8) IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8) NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1 ENDIF DO I = 1, NBROW_L_RECTANGLE_TO_MOVE DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) ENDDO 500 RETURN END SUBROUTINE ZMUMPS_COMPACT_FACTORS SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA COMPLEX(kind=8), INTENT(INOUT) :: A(SIZEA) INTEGER I, J INTEGER(8) :: INEW, IOLD INEW = int(NPIV+1,8) IOLD = int(LDA+1,8) DO I = 2, NCONTIG DO J = 1, NPIV A(INEW)=A(IOLD) INEW = INEW + 1_8 IOLD = IOLD + 1_8 ENDDO IOLD = IOLD + int(LDA - NPIV,8) ENDDO RETURN END SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX(kind=8) A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX(kind=8) A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.4.1/src/mumps_save_restore_C.h0000664000175000017500000000207114102210474020045 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_SAVE_RESTORE_C_H #define MUMPS_SAVE_RESTORE_C_H #include "mumps_common.h" #define MUMPS_GET_SAVE_DIR_C \ F_SYMBOL(get_save_dir_c,GET_SAVE_DIR_C) void MUMPS_CALL MUMPS_GET_SAVE_DIR_C(MUMPS_INT *len_save_dir, char* save_dir, mumps_ftnlen l1); #define MUMPS_GET_SAVE_PREFIX_C \ F_SYMBOL(get_save_prefix_c,GET_SAVE_PREFIX_C) void MUMPS_CALL MUMPS_GET_SAVE_PREFIX_C(MUMPS_INT *len_save_prefix, char* save_prefix, mumps_ftnlen l1); #define MUMPS_SAVE_RESTORE_RETURN_C \ F_SYMBOL(save_restore_return_c,SAVE_RESTORE_RETURN_C) void MUMPS_CALL MUMPS_SAVE_RESTORE_RETURN_C(); #endif /* MUMPS_SAVE_RESTORE_C_H */ MUMPS_5.4.1/src/sana_dist_m.F0000664000175000017500000015505714102210521016106 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ANA_DISTM(MYID, N, STEP, FRERE, FILS, IPOOL, & LIPOOL, NE, DAD, ND, PROCNODE, SLAVEF, ABOVE_L0, SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB, MAXFR_UNDER_L0, & MAX_FRONT_SURFACE_LOCAL_L0, MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, ENTRIES_IN_FACTORS_MASTERS_LO, & COST_SUBTREES_UNDER_LO, OPSA_UNDER_L0, PEAK_FR, PEAK_FR_OOC, & NRLADU, NIRADU, NIRNEC, NRLNEC, NRLNEC_ACTIVE, & NRLADU_if_LR_LU, NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, NRLNEC_if_LR_CB, NRLADULR_UD, NRLADULR_WC, & NRLNECLR_CB_UD, NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC, & PEAK_LRLU_UD,PEAK_OOC_LRLU_UD,PEAK_OOC_LRLU_WC, PEAK_LRLUCB_UD, & PEAK_LRLUCB_WC,PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD, NIRADU_OOC, NIRNEC_OOC, MAXFR, & OPSA, UU, KEEP,KEEP8, LOCAL_M, LOCAL_N, SBUF_RECOLD, & SBUF_SEND_FR, SBUF_REC_FR, SBUF_SEND_LR, SBUF_REC_LR, & OPS_SUBTREE, NSTEPS, I_AM_CAND,NMB_PAR2, ISTEP_TO_INIV2, & CANDIDATES, IFLAG, IERROR, MAX_FRONT_SURFACE_LOCAL, & MAX_SIZE_FACTOR, ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS, ROOT_yes, ROOT_NPROW, ROOT_NPCOL & ) USE SMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE SMUMPS_ANA_LR, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE LOGICAL, intent(in) :: ROOT_yes INTEGER, intent(in) :: ROOT_NPROW, ROOT_NPCOL INTEGER, intent(in) :: MYID, N, LIPOOL LOGICAL, intent(in) :: ABOVE_L0 INTEGER, intent(in) :: MAXFR_UNDER_L0 INTEGER(8), intent(in) :: MAX_FRONT_SURFACE_LOCAL_L0, & MAX_SIZE_FACTOR_L0, & ENTRIES_IN_FACTORS_UNDER_L0, & ENTRIES_IN_FACTORS_MASTERS_LO DOUBLE PRECISION, intent(in) :: COST_SUBTREES_UNDER_LO, & OPSA_UNDER_L0 INTEGER(8), intent(inout) :: SIZECB_UNDER_L0, & SIZECB_UNDER_L0_IF_LRCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER NIRADU, NIRNEC INTEGER(8) NRLADU, NRLNEC, NRLNEC_ACTIVE INTEGER(8), intent(out) :: NRLADU_if_LR_LU, & NRLADULR_UD, NRLADULR_WC, & NRLNEC_if_LR_LU, NRLNEC_if_LR_LUCB, NRLNEC_if_LR_CB, & NRLNECOOC_if_LR_LUCB, NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, NRLNECLR_LUCB_WC INTEGER(8), intent(out):: & PEAK_FR, PEAK_FR_OOC, & PEAK_LRLU_UD, & PEAK_OOC_LRLU_UD, PEAK_OOC_LRLU_WC, & PEAK_LRLUCB_UD, PEAK_LRLUCB_WC, & PEAK_OOC_LRLUCB_UD, PEAK_OOC_LRLUCB_WC, & PEAK_LRCB_UD, PEAK_OOC_LRCB_UD INTEGER(8) NRLADU_CURRENT, NRLADU_ROOT_3 INTEGER NIRADU_OOC, NIRNEC_OOC INTEGER MAXFR, NSTEPS INTEGER(8) MAX_FRONT_SURFACE_LOCAL INTEGER STEP(N) INTEGER FRERE(NSTEPS), FILS(N), IPOOL(max(LIPOOL,1)), NE(NSTEPS), & ND(NSTEPS), PROCNODE(NSTEPS), DAD(NSTEPS) REAL UU INTEGER SLAVEF, KEEP(500), LOCAL_M, LOCAL_N INTEGER(8) KEEP8(150) INTEGER(8) ENTRIES_IN_FACTORS_LOC, & ENTRIES_IN_FACTORS_LOC_MASTERS INTEGER SBUF_SEND_FR, SBUF_REC_FR INTEGER SBUF_SEND_LR, SBUF_REC_LR INTEGER(8) SBUF_RECOLD INTEGER NMB_PAR2 INTEGER ISTEP_TO_INIV2( KEEP(71) ) LOGICAL I_AM_CAND(NMB_PAR2) INTEGER CANDIDATES( SLAVEF+1, NMB_PAR2 ) REAL OPSA DOUBLE PRECISION OPSA_LOC INTEGER(8) MAX_SIZE_FACTOR REAL OPS_SUBTREE DOUBLE PRECISION OPS_SBTR_LOC INTEGER, ALLOCATABLE, DIMENSION(:) :: TNSTK, LSTKI INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: LSTKR_if_LRCB, & LSTKRLR_CB_UD, & LSTKRLR_CB_WC LOGICAL OUTER_SENDS_FR INTEGER(8) :: SAVE_SIZECB_UNDER_L0, & SAVE_SIZECB_UNDER_L0_IF_LRCB INTEGER SBUFR_FR, SBUFS_FR INTEGER SBUFR_LR, SBUFS_LR INTEGER(8) SBUFS_CB, SBUFR_CB INTEGER ITOP,NELIM,NFR INTEGER(8) ISTKR, LSTK INTEGER(8) :: NRLADU_CURRENT_MISSING INTEGER(8) :: ISTKR_if_LRCB, ISTKRLR_CB_UD, ISTKRLR_CB_WC, & K464_8, K465_8 INTEGER :: LRSTATUS, IDUMMY INTEGER :: NBNODES_BLR LOGICAL :: COMPRESS_PANEL, COMPRESS_CB INTEGER ISTKI, STKI, ISTKI_OOC INTEGER K,NSTK, IFATH INTEGER INODE, LEAF, IN INTEGER LEVEL, MAXITEMPCB INTEGER(8) CURRENT_ACTIVE_MEM, MAXTEMPCB INTEGER(8):: MAXTEMPCB_LR INTEGER :: NB_BLR LOGICAL UPDATE, UPDATEF, MASTER, MASTERF, INSSARBR INTEGER LEVELF, NCB, SIZECBI INTEGER(8) NCB8 INTEGER(8) NFR8, NELIM8 INTEGER(8) SIZECB, SIZECBINFR, SIZECB_SLAVE INTEGER(8) SIZECB_if_LRCB, SIZECB_SLAVE_if_LRCB INTEGER(8) SIZECBLR_SLAVE_UD, SIZECBLR_SLAVE_WC INTEGER(8) SIZECBLR_UD, SIZECBLR_WC INTEGER(8) :: PEAK_DYN_LRLU_UD, PEAK_DYN_LRCB_UD, & PEAK_DYN_LRLUCB_UD, PEAK_DYN_LRLU_WC, & PEAK_DYN_LRLUCB_WC INTEGER SIZEHEADER, SIZEHEADER_OOC, XSIZE_OOC INTEGER EXTRA_PERM_INFO_OOC INTEGER NBROWMAX, NSLAVES_LOC, NSLAVES_PASSED, & NELIMF, NFRF, NCBF, & NBROWMAXF, LKJIB_FR, LKJIB_LR, & NBR, NBCOLFAC INTEGER(8) LEV3MAXREC, CBMAXR, CBMAXS INTEGER ALLOCOK INTEGER PANEL_SIZE LOGICAL PACKED_CB DOUBLE PRECISION OPS_NODE, OPS_NODE_MASTER, OPS_NODE_SLAVE INTEGER(8) ENTRIES_NODE_UPPER_PART, ENTRIES_NODE_LOWER_PART INTEGER NBouter_MIN INCLUDE 'mumps_headers.h' INTEGER WHAT INTEGER(8) IDUMMY8 INTRINSIC min, int, real INTEGER SMUMPS_OOC_GET_PANEL_SIZE EXTERNAL SMUMPS_OOC_GET_PANEL_SIZE INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL MUMPS_IN_OR_ROOT_SSARBR EXTERNAL MUMPS_MAX_SURFCB_NBROWS EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, & MUMPS_IN_OR_ROOT_SSARBR logical :: FORCE_CAND, CONCERNED, UPDATES, STACKCB, MASTERSON integer :: IFSON, LEVELSON IF (KEEP(50).eq.2) THEN EXTRA_PERM_INFO_OOC = 1 ELSE IF (KEEP(50).eq.0) THEN EXTRA_PERM_INFO_OOC = 2 ELSE EXTRA_PERM_INFO_OOC = 0 ENDIF PACKED_CB=( KEEP(215).EQ.0 .AND. KEEP(50).NE.0 ) MAX_FRONT_SURFACE_LOCAL=0_8 MAX_SIZE_FACTOR=0_8 ALLOCATE( LSTKR(NSTEPS), TNSTK(NSTEPS), & LSTKI(NSTEPS) , & LSTKR_if_LRCB(NSTEPS), LSTKRLR_CB_UD(NSTEPS), & LSTKRLR_CB_WC(NSTEPS), & stat=ALLOCOK) if (ALLOCOK .GT. 0) THEN IFLAG =-7 IERROR = 6*NSTEPS RETURN endif LKJIB_FR = max(KEEP(5),KEEP(6)) OUTER_SENDS_FR = (KEEP(263).NE.0 .OR. & KEEP(50).EQ.0. AND. (KEEP(468).LT.3 .OR. UU.EQ.0.0E0)) IF ( OUTER_SENDS_FR ) THEN LKJIB_FR = max(LKJIB_FR, KEEP(420)) ENDIF LKJIB_LR = max(LKJIB_FR,KEEP(488)) IF (KEEP(66).NE.0.AND.SLAVEF.GT.1) THEN IF ( KEEP(50).EQ.0 ) THEN NBouter_MIN = ceiling & ( & (dble(KEEP(59))*dble(KEEP(108))*dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ELSE NBouter_MIN = ceiling & ( & ( max (dble(KEEP(108))*dble(KEEP(108)), & dble(KEEP(59))*dble(KEEP(108)/2) & ) & *dble(KEEP(35))) & / & (dble(huge(KEEP(108))-10000000)) & ) ENDIF NBouter_MIN = max (NBouter_MIN, 4) LKJIB_FR = min(KEEP(108)/NBouter_MIN, 4321) ENDIF TNSTK = NE LEAF = LIPOOL+1 #if defined(OLD_OOC_NOPANEL) XSIZE_OOC=XSIZE_OOC_NOPANEL #else IF (KEEP(50).EQ.0) THEN XSIZE_OOC=XSIZE_OOC_UNSYM ELSE XSIZE_OOC=XSIZE_OOC_SYM ENDIF #endif SIZEHEADER_OOC = XSIZE_OOC+6 SIZEHEADER = XSIZE_IC + 6 ISTKR_if_LRCB = 0_8 ISTKRLR_CB_UD = 0_8 ISTKRLR_CB_WC = 0_8 ISTKR = 0_8 ISTKI = 0 ISTKI_OOC = 0 NBNODES_BLR = 0 OPSA_LOC = 0.0D0 ENTRIES_IN_FACTORS_LOC = 0_8 ENTRIES_IN_FACTORS_LOC_MASTERS = 0_8 OPS_SBTR_LOC = 0.0D0 NRLADU = 0_8 NIRADU = 0 NIRADU_OOC = 0 NRLADU_CURRENT = 0_8 NRLADULR_UD = 0_8 NRLADULR_WC = 0_8 NRLADU_ROOT_3 = 0_8 NRLNEC_ACTIVE = 0_8 IF (ABOVE_L0) THEN SAVE_SIZECB_UNDER_L0 = SIZECB_UNDER_L0 SAVE_SIZECB_UNDER_L0_IF_LRCB = SIZECB_UNDER_L0_IF_LRCB ELSE SAVE_SIZECB_UNDER_L0 = 0_8 SAVE_SIZECB_UNDER_L0_IF_LRCB = 0_8 ENDIF PEAK_DYN_LRLU_UD = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLUCB_UD = SAVE_SIZECB_UNDER_L0_IF_LRCB PEAK_DYN_LRLU_WC = SAVE_SIZECB_UNDER_L0 PEAK_DYN_LRLUCB_WC = SAVE_SIZECB_UNDER_L0 NRLNEC = 0_8 NRLADU_if_LR_LU = 0_8 NRLNEC_if_LR_LU = 0_8 NRLNEC_if_LR_CB = 0_8 NRLNEC_if_LR_LUCB = 0_8 NRLNECOOC_if_LR_LUCB = 0_8 NRLNECLR_CB_UD = 0_8 NRLNECLR_LUCB_UD = 0_8 NRLNECLR_LUCB_WC = 0_8 NIRNEC = 0 NIRNEC_OOC = 0 MAXFR = 0 PEAK_FR = 0_8 PEAK_FR_OOC = 0_8 PEAK_LRLU_UD = 0_8 PEAK_OOC_LRLU_UD = 0_8 PEAK_OOC_LRLU_WC = 0_8 PEAK_LRLUCB_UD = 0_8 PEAK_LRLUCB_WC = 0_8 PEAK_OOC_LRLUCB_UD= 0_8 PEAK_OOC_LRLUCB_WC= 0_8 PEAK_LRCB_UD = 0_8 PEAK_OOC_LRCB_UD = 0_8 ITOP = 0 MAXTEMPCB = 0_8 MAXTEMPCB_LR = 0_8 MAXITEMPCB = 0 SBUFS_CB = 1_8 SBUFS_FR = 1 SBUFS_LR = 1 SBUFR_CB = 1_8 SBUFR_FR = 1 SBUFR_LR = 1 IF (KEEP(38) .NE. 0 .AND. KEEP(60).EQ.0) THEN INODE = KEEP(38) NRLADU_ROOT_3 = int(LOCAL_M,8)*int(LOCAL_N,8) NRLADU = NRLADU_ROOT_3 NRLNEC_ACTIVE = NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_ROOT_3) NRLNEC = NRLADU NRLADU_if_LR_LU = NRLADU_ROOT_3 NRLNECOOC_if_LR_LUCB = NRLNEC_ACTIVE NRLNEC_if_LR_LU = NRLADU NRLNEC_if_LR_CB = NRLADU NRLNEC_if_LR_LUCB = NRLADU PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD + SIZECB_UNDER_L0) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID) THEN NIRADU = SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = SIZEHEADER_OOC+2*(ND(STEP(INODE))+KEEP(253)) ELSE NIRADU = SIZEHEADER NIRADU_OOC = SIZEHEADER_OOC ENDIF NIRNEC = NIRADU NIRNEC_OOC = NIRADU_OOC ENDIF IF((KEEP(24).eq.0).OR.(KEEP(24).eq.1)) THEN FORCE_CAND=.FALSE. ELSE FORCE_CAND=(mod(KEEP(24),2).eq.0) END IF 90 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF - 1 INODE = IPOOL(LEAF) ELSE IF (LIPOOL.NE.0) THEN WRITE(MYID+6,*) ' ERROR 1 in SMUMPS_ANA_DISTM ' CALL MUMPS_ABORT() ELSE GOTO 115 ENDIF ENDIF 95 CONTINUE NFR = ND(STEP(INODE))+KEEP(253) NFR8 = int(NFR,8) NSTK = NE(STEP(INODE)) NELIM = 0 IN = INODE 100 NELIM = NELIM + 1 NELIM8=int(NELIM,8) IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IFSON = -IN IFATH = DAD(STEP(INODE)) MASTER = MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP(199)) & .EQ. MYID LEVEL = MUMPS_TYPENODE(PROCNODE(STEP(INODE)),KEEP(199)) INSSARBR = MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) UPDATE=.FALSE. if(.NOT.FORCE_CAND) then UPDATE = ( (MASTER.AND.(LEVEL.NE.3) ).OR. LEVEL.EQ.2 ) else if(MASTER.and.(LEVEL.ne.3)) then UPDATE = .TRUE. else if(LEVEL.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(INODE)))) THEN UPDATE = .TRUE. end if end if end if NCB = NFR-NELIM NCB8 = int(NCB,8) SIZECBINFR = NCB8*NCB8 IF (KEEP(50).EQ.0) THEN SIZECB = SIZECBINFR ELSE IFATH = DAD(STEP(INODE)) IF ( IFATH.NE.KEEP(38) .AND. PACKED_CB ) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = SIZECBINFR ENDIF ENDIF CALL COMPUTE_BLR_VCS(KEEP(472), NB_BLR, KEEP(488), NELIM) IDUMMY = -99999 CALL IS_FRONT_BLR_CANDIDATE (INODE, LEVEL, NFR, NELIM, & KEEP(494), 1, KEEP(490), & KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, IDUMMY) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) IF (COMPRESS_PANEL.OR.COMPRESS_CB) NBNODES_BLR = NBNODES_BLR+1 IF (COMPRESS_PANEL) THEN K464_8 = int(KEEP(464),8) ELSE K464_8 = 1000_8 ENDIF IF (COMPRESS_CB) THEN K465_8 = int(KEEP(465),8) SIZECB_if_LRCB = 0_8 SIZECBLR_UD = SIZECB*K465_8/1000_8 SIZECBLR_WC = SIZECB ELSE K465_8 = 1000_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = SIZECB ENDIF SIZECBI = 2* NCB + SIZEHEADER IF (LEVEL.NE.2) THEN NSLAVES_LOC = -99999999 SIZECB_SLAVE = -99999997_8 SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE NBROWMAX = NCB ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 5 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(INODE))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF NSLAVES_PASSED=NSLAVES_LOC ELSE WHAT = 2 NSLAVES_PASSED=SLAVEF NSLAVES_LOC =SLAVEF-1 ENDIF CALL MUMPS_MAX_SURFCB_NBROWS(WHAT, KEEP,KEEP8, & NCB, NFR, NSLAVES_PASSED, NBROWMAX, SIZECB_SLAVE & ) IF (COMPRESS_CB) THEN SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_SLAVE_UD = SIZECB_SLAVE*K465_8/1000_8 SIZECBLR_SLAVE_WC = SIZECB_SLAVE ELSE SIZECB_SLAVE_if_LRCB = SIZECB_SLAVE SIZECBLR_SLAVE_UD = 0_8 SIZECBLR_SLAVE_WC = 0_8 ENDIF ENDIF IF (KEEP(60).GT.1) THEN IF (MASTER .AND. INODE.EQ.KEEP(38)) THEN NIRADU = NIRADU+SIZEHEADER+2*(ND(STEP(INODE))+KEEP(253)) NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC+ & 2*(ND(STEP(INODE))+KEEP(253)) ENDIF ENDIF IF (LEVEL.EQ.3) THEN IF ( & KEEP(60).LE.1 & ) THEN NRLADU_CURRENT = int(LOCAL_M,8)*int(LOCAL_N,8) NRLNEC = max(NRLNEC,NRLADU+ISTKR+ & NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+ & NRLADU_CURRENT) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB , & NRLADU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU+ISTKR_if_LRCB+ & NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3 + & NRLADU_CURRENT+ISTKR_if_LRCB) PEAK_LRLU_UD = max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (MASTER) THEN IF (NFR.GT.MAXFR) MAXFR = NFR ENDIF ENDIF IF(KEEP(86).EQ.1)THEN IF(MASTER.AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)), KEEP(199))) & )THEN IF(LEVEL.EQ.1)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8) IF (KEEP(268).NE.0) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NFR8+NELIM8) ENDIF ELSEIF(LEVEL.EQ.2)THEN IF(KEEP(50).EQ.0)THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NFR8*NELIM8) ELSE MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*NELIM8) IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN MAX_FRONT_SURFACE_LOCAL=max(MAX_FRONT_SURFACE_LOCAL, & NELIM8*(NELIM8+1_8)) ENDIF ENDIF ENDIF ENDIF ENDIF IF (LEVEL.EQ.2) THEN IF (MASTER) THEN IF (KEEP(50).EQ.0) THEN SBUFS_FR = max(SBUFS_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFS_LR = max(SBUFS_LR, NFR*LKJIB_LR+LKJIB_LR+4) ELSE SBUFS_FR = max(SBUFS_FR, NELIM*LKJIB_FR+NELIM+6) SBUFS_LR = max(SBUFS_LR, NELIM*LKJIB_LR+NELIM+6) ENDIF ELSEIF (UPDATE) THEN if (KEEP(50).EQ.0) THEN SBUFR_FR = max(SBUFR_FR, NFR*LKJIB_FR+LKJIB_FR+4) SBUFR_LR = max(SBUFR_LR, NFR*LKJIB_LR+LKJIB_LR+4) else SBUFR_FR = max( SBUFR_FR, NELIM*LKJIB_FR+NELIM+6 ) SBUFR_LR = max( SBUFR_LR, NELIM*LKJIB_LR+NELIM+6 ) SBUFS_FR = max( SBUFS_FR, NBROWMAX*LKJIB_FR+6 ) SBUFS_LR = max( SBUFS_LR, NBROWMAX*LKJIB_LR+6 ) SBUFR_FR = max( SBUFR_FR, NBROWMAX*LKJIB_FR+6 ) SBUFR_LR = max( SBUFR_LR, NBROWMAX*LKJIB_LR+6 ) endif ENDIF ENDIF IF ( UPDATE ) THEN IF ( (MASTER) .AND. (LEVEL.EQ.1) ) THEN NIRADU = NIRADU + 2*NFR + SIZEHEADER NIRADU_OOC = NIRADU_OOC + 2*NFR + SIZEHEADER_OOC PANEL_SIZE = SMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NFR, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(2*NFR-NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NFR,8) NRLADU = NRLADU + NRLADU_CURRENT MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) ENDIF IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0_8 ENDIF SIZECBI = 2* NCB + SIZEHEADER ELSEIF (LEVEL.EQ.2) THEN IF (MASTER) THEN NIRADU = NIRADU+SIZEHEADER +SLAVEF-1+2*NFR NIRADU_OOC = NIRADU_OOC+SIZEHEADER_OOC +SLAVEF-1+2*NFR IF (KEEP(50).EQ.0) THEN NBCOLFAC=NFR ELSE NBCOLFAC=NELIM ENDIF PANEL_SIZE = SMUMPS_OOC_GET_PANEL_SIZE( & 2_8*int(KEEP(226),8), NBCOLFAC, KEEP(227), KEEP(50)) NIRADU_OOC = NIRADU_OOC + & EXTRA_PERM_INFO_OOC*(2+NELIM + NELIM/PANEL_SIZE+1) NRLADU_CURRENT = int(NBCOLFAC,8)*int(NELIM,8) NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = NRLADU_CURRENT ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) SIZECB = 0_8 SIZECBINFR = 0_8 SIZECB_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECB=SIZECB_SLAVE SIZECBINFR = SIZECB NIRADU = NIRADU+4+NELIM+NBROWMAX NIRADU_OOC = NIRADU_OOC+4+NELIM+NBROWMAX IF (KEEP(50).EQ.0) THEN NRLADU_CURRENT = int(NELIM,8)*int(NBROWMAX,8) ELSE NRLADU_CURRENT = int(NELIM,8)*int(NCB/NSLAVES_LOC,8) ENDIF NRLADU = NRLADU + NRLADU_CURRENT IF (COMPRESS_PANEL) THEN NRLADU_if_LR_LU = NRLADU_if_LR_LU + 0_8 NRLADU_CURRENT_MISSING = NRLADU_CURRENT NRLADULR_UD = NRLADULR_UD + & NRLADU_CURRENT*K464_8/1000_8 NRLADULR_WC = NRLADULR_WC + & NRLADU_CURRENT ELSE NRLADU_if_LR_LU = NRLADU_if_LR_LU + NRLADU_CURRENT NRLADU_CURRENT_MISSING = 0 ENDIF MAX_SIZE_FACTOR=max(MAX_SIZE_FACTOR,NRLADU_CURRENT) IF (KEEP(50).EQ.0) THEN SIZECBI = 7 + NBROWMAX + NCB ELSE SIZECBI = 8 + NBROWMAX + NCB ENDIF IF (KEEP(50).NE.0) THEN SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_SYM ELSE SIZECBI=SIZECBI+NSLAVES_LOC+ & XTRA_SLAVES_UNSYM ENDIF ENDIF ENDIF NIRNEC = max0(NIRNEC, & NIRADU+ISTKI+SIZECBI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC, & NIRADU_OOC+ISTKI_OOC+SIZECBI+MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) CURRENT_ACTIVE_MEM = ISTKR+SIZECBINFR IF (KEEP(50).NE.0.AND.UPDATE.AND.LEVEL.EQ.1) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + & int(NELIM,8)*int(NCB,8) ENDIF IF (MASTER .AND. KEEP(219).NE.0.AND. & KEEP(50).EQ.2.AND.LEVEL.EQ.2) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM + int(NELIM,8) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) ELSE NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & MAXTEMPCB_LR+ & NRLADU_CURRENT_MISSING) ENDIF IF (NSTK .NE. 0 .AND. INSSARBR .AND. & KEEP(234).NE.0 .AND. KEEP(55).EQ.0) THEN CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTKR(ITOP) ENDIF IF (SLAVEF.EQ.1) THEN NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = & max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+MAXTEMPCB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+MAXTEMPCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+MAXTEMPCB_LR) ENDIF NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) IF (NFR.GT.MAXFR) MAXFR = NFR IF (NSTK.GT.0) THEN DO 70 K=1,NSTK LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK IF (K==1 .AND. INSSARBR.AND.KEEP(234).NE.0 & .AND.KEEP(55).EQ.0) THEN ELSE CURRENT_ACTIVE_MEM = CURRENT_ACTIVE_MEM - LSTK ENDIF LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in SMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF 70 CONTINUE ENDIF ELSE IF (LEVEL.NE.3) THEN DO WHILE (IFSON.GT.0) UPDATES=.FALSE. MASTERSON = MUMPS_PROCNODE(PROCNODE(STEP(IFSON)),KEEP(199)) & .EQ.MYID LEVELSON = MUMPS_TYPENODE(PROCNODE(STEP(IFSON)),KEEP(199)) if(.NOT.FORCE_CAND) then UPDATES =((MASTERSON.AND.(LEVELSON.NE.3)).OR. & LEVELSON.EQ.2) else if(MASTERSON.and.(LEVELSON.ne.3)) then UPDATES = .TRUE. else if(LEVELSON.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFSON)))) then UPDATES = .TRUE. end if end if end if IF (UPDATES) THEN LSTK = LSTKR(ITOP) ISTKR = ISTKR - LSTK LSTK = LSTKR_if_LRCB(ITOP) ISTKR_if_LRCB = ISTKR_if_LRCB - LSTK LSTK = LSTKRLR_CB_UD(ITOP) ISTKRLR_CB_UD = ISTKRLR_CB_UD - LSTK LSTK = LSTKRLR_CB_WC(ITOP) ISTKRLR_CB_WC = ISTKRLR_CB_WC - LSTK STKI = LSTKI( ITOP ) ISTKI = ISTKI - STKI ISTKI_OOC = ISTKI_OOC - STKI - (XSIZE_OOC-XSIZE_IC) ITOP = ITOP - 1 IF (ITOP.LT.0) THEN write(*,*) MYID, & ': ERROR 2 in SMUMPS_ANA_DISTM. ITOP = ',ITOP CALL MUMPS_ABORT() ENDIF ENDIF IFSON = FRERE(STEP(IFSON)) END DO ENDIF IF ( & ( (INODE.NE.KEEP(20)).OR.(KEEP(60).EQ.0) ) & .AND. & ( (INODE.NE.KEEP(38)).OR.(KEEP(60).LE.1) ) & ) & THEN ENTRIES_NODE_LOWER_PART = int(NFR-NELIM,8) * int(NELIM,8) IF ( KEEP(50).EQ.0 ) THEN ENTRIES_NODE_UPPER_PART = int(NFR,8) * int(NELIM,8) ELSE ENTRIES_NODE_UPPER_PART = & (int(NELIM,8)*int(NELIM+1,8))/2_8 ENDIF IF (KEEP(50).EQ.2 .AND. LEVEL.EQ.3) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM, 0, & 1,OPS_NODE) ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) ENDIF IF (LEVEL.EQ.2) THEN CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 2,OPS_NODE_MASTER) OPS_NODE_SLAVE=OPS_NODE-OPS_NODE_MASTER ENDIF ELSE OPS_NODE = 0.0D0 ENTRIES_NODE_UPPER_PART = 0_8 ENTRIES_NODE_LOWER_PART = 0_8 ENDIF IF ( MASTER ) THEN ENTRIES_IN_FACTORS_LOC_MASTERS = & ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ENDIF IF (UPDATE.OR.LEVEL.EQ.3) THEN IF ( LEVEL .EQ. 3 ) THEN IF (ROOT_yes) THEN CALL MUMPS_UPDATE_FLOPS_ROOT( OPSA_LOC, KEEP(50), NFR, & NFR, ROOT_NPROW, ROOT_NPCOL, MYID ) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART / & int(ROOT_NPROW*ROOT_NPCOL,8) IF (MASTER) THEN ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & mod(ENTRIES_NODE_UPPER_PART, & int(SLAVEF,8)) ENDIF ENDIF ELSE IF (MASTER .AND. LEVEL.EQ.2) THEN OPSA_LOC = OPSA_LOC + OPS_NODE_MASTER ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & mod(ENTRIES_NODE_LOWER_PART, & int(NSLAVES_LOC,8)) ELSE IF (MASTER .AND. LEVEL.EQ.1) THEN OPSA_LOC = OPSA_LOC + dble(OPS_NODE) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_NODE_UPPER_PART + & ENTRIES_NODE_LOWER_PART ELSE IF (UPDATE) THEN OPSA_LOC = OPSA_LOC + & dble(OPS_NODE_SLAVE)/dble(NSLAVES_LOC) ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC & + ENTRIES_NODE_LOWER_PART / & int(NSLAVES_LOC,8) ENDIF IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP(199)) .OR. NE(STEP(INODE))==0) THEN IF (LEVEL == 1) THEN OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ELSE CALL MUMPS_GET_FLOPS_COST(NFR, & NELIM, NELIM,KEEP(50), & 1,OPS_NODE) OPS_SBTR_LOC = OPS_SBTR_LOC + OPS_NODE ENDIF ENDIF ENDIF IF (IFATH .EQ. 0) THEN IF (LEAF.GT.1) THEN GOTO 90 ELSE GOTO 115 ENDIF ELSE NFRF = ND(STEP(IFATH))+KEEP(253) IF (DAD(STEP(IFATH)).EQ.0) THEN NELIMF = NFRF-KEEP(253) IF (ABOVE_L0) IN=0 ELSE NELIMF = 0 IN = IFATH DO WHILE (IN.GT.0) IN = FILS(IN) NELIMF = NELIMF+1 ENDDO ENDIF NCBF = NFRF - NELIMF LEVELF = MUMPS_TYPENODE(PROCNODE(STEP(IFATH)),KEEP(199)) MASTERF= MUMPS_PROCNODE(PROCNODE(STEP(IFATH)), & KEEP(199)).EQ.MYID UPDATEF= .FALSE. if(.NOT.FORCE_CAND) then UPDATEF= ((MASTERF.AND.(LEVELF.NE.3)).OR.LEVELF.EQ.2) else if(MASTERF.and.(LEVELF.ne.3)) then UPDATEF = .TRUE. else if (LEVELF.eq.2) then if ( I_AM_CAND(ISTEP_TO_INIV2(STEP(IFATH)))) THEN UPDATEF = .TRUE. end if end if end if CONCERNED = UPDATEF .OR. UPDATE IF (LEVELF .NE. 2) THEN NBROWMAXF = -999999 ELSE IF (KEEP(48) .EQ. 5) THEN WHAT = 4 IF (FORCE_CAND) THEN NSLAVES_LOC=CANDIDATES(SLAVEF+1, & ISTEP_TO_INIV2(STEP(IFATH))) ELSE NSLAVES_LOC=SLAVEF-1 ENDIF ELSE WHAT = 1 NSLAVES_LOC=SLAVEF ENDIF CALL MUMPS_MAX_SURFCB_NBROWS( WHAT, KEEP, KEEP8, & NCBF, NFRF, NSLAVES_LOC, NBROWMAXF, IDUMMY8 & ) ENDIF IF(LEVEL.EQ.1.AND.UPDATE.AND. & (UPDATEF.OR.LEVELF.EQ.2) & .AND.LEVELF.NE.3) THEN IF ( INSSARBR .AND. KEEP(234).NE.0) THEN NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ISTKR_if_LRCB) ELSE NRLNEC = max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM+SIZECB) NRLNEC_if_LR_LU = & max(NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+SIZECB+ & NRLADU_CURRENT_MISSING) NRLNEC_if_LR_CB = & max(NRLNEC_if_LR_CB ,NRLADU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) NRLNEC_if_LR_LUCB = & max(NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB+ & NRLADU_CURRENT_MISSING) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & NRLADU_CURRENT+NRLADU_ROOT_3+ & CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB+ SIZECB) ENDIF PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF IF (UPDATE .AND. LEVEL.EQ.2 .AND. .NOT. MASTER) THEN NRLNEC = & max(NRLNEC,NRLADU+CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE,2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM) IF (.NOT.COMPRESS_PANEL) THEN NRLNEC_if_LR_LU = max( & NRLNEC_if_LR_LU,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM+NRLADU_CURRENT) NRLNEC_if_LR_CB = max( & NRLNEC_if_LR_CB ,NRLADU + & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNEC_if_LR_LUCB = max( & NRLNEC_if_LR_LUCB,NRLADU_if_LR_LU+ & CURRENT_ACTIVE_MEM-ISTKR + & ISTKR_if_LRCB+NRLADU_CURRENT) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & 2_8*NRLADU_CURRENT+ & NRLADU_ROOT_3+CURRENT_ACTIVE_MEM-ISTKR+ & ISTKR_if_LRCB) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_OOC_LRCB_UD = & max(PEAK_OOC_LRCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_CB_UD) ENDIF ENDIF IF (LEVELF.EQ.3) THEN IF (LEVEL.EQ.1) THEN LEV3MAXREC = int(min(NCB,LOCAL_M),8) * & int(min(NCB,LOCAL_N),8) ELSE LEV3MAXREC = min(SIZECB, & int(min(NBROWMAX,LOCAL_M),8) & *int(min(NCB,LOCAL_N),8)) ENDIF MAXTEMPCB = max(MAXTEMPCB, LEV3MAXREC) MAXTEMPCB_LR = max(MAXTEMPCB_LR,LEV3MAXREC) MAXITEMPCB = max(MAXITEMPCB,SIZECBI+SIZEHEADER) SBUFR_CB = max(SBUFR_CB, LEV3MAXREC+int(SIZECBI,8)) NIRNEC = max(NIRNEC,NIRADU+ISTKI+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) NIRNEC_OOC = max(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & min(NCB,LOCAL_M)+ min(NCB,LOCAL_N)+SIZEHEADER) ENDIF IF (CONCERNED) THEN IF (LEVELF.EQ.2) THEN IF (UPDATE.AND.(LEVEL.NE.2.OR..NOT.MASTER)) THEN IF(MASTERF)THEN NBR = min(NBROWMAXF,NBROWMAX) ELSE NBR = min(max(NELIMF,NBROWMAXF),NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXS = int(NBR,8)*int(NCB,8) ELSE CBMAXS = int(NBR,8)*int(NCB,8) - & (int(NBR,8)*int(NBR-1,8))/2_8 ENDIF ELSE CBMAXS = 0_8 END IF IF (MASTERF) THEN IF (LEVEL.EQ.1) THEN IF (.NOT.UPDATE) THEN NBR = min(NELIMF, NCB) ELSE NBR = 0 ENDIF ELSE NBR = min(NELIMF, NBROWMAX) ENDIF IF (KEEP(50).EQ.0) THEN CBMAXR = int(NBR,8)*NCB8 ELSE CBMAXR = int(NBR,8)*int(min(NCB,NELIMF),8)- & (int(NBR,8)*int(NBR-1,8))/2_8 CBMAXR = min(CBMAXR, int(NELIMF,8)*int(NELIMF+1,8)/2_8) CBMAXR = min(CBMAXR, SIZECB) IF ((LEVEL.EQ.1).AND.(.NOT. PACKED_CB)) THEN CBMAXR = min(CBMAXR,(NCB8*(NCB8+1_8))/2_8) ENDIF ENDIF ELSE IF (UPDATEF) THEN NBR = min(NBROWMAXF,NBROWMAX) CBMAXR = int(NBR,8) * NCB8 IF (KEEP(50).NE.0) THEN CBMAXR = CBMAXR - (int(NBR,8)*(int(NBR-1,8)))/2_8 ENDIF ELSE CBMAXR = 0_8 ENDIF ELSEIF (LEVELF.EQ.3) THEN CBMAXR = LEV3MAXREC IF (UPDATE.AND. .NOT. (MASTER.AND.LEVEL.EQ.2)) THEN CBMAXS = LEV3MAXREC ELSE CBMAXS = 0_8 ENDIF ELSE IF (MASTERF) THEN CBMAXS = 0_8 NBR = min(NFRF,NBROWMAX) IF ((LEVEL.EQ.1).AND.UPDATE) THEN NBR = 0 ENDIF CBMAXR = int(NBR,8)*int(min(NFRF,NCB),8) IF (LEVEL.EQ.2) & CBMAXR = min(CBMAXR, SIZECB_SLAVE) IF ( KEEP(50).NE.0 ) THEN CBMAXR = min(CBMAXR,(int(NFRF,8)*int(NFRF+1,8))/2_8) ELSE CBMAXR = min(CBMAXR,int(NFRF,8)*int(NFRF,8)) ENDIF ELSE CBMAXR = 0_8 CBMAXS = SIZECB ENDIF ENDIF IF (UPDATE) THEN CBMAXS = min(CBMAXS, SIZECB) IF ( .not. ( LEVELF .eq. 1 .AND. UPDATEF ) )THEN SBUFS_CB = max(SBUFS_CB, CBMAXS+int(SIZECBI,8)) ENDIF ENDIF STACKCB = .FALSE. IF (UPDATEF) THEN STACKCB = .TRUE. SIZECBI = 2 * NCB + SIZEHEADER IF (LEVEL.EQ.1) THEN IF (KEEP(50).NE.0.AND.LEVELF.NE.3 & .AND.PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF IF (MASTER) THEN IF (MASTERF) THEN SIZECBI = 2+ XSIZE_IC ENDIF ELSE IF (LEVELF.EQ.1) THEN SIZECB = min(CBMAXR,SIZECB) IF (COMPRESS_CB) THEN SIZECBLR_UD = min(SIZECBLR_UD,SIZECB) SIZECBLR_WC = min(SIZECBLR_WC,SIZECB) SIZECB_if_LRCB = min(SIZECB_if_LRCB,SIZECB) ENDIF SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, int(SIZECBI,8)+SIZECB) SIZECBI = 2 * NCB + SIZEHEADER ELSE SIZECBI = 2 * NCB + 9 SBUFR_CB = max(SBUFR_CB, & min(SIZECB,CBMAXR) + int(SIZECBI,8)) MAXTEMPCB = max(MAXTEMPCB, min(SIZECB,CBMAXR)) IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF SIZECBI = 2 * NCB + SIZEHEADER MAXITEMPCB = max(MAXITEMPCB, SIZECBI) IF ( .NOT. MASTERF ) THEN SIZECBI = 0 ELSE SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ENDIF SIZECB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECB_if_LRCB = 0_8 ENDIF ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB IF (COMPRESS_CB) THEN MAXTEMPCB_LR = & max(MAXTEMPCB_LR, (NCB8*int(NB_BLR,8))) ELSE MAXTEMPCB_LR = max(MAXTEMPCB_LR, min(SIZECB,CBMAXR)) ENDIF MAXTEMPCB = max(MAXTEMPCB, min(CBMAXR,SIZECB) ) MAXITEMPCB = max(MAXITEMPCB,NBROWMAX+NCB+SIZEHEADER) IF (.NOT. & (UPDATE.AND.(.NOT.MASTER).AND.(NSLAVES_LOC.EQ.1)) & ) & SBUFR_CB = max(SBUFR_CB, & min(CBMAXR,SIZECB) + int(NBROWMAX + NCB + 6,8)) IF (MASTER) THEN SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 IF (MASTERF) THEN SIZECBI = 2 + XSIZE_IC ELSE SIZECBI = 0 ENDIF ELSE IF (UPDATE) THEN IF (MASTERF) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF IF (KEEP(50).EQ.0) THEN SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER ELSE SIZECBI = SIZECBI + NBROWMAX + NFR + & SIZEHEADER+ NSLAVES_LOC ENDIF ELSE SIZECB = 0_8 IF ( MASTERF ) THEN SIZECBI = NCB + SIZEHEADER + SLAVEF - 1 ELSE SIZECBI = 0 ENDIF SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 ENDIF ENDIF ELSE IF (LEVELF.NE.3) THEN STACKCB = .TRUE. SIZECB = 0_8 SIZECB_SLAVE_if_LRCB = 0_8 SIZECBLR_UD = 0_8 SIZECBLR_WC = 0_8 SIZECBI = 0 IF ( (LEVEL.EQ.1) .AND. (LEVELF.NE.1) ) THEN IF (PACKED_CB) THEN SIZECB = (NCB8*(NCB8+1_8))/2_8 ELSE SIZECB = NCB8*NCB8 ENDIF SIZECBI = 2 * NCB + SIZEHEADER ELSE IF (LEVEL.EQ.2) THEN IF (MASTER) THEN SIZECBI=0 ELSE SIZECB = SIZECB_SLAVE SIZECBLR_UD = SIZECBLR_SLAVE_UD SIZECBLR_WC = SIZECBLR_SLAVE_WC SIZECB_if_LRCB = SIZECB_SLAVE_if_LRCB SIZECBI = NBROWMAX + NFR + SIZEHEADER ENDIF ENDIF ENDIF ENDIF IF (STACKCB) THEN IF (FRERE(STEP(INODE)).EQ.0) THEN write(*,*) ' ERROR 3 in SMUMPS_ANA_DISTM' CALL MUMPS_ABORT() ENDIF ITOP = ITOP + 1 IF ( ITOP .GT. NSTEPS ) THEN WRITE(*,*) 'ERROR 4 in SMUMPS_ANA_DISTM ' ENDIF LSTKI(ITOP) = SIZECBI ISTKI=ISTKI + SIZECBI ISTKI_OOC = ISTKI_OOC + SIZECBI + (XSIZE_OOC-XSIZE_IC) LSTKR(ITOP) = SIZECB ISTKR = ISTKR + LSTKR(ITOP) NRLNEC = max(NRLNEC,NRLADU+ISTKR+MAXTEMPCB) NIRNEC = max0(NIRNEC,NIRADU+ISTKI+MAXITEMPCB) NIRNEC_OOC = max0(NIRNEC_OOC,NIRADU_OOC+ISTKI_OOC+ & MAXITEMPCB + & (XSIZE_OOC-XSIZE_IC) ) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU+ISTKR+MAXTEMPCB) LSTKR_if_LRCB(ITOP) = SIZECB_if_LRCB ISTKR_if_LRCB = ISTKR_if_LRCB + LSTKR_if_LRCB(ITOP) LSTKRLR_CB_UD(ITOP) = SIZECBLR_UD ISTKRLR_CB_UD = ISTKRLR_CB_UD + LSTKRLR_CB_UD(ITOP) LSTKRLR_CB_WC(ITOP) = SIZECBLR_WC ISTKRLR_CB_WC = ISTKRLR_CB_WC + LSTKRLR_CB_WC(ITOP) NRLNECLR_CB_UD = max(NRLNECLR_CB_UD, ISTKRLR_CB_UD) NRLNECLR_LUCB_UD = max(NRLNECLR_LUCB_UD, & NRLADULR_UD+ISTKRLR_CB_UD) NRLNECLR_LUCB_WC = max(NRLNECLR_LUCB_WC, & NRLADULR_WC+ISTKRLR_CB_WC) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF ENDIF 115 CONTINUE NRLNEC = max(NRLNEC, NRLADU+int(KEEP(30),8)) NRLNEC_ACTIVE = max(NRLNEC_ACTIVE, MAX_SIZE_FACTOR+ & int(KEEP(30),8)) NRLNEC_if_LR_LU = max(NRLNEC_if_LR_LU, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_LUCB = max(NRLNEC_if_LR_LUCB, & NRLADU_if_LR_LU + int(KEEP(30),8)) NRLNEC_if_LR_CB = max(NRLNEC_if_LR_CB, & NRLADU + int(KEEP(30),8)) NRLNECOOC_if_LR_LUCB = max(NRLNECOOC_if_LR_LUCB, & MAX_SIZE_FACTOR+ int(KEEP(30),8)) PEAK_FR = SAVE_SIZECB_UNDER_L0 + NRLNEC PEAK_FR_OOC = SAVE_SIZECB_UNDER_L0 + NRLNEC_ACTIVE PEAK_LRCB_UD = & max(PEAK_LRCB_UD, & NRLNEC_if_LR_CB + NRLNECLR_CB_UD) PEAK_LRLU_UD = & max(PEAK_LRLU_UD, & NRLNEC_if_LR_LU + NRLADULR_UD) PEAK_OOC_LRLU_UD = & max(PEAK_OOC_LRLU_UD, & NRLNEC_ACTIVE + NRLADULR_UD) PEAK_OOC_LRLU_WC = & max(PEAK_OOC_LRLU_WC, & NRLNEC_ACTIVE + NRLADULR_WC) PEAK_LRLUCB_UD = & max(PEAK_LRLUCB_UD, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_LRLUCB_WC = & max(PEAK_LRLUCB_WC, & NRLNEC_if_LR_LUCB + NRLNECLR_LUCB_WC) PEAK_OOC_LRLUCB_UD = & max(PEAK_OOC_LRLUCB_UD, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_UD) PEAK_OOC_LRLUCB_WC = & max(PEAK_OOC_LRLUCB_WC, & NRLNECOOC_if_LR_LUCB + NRLNECLR_LUCB_WC) SBUF_RECOLD = max(int(SBUFR_FR,8),SBUFR_CB) SBUF_RECOLD = max(SBUF_RECOLD, & MAXTEMPCB+int(MAXITEMPCB,8)) + 10_8 SBUF_REC_FR = max(SBUFR_FR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_LR = max(SBUFR_LR, int(min(100000_8,SBUFR_CB))) + 17 SBUF_REC_FR = SBUF_REC_FR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_REC_LR = SBUF_REC_LR + 2 * KEEP(127) + SLAVEF - 1 + 7 SBUF_SEND_FR = max(SBUFS_FR, int(min(100000_8,SBUFR_CB)))+17 SBUF_SEND_LR = max(SBUFS_LR, int(min(100000_8,SBUFR_CB)))+17 IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN SBUF_RECOLD = SBUF_RECOLD+int(KEEP(108)+1,8) SBUF_REC_FR = SBUF_REC_FR+KEEP(108)+1 SBUF_REC_LR = SBUF_REC_LR+KEEP(108)+1 SBUF_SEND_FR = SBUF_SEND_FR+KEEP(108)+1 SBUF_SEND_LR = SBUF_SEND_LR+KEEP(108)+1 ENDIF IF (SLAVEF.EQ.1) THEN SBUF_RECOLD = 1_8 SBUF_REC_FR = 1 SBUF_REC_LR = 1 SBUF_SEND_FR= 1 SBUF_SEND_LR= 1 ENDIF DEALLOCATE( LSTKR, TNSTK, LSTKI ) IF (ABOVE_L0) THEN KEEP(470) = KEEP(470)+ NBNODES_BLR ELSE KEEP(470) = NBNODES_BLR ENDIF IF (.NOT.ABOVE_L0) THEN PEAK_FR = NRLNEC PEAK_FR_OOC = NRLNEC_ACTIVE ENDIF MAXFR = max(MAXFR, MAXFR_UNDER_L0) MAX_FRONT_SURFACE_LOCAL = max (MAX_FRONT_SURFACE_LOCAL, & MAX_FRONT_SURFACE_LOCAL_L0) MAX_SIZE_FACTOR = max (MAX_SIZE_FACTOR, & MAX_SIZE_FACTOR_L0) ENTRIES_IN_FACTORS_LOC_MASTERS = ENTRIES_IN_FACTORS_LOC_MASTERS + & ENTRIES_IN_FACTORS_MASTERS_LO ENTRIES_IN_FACTORS_LOC = ENTRIES_IN_FACTORS_LOC + & ENTRIES_IN_FACTORS_UNDER_L0 OPS_SBTR_LOC = OPS_SBTR_LOC + COST_SUBTREES_UNDER_LO OPSA_LOC = OPSA_LOC + OPSA_UNDER_L0 OPS_SUBTREE = real(OPS_SBTR_LOC) OPSA = real(OPSA_LOC) RETURN END SUBROUTINE SMUMPS_ANA_DISTM MUMPS_5.4.1/src/cfac_process_maprow.F0000664000175000017500000020723114102210523017636 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_DATA_M USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR USE CMUMPS_FAC_FRONT_AUX_M, & ONLY : CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (CMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER COMPLEX :: ADummy(1) COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL CMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in CMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL CMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL CMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2( & NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN CMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN CMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN CMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL CMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL CMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN CALL CMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL CMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL CMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL CMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE CMUMPS_MAPLIG SUBROUTINE CMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_FAC_LR, ONLY: CMUMPS_DECOMPRESS_PANEL USE CMUMPS_FAC_FRONT_AUX_M, & ONLY : CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT USE CMUMPS_LR_DATA_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR & , CMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I, ISTCHK, ISTCHK_LOC INTEGER NBROWS_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP COMPLEX :: ADummy(1) COMPLEX, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in CMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in CMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in CMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in CMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in CMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL CMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_BLR_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT, & 1:NB_BLR_COLS-NB_BLR_SHIFT), & 0, 'V', 5, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN IF (NELIM.EQ.0) THEN POSROW = IACHK + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF (CB_IS_LR) THEN CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS) ELSE CALL CMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during CMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL CMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL CMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL CMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL CMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL CMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL CMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING CMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING CMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING CMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL CMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in CMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL CMUMPS_DM_FREE_BLOCK( SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL CMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL CMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL CMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE CMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE CMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE CMUMPS_BUF, ONLY: CMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE CMUMPS_LR_TYPE USE CMUMPS_LR_STATS USE CMUMPS_LR_DATA_M USE CMUMPS_FAC_LR, ONLY: CMUMPS_DECOMPRESS_PANEL USE CMUMPS_LOAD, ONLY : CMUMPS_LOAD_POOL_UPD_NEW_POOL USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR & , CMUMPS_DM_SET_PTR, CMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) COMPLEX, intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(N) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS COMPLEX, DIMENSION(:), POINTER :: SON_A COMPLEX, DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR REAL, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER(8) :: LA_TEMP COMPLEX, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL CMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL CMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL CMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL CMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL CMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL CMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL CMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_COL_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT, & 1:NB_BLR_COLS-NB_COL_SHIFT), & 0, 'V', 6, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = IACHK+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE IF (CB_IS_LR) THEN CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS ) ELSE CALL CMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON ) ENDIF ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (CB_IS_LR.AND.SON_NIV.EQ.1) & NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ( (IS_ofType5or6) .AND. & ( & ( KEEP(50).EQ.0) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.PACKED_CB) ) & ) & ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE IF (CB_IS_LR) THEN CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ELSE CALL CMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) ENDIF IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL CMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/CMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL CMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL CMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL CMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL CMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in CMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL CMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_FREE_BLOCK( SON_A_MASTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL CMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1) ENDIF CALL CMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE CMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.4.1/src/sfac_process_band.F0000664000175000017500000002607214102210521017255 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined(NO_FDM_DESCBAND) & IWHANDLER_IN, #endif & IFLAG, IERROR ) USE SMUMPS_LOAD USE SMUMPS_LR_DATA_M, ONLY: SMUMPS_BLR_INIT_FRONT, & SMUMPS_BLR_SAVE_NFS4FATHER #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB, N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), & ITLOC( N + KEEP(253) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER :: ISTEP_TO_INIV2(KEEP(71)) #if ! defined(NO_FDM_DESCBAND) INTEGER IWHANDLER_IN #endif INTEGER COMP, IFLAG, IERROR INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES INTEGER NSLAVES_RECU, NFRONT INTEGER LREQ INTEGER :: IBUFR INTEGER(8) :: LREQCB #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER_LOC #endif DOUBLE PRECISION FLOP1 INCLUDE 'mumps_headers.h' #if ! defined(NO_FDM_DESCBAND) INTEGER :: INFO_TMP(2) #else #endif INTEGER :: LRSTATUS INTEGER :: ESTIM_NFS4FATHER_ATSON LOGICAL :: LR_ACTIVATED, COMPRESS_CB INODE = BUFR( 2 ) NBPROCFILS = BUFR( 3 ) NROW = BUFR( 4 ) NCOL = BUFR( 5 ) NASS = BUFR( 6 ) NFRONT = BUFR( 7 ) NSLAVES_RECU = BUFR( 8 ) LRSTATUS = BUFR( 9 ) ESTIM_NFS4FATHER_ATSON = BUFR(10) IBUFR = 11 #if ! defined(NO_FDM_DESCBAND) IWHANDLER_LOC = IWHANDLER_IN IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN INFO_TMP=0 CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR, & IWHANDLER_LOC, INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF GOTO 555 ENDIF #endif IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NASS * NROW ) + & dble(NROW*NASS)*dble(2*NCOL-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW ) & * dble( 2 * NCOL - NROW - NASS + 1) END IF CALL SMUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8) IF ( KEEP(50) .eq. 0 ) THEN NSLAVES = NSLAVES_RECU + XTRA_SLAVES_UNSYM ELSE NSLAVES = NSLAVES_RECU + XTRA_SLAVES_SYM END IF LREQ = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ) LREQCB = int(NCOL,8) * int(NROW,8) CALL SMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE., & MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST, STEP, PIMASTER,PAMASTER, & LREQ, LREQCB, INODE, S_ACTIVE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST(STEP(INODE)) = IWPOSCB + 1 PTRAST(STEP(INODE)) = IPTRLU + 1_8 # if ! defined(NO_FDM_DESCBAND) 555 CONTINUE # endif # if ! defined(NO_FDM_DESCBAND) IF ((IWHANDLER_IN .LE. 0) .AND. & (INODE .NE. INODE_WAITED_FOR)) THEN RETURN ENDIF IW(IWPOSCB+1+XXA) = IWHANDLER_LOC # endif IW(IWPOSCB+1+XXF) = -9999 IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : & IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL ) &= BUFR( IBUFR + NSLAVES_RECU : & IBUFR + NSLAVES_RECU + NROW + NCOL - 1 ) IF ( KEEP(50) .eq. 0 ) THEN IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT IF (NSLAVES_RECU.GT.0) THEN write(6,*) " Internal error in SMUMPS_PROCESS_DESC_BANDE " CALL MUMPS_ABORT() ENDIF ELSE IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ))) IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ): & IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_RECU ) = & BUFR( IBUFR: IBUFR - 1 + NSLAVES_RECU ) END IF IW(IWPOSCB+1+XXNBPR)=NBPROCFILS IW(IWPOSCB+1+XXLR)=LRSTATUS COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP=0 CALL SMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) IF (INFO_TMP(1).LT.0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) RETURN ENDIF IF (COMPRESS_CB.AND. & (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (ESTIM_NFS4FATHER_ATSON.GE.0) & ) THEN CALL SMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF), & ESTIM_NFS4FATHER_ATSON ) ENDIF ENDIF IF (NBPROCFILS .EQ. 0) THEN ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_DESC_BANDE RECURSIVE SUBROUTINE SMUMPS_TREAT_DESCBAND( INODE, & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) # if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M # endif USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER, INTENT(IN) :: INODE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: SRC_DESCBAND #if ! defined(NO_FDM_DESCBAND) INTEGER :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) # if ! defined(NO_FDM_DESCBAND) IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC) CALL SMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1), & DESCBAND_STRUC%LBUFR, & LBUFR_BYTES, & IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, & IWHANDLER, & IFLAG, IERROR ) IF (IFLAG .LT. 0) GOTO 500 CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA)) ELSE IF (INODE_WAITED_FOR.GT.0) THEN WRITE(*,*) " Internal error 1 in SMUMPS_TREAT_DESCBAND", & INODE, INODE_WAITED_FOR CALL MUMPS_ABORT() ENDIF INODE_WAITED_FOR = INODE # endif DO WHILE (PTRIST(STEP(INODE)) .EQ. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT(COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & SRC_DESCBAND, MAITRE_DESC_BANDE, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (IFLAG .LT. 0) THEN RETURN ENDIF ENDDO # if ! defined(NO_FDM_DESCBAND) INODE_WAITED_FOR = -1 ENDIF # endif RETURN 500 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_TREAT_DESCBAND MUMPS_5.4.1/src/mumps_c.c0000664000175000017500000005464114102210474015331 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* Header used for debug purpose only #include */ #include #include "mumps_common.h" #if MUMPS_ARITH == MUMPS_ARITH_s # include "smumps_c.h" # define MUMPS_REAL SMUMPS_REAL # define MUMPS_COMPLEX SMUMPS_COMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_d # include "dmumps_c.h" # define MUMPS_REAL DMUMPS_REAL # define MUMPS_COMPLEX DMUMPS_COMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_c # include "cmumps_c.h" # define MUMPS_REAL CMUMPS_REAL # define MUMPS_COMPLEX CMUMPS_COMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_z # include "zmumps_c.h" # define MUMPS_REAL ZMUMPS_REAL # define MUMPS_COMPLEX ZMUMPS_COMPLEX #endif /* * F_SYM_ARITH is the same as F_SYMBOL (see mumps_common.h) for the symbols * that depend on the arithmetic. * Example: For CMUMPS_XXX, first define * #define CMUMPS_XXX F_SYM_ARITH(xxx,XXX) and then use * CMUMPS_XXX in the code to get rid of any symbol convention annoyance. */ #if MUMPS_ARITH == MUMPS_ARITH_s # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) SMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) smumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) smumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) smumps_##lower_case # endif #elif MUMPS_ARITH == MUMPS_ARITH_d # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) DMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) dmumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) dmumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) dmumps_##lower_case # endif #elif MUMPS_ARITH == MUMPS_ARITH_c # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) CMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) cmumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) cmumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) cmumps_##lower_case # endif #elif MUMPS_ARITH == MUMPS_ARITH_z # if defined(UPPER) || defined(MUMPS_WIN32) # define F_SYM_ARITH(lower_case,upper_case) ZMUMPS_##upper_case # elif defined(Add_) # define F_SYM_ARITH(lower_case,upper_case) zmumps_##lower_case##_ # elif defined(Add__) # define F_SYM_ARITH(lower_case,upper_case) zmumps_##lower_case##__ # else # define F_SYM_ARITH(lower_case,upper_case) zmumps_##lower_case # endif #endif #define MUMPS_F77 \ F_SYM_ARITH(f77,F77) void MUMPS_CALL MUMPS_F77( MUMPS_INT *job, MUMPS_INT *sym, MUMPS_INT *par, MUMPS_INT *comm_fortran, MUMPS_INT *n, MUMPS_INT *nblk, MUMPS_INT *icntl, MUMPS_REAL *cntl, MUMPS_INT *keep, MUMPS_REAL *dkeep, MUMPS_INT8 *keep8, MUMPS_INT *nz, MUMPS_INT8 *nnz, MUMPS_INT *irn, MUMPS_INT *irn_avail, MUMPS_INT *jcn, MUMPS_INT *jcn_avail, MUMPS_COMPLEX *a, MUMPS_INT *a_avail, MUMPS_INT *nz_loc, MUMPS_INT8 *nnz_loc, MUMPS_INT *irn_loc, MUMPS_INT *irn_loc_avail, MUMPS_INT *jcn_loc, MUMPS_INT *jcn_loc_avail, MUMPS_COMPLEX *a_loc, MUMPS_INT *a_loc_avail, MUMPS_INT *nelt, MUMPS_INT *eltptr, MUMPS_INT *eltptr_avail, MUMPS_INT *eltvar, MUMPS_INT *eltvar_avail, MUMPS_COMPLEX *a_elt, MUMPS_INT *a_elt_avail, MUMPS_INT *blkptr, MUMPS_INT *blkptr_avail, MUMPS_INT *blkvar, MUMPS_INT *blkvar_avail, MUMPS_INT *perm_in, MUMPS_INT *perm_in_avail, MUMPS_COMPLEX *rhs, MUMPS_INT *rhs_avail, MUMPS_COMPLEX *redrhs, MUMPS_INT *redrhs_avail, MUMPS_INT *info, MUMPS_REAL *rinfo, MUMPS_INT *infog, MUMPS_REAL *rinfog, MUMPS_INT *deficiency, MUMPS_INT *lwk_user, MUMPS_INT *size_schur, MUMPS_INT *listvar_schur, MUMPS_INT *listvar_schur_avail, MUMPS_COMPLEX *schur, MUMPS_INT *schur_avail, MUMPS_COMPLEX *wk_user, MUMPS_INT *wk_user_avail, MUMPS_REAL *colsca, MUMPS_INT *colsca_avail, MUMPS_REAL *rowsca, MUMPS_INT *rowsca_avail, MUMPS_INT *instance_number, MUMPS_INT *nrhs, MUMPS_INT *lrhs, MUMPS_INT *lredrhs, MUMPS_COMPLEX *rhs_sparse, MUMPS_INT *rhs_sparse_avail, MUMPS_COMPLEX *sol_loc, MUMPS_INT *sol_loc_avail, MUMPS_COMPLEX *rhs_loc, MUMPS_INT *rhs_loc_avail, MUMPS_INT *irhs_sparse, MUMPS_INT *irhs_sparse_avail, MUMPS_INT *irhs_ptr, MUMPS_INT *irhs_ptr_avail, MUMPS_INT *isol_loc, MUMPS_INT *isol_loc_avail, MUMPS_INT *irhs_loc, MUMPS_INT *irhs_loc_avail, MUMPS_INT *nz_rhs, MUMPS_INT *lsol_loc, MUMPS_INT *nloc_rhs, MUMPS_INT *lrhs_loc, MUMPS_INT *schur_mloc, MUMPS_INT *schur_nloc, MUMPS_INT *schur_lld, MUMPS_INT *schur_mblock, MUMPS_INT *schur_nblock, MUMPS_INT *schur_nprow, MUMPS_INT *schur_npcol, MUMPS_INT *ooc_tmpdir, MUMPS_INT *ooc_prefix, MUMPS_INT *write_problem, MUMPS_INT *save_dir, MUMPS_INT *save_prefix, MUMPS_INT *ooc_tmpdirlen, MUMPS_INT *ooc_prefixlen, MUMPS_INT *write_problemlen, MUMPS_INT *save_dirlen, MUMPS_INT *save_prefixlen, MUMPS_INT *metis_options ); /* * COLSCA and ROWSCA are static. They are passed inside cmumps_f77 but * might also be changed on return by MUMPS_ASSIGN_COLSCA/ROWSCA * NB: They are put here because they use MUMPS_REAL and need thus * one symbol per arithmetic. */ #if MUMPS_ARITH == MUMPS_ARITH_s # define MUMPS_COLSCA_STATIC SMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC SMUMPS_ROWSCA_STATIC #elif MUMPS_ARITH == MUMPS_ARITH_d # define MUMPS_COLSCA_STATIC DMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC DMUMPS_ROWSCA_STATIC #elif MUMPS_ARITH == MUMPS_ARITH_c # define MUMPS_COLSCA_STATIC CMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC CMUMPS_ROWSCA_STATIC #elif MUMPS_ARITH == MUMPS_ARITH_z # define MUMPS_COLSCA_STATIC ZMUMPS_COLSCA_STATIC # define MUMPS_ROWSCA_STATIC ZMUMPS_ROWSCA_STATIC #endif static MUMPS_REAL * MUMPS_COLSCA_STATIC; static MUMPS_REAL * MUMPS_ROWSCA_STATIC; #define MUMPS_ASSIGN_COLSCA \ F_SYM_ARITH(assign_colsca,ASSIGN_COLSCA) void MUMPS_CALL MUMPS_ASSIGN_COLSCA(MUMPS_REAL * f77colsca) { MUMPS_COLSCA_STATIC = f77colsca; } #define MUMPS_NULLIFY_C_COLSCA \ F_SYM_ARITH(nullify_c_colsca,NULLIFY_C_COLSCA) void MUMPS_CALL MUMPS_NULLIFY_C_COLSCA() { MUMPS_COLSCA_STATIC = 0; } #define MUMPS_ASSIGN_ROWSCA \ F_SYM_ARITH(assign_rowsca,ASSIGN_ROWSCA) void MUMPS_CALL MUMPS_ASSIGN_ROWSCA(MUMPS_REAL * f77rowsca) { MUMPS_ROWSCA_STATIC = f77rowsca; } #define MUMPS_NULLIFY_C_ROWSCA \ F_SYM_ARITH(nullify_c_rowsca,NULLIFY_C_ROWSCA) void MUMPS_CALL MUMPS_NULLIFY_C_ROWSCA() { MUMPS_ROWSCA_STATIC = 0; } /* FIXME: move CMUMPS_SET_TMP_PTR to another file */ #define MUMPS_SET_TMP_PTR \ F_SYM_ARITH(set_tmp_ptr,SET_TMP_PTR) /* Fortran routine MUMPS_SET_TMP_PTR called from C */ #define MUMPS_SET_TMP_PTR_C \ F_SYM_ARITH(set_tmp_ptr_c,SET_TMP_PTR_C) /* C routine MUMPS_SET_TMP_PTR_C called from Fortran */ void MUMPS_SET_TMP_PTR(void *x, MUMPS_INT8 * size); void MUMPS_CALL MUMPS_SET_TMP_PTR_C(MUMPS_INT8 *addr_ptr, MUMPS_INT8 *size) /* called from Fortran */ { /* MUMPS_SET_TMP_PTR sets a static Fortran pointer from an address and a size: size is passed by address The address passed in *addr_ptr, however, *addr_ptr is a MUMPS_INT8 addr_ptr is the pointer to the address we want to pass We cast addr_ptr to a pointer to an address before taking the content *(void *)addr_ptr) */ MUMPS_SET_TMP_PTR(*(void**)addr_ptr, size); /* calls Fortran */ } #if MUMPS_ARITH == MUMPS_ARITH_s # define mumps_c smumps_c # define MUMPS_STRUC_C SMUMPS_STRUC_C #elif MUMPS_ARITH == MUMPS_ARITH_d # define mumps_c dmumps_c # define MUMPS_STRUC_C DMUMPS_STRUC_C #elif MUMPS_ARITH == MUMPS_ARITH_c # define mumps_c cmumps_c # define MUMPS_STRUC_C CMUMPS_STRUC_C #elif MUMPS_ARITH == MUMPS_ARITH_z # define mumps_c zmumps_c # define MUMPS_STRUC_C ZMUMPS_STRUC_C #endif void MUMPS_CALL mumps_c(MUMPS_STRUC_C * mumps_par) { /* * The following local variables will * be passed to the F77 interface. */ MUMPS_INT *icntl; MUMPS_REAL *cntl; MUMPS_INT *keep; MUMPS_REAL *dkeep; MUMPS_INT8 *keep8; MUMPS_INT *irn; MUMPS_INT *jcn; MUMPS_COMPLEX *a; MUMPS_INT *irn_loc; MUMPS_INT *jcn_loc; MUMPS_COMPLEX *a_loc; MUMPS_INT *eltptr, *eltvar; MUMPS_COMPLEX *a_elt; MUMPS_INT *blkptr; MUMPS_INT *blkvar; MUMPS_INT *perm_in; MUMPS_INT perm_in_avail; MUMPS_INT *listvar_schur; MUMPS_INT listvar_schur_avail; MUMPS_COMPLEX *schur; MUMPS_INT schur_avail; MUMPS_COMPLEX *rhs; MUMPS_COMPLEX *redrhs; MUMPS_COMPLEX *wk_user; MUMPS_INT wk_user_avail; MUMPS_REAL *colsca; MUMPS_REAL *rowsca; MUMPS_COMPLEX *rhs_sparse, *sol_loc, *rhs_loc; MUMPS_INT *irhs_sparse, *irhs_ptr, *isol_loc, *irhs_loc; MUMPS_INT irn_avail, jcn_avail, a_avail, rhs_avail, redrhs_avail; /* These are actually used * as booleans, but we stick * to simple types for the * C-F77 interface */ MUMPS_INT irn_loc_avail, jcn_loc_avail, a_loc_avail; MUMPS_INT eltptr_avail, eltvar_avail, a_elt_avail; MUMPS_INT blkptr_avail, blkvar_avail; MUMPS_INT colsca_avail, rowsca_avail; MUMPS_INT irhs_ptr_avail, rhs_sparse_avail, sol_loc_avail, rhs_loc_avail; MUMPS_INT irhs_sparse_avail, isol_loc_avail, irhs_loc_avail; MUMPS_INT *info; MUMPS_INT *infog; MUMPS_REAL *rinfo; MUMPS_REAL *rinfog; MUMPS_INT ooc_tmpdir[255]; MUMPS_INT ooc_prefix[63]; MUMPS_INT write_problem[255]; MUMPS_INT save_dir[255]; MUMPS_INT save_prefix[255]; /* Other local variables */ MUMPS_INT idummy; MUMPS_INT *idummyp; MUMPS_REAL rdummy; MUMPS_REAL *rdummyp; MUMPS_COMPLEX cdummy; MUMPS_COMPLEX *cdummyp; /* String lengths to be passed to Fortran by address */ MUMPS_INT ooc_tmpdirlen; MUMPS_INT ooc_prefixlen; MUMPS_INT save_dirlen; MUMPS_INT save_prefixlen; MUMPS_INT write_problemlen; MUMPS_INT *metis_options; int i; static const MUMPS_INT no = 0; static const MUMPS_INT yes = 1; idummyp = &idummy; cdummyp = &cdummy; rdummyp = &rdummy; /* [SDCZ]MUMPS_F77 always calls either * MUMPS_NULLIFY_C_COLSCA or MUMPS_ASSIGN_C_COLSCA * (and ROWSCA). The next two lines are thus not * strictly necessary. */ MUMPS_COLSCA_STATIC=0; MUMPS_ROWSCA_STATIC=0; /* Initialize pointers to zero for job == -1 */ if ( mumps_par->job == -1 ) { /* job = -1: we just reset all pointers to 0 */ mumps_par->irn=0; mumps_par->jcn=0; mumps_par->a=0; mumps_par->rhs=0; mumps_par->wk_user=0; mumps_par->redrhs=0; mumps_par->eltptr=0; mumps_par->eltvar=0; mumps_par->a_elt=0; mumps_par->blkptr=0; mumps_par->blkvar=0; mumps_par->perm_in=0; mumps_par->sym_perm=0; mumps_par->uns_perm=0; mumps_par->irn_loc=0;mumps_par->jcn_loc=0;mumps_par->a_loc=0; mumps_par->listvar_schur=0;mumps_par->schur=0;mumps_par->mapping=0;mumps_par->pivnul_list=0;mumps_par->colsca=0;mumps_par->colsca_from_mumps=0;mumps_par->rowsca=0;mumps_par->rowsca_from_mumps=0; mumps_par->rhs_sparse=0; mumps_par->irhs_sparse=0; mumps_par->sol_loc=0; mumps_par->rhs_loc=0; mumps_par->irhs_ptr=0; mumps_par->isol_loc=0; mumps_par->irhs_loc=0; strcpy(mumps_par->ooc_tmpdir,"NAME_NOT_INITIALIZED"); strcpy(mumps_par->ooc_prefix,"NAME_NOT_INITIALIZED"); strcpy(mumps_par->write_problem,"NAME_NOT_INITIALIZED"); strcpy(mumps_par->save_dir,"NAME_NOT_INITIALIZED"); strcpy(mumps_par->save_prefix,"NAME_NOT_INITIALIZED"); strncpy(mumps_par->version_number,MUMPS_VERSION,MUMPS_VERSION_MAX_LEN); mumps_par->version_number[MUMPS_VERSION_MAX_LEN+1] = '\0'; /* Next line initializes scalars to arbitrary values. * Some of those will anyway be overwritten during the * call to Fortran routine [SDCZ]MUMPS_INIT_PHASE */ mumps_par->n=0; mumps_par->nblk=0; mumps_par->nz=0; mumps_par->nnz=0; mumps_par->nz_loc=0; mumps_par->nnz_loc=0; mumps_par->nelt=0;mumps_par->instance_number=0;mumps_par->deficiency=0;mumps_par->lwk_user=0;mumps_par->size_schur=0;mumps_par->lrhs=0; mumps_par->lredrhs=0; mumps_par->nrhs=0; mumps_par->nz_rhs=0; mumps_par->lsol_loc=0; mumps_par->nloc_rhs=0; mumps_par->lrhs_loc=0; mumps_par->schur_mloc=0; mumps_par->schur_nloc=0; mumps_par->schur_lld=0; mumps_par->mblock=0; mumps_par->nblock=0; mumps_par->nprow=0; mumps_par->npcol=0; } ooc_tmpdirlen=(int)strlen(mumps_par->ooc_tmpdir); ooc_prefixlen=(int)strlen(mumps_par->ooc_prefix); write_problemlen=(int)strlen(mumps_par->write_problem); save_dirlen =(int)strlen(mumps_par->save_dir); save_prefixlen=(int)strlen(mumps_par->save_prefix); /* Avoid the use of strnlen which may not be * available on all systems. Allow strings without * \0 at the end, if the file is not found, the * Fortran layer is responsible for raising an * error. */ if(ooc_tmpdirlen > 255){ ooc_tmpdirlen=255; } if(ooc_prefixlen > 63){ ooc_prefixlen=63; } if(write_problemlen > 255){ write_problemlen=255; } if(save_dirlen > 255){ save_dirlen=255; } if(save_prefixlen > 255){ save_prefixlen=255; } /* * Extract info from the C structure to call the F77 interface. The * following macro avoids repeating the same code with risks of errors. */ #define EXTRACT_POINTERS(component,dummypointer) \ if ( mumps_par-> component == 0) \ { component = dummypointer; \ component ## _avail = no; } \ else \ { component = mumps_par-> component; \ component ## _avail = yes; } /* * For example, EXTRACT_POINTERS(irn,idummyp) produces the following line of code: if (mumps_par->irn== 0) {irn= idummyp;irn_avail = no; } else { irn = mumps_par->irn;irn_avail = yes; } ; * which says that irn is set to mumps_par->irn except if * mumps_par->irn is 0, which means that it is not available. */ EXTRACT_POINTERS(irn,idummyp); EXTRACT_POINTERS(jcn,idummyp); EXTRACT_POINTERS(rhs,cdummyp); EXTRACT_POINTERS(wk_user,cdummyp); EXTRACT_POINTERS(redrhs,cdummyp); EXTRACT_POINTERS(irn_loc,idummyp); EXTRACT_POINTERS(jcn_loc,idummyp); EXTRACT_POINTERS(a_loc,cdummyp); EXTRACT_POINTERS(a,cdummyp); EXTRACT_POINTERS(eltptr,idummyp); EXTRACT_POINTERS(eltvar,idummyp); EXTRACT_POINTERS(a_elt,cdummyp); EXTRACT_POINTERS(blkptr,idummyp); EXTRACT_POINTERS(blkvar,idummyp); EXTRACT_POINTERS(perm_in,idummyp); EXTRACT_POINTERS(listvar_schur,idummyp); EXTRACT_POINTERS(schur,cdummyp); /* EXTRACT_POINTERS not adapted to rowsca and colsca */ if ( mumps_par->rowsca != 0 && mumps_par->rowsca_from_mumps == 0 ) { /* has been set by user and was not allocated in mumps */ rowsca = mumps_par-> rowsca; rowsca_avail = yes; } else { /* Changing the rowsca pointer in C after an earlier call where rowsca was allocated by mumps is not possible. FIXME: check if the content of rowsca could still be modified by the user -- with ICNTL(8) set to -1 -- before calling the next factorization step again. */ rowsca = rdummyp; rowsca_avail = no; } if ( mumps_par->colsca != 0 && mumps_par->colsca_from_mumps == 0 ) /* has been changed by user and was not allocated in mumps */ { colsca = mumps_par-> colsca; colsca_avail = yes; } else { /* Changing the colsca pointer in C after an earlier call where colsca was allocated by mumps is not possible. FIXME: check if the content of colsca could still be modified by the user -- with ICNTL(8) set to -1 -- before calling the next factorization step again. */ colsca = rdummyp; colsca_avail = no; } EXTRACT_POINTERS(rhs_sparse,cdummyp); EXTRACT_POINTERS(sol_loc,cdummyp); EXTRACT_POINTERS(rhs_loc,cdummyp); EXTRACT_POINTERS(irhs_sparse,idummyp); EXTRACT_POINTERS(isol_loc,idummyp); EXTRACT_POINTERS(irhs_loc,idummyp); EXTRACT_POINTERS(irhs_ptr,idummyp); /* printf("irn_avail,jcn_avail, rhs_avail, a_avail, eltptr_avail, eltvar_avail,a_elt_avail,perm_in_avail= %d %d %d %d %d %d %d \n", irn_avail,jcn_avail, rhs_avail, a_avail, eltptr_avail, eltvar_avail, a_elt_avail, perm_in_avail); */ /* * Extract integers (input) or pointers that are * always allocated (such as ICNTL, INFO, ...) */ /* size_schur = mumps_par->size_schur; */ /* instance_number = mumps_par->instance_number; */ icntl = mumps_par->icntl; cntl = mumps_par->cntl; keep = mumps_par->keep; dkeep = mumps_par->dkeep; keep8 = mumps_par->keep8; info = mumps_par->info; infog = mumps_par->infog; rinfo = mumps_par->rinfo; rinfog = mumps_par->rinfog; for(i=0;iooc_tmpdir[i]; } for(i=0;iooc_prefix[i]; } for(i=0;iwrite_problem[i]; } for(i=0;isave_dir[i]; } for(i=0;isave_prefix[i]; } metis_options = mumps_par->metis_options; /* Call F77 interface */ MUMPS_F77(&(mumps_par->job), &(mumps_par->sym), &(mumps_par->par), &(mumps_par->comm_fortran), &(mumps_par->n), &(mumps_par->nblk), icntl, cntl, keep, dkeep, keep8, &(mumps_par->nz), &(mumps_par->nnz), irn, &irn_avail, jcn, &jcn_avail, a, &a_avail, &(mumps_par->nz_loc), &(mumps_par->nnz_loc), irn_loc, &irn_loc_avail, jcn_loc, &jcn_loc_avail, a_loc, &a_loc_avail, &(mumps_par->nelt), eltptr, &eltptr_avail, eltvar, &eltvar_avail, a_elt, &a_elt_avail, blkptr, &blkptr_avail, blkvar, &blkvar_avail, perm_in, &perm_in_avail, rhs, &rhs_avail, redrhs, &redrhs_avail, info, rinfo, infog, rinfog, &(mumps_par->deficiency), &(mumps_par->lwk_user), &(mumps_par->size_schur), listvar_schur, &listvar_schur_avail, schur, &schur_avail, wk_user, &wk_user_avail, colsca, &colsca_avail, rowsca, &rowsca_avail, &(mumps_par->instance_number), &(mumps_par->nrhs), &(mumps_par->lrhs), &(mumps_par->lredrhs), rhs_sparse, &rhs_sparse_avail, sol_loc, &sol_loc_avail, rhs_loc, &rhs_loc_avail, irhs_sparse, &irhs_sparse_avail, irhs_ptr, &irhs_ptr_avail, isol_loc, &isol_loc_avail, irhs_loc, &irhs_loc_avail, &(mumps_par->nz_rhs), &(mumps_par->lsol_loc), &(mumps_par->lrhs_loc), &(mumps_par->nloc_rhs) , &(mumps_par->schur_mloc) , &(mumps_par->schur_nloc) , &(mumps_par->schur_lld) , &(mumps_par->mblock) , &(mumps_par->nblock) , &(mumps_par->nprow) , &(mumps_par->npcol) , ooc_tmpdir , ooc_prefix , write_problem , save_dir , save_prefix , &ooc_tmpdirlen , &ooc_prefixlen , &write_problemlen , &save_dirlen , &save_prefixlen , metis_options ); /* * Set interface to C (KEEP(500)=1) after job=-1 */ if ( mumps_par->job == -1 ) { mumps_par->keep[499]=1; } /* * mapping and pivnul_list are usually 0 except if * MUMPS_ASSIGN_MAPPING/MUMPS_ASSIGN_PIVNUL_LIST was called. */ mumps_par->mapping=mumps_get_mapping(); mumps_par->pivnul_list=mumps_get_pivnul_list(); /* to get permutations computed during analysis */ mumps_par->sym_perm=mumps_get_sym_perm(); mumps_par->uns_perm=mumps_get_uns_perm(); /* * colsca/rowsca can either be user data or have been modified * within mumps by calls to MUMPS_ASSIGN_COLSCA and/or * MUMPS_ASSIGN_ROWSCA. In all cases their address is contained * in MUMPS_COLSCA_STATIC and/or MUMPS_ROWSCA_STATIC. * * In case of a null pointer, we also reset mumps_par->rowsca/colsca * to 0 (case of JOB=-2, the Fortran pointer will be NULL but the * C pointer should also be null. */ if (rowsca_avail == no) { mumps_par->rowsca = MUMPS_ROWSCA_STATIC; if (MUMPS_ROWSCA_STATIC) { /* remember that row Scaling was computed by MUMPS */ mumps_par->rowsca_from_mumps=1; } } if (colsca_avail == no) { mumps_par->colsca = MUMPS_COLSCA_STATIC; if (MUMPS_COLSCA_STATIC) { /* remember that column Scaling was computed by MUMPS */ mumps_par->colsca_from_mumps=1; } } /* * Decode OOC_TMPDIR and OOC_PREFIX */ for(i=0;iooc_tmpdir[i]=(char)ooc_tmpdir[i]; } mumps_par->ooc_tmpdir[ooc_tmpdirlen]='\0'; for(i=0;iooc_prefix[i]=(char)ooc_prefix[i]; } mumps_par->ooc_prefix[ooc_prefixlen]='\0'; } MUMPS_5.4.1/src/zfac_type3_symmetrize.F0000664000175000017500000001374014102210524020157 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SYMMETRIZE( BUF, BLOCK_SIZE, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, COMM ) IMPLICIT NONE INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM INTEGER MYROW, MYCOL, MYID COMPLEX(kind=8) BUF( BLOCK_SIZE * BLOCK_SIZE ) COMPLEX(kind=8) A( LOCAL_M, LOCAL_N ) INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST INTEGER IGLOB, JGLOB INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE INTEGER IROW_LOC_DEST, JCOL_LOC_DEST INTEGER PROC_SOURCE, PROC_DEST NBLOCK = ( N - 1 ) / BLOCK_SIZE + 1 DO IBLOCK = 1, NBLOCK IF ( IBLOCK .NE. NBLOCK & ) THEN IBLOCK_SIZE = BLOCK_SIZE ELSE IBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF ROW_SOURCE = mod( IBLOCK - 1, NPROW ) COL_DEST = mod( IBLOCK - 1, NPCOL ) IGLOB = ( IBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_SOURCE = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 JCOL_LOC_DEST = BLOCK_SIZE * & ( ( IGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( IGLOB - 1, BLOCK_SIZE ) + 1 DO JBLOCK = 1, IBLOCK IF ( JBLOCK .NE. NBLOCK & ) THEN JBLOCK_SIZE = BLOCK_SIZE ELSE JBLOCK_SIZE = N - ( NBLOCK - 1 ) * BLOCK_SIZE END IF COL_SOURCE = mod( JBLOCK - 1, NPCOL ) ROW_DEST = mod( JBLOCK - 1, NPROW ) PROC_SOURCE = ROW_SOURCE * NPCOL + COL_SOURCE PROC_DEST = ROW_DEST * NPCOL + COL_DEST IF ( PROC_SOURCE .eq. PROC_DEST ) THEN IF ( MYID .eq. PROC_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 IF ( IBLOCK .eq. JBLOCK ) THEN IF ( IBLOCK_SIZE .ne. JBLOCK_SIZE ) THEN WRITE(*,*) MYID,': Error in calling transdiag:unsym' CALL MUMPS_ABORT() END IF CALL ZMUMPS_TRANS_DIAG( A( IROW_LOC_SOURCE, & JCOL_LOC_SOURCE), & IBLOCK_SIZE, LOCAL_M ) ELSE CALL ZMUMPS_TRANSPO( & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), & A( IROW_LOC_DEST, JCOL_LOC_DEST ), & IBLOCK_SIZE, JBLOCK_SIZE, LOCAL_M ) END IF END IF ELSE IF ( MYROW .eq. ROW_SOURCE & .AND. MYCOL .eq. COL_SOURCE ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 JCOL_LOC_SOURCE = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPCOL) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL ZMUMPS_SEND_BLOCK( BUF, & A( IROW_LOC_SOURCE, JCOL_LOC_SOURCE ), LOCAL_M, & IBLOCK_SIZE, JBLOCK_SIZE, COMM, PROC_DEST ) ELSE IF ( MYROW .eq. ROW_DEST & .AND. MYCOL .eq. COL_DEST ) THEN JGLOB = ( JBLOCK - 1 ) * BLOCK_SIZE + 1 IROW_LOC_DEST = BLOCK_SIZE * & ( ( JGLOB - 1 ) / (BLOCK_SIZE*NPROW) ) & + mod( JGLOB - 1, BLOCK_SIZE ) + 1 CALL ZMUMPS_RECV_BLOCK( BUF, & A( IROW_LOC_DEST, JCOL_LOC_DEST ), LOCAL_M, & JBLOCK_SIZE, IBLOCK_SIZE, COMM, PROC_SOURCE ) END IF END DO END DO RETURN END SUBROUTINE ZMUMPS_SYMMETRIZE SUBROUTINE ZMUMPS_SEND_BLOCK( BUF, A, LDA, M, N, COMM, DEST ) IMPLICIT NONE INTEGER M, N, LDA, DEST, COMM COMPLEX(kind=8) BUF(*), A(LDA,*) INTEGER I, IBUF, IERR INTEGER J INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IBUF = 1 DO J = 1, N BUF( IBUF: IBUF + M - 1 ) = A( 1 : M, J ) DO I = 1, M END DO IBUF = IBUF + M END DO CALL MPI_SEND( BUF, M * N, MPI_DOUBLE_COMPLEX, & DEST, SYMMETRIZE, COMM, IERR ) RETURN END SUBROUTINE ZMUMPS_SEND_BLOCK SUBROUTINE ZMUMPS_RECV_BLOCK( BUF, A, LDA, M, N, COMM, SOURCE ) IMPLICIT NONE INTEGER LDA, M, N, COMM, SOURCE COMPLEX(kind=8) BUF(*), A( LDA, *) INTEGER I, IBUF, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) CALL MPI_RECV( BUF(1), M * N, MPI_DOUBLE_COMPLEX, SOURCE, & SYMMETRIZE, COMM, STATUS, IERR ) IBUF = 1 DO I = 1, M CALL zcopy( N, BUF(IBUF), 1, A(I,1), LDA ) IBUF = IBUF + N END DO RETURN END SUBROUTINE ZMUMPS_RECV_BLOCK SUBROUTINE ZMUMPS_TRANS_DIAG( A, N, LDA ) IMPLICIT NONE INTEGER N,LDA COMPLEX(kind=8) A( LDA, * ) INTEGER I, J DO I = 2, N DO J = 1, I - 1 A( J, I ) = A( I, J ) END DO END DO RETURN END SUBROUTINE ZMUMPS_TRANS_DIAG SUBROUTINE ZMUMPS_TRANSPO( A1, A2, M, N, LD ) IMPLICIT NONE INTEGER M,N,LD COMPLEX(kind=8) A1( LD,* ), A2( LD, * ) INTEGER I, J DO J = 1, N DO I = 1, M A2( J, I ) = A1( I, J ) END DO END DO RETURN END SUBROUTINE ZMUMPS_TRANSPO MUMPS_5.4.1/src/lr_common.F0000664000175000017500000000532214102210475015607 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_LR_COMMON IMPLICIT NONE CONTAINS SUBROUTINE COMPUTE_BLR_VCS(K472, IBCKSZ, MAXSIZE, NASS) INTEGER, INTENT(IN) :: MAXSIZE, NASS, K472 INTEGER, INTENT(OUT) :: IBCKSZ IF (K472.EQ.1) THEN IF (NASS.LE.1000) THEN IBCKSZ = 128 ELSEIF (NASS.GT.1000.AND.NASS.LE.5000) THEN IBCKSZ = 256 ELSEIF (NASS.GT.5000.AND.NASS.LE.10000) THEN IBCKSZ = 384 ELSE IBCKSZ = 512 ENDIF IBCKSZ = min(IBCKSZ,MAXSIZE) ELSE IBCKSZ = MAXSIZE ENDIF END SUBROUTINE COMPUTE_BLR_VCS SUBROUTINE MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & VLIST, FILS, FRERE_STEPS, STEP, DAD_STEPS, NE_STEPS, NA, LNA, & PVS, K38, STEP_SCALAPACK_ROOT) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NV, NSTEPS, LNA, F, VLIST(NV) INTEGER :: FILS(:), FRERE_STEPS(:), & DAD_STEPS(:), STEP(:), NE_STEPS(:), NA(:) INTEGER, INTENT(INOUT) :: PVS(NSTEPS), LPTR, RPTR INTEGER, INTENT(INOUT) :: K38 INTEGER, INTENT(IN) :: STEP_SCALAPACK_ROOT LOGICAL :: FIRST INTEGER :: PV, NODE, I PV = VLIST(1) NODE = ABS(STEP(PV)) PVS(NODE) = PV IF(FIRST) THEN I = DAD_STEPS(NODE) DO WHILE(FILS(I).GT.0) I = FILS(I) END DO FILS(I) = -PV END IF IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF IF(DAD_STEPS(NODE) .EQ. 0) THEN NA(RPTR) = PV RPTR = RPTR -1 ELSE DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF IF(NE_STEPS(NODE) .EQ. 0) THEN NA(LPTR) = PV LPTR = LPTR -1 END IF STEP(VLIST(1)) = ABS(STEP(VLIST(1))) IF (STEP(VLIST(1)).EQ.STEP_SCALAPACK_ROOT) THEN K38 = VLIST(1) ENDIF DO I=1, NV-1 IF(STEP(VLIST(I+1)).GT.0) STEP(VLIST(I+1)) = -STEP(VLIST(I+1)) FILS(VLIST(I)) = VLIST(I+1) END DO FILS(VLIST(NV)) = F RETURN END SUBROUTINE MUMPS_UPD_TREE END MODULE MUMPS_LR_COMMON MUMPS_5.4.1/src/sfac_front_LDLT_type1.F0000664000175000017500000011323714102210521017704 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC1_LDLT_M CONTAINS SUBROUTINE SMUMPS_FAC1_LDLT( N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, IFLAG, IERROR, & UU, NNEGW, NPVW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP,KEEP8, & MYID, SEUIL, AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) USE SMUMPS_FAC_FRONT_AUX_M USE SMUMPS_OOC USE SMUMPS_FAC_LR USE SMUMPS_LR_TYPE USE SMUMPS_LR_STATS USE SMUMPS_ANA_LR, ONLY : GET_CUT USE SMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, intent(inout) :: NNEGW, NPVW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER MYID, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL UU, SEUIL REAL A( LA ) INTEGER, TARGET :: IW( LIW ) INTEGER, intent(in) :: PERM(N) LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER :: LRGROUPS(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER :: LDA REAL UUTEMP LOGICAL STATICMODE REAL SEUIL_LOC LOGICAL IS_MAXFROMM_AVAIL INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER LAST_ROW, FIRST_ROW REAL MAXFROMM INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, NextPiv2beWritten, IFLAG_OOC, & IDUMMY, PP_FIRST2SWAP_L, PP_LastPIVRPTRFilled TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1, OFFSET INTEGER NFS4FATHER REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY LOGICAL LASTBL INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER K473_LOC INTEGER INFO_TMP(2), MAXI_RANK INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: PTDummy TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_L REAL, POINTER, DIMENSION(:) :: DIAG INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, I, IP, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG REAL, ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) REAL,ALLOCATABLE :: RWORK(:) REAL, ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: II,JJ INTEGER(8) :: UPOS, LPOS, DPOS REAL :: ONE, MONE, ZERO PARAMETER (ONE = 1.0E0, MONE=-1.0E0) PARAMETER (ZERO=0.0E0) INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC INTEGER :: NVSCHUR, NVSCHUR_K253, IROW_L INCLUDE 'mumps_headers.h' INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER PIVSIZ,IWPOSP2 INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY IS_MAXFROMM_AVAIL = .FALSE. IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF UUTEMP=UU IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE SEUIL_LOC = SEUIL ENDIF LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) LDA = NFRONT NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED= .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL SMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) LRTRSM_OPTION = KEEP(475) PIVOT_OPTION = KEEP(468) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION = 0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 LASTBL = .FALSE. CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF (OOC_EFFECTIVE_ON_FRONT) THEN IDUMMY = -8765 NextPiv2beWritten = 1 PP_FIRST2SWAP_L = NextPiv2beWritten MonBloc%LastPanelWritten_L = 0 PP_LastPIVRPTRFilled = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -77777 MonBloc%INDICES => & IW(IOLDPS+6+NFRONT+XSIZE: & IOLDPS+5+NFRONT+XSIZE+NFRONT) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 500 CALL SMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .TRUE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF DO II=1,NPARTSCB DO JJ=1,NPARTSCB NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL SMUMPS_FAC_I_LDLT(NFRONT,NASS,INODE, & IBEG_BLOCK, IEND_BLOCK, & IW,LIW,A,LA, & INOPV, NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UUTEMP, & SEUIL_LOC,KEEP,KEEP8,PIVSIZ, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled, MAXFROMM, IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF LASTBL = .TRUE. ELSE IF ( INOPV.LE.0 ) THEN NPVW = NPVW + PIVSIZ NVSCHUR_K253 = 0 IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT NVSCHUR_K253 = NVSCHUR + KEEP(253) ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & INODE,A,LA, & LDA, & POSELT,IFINB, & PIVSIZ, MAXFROMM, & IS_MAXFROMM_AVAIL, (UUTEMP.NE.0.0E0), & PARPIV_T1, & LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IF(PIVSIZ .EQ. 2) THEN IWPOSP2 = IOLDPS+IW(IOLDPS+1+XSIZE)+6 IW(IWPOSP2+NFRONT+XSIZE) = & -IW(IWPOSP2+NFRONT+XSIZE) ENDIF IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + PIVSIZ IF (IFINB.EQ.0) THEN GOTO 50 ELSE IF (IFINB.EQ.-1) THEN LASTBL = .TRUE. ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK, & NPIV, NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & -6666, -6666, & IEND_BLR, LAST_ROW, & .FALSE., .TRUE., LR_ACTIVATED, & IW, LIW, -6666 & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = IEND_BLR ENDIF CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR,IEND_BLR,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, POSELT, & KEEP, KEEP8, & IEND_BLR, NASS, & NASS, LAST_ROW, & (PIVOT_OPTION.LE.1), .TRUE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ELSE NELIM = IEND_BLOCK - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_L) NULLIFY(BLR_L) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_ROW = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_ROW = NASS ELSE FIRST_ROW = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_ROW = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_ROW = NASS ELSE LAST_ROW = NFRONT ENDIF IF ((IEND_BLR.LT.NFRONT) .AND. (LAST_ROW-FIRST_ROW.GT.0)) THEN CALL SMUMPS_FAC_SQ_LDLT(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NASS, & INODE, A, LA, LDA, POSELT, & KEEP, KEEP8, & FIRST_ROW, LAST_ROW, & -6666, -6666, & .TRUE., .FALSE., LR_ACTIVATED, & IW, LIW, IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS,DPOS,OFFSET) !$OMP& FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (PIVOT_OPTION.LT.3) THEN IF (LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL SMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_L, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 1, 0, & .FALSE., & IW, OFFSET_IW=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (NELIM.GT.0) THEN IF (PIVOT_OPTION.LE.1) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) DPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR)-1,8) OFFSET=IOLDPS+6+XSIZE+NFRONT+IBEG_BLR-1 UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_FAC_LDLT_COPYSCALE_U( NELIM, 1, & KEEP(424), NFRONT, NPIV-IBEG_BLR+1, & LIW, IW, OFFSET, LA, A, POSELT, LPOS, UPOS, DPOS) #if defined(BLR_MT) !$OMP END SINGLE #endif LPOS = POSELT & +int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-1-NELIM,8) CALL SMUMPS_BLR_UPD_NELIM_VAR_L( & A, LA, UPOS, A, LA, LPOS, & IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & FIRST_BLOCK, NELIM, 'N') ENDIF ENDIF IF (IFLAG.LT.0) GOTO 400 #if defined(BLR_MT) !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL SMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (KEEP(480).GE.2) THEN IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS-CURRENT_BLR ELSE FIRST_BLOCK = 1 ENDIF CALL SMUMPS_BLR_UPD_PANEL_LEFT_LDLT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), KEEP8, FIRST_BLOCK=FIRST_BLOCK) ENDIF ELSE CALL SMUMPS_BLR_UPDATE_TRAILING_LDLT(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, NELIM, & IW(HF+IOLDPS+NFRONT+IBEG_BLR-1), BLOCK, & MAXI_CLUSTER, NPIV, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF CALL SMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, NFRONT, & .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), NB_BLR, BLR_L, CURRENT_BLR, 'V', & 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_L) ELSE NULLIFY(NEXT_BLR_L) ENDIF ENDIF NULLIFY(BLR_L) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%Last = LASTBL MonBloc%LastPiv= NPIV LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, & TYPEF_L, A(POSELT), & LAFAC, MonBloc, NextPiv2beWritten, IDUMMY, IW(IOLDPS), & LIWFAC, MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO J=1,NB_BLR+1 BEGS_BLR_TMP(J) = BEGS_BLR_STATIC(J) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, NELIM_LOC) #endif IF ( (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DIAGPOS, POSELT_DIAG, !$OMP& MEM, allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*DIAGSIZ_STA MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DIAGPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA DIAG(DIAGPOS:DIAGPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DIAGPOS = DIAGPOS + DIAGSIZ_DYN POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL SMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), 0, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL SMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 #if defined(BLR_MT) !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL SMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL SMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & IW(HF+IOLDPS+NFRONT), BLOCK, & ACC_LUA, MAXI_CLUSTER, MAXI_RANK, & 1, IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(484), KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif END IF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$OMP MASTER #endif NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL SMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) IF (NFS4FATHER.GE.0) NFS4FATHER = NFS4FATHER + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 CALL SMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 2, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR+KEEP(253), KEEP(1), & M_ARRAY=M_ARRAY, & NELIM=NELIM ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 448 #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF DEALLOCATE(M_ARRAY) #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif 448 CONTINUE ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 1, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 2, 1) ENDIF IF (.NOT. COMPRESS_PANEL) THEN CALL SMUMPS_FAC_T_LDLT(NFRONT,NASS,IW,LIW,A,LA, & LDA, IOLDPS,POSELT, KEEP,KEEP8, & (PIVOT_OPTION.NE.3), ETATASS, & TYPEF_L, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, IOLDPS+6+XSIZE+NFRONT, INODE ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 1, 1) ENDIF ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_L, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL SMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.KEEP(480).NE.0) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL SMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 0, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND. .NOT.COMPRESS_CB) THEN CALL SMUMPS_BLR_END_FRONT( IW(IOLDPS+XXF),IFLAG,KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC1_LDLT END MODULE SMUMPS_FAC1_LDLT_M MUMPS_5.4.1/src/sarrowheads.F0000664000175000017500000010157014102210521016136 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id ) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ) INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER(8) :: IPTRI, IPTRR EARLYT3ROOTINS = KEEP(200) .EQ. 0 TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP8(26) = 0_8 KEEP8(27) = 0_8 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1, INIV2)+1,INIV2 ) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( & ( (ITYPE .EQ. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF (EARLYT3ROOTINS) THEN ELSE KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ENDIF ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0_8 KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP8(27) > 0 ) THEN ALLOCATE( id%INTARR( KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SET_IERROR(KEEP8(27),id%INFO(2)) RETURN END IF ELSE ALLOCATE( id%INTARR( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 1 RETURN END IF END IF IPTRI = 1_8 IPTRR = 1_8 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ELSE IF ( ITYPE .eq. 3) THEN IF ( EARLYT3ROOTINS ) THEN PTRAIW(I)=0 PTRARW(I)=0 ELSE NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = int(PTRAIW( I )) NROW = 0 id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3, 8) IPTRR = IPTRR + int(NCOL + NROW + 1, 8) ELSE PTRAIW(I) = 0_8 PTRARW(I) = 0_8 END IF END DO IF ( IPTRI - 1_8 .NE. KEEP8(27) ) THEN WRITE(*,*) 'Error 1 in ana_arrowheads', & ' IPTRI - 1, KEEP8(27)=', IPTRI - 1, KEEP8(27) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1_8 .NE. KEEP8(26) ) THEN WRITE(*,*) 'Error 2 in ana_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE SMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE SMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, LINTARR, DBLARR, LDBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) !$ USE OMP_LIB USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL ASPK(NZ) REAL COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER RG2L( N ), FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER LP, SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) REAL :: DBLARR( LDBLARR ) REAL :: A( LA ) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI REAL, DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT REAL VAL INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER INODE, ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating IW4' CALL MUMPS_ABORT() END IF DO I = 1, N I1 = PTRAIW( I ) IA = PTRARW( I ) IF ( IA .GT. 0 ) THEN DBLARR( IA ) = ZERO IW4( I, 1 ) = INTARR( I1 ) IW4( I, 2 ) = -INTARR( I1 + 1 ) INTARR( I1 + 2 ) = I END IF END DO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFI' CALL MUMPS_ABORT() END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFR' CALL MUMPS_ABORT() END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA, ISHIFT, IS1, IS, IAS, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L(JSEND) JPOSROOT = RG2L(IARR) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE WRITE(*,*) MYID,':INTERNAL Error: root arrowhead ' WRITE(*,*) MYID,':is not belonging to me. IARR,JARR=' & ,IARR,JARR CALL MUMPS_ABORT() END IF ELSE IF ( IARR .GE. 0 ) THEN IF ( IARR .eq. JARR ) THEN IA = PTRARW( IARR ) DBLARR( IA ) = DBLARR( IA ) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = int(INTARR(IS1) + IW4(IARR,2),8) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS1 + ISHIFT + 2_8) = JARR DBLARR(PTRARW(IARR)+ISHIFT) = VAL END IF ELSE IARR = -IARR ISHIFT = int(PTRAIW(IARR)+IW4(IARR,1)+2,8) INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+int(IW4(IARR,1),8) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) & CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN CALL SMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL SMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF IF ( KEEP( 46 ) .NE. 0 ) DEALLOCATE( IW4 ) IF (NBUFS.GT.0) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) ENDIF RETURN END SUBROUTINE SMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE SMUMPS_ARROW_FILL_SEND_BUF(ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER ISEND, JSEND, DEST, NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) REAL BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP REAL VAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST) CALL MPI_SEND(BUFI(1,DEST),TAILLE_SENDI, & MPI_INTEGER, & DEST, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST), TAILLE_SENDR, & MPI_REAL, DEST, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST) = 0 ENDIF IREQ = BUFI(1,DEST) + 1 BUFI(1,DEST) = IREQ BUFI( IREQ * 2, DEST ) = ISEND BUFI( IREQ * 2 + 1, DEST ) = JSEND BUFR( IREQ, DEST ) = VAL RETURN END SUBROUTINE SMUMPS_ARROW_FILL_SEND_BUF SUBROUTINE SMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) REAL BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_REAL, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE SMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) REAL DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT REAL sswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP sswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = sswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL SMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL SMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE SMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE SMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, PTRAIW, PTRARW, & KEEP, KEEP8, MYID, COMM, NBRECORDS, & A, LA, root, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, INFO1, INFO2 & ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW(N) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS REAL A( LA ) INTEGER INFO1, INFO2 REAL DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER, POINTER, DIMENSION(:) :: BUFI REAL, POINTER, DIMENSION(:) :: BUFR INTEGER, POINTER, DIMENSION(:,:) :: IW4 LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: I18, IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE REAL VAL REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER numroc EXTERNAL numroc TYPE_PARALL = KEEP(46) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS * 2 + 1 WRITE(*,*) MYID,': Could not allocate BUFI: goto 500' GOTO 500 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS WRITE(*,*) MYID,': Could not allocate BUFR: goto 500' GOTO 500 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = 2 * N WRITE(*,*) MYID,': Could not allocate IW4: goto 500' GOTO 500 END IF IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL SMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. DO I=1,N I18 = PTRAIW(I) IA8 = PTRARW(I) IF (IA8.GT.0_8) THEN DBLARR(IA8) = ZERO IW4(I,1) = INTARR(I18) IW4(I,2) = -INTARR(I18+1_8) INTARR(I18+2)=I ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_REAL, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT + int(JLOCROOT - 1,8) & * int(LOCAL_M,8) & + int(ILOCROOT - 1,8)) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL SMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( IW4 ) 500 CONTINUE KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE SMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE SMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N REAL :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) REAL, PARAMETER :: ZERO = 0.0E0 INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_SET_TO_ZERO SUBROUTINE SMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA REAL, INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL SMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL SMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL SMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE SMUMPS_SET_ROOT_TO_ZERO SUBROUTINE SMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: numroc LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE SMUMPS_GET_ROOT_INFO MUMPS_5.4.1/src/zfac_determinant.F0000664000175000017500000002036414102210524017135 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_UPDATEDETER(PIV, DETER, NEXP) IMPLICIT NONE COMPLEX(kind=8), intent(in) :: PIV COMPLEX(kind=8), intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DOUBLE PRECISION R_PART, C_PART INTEGER NEXP_LOC DETER=DETER*PIV R_PART=dble(DETER) C_PART=aimag(DETER) NEXP_LOC = exponent(abs(R_PART)+abs(C_PART)) NEXP = NEXP + NEXP_LOC R_PART=scale(R_PART, -NEXP_LOC) C_PART=scale(C_PART, -NEXP_LOC) DETER=cmplx(R_PART,C_PART,kind=kind(DETER)) RETURN END SUBROUTINE ZMUMPS_UPDATEDETER SUBROUTINE ZMUMPS_UPDATEDETER_SCALING(PIV, DETER, NEXP) IMPLICIT NONE DOUBLE PRECISION, intent(in) :: PIV DOUBLE PRECISION, intent(inout) :: DETER INTEGER, intent(inout) :: NEXP DETER=DETER*fraction(PIV) NEXP=NEXP+exponent(PIV)+exponent(DETER) DETER=fraction(DETER) RETURN END SUBROUTINE ZMUMPS_UPDATEDETER_SCALING SUBROUTINE ZMUMPS_GETDETER2D(BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DETER,NEXP,SYM) IMPLICIT NONE INTEGER, intent (in) :: SYM INTEGER, intent (inout) :: NEXP COMPLEX(kind=8), intent (inout) :: DETER INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX(kind=8), intent(in) :: A(*) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) CALL ZMUMPS_UPDATEDETER(A(I),DETER,NEXP) IF (SYM.EQ.1) THEN CALL ZMUMPS_UPDATEDETER(A(I),DETER,NEXP) ENDIF IF (SYM.NE.1) THEN IF (IPIV(ILOC+K) .NE. IBLOCK*BLOCK_SIZE+K) THEN DETER = -DETER ENDIF ENDIF K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE ZMUMPS_GETDETER2D SUBROUTINE ZMUMPS_DETER_REDUCTION( & COMM, DETER_IN, NEXP_IN, & DETER_OUT, NEXP_OUT, NPROCS) IMPLICIT NONE INTEGER, intent(in) :: COMM, NPROCS COMPLEX(kind=8), intent(in) :: DETER_IN INTEGER,intent(in) :: NEXP_IN COMPLEX(kind=8),intent(out):: DETER_OUT INTEGER,intent(out):: NEXP_OUT INTEGER :: IERR_MPI EXTERNAL ZMUMPS_DETERREDUCE_FUNC INTEGER TWO_SCALARS_TYPE, DETERREDUCE_OP COMPLEX(kind=8) :: INV(2) COMPLEX(kind=8) :: OUTV(2) INCLUDE 'mpif.h' IF (NPROCS .EQ. 1) THEN DETER_OUT = DETER_IN NEXP_OUT = NEXP_IN RETURN ENDIF CALL MPI_TYPE_CONTIGUOUS(2, MPI_DOUBLE_COMPLEX, & TWO_SCALARS_TYPE, & IERR_MPI) CALL MPI_TYPE_COMMIT(TWO_SCALARS_TYPE, IERR_MPI) CALL MPI_OP_CREATE(ZMUMPS_DETERREDUCE_FUNC, & .TRUE., & DETERREDUCE_OP, & IERR_MPI) INV(1)=DETER_IN INV(2)=cmplx(NEXP_IN,kind=kind(INV)) CALL MPI_ALLREDUCE( INV, OUTV, 1, TWO_SCALARS_TYPE, & DETERREDUCE_OP, COMM, IERR_MPI) CALL MPI_OP_FREE(DETERREDUCE_OP, IERR_MPI) CALL MPI_TYPE_FREE(TWO_SCALARS_TYPE, IERR_MPI) DETER_OUT = OUTV(1) NEXP_OUT = int(OUTV(2)) RETURN END SUBROUTINE ZMUMPS_DETER_REDUCTION SUBROUTINE ZMUMPS_DETERREDUCE_FUNC(INV, INOUTV, NEL, DATATYPE) IMPLICIT NONE #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4), INTENT(IN) :: NEL, DATATYPE #else INTEGER, INTENT(IN) :: NEL, DATATYPE #endif COMPLEX(kind=8), INTENT(IN) :: INV ( 2 * NEL ) COMPLEX(kind=8), INTENT(INOUT) :: INOUTV ( 2 * NEL ) INTEGER I, TMPEXPIN, TMPEXPINOUT DO I = 1, NEL TMPEXPIN = int(INV (I*2)) TMPEXPINOUT = int(INOUTV(I*2)) CALL ZMUMPS_UPDATEDETER(INV(I*2-1), & INOUTV(I*2-1), & TMPEXPINOUT) TMPEXPINOUT = TMPEXPINOUT + TMPEXPIN INOUTV(I*2) = cmplx(TMPEXPINOUT,kind=kind(INOUTV)) ENDDO RETURN END SUBROUTINE ZMUMPS_DETERREDUCE_FUNC SUBROUTINE ZMUMPS_DETER_SQUARE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP COMPLEX(kind=8), intent (inout) :: DETER DETER=DETER*DETER NEXP=NEXP+NEXP RETURN END SUBROUTINE ZMUMPS_DETER_SQUARE SUBROUTINE ZMUMPS_DETER_SCALING_INVERSE(DETER, NEXP) IMPLICIT NONE INTEGER, intent (inout) :: NEXP DOUBLE PRECISION, intent (inout) :: DETER DETER=1.0D0/DETER NEXP=-NEXP RETURN END SUBROUTINE ZMUMPS_DETER_SCALING_INVERSE SUBROUTINE ZMUMPS_DETER_SIGN_PERM(DETER, N, VISITED, PERM) IMPLICIT NONE COMPLEX(kind=8), intent(inout) :: DETER INTEGER, intent(in) :: N INTEGER, intent(inout) :: VISITED(N) INTEGER, intent(in) :: PERM(N) INTEGER I, J, K K = 0 DO I = 1, N IF (VISITED(I) .GT. N) THEN VISITED(I)=VISITED(I)-N-N-1 CYCLE ENDIF J = PERM(I) DO WHILE (J.NE.I) VISITED(J) = VISITED(J) + N + N + 1 K = K + 1 J = PERM(J) ENDDO ENDDO IF (mod(K,2).EQ.1) THEN DETER = -DETER ENDIF RETURN END SUBROUTINE ZMUMPS_DETER_SIGN_PERM SUBROUTINE ZMUMPS_PAR_ROOT_MINMAX_PIV_UPD ( & BLOCK_SIZE,IPIV, & MYROW, MYCOL, NPROW, NPCOL, & A, LOCAL_M, LOCAL_N, N, MYID, & DKEEP, KEEP, SYM) USE ZMUMPS_FAC_FRONT_AUX_M, & ONLY : ZMUMPS_UPDATE_MINMAX_PIVOT IMPLICIT NONE INTEGER, intent (in) :: BLOCK_SIZE, NPROW, NPCOL, & LOCAL_M, LOCAL_N, N, SYM INTEGER, intent (in) :: MYROW, MYCOL, MYID, IPIV(LOCAL_M) COMPLEX(kind=8), intent(in) :: A(*) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER, INTENT(IN) :: KEEP(500) INTEGER I,IMX,DI,NBLOCK,IBLOCK,ILOC,JLOC, & ROW_PROC,COL_PROC, K DOUBLE PRECISION :: ABSPIVOT DI = LOCAL_M + 1 NBLOCK = ( N - 1 ) / BLOCK_SIZE DO IBLOCK = 0, NBLOCK ROW_PROC = mod( IBLOCK, NPROW ) IF ( MYROW.EQ.ROW_PROC ) THEN COL_PROC = mod( IBLOCK, NPCOL ) IF ( MYCOL.EQ.COL_PROC ) THEN ILOC = ( IBLOCK / NPROW ) * BLOCK_SIZE JLOC = ( IBLOCK / NPCOL ) * BLOCK_SIZE I = ILOC + JLOC * LOCAL_M + 1 IMX = min(ILOC+BLOCK_SIZE,LOCAL_M) & + (min(JLOC+BLOCK_SIZE,LOCAL_N)-1)*LOCAL_M & + 1 K=1 DO WHILE ( I .LT. IMX ) IF (SYM.NE.1) THEN ABSPIVOT = abs(A(I)) ELSE ABSPIVOT = abs(A(I)*A(I)) ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( ABSPIVOT, & DKEEP, KEEP, .FALSE.) K = K + 1 I = I + DI END DO END IF END IF END DO RETURN END SUBROUTINE ZMUMPS_PAR_ROOT_MINMAX_PIV_UPD MUMPS_5.4.1/src/cfac_process_end_facto_slave.F0000664000175000017500000002633714102210523021453 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_LOAD #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE CMUMPS_LR_DATA_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER INODE, FPERE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER COMM, MYID INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER N INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER FRERE(KEEP(28)) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER MRS_INODE INTEGER MRS_ISON INTEGER MRS_NSLAVES_PERE INTEGER MRS_NASS_PERE INTEGER MRS_NFRONT_PERE INTEGER MRS_LMAP INTEGER MRS_NFS4FATHER INTEGER, POINTER, DIMENSION(:) :: MRS_SLAVES_PERE, MRS_TROW INTEGER ITYPE2 INTEGER IHDR_REC PARAMETER (ITYPE2=2) INTEGER IOLDPS, NROW, LDA INTEGER NPIV, LCONT, NELIM, NASS, NCOL_TO_SEND, & SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER(8) :: SHIFT_VAL_SON INTEGER(8) :: MEM_GAIN INTEGER(8) :: DYN_SIZE #if ! defined(NO_FDM_MAPROW) TYPE(MAPROW_STRUC_T), POINTER :: MRS #endif INTEGER :: IWHANDLER_SAVE INTEGER :: LRSTATUS LOGICAL :: CB_STORED_IN_BLRSTRUC, COMPRESS_CB IF (KEEP(50).EQ.0) THEN IHDR_REC=6 ELSE IHDR_REC=8 ENDIF IOLDPS = PTRIST(STEP(INODE)) IWHANDLER_SAVE = IW(IOLDPS+XXA) LRSTATUS = IW(IOLDPS+XXLR) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL CMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8) ENDIF IW(IOLDPS+XXS)=S_ALL IOLDPS = PTRIST(STEP(INODE)) LRSTATUS = IW(IOLDPS+XXLR) IF ( (KEEP(214).EQ.1) & ) THEN CALL CMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP,KEEP8, DKEEP, ITYPE2 & ) IOLDPS = PTRIST(STEP(INODE)) IF (KEEP(38).NE.FPERE) THEN CB_STORED_IN_BLRSTRUC = .FALSE. LRSTATUS = IW(IOLDPS+XXLR) IF ((LRSTATUS.EQ.1).OR.(LRSTATUS.EQ.3)) THEN CB_STORED_IN_BLRSTRUC = .TRUE. IW(IOLDPS+XXS) = S_NOLNOCB CALL MUMPS_GETI8(MEM_GAIN, IW(IOLDPS+XXR)) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ELSE IW(IOLDPS+XXS)=S_NOLCBNOCONTIG CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE .GT.0) THEN ELSE IF (KEEP(216).NE.3) THEN MEM_GAIN=int(IW( IOLDPS + 2 + KEEP(IXSZ) ),8)* & int(IW( IOLDPS + 3 + KEEP(IXSZ) ),8) LRLUS = LRLUS+MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) ENDIF ENDIF ENDIF CALL MUMPS_GETI8( DYN_SIZE, IW(IOLDPS+XXD)) IF (DYN_SIZE > 0_8) THEN ELSE IF (KEEP(216).EQ.2) THEN IF (FPERE.NE.KEEP(38)) THEN IF (.NOT. CB_STORED_IN_BLRSTRUC) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), 0, & IW( IOLDPS + XXS ), 0_8 ) IW(IOLDPS+XXS)=S_NOLCBCONTIG ENDIF ENDIF ENDIF ENDIF IF ( KEEP(38).EQ.FPERE) THEN LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV NCOL_TO_SEND = LCONT-NELIM SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NASS SHIFT_VAL_SON = int(NASS,8) LDA = LCONT + NPIV IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOTBAND_INIT) THEN IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_REC_CONTSTATIC ELSE ENDIF CALL CMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG < 0 ) GOTO 600 IF (NELIM.EQ.0) THEN IF (KEEP(214).EQ.2) THEN CALL CMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8,DKEEP, ITYPE2 & ) ENDIF CALL CMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IOLDPS = PTRIST(STEP(INODE)) IF (IW(IOLDPS+IHDR_REC+KEEP(IXSZ)).EQ.S_ROOT2SON_CALLED) THEN CALL CMUMPS_FREE_BAND( N, INODE, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, STEP, & MYID, KEEP, KEEP8, ITYPE2 & ) ELSE IW(IOLDPS+IHDR_REC+KEEP(IXSZ)) = S_ROOTBAND_INIT IF (KEEP(214).EQ.1.AND.KEEP(216).NE.3) THEN IW(IOLDPS+XXS)=S_NOLCBNOCONTIG38 CALL CMUMPS_SIZEFREEINREC( IW(IOLDPS), & LIW-IOLDPS+1, & MEM_GAIN, KEEP(IXSZ) ) LRLUS = LRLUS + MEM_GAIN KEEP8(69) = KEEP8(69) - MEM_GAIN CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-MEM_GAIN,KEEP,KEEP8,LRLUS) IF (KEEP(216).EQ.2) THEN CALL CMUMPS_MAKECBCONTIG(A,LA,PTRAST(STEP(INODE)), & IW( IOLDPS + 2 + KEEP(IXSZ) ), & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 3 + KEEP(IXSZ) )+ & IW( IOLDPS + KEEP(IXSZ) ), & IW( IOLDPS + 4 + KEEP(IXSZ) ) - & IW( IOLDPS + 3 + KEEP(IXSZ) ), & IW( IOLDPS + XXS ),0_8) IW(IOLDPS+XXS)=S_NOLCBCONTIG38 ENDIF ENDIF ENDIF ENDIF ENDIF 600 CONTINUE #if ! defined(NO_FDM_MAPROW) IOLDPS = PTRIST(STEP(INODE)) IF (FPERE .NE. KEEP(38)) THEN IF (MUMPS_FMRD_IS_MAPROW_STORED( IW(IOLDPS+XXA) )) THEN CALL MUMPS_FMRD_RETRIEVE_MAPROW( IW(IOLDPS+XXA), MRS ) IF (FPERE .NE. MRS%INODE) THEN WRITE(*,*) " Internal error 1 in CMUMPS_END_FACTO_SLAVE", & INODE, MRS%INODE, FPERE CALL MUMPS_ABORT() ENDIF MRS_INODE = MRS%INODE MRS_ISON = MRS%ISON MRS_NSLAVES_PERE = MRS%NSLAVES_PERE MRS_NASS_PERE = MRS%NASS_PERE MRS_NFRONT_PERE = MRS%NFRONT_PERE MRS_LMAP = MRS%LMAP MRS_NFS4FATHER = MRS%NFS4FATHER MRS_SLAVES_PERE => MRS%SLAVES_PERE MRS_TROW => MRS%TROW CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & MRS_INODE, MRS_ISON, & MRS_NSLAVES_PERE, MRS_SLAVES_PERE(1), & MRS_NFRONT_PERE, MRS_NASS_PERE, MRS_NFS4FATHER, & MRS_LMAP, MRS_TROW(1), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) CALL MUMPS_FMRD_FREE_MAPROW_STRUC( IWHANDLER_SAVE ) ENDIF ENDIF #endif RETURN END SUBROUTINE CMUMPS_END_FACTO_SLAVE MUMPS_5.4.1/src/zana_aux_ELT.F0000664000175000017500000010761014102210524016132 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES, LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,L1,L2,NCMPA,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL ZMUMPS_ANA_G11_ELT, ZMUMPS_ANA_G12_ELT, & ZMUMPS_ANA_G1_ELT, ZMUMPS_ANA_G2_ELT, & ZMUMPS_ANA_G2_ELTNEW, & ZMUMPS_ANA_J1_ELT, ZMUMPS_ANA_J2_ELT, & ZMUMPS_ANA_K, & ZMUMPS_ANA_LNEW, ZMUMPS_ANA_M, & MUMPS_AMD_ELT #if defined(OLDDFS) EXTERNAL ZMUMPS_ANA_L #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 4*N GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min0(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min0(10,ELTPTR(NELT+1)-1) IF (LDIAG.EQ.4) K = ELTPTR(NELT+1)-1 IF (K.GT.0) WRITE (MP,99995) (ELTVAR(I),I=1,K) K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP(I,1),I=1,K) ENDIF 10 L1 = 1 L2 = L1 + N IF (LIW .LT. 3*N) THEN INFO(1) = -2002 INFO(2) = LIW ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL ZMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL ZMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL ZMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4*N+4, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL ZMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL ZMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in ZMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL ZMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL ZMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+K) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+IKEEP(K,1)).EQ.1) THEN GOTO 40 ELSE IW(L1+IKEEP(K,1)) = 1 ENDIF ENDDO CALL ZMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL ZMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in ZMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL ZMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF #if defined(OLDDFS) CALL ZMUMPS_ANA_L(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, KEEP(60)) #else CALL ZMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+N),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY) #endif DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL ZMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL ZMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) KEEP(210)=0 IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) KEEP(210)=1 IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL ZMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE ZMUMPS_ANA_F_ELT SUBROUTINE ZMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine ZMUMPS_NODEL ***') END SUBROUTINE ZMUMPS_NODEL SUBROUTINE ZMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G1_ELT SUBROUTINE ZMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G2_ELTNEW SUBROUTINE ZMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G2_ELT SUBROUTINE ZMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_J1_ELT SUBROUTINE ZMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_J2_ELT SUBROUTINE ZMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE ZMUMPS_ANA_DIST_ELEMENTS SUBROUTINE ZMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ELTPROC SUBROUTINE ZMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine ZMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine ZMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine ZMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE ZMUMPS_FRTELT SUBROUTINE ZMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD,LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL ZMUMPS_SUPVAR LP = 6 CALL ZMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3*N+3+1),3*N+3,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from ZMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3*N+3+1+I) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(N+1:2*N) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(N+J).NE.I)) THEN IW(N+J) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G11_ELT SUBROUTINE ZMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE ZMUMPS_ANA_G12_ELT SUBROUTINE ZMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LIW,LP,N,NELT,NSUP,NZ INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER FLAG,NEW,VARS EXTERNAL ZMUMPS_SUPVARB INFO(1) = 0 INFO(2) = 0 INFO(3) = 0 INFO(4) = 0 IF (N.LT.1) GO TO 10 IF (NELT.LT.1) GO TO 20 IF (NZ.LT.ELTPTR(NELT+1)-1) GO TO 30 IF (LIW.LT.6) THEN INFO(4) = 3*N + 3 GO TO 40 END IF NEW = 1 VARS = NEW + LIW/3 FLAG = VARS + LIW/3 CALL ZMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP,LIW/3-1, & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = 3*N + 3 GO TO 40 ELSE INFO(4) = 3*NSUP + 3 END IF GO TO 50 10 INFO(1) = -1 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 20 INFO(1) = -2 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 30 INFO(1) = -3 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 40 INFO(1) = -4 IF (LP.GT.0) THEN WRITE (LP,FMT=9000) INFO(1) WRITE (LP,FMT=9010) INFO(4) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from ZMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE ZMUMPS_SUPVAR SUBROUTINE ZMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE ZMUMPS_SUPVARB MUMPS_5.4.1/src/cfac_distrib_distentry.F0000664000175000017500000010054214102210523020335 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE CMUMPS_BUILD_MAPPING SUBROUTINE CMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (CMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR COMPLEX DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTRAIW( N ), PTRARW( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, COMM, NBRECORDS INTEGER(8) :: LA INTEGER SLAVEF INTEGER ISTEP_TO_INIV2(KEEP(71)) INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) COMPLEX A( LA ) TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I INTEGER(8) :: I18, IA8 INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER(8) :: IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI COMPLEX, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI COMPLEX, ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 INFO(2) = N * 2 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO I = 1, N I18 = PTRAIW( I ) IA8 = PTRARW( I ) IF ( IA8 .GT. 0_8 ) THEN DBLARR( IA8 ) = ZERO IW4( I, 1 ) = INTARR( I18 ) IW4( I, 2 ) = -INTARR( I18 + 1_8 ) INTARR( I18 + 2_8 ) = I END IF END DO EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL CMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL CMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA8, ISHIFT, IIW8, IS18, IS8, IAS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) INTARR(IS18+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,2) = IW4(IARR,2) - 1 ELSE ISHIFT = IW4(IARR,1) INTARR(PTRAIW(IARR)+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,1) = IW4(IARR,1) - 1 IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L_ROW(JSEND) JPOSROOT = root%RG2L_ROW(IARR ) ELSE IPOSROOT = root%RG2L_ROW(IARR ) JPOSROOT = root%RG2L_ROW(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JSEND IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ELSE IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JSEND IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ENDIF DEST=MASTER_NODE CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .GE. 0) THEN CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP, KEEP8 ) ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST = -3 CALL CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, &BUFI, BUFR, BUFRECI, BUFRECR, &NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, &SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, &N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, &PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, &IW4(1,1), root, KEEP,KEEP8 ) DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_COMPLEX, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN END SUBROUTINE CMUMPS_REDISTRIBUTION SUBROUTINE CMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, N, & PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV, LOCAL_M, LOCAL_N INTEGER(8) :: LINTARR, LDBLARR INTEGER(8) :: LA, PTR_ROOT INTEGER BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) INTEGER BUFRECI( NBRECORDS * 2 + 1 ) INTEGER IREQI(SLAVEF), IREQR(SLAVEF), IACT(SLAVEF) INTEGER IW4( N, 2 ) INTEGER(8) PTRAIW( N ), PTRARW( N ) INTEGER PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR( LINTARR ) COMPLEX DBLARR( LDBLARR ), A( LA ) LOGICAL SEND_ACTIVE(SLAVEF) COMPLEX BUFR( NBRECORDS, 2, SLAVEF ) COMPLEX BUFRECR( NBRECORDS ) COMPLEX VAL INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R, MSGSOU LOGICAL FLAG, SEND_LOCAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( DEST .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST + 1 IEND = DEST + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_COMPLEX, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF ELSE CALL MPI_WAIT( IREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. END IF END DO IF ( ISLAVE - 1 .ne. MYID ) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, ARR_INT, COMM, & IREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFR(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_R, & MPI_COMPLEX, ISLAVE - 1, ARR_REAL, COMM, & IREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. ELSE SEND_LOCAL = .TRUE. END IF IACT( ISLAVE ) = 3 - IACT( ISLAVE ) BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 END IF IF ( DEST .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL CMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE CMUMPS_DIST_FILL_BUFFER SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) COMPLEX BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8) :: PTRAIW( N ), PTRARW( N ) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA COMPLEX A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS COMPLEX VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL CMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE CMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.4.1/src/zfac_asm_master_m.F0000664000175000017500000021341114102210525017270 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE ZMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & ) !$ USE OMP_LIB USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_IS_DYNAMIC, & ZMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & ZMUMPS_BLR_ASM_NIV1 USE ZMUMPS_LR_DATA_M, ONLY : ZMUMPS_BLR_INIT_FRONT, & ZMUMPS_BLR_SAVE_NFS4FATHER USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 COMPLEX(kind=8), TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: JK8, J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = N NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in ZMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN ZMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL ZMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN ZMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL ZMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL ZMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL ZMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) IF (IS_DYNAMIC_CB) THEN CALL ZMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL ZMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) DO 250 JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING ZMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING ZMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING ZMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV1 SUBROUTINE ZMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_IS_DYNAMIC USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF COMPLEX(kind=8), TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE COMPLEX(kind=8), DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: JK8, AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER IJROW,NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT COMPLEX(kind=8) ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL ZMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL ZMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL ZMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress ZMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL ZMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL ZMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL ZMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN ZMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL ZMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+KEEP(IXSZ)+NSLAVES)= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL ZMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL ZMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL ZMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL ZMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & ZMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL ZMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1_8 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = cmplx(MAXARR,kind=kind(A)) ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL ZMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL ZMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL ZMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL ZMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL ZMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL ZMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING ZMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING ZMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_ASM_NIV2 END MODULE ZMUMPS_FAC_ASM_MASTER_M MUMPS_5.4.1/src/omp_tps_common_m.F0000664000175000017500000000101514102210475017162 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_TPS_M_RETURN() RETURN END SUBROUTINE MUMPS_TPS_M_RETURN MUMPS_5.4.1/src/dsol_fwd.F0000664000175000017500000001456414102210522015424 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE DMUMPS_STATIC_PTR_M, ONLY : DMUMPS_SET_STATIC_PTR, & DMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS DOUBLE PRECISION A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), LRHSCOMP DOUBLE PRECISION, intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL DMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL DMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL DMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL DMUMPS_SET_STATIC_PTR(A) CALL DMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL DMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error DMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL DMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE DMUMPS_SOL_R MUMPS_5.4.1/src/dana_aux_ELT.F0000664000175000017500000010761014102210522016102 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_ANA_F_ELT(N, NELT, ELTPTR, ELTVAR, LIW, & IKEEP, & IORD, NFSIZ, FILS, FRERE, & LISTVAR_SCHUR, SIZE_SCHUR, & ICNTL, INFO, KEEP,KEEP8, & NSLAVES, & XNODEL, NODEL #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) & , METIS_OPTIONS #endif & ) USE MUMPS_ANA_ORD_WRAPPERS IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SIZE_SCHUR, NSLAVES, LIW INTEGER, INTENT(IN) :: ELTPTR(NELT+1) INTEGER, INTENT(IN) :: ELTVAR(ELTPTR(NELT+1)-1) INTEGER, INTENT(IN) :: LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, INTENT(INOUT) :: IORD INTEGER, INTENT(INOUT) :: IKEEP(N,3) INTEGER, INTENT(INOUT) :: INFO(80), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(OUT) :: NFSIZ(N), FILS(N), FRERE(N) INTEGER, INTENT(OUT) :: XNODEL(N+1), NODEL(ELTPTR(NELT+1)-1) #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) INTEGER, INTENT(IN) :: METIS_OPTIONS(40) #endif INTEGER K,I,L1,L2,NCMPA,IFSON,IN INTEGER NEMIN, MPRINT, LP, MP, LDIAG INTEGER(8) :: NZ8, LLIW8, IWFR8 INTEGER allocok, ITEMP LOGICAL PROK, NOSUPERVAR, LPOK INTEGER(8) :: K79REF PARAMETER(K79REF=12000000_8) LOGICAL SPLITROOT INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER :: IDUMMY(1) INTEGER, DIMENSION(:), ALLOCATABLE :: IW INTEGER, DIMENSION(:), ALLOCATABLE :: IW2 INTEGER, DIMENSION(:), ALLOCATABLE :: PARENT INTEGER, DIMENSION(:,:), ALLOCATABLE :: IWtemp INTEGER(8), DIMENSION(:), ALLOCATABLE :: IPE8 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) INTEGER :: NUMFLAG #else INTEGER, DIMENSION(:), ALLOCATABLE :: NUMFLAG #endif INTEGER :: OPT_METIS_SIZE, METIS_IDX_SIZE INTEGER :: IERR #endif INTEGER IDUM EXTERNAL DMUMPS_ANA_G11_ELT, DMUMPS_ANA_G12_ELT, & DMUMPS_ANA_G1_ELT, DMUMPS_ANA_G2_ELT, & DMUMPS_ANA_G2_ELTNEW, & DMUMPS_ANA_J1_ELT, DMUMPS_ANA_J2_ELT, & DMUMPS_ANA_K, & DMUMPS_ANA_LNEW, DMUMPS_ANA_M, & MUMPS_AMD_ELT #if defined(OLDDFS) EXTERNAL DMUMPS_ANA_L #endif ALLOCATE( IW ( LIW ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = LIW GOTO 90 ENDIF ALLOCATE( IPE8 ( N + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = (N+1)*KEEP(10) GOTO 90 ENDIF ALLOCATE( PARENT(N), IWtemp ( N, 3 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = 4*N GOTO 90 ENDIF MPRINT= ICNTL(3) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) MP = ICNTL(3) PROK = ((MP.GT.0).AND.(ICNTL(4).GE.2)) LDIAG = ICNTL(4) IF (KEEP(60).NE.0) THEN NOSUPERVAR=.TRUE. IF (IORD.GT.1) IORD = 0 ELSE NOSUPERVAR=.FALSE. ENDIF IF (IORD == 7) THEN IF ( N < 10000 ) THEN IORD = 0 ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IORD = 5 #else IORD = 0 #endif ENDIF END IF #if ! defined(metis) && ! defined(parmetis) && ! defined(metis4) && ! defined(parmetis3) IF (IORD == 5) IORD = 0 #endif IF (KEEP(1).LT.1) KEEP(1) = 1 NEMIN = KEEP(1) IF (LDIAG.LE.2 .OR. MP.LE.0) GO TO 10 WRITE (MP,99999) N, NELT, LIW, INFO(1) K = min0(10,NELT+1) IF (LDIAG.EQ.4) K = NELT+1 IF (K.GT.0) WRITE (MP,99998) (ELTPTR(I),I=1,K) K = min0(10,ELTPTR(NELT+1)-1) IF (LDIAG.EQ.4) K = ELTPTR(NELT+1)-1 IF (K.GT.0) WRITE (MP,99995) (ELTVAR(I),I=1,K) K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (IORD.EQ.1 .AND. K.GT.0) THEN WRITE (MP,99997) (IKEEP(I,1),I=1,K) ENDIF 10 L1 = 1 L2 = L1 + N IF (LIW .LT. 3*N) THEN INFO(1) = -2002 INFO(2) = LIW ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF ( IORD == 5 ) THEN IF (LIW .LT. N+N+1) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 ENDIF ELSE #endif IF (NOSUPERVAR) THEN IF ( LIW .LT. 2*N ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ELSE IF ( LIW .LT. 4*N+4 ) THEN INFO(1)= -2002 INFO(2) = LIW GOTO 90 END IF ENDIF #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) ENDIF #endif IDUM=0 CALL DMUMPS_NODEL(NELT, N, ELTPTR(NELT+1)-1, ELTPTR, ELTVAR, & XNODEL, NODEL, IW(L1), IDUM, ICNTL) IF (IORD.NE.1 .AND. IORD .NE. 5) THEN IORD = 0 IF (NOSUPERVAR) THEN CALL DMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) ELSE CALL DMUMPS_ANA_G11_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), 4*N+4, IW(L1)) ENDIF LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF IF (NOSUPERVAR) THEN CALL DMUMPS_ANA_G2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ELSE CALL DMUMPS_ANA_G12_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) ENDIF IF (NOSUPERVAR) THEN CALL MUMPS_HAMD(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp, & LISTVAR_SCHUR, SIZE_SCHUR) IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in DMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ELSE CALL MUMPS_AMD_ELT(N, LLIW8, IPE8, IWFR8, IWtemp(1,2), IW2, & IW(L1), IKEEP, & IKEEP(1,2), NCMPA, FILS, IKEEP(1,3), IW(L2), IWtemp(1,3), & IWtemp) ENDIF ELSE #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) IF (IORD.EQ.5) THEN IF (PROK) THEN WRITE(MPRINT,'(A)') ' Ordering based on METIS' ENDIF CALL DMUMPS_ANA_G1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IWtemp(1,2), IW(L1)) LLIW8 = max(NZ8,int(N,8)) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8, INFO(2)) GOTO 90 ENDIF CALL DMUMPS_ANA_G2_ELTNEW(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) #if defined(metis4) || defined(parmetis3) NUMFLAG = 1 OPT_METIS_SIZE = 8 #else ALLOCATE( NUMFLAG ( N ), stat = IERR ) IF ( IERR .GT. 0 ) THEN INFO( 1 ) = -7 INFO( 2 ) = N GOTO 90 ENDIF DO I=1,N NUMFLAG(I) = 1 ENDDO OPT_METIS_SIZE = 40 #endif CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (KEEP(10).EQ.1.AND.METIS_IDX_SIZE.NE.64) THEN INFO(1) = -52 INFO(2) = 1 GOTO 90 ENDIF IF (METIS_IDX_SIZE .EQ. 32) THEN CALL MUMPS_METIS_NODEND_MIXEDto32(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), LP, LPOK) ELSE IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_NODEND_MIXEDto64(N, IPE8, IW2, #if defined(metis4) || defined(parmetis3) & NUMFLAG, #else & NUMFLAG, #endif & METIS_OPTIONS(1), OPT_METIS_SIZE, & IKEEP(1:N,2), IKEEP(1:N,1), INFO(1), & LP, LPOK, KEEP(10), & LLIW8, .FALSE., .TRUE. ) ELSE WRITE(*,*) & "Internal error in METIS wrappers, METIS_IDX_SIZE=", & METIS_IDX_SIZE CALL MUMPS_ABORT() ENDIF IF (INFO(1) .LT. 0) GOTO 90 DEALLOCATE(IW2) ELSE IF (IORD.NE.1) THEN WRITE(*,*) IORD WRITE(*,*) 'bad option for ordering' CALL MUMPS_ABORT() ENDIF #endif DO K=1,N IW(L1+K) = 0 ENDDO DO K=1,N IF ((IKEEP(K,1).LE.0).OR.(IKEEP(K,1).GT.N)) & GO TO 40 IF (IW(L1+IKEEP(K,1)).EQ.1) THEN GOTO 40 ELSE IW(L1+IKEEP(K,1)) = 1 ENDIF ENDDO CALL DMUMPS_ANA_J1_ELT(N, NZ8, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IWtemp(1,2), IW(L1)) LLIW8 = NZ8+int(N,8) ALLOCATE( IW2(LLIW8), stat = allocok ) IF (allocok.GT.0) THEN INFO(1) = -7 CALL MUMPS_SET_IERROR(LLIW8,INFO(2)) GOTO 90 ENDIF CALL DMUMPS_ANA_J2_ELT(N, NELT, ELTPTR(NELT+1)-1, & ELTPTR, ELTVAR, XNODEL, NODEL, & IKEEP, IW2, LLIW8, IPE8, IWtemp(1,2), & IW(L1), IWFR8) IF (KEEP(60) == 0) THEN ITEMP = 0 ELSE ITEMP = SIZE_SCHUR IF (KEEP(60) == 1) THEN KEEP(20) = LISTVAR_SCHUR(1) ELSEIF (KEEP(60) == 2 .OR. KEEP(60) == 3 ) THEN KEEP(38) = LISTVAR_SCHUR(1) ELSE WRITE(*,*) "Internal error in DMUMPS_ANA_F_ELT",KEEP(60) CALL MUMPS_ABORT() ENDIF ENDIF CALL DMUMPS_ANA_K(N, IPE8, IW2, LLIW8, IWFR8, IKEEP, & IKEEP(1,2), IW(L1), & IW(L2), NCMPA, ITEMP, IWtemp) ENDIF #if defined(OLDDFS) CALL DMUMPS_ANA_L(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, KEEP(60)) #else CALL DMUMPS_ANA_LNEW(N, IWtemp, IW(L1), IKEEP, IKEEP(1,2), & IKEEP(1,3), & NFSIZ, IWtemp(1,2), & INFO(6), FILS, FRERE, IWtemp(1,3), NEMIN, & IW(L2), KEEP(60), KEEP(20), KEEP(38), & IW2,KEEP(104),IW(L2+N),KEEP(50), & ICNTL(13), KEEP(37), NSLAVES, KEEP(250).EQ.1, & .FALSE., IDUMMY, LIDUMMY) #endif DEALLOCATE(IW2) IF (KEEP(60).NE.0) THEN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO WHILE (IN.GT.0) IN = FILS (IN) END DO IFSON = -IN IF (KEEP(60)==1) THEN IN = KEEP(20) ELSE IN = KEEP(38) ENDIF DO I=2,SIZE_SCHUR FILS(IN) = LISTVAR_SCHUR (I) IN = FILS(IN) FRERE (IN) = N+1 ENDDO FILS(IN) = -IFSON ENDIF CALL DMUMPS_ANA_M(IKEEP(1,2), & IWtemp(1,3), INFO(6), & INFO(5), KEEP(2),KEEP(50), & KEEP8(101), KEEP(108),KEEP(5), & KEEP(6), KEEP(226), KEEP(253)) IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) END IF IF ( KEEP(48) == 4 .OR. & ( (KEEP(24).NE.0).AND.(KEEP8(21).GT.0_8) ) ) THEN CALL DMUMPS_SET_K821_SURFACE(KEEP8(21), KEEP(2), & KEEP(48), KEEP(50), NSLAVES) END IF IF (KEEP(210).LT.0.OR.KEEP(210).GT.2) KEEP(210)=0 IF (KEEP(210).EQ.0.AND.KEEP(201).GT.0) KEEP(210)=1 IF (KEEP(210).EQ.0.AND.KEEP(201).EQ.0) KEEP(210)=2 IF (KEEP(210).EQ.2) KEEP8(79)=huge(KEEP8(79)) IF (KEEP(210).EQ.1.AND.KEEP8(79).LE.0_8) THEN KEEP8(79)=K79REF * int(NSLAVES,8) ENDIF IF (KEEP(79).EQ.0) THEN IF (KEEP(210).EQ.1) THEN SPLITROOT = .FALSE. IF ( KEEP(62).GE.1) THEN IDUMMY(1)= -1 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF (PROK) THEN WRITE(MP,*) " Number of split nodes in pre-splitting=", & KEEP(61) ENDIF ENDIF ENDIF ENDIF SPLITROOT = ((ICNTL(13).GT.0 .AND. NSLAVES.GT.ICNTL(13)) .OR. & ICNTL(13).EQ.-1 ) IF (KEEP(53) .NE. 0) THEN SPLITROOT = .TRUE. ENDIF SPLITROOT = (SPLITROOT.AND.( (KEEP(60).EQ.0) )) IF (SPLITROOT) THEN IDUMMY(1) = -1 CALL DMUMPS_CUTNODES(N, FRERE, FILS, NFSIZ, & IDUMMY, LIDUMMY, INFO(6), & NSLAVES, KEEP,KEEP8, SPLITROOT, & MP, LDIAG, INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 90 IF ( KEEP(53) .NE. 0 ) THEN CALL MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, KEEP(20) ) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN K = min0(10,N) IF (LDIAG.EQ.4) K = N IF (K.GT.0) WRITE (MP,99997) (IKEEP(I,1),I=1,K) IF (K.GT.0) WRITE (MP,99991) (IKEEP(I,2),I=1,K) IF (K.GT.0) WRITE (MP,99990) (IKEEP(I,3),I=1,K) IF (K.GT.0) WRITE (MP,99987) (NFSIZ(I),I=1,K) IF (K.GT.0) WRITE (MP,99989) (FILS(I),I=1,K) IF (K.GT.0) WRITE (MP,99988) (FRERE(I),I=1,K) ENDIF GO TO 90 40 INFO(1) = -4 INFO(2) = K 90 CONTINUE IF (INFO(1) .LT.0) THEN IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99996) INFO(1) IF ((LP.GT.0).AND.(ICNTL(4).GE.1)) WRITE (LP,99982) INFO(2) ENDIF IF (allocated(IW)) DEALLOCATE(IW) IF (allocated(IPE8)) DEALLOCATE(IPE8) IF (allocated(IW2)) DEALLOCATE(IW2) IF (allocated(IWtemp)) DEALLOCATE(IWtemp) RETURN 99999 FORMAT (/'Entering analysis phase with ...'/ & ' N NELT LIW INFO(1)'/, & 9X, I10, I11, I12, I14) 99998 FORMAT ('Element pointers: ELTPTR() '/(9X, 7I10)) 99995 FORMAT ('Element variables: ELTVAR() '/(9X, 7I10)) 99997 FORMAT ('IKEEP(.,1)=', 10I6/(12X, 10I6)) 99996 FORMAT (/'** Error return ** from Analysis * INFO(1)=', I3) 99991 FORMAT ('IKEEP(.,2)=', 10I6/(12X, 10I6)) 99990 FORMAT ('IKEEP(.,3)=', 10I6/(12X, 10I6)) 99989 FORMAT ('FILS (.) =', 10I6/(12X, 10I6)) 99988 FORMAT ('FRERE(.) =', 10I6/(12X, 10I6)) 99987 FORMAT ('NFSIZ(.) =', 10I6/(12X, 10I6)) 99982 FORMAT ('Error in permutation array KEEP INFO(2)=', I3) END SUBROUTINE DMUMPS_ANA_F_ELT SUBROUTINE DMUMPS_NODEL( NELT, N, NELNOD, XELNOD, ELNOD, & XNODEL, NODEL, FLAG, IERROR, ICNTL ) IMPLICIT NONE INTEGER NELT, N, NELNOD, IERROR, ICNTL(60) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I, J, K, MP, NBERR MP = ICNTL(2) FLAG(1:N) = 0 XNODEL(1:N) = 0 IERROR = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN IERROR = IERROR + 1 ELSE IF ( FLAG(J).NE.I ) THEN XNODEL(J) = XNODEL(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO IF ( IERROR.GT.0 .AND. MP.GT.0 .AND. ICNTL(4).GE.2 ) THEN NBERR = 0 WRITE(MP,99999) DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF ( J.LT.1 .OR. J.GT.N ) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN WRITE(MP,'(A,I8,A,I8,A)') & 'Element ',I,' variable ',J,' ignored.' ELSE GO TO 100 ENDIF ENDIF ENDDO ENDDO ENDIF 100 CONTINUE K = 1 DO I = 1, N K = K + XNODEL(I) XNODEL(I) = K ENDDO XNODEL(N+1) = XNODEL(N) FLAG(1:N) = 0 DO I = 1, NELT DO K = XELNOD(I), XELNOD(I+1)-1 J = ELNOD(K) IF (FLAG(J).NE.I) THEN XNODEL(J) = XNODEL(J) - 1 NODEL(XNODEL(J)) = I FLAG(J) = I ENDIF ENDDO ENDDO RETURN 99999 FORMAT (/'*** Warning message from subroutine DMUMPS_NODEL ***') END SUBROUTINE DMUMPS_NODEL SUBROUTINE DMUMPS_ANA_G1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, FLAG) IMPLICIT NONE INTEGER N, NELT, NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN LEN(I) = LEN(I) + 1 LEN(J) = LEN(J) + 1 FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G1_ELT SUBROUTINE DMUMPS_ANA_G2_ELTNEW(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N+1) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ENDDO IPE(N+1)=IPE(N) FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J IPE(J) = IPE(J) - 1 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G2_ELTNEW SUBROUTINE DMUMPS_ANA_G2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER LEN(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IWFR = IWFR + int(LEN(I),8) IF (LEN(I).GT.0) THEN IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.LT.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1_8 IW(IPE(I)) = J IPE(J) = IPE(J) - 1_8 IW(IPE(J)) = I FLAG(J) = I ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G2_ELT SUBROUTINE DMUMPS_ANA_J1_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, LEN, FLAG) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), FLAG(N) INTEGER I,J,K1,K2,K3 FLAG(1:N) = 0 LEN(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN LEN(I) = LEN(I) + 1 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO NZ = 0_8 DO I = 1,N NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_J1_ELT SUBROUTINE DMUMPS_ANA_J2_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & PERM, IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER PERM(N) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), IW(LW), & FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 0_8 DO I = 1,N IWFR = IWFR + int(LEN(I) + 1,8) IPE(I) = IWFR ENDDO IWFR = IWFR + 1_8 FLAG(1:N) = 0 DO I = 1,N DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IF (PERM(J).GT.PERM(I)) THEN IW(IPE(I)) = J IPE(I) = IPE(I) - 1_8 FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO DO I = 1,N J = int(IPE(I)) IW(J) = LEN(I) IF (LEN(I).EQ.0) IPE(I) = 0_8 ENDDO RETURN END SUBROUTINE DMUMPS_ANA_J2_ELT SUBROUTINE DMUMPS_ANA_DIST_ELEMENTS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, & NELT, FRTPTR, FRTELT, & KEEP,KEEP8, ICNTL, SYM ) IMPLICIT NONE INTEGER MYID, SLAVEF, N, NELT, SYM INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAIW( NELT+1 ), PTRARW( NELT+1 ) INTEGER STEP( N ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PROCNODE( KEEP(28) ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER(8) :: IPTRI8, IPTRR8, NVAR8 INTEGER ELT, I, K INTEGER TYPE_PARALL, ITYPE, IRANK LOGICAL :: EARLYT3ROOTINS TYPE_PARALL = KEEP(46) PTRAIW( 1:NELT ) = 0_8 EARLYT3ROOTINS = KEEP(200) .EQ.0 DO I = 1, N IF (STEP(I).LT.0) CYCLE ITYPE = MUMPS_TYPENODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(abs(STEP(I))), KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( (ITYPE .EQ. 2) .OR. & (ITYPE .EQ. 3 .AND. .NOT. EARLYT3ROOTINS ) .OR. & (ITYPE .EQ. 1 .AND. IRANK .EQ. MYID) ) THEN DO K = FRTPTR(I),FRTPTR(I+1)-1 ELT = FRTELT(K) PTRAIW( ELT ) = PTRARW(ELT+1) - PTRARW(ELT) ENDDO ELSE END IF END DO IPTRI8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT ) PTRAIW( ELT ) = IPTRI8 IPTRI8 = IPTRI8 + NVAR8 ENDDO PTRAIW( NELT+1 ) = IPTRI8 KEEP8(27) = IPTRI8 - 1 IF ( .TRUE. ) THEN IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRAIW( ELT+1 ) - PTRAIW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ELSE IF (SYM .EQ. 0) THEN IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + NVAR8*NVAR8 ENDDO PTRARW( NELT+1 ) = IPTRR8 ELSE IPTRR8 = 1_8 DO ELT = 1,NELT NVAR8 = PTRARW( ELT+1 ) - PTRARW( ELT ) PTRARW( ELT ) = IPTRR8 IPTRR8 = IPTRR8 + (NVAR8*(NVAR8+1))/2 ENDDO PTRARW( NELT+1 ) = IPTRR8 ENDIF ENDIF KEEP8(26) = IPTRR8 - 1_8 RETURN END SUBROUTINE DMUMPS_ANA_DIST_ELEMENTS SUBROUTINE DMUMPS_ELTPROC( N, NELT, ELTPROC, SLAVEF, PROCNODE, & KEEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, SLAVEF INTEGER, INTENT(IN) :: PROCNODE( N ) INTEGER, INTENT(INOUT) :: ELTPROC( NELT ) INTEGER :: KEEP(500) INTEGER ELT, I, ITYPE LOGICAL :: EARLYT3ROOTINS INTEGER, EXTERNAL :: MUMPS_TYPENODE, MUMPS_PROCNODE EARLYT3ROOTINS = KEEP(200) .EQ.0 DO ELT = 1, NELT I = ELTPROC(ELT) IF ( I .NE. 0) THEN ITYPE = MUMPS_TYPENODE(PROCNODE(I),KEEP(199)) IF (ITYPE.EQ.1) THEN ELTPROC(ELT) = MUMPS_PROCNODE(PROCNODE(I),KEEP(199)) ELSE IF ( ITYPE.EQ.2 .OR. .NOT. EARLYT3ROOTINS ) THEN ELTPROC(ELT) = -1 ELSE ELTPROC(ELT) = -2 ENDIF ELSE ELTPROC(ELT) = -3 ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_ELTPROC SUBROUTINE DMUMPS_FRTELT(N, NELT, NELNOD, FRERE, FILS, NA, NE, & XNODEL, NODEL, FRTPTR, FRTELT, ELTNOD) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NELT, NELNOD INTEGER, INTENT(IN) :: FRERE(N), FILS(N), NA(N), NE(N) INTEGER, INTENT(OUT):: FRTPTR(N+1), FRTELT(NELT), ELTNOD(NELT) INTEGER, INTENT(IN) :: XNODEL(N+1), NODEL(NELNOD) INTEGER, DIMENSION(:), ALLOCATABLE :: TNSTK, IPOOL INTEGER I, K, IFATH, allocok INTEGER INODE, LEAF, NBLEAF, NBROOT, III, IN ALLOCATE(TNSTK( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of TNSTK in ' & // 'routine DMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF ALLOCATE(IPOOL( N ), stat=allocok) IF (allocok.ne.0) THEN WRITE(6,*) ' Allocation error of IPOOL in ' & // 'routine DMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF TNSTK = NE LEAF = 1 IF (N.EQ.1) THEN NBROOT = 1 NBLEAF = 1 IPOOL(1) = 1 LEAF = LEAF + 1 ELSEIF (NA(N).LT.0) THEN NBLEAF = N NBROOT = N DO 20 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 20 CONTINUE INODE = -NA(N)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSEIF (NA(N-1).LT.0) THEN NBLEAF = N-1 NBROOT = NA(N) IF (NBLEAF-1.GT.0) THEN DO 30 I=1,NBLEAF-1 INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 30 CONTINUE ENDIF INODE = -NA(N-1)-1 IPOOL(LEAF) = INODE LEAF = LEAF + 1 ELSE NBLEAF = NA(N-1) NBROOT = NA(N) DO 40 I = 1,NBLEAF INODE = NA(I) IPOOL(LEAF) = INODE LEAF = LEAF + 1 40 CONTINUE ENDIF ELTNOD(1:NELT) = 0 III = 1 90 CONTINUE IF (III.NE.LEAF) THEN INODE=IPOOL(III) III = III + 1 ELSE WRITE(6,*) ' ERROR 1 in subroutine DMUMPS_FRTELT ' CALL MUMPS_ABORT() ENDIF 95 CONTINUE IN = INODE 100 CONTINUE DO K = XNODEL(IN),XNODEL(IN+1)-1 I = NODEL(K) IF (ELTNOD(I).EQ.0) ELTNOD(I) = INODE ENDDO IN = FILS(IN) IF (IN .GT. 0 ) GOTO 100 IN = INODE 110 IN = FRERE(IN) IF (IN.GT.0) GO TO 110 IF (IN.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 115 GOTO 90 ELSE IFATH = -IN ENDIF TNSTK(IFATH) = TNSTK(IFATH) - 1 IF ( TNSTK(IFATH) .EQ. 0 ) THEN INODE = IFATH GOTO 95 ELSE GOTO 90 ENDIF 115 CONTINUE FRTPTR(1:N) = 0 DO I = 1,NELT IF (ELTNOD(I) .NE. 0) THEN FRTPTR(ELTNOD(I)) = FRTPTR(ELTNOD(I)) + 1 ENDIF ENDDO K = 1 DO I = 1,N K = K + FRTPTR(I) FRTPTR(I) = K ENDDO FRTPTR(N+1) = FRTPTR(N) DO K = 1,NELT INODE = ELTNOD(K) IF (INODE .NE. 0) THEN FRTPTR(INODE) = FRTPTR(INODE) - 1 FRTELT(FRTPTR(INODE)) = K ENDIF ENDDO DEALLOCATE(TNSTK, IPOOL) RETURN END SUBROUTINE DMUMPS_FRTELT SUBROUTINE DMUMPS_ANA_G11_ELT(N, NZ, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & LEN, LW, IW) IMPLICIT NONE INTEGER N,NELT,NELNOD,LW INTEGER(8), INTENT(OUT) :: NZ INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW) INTEGER I,J,K1,K2,K3,LP,NSUP,SUPVAR INTEGER INFO44(6) EXTERNAL DMUMPS_SUPVAR LP = 6 CALL DMUMPS_SUPVAR(N,NELT,XELNOD(NELT+1)-1,ELNOD,XELNOD, & NSUP,IW(3*N+3+1),3*N+3,IW,LP,INFO44) IF (INFO44(1) .LT. 0) THEN IF (LP.GE.0) WRITE(LP,*) & 'Error return from DMUMPS_SUPVAR. INFO(1) = ',INFO44(1) ENDIF IW(1:NSUP) = 0 LEN(1:N) = 0 DO I = 1,N SUPVAR = IW(3*N+3+1+I) IF (SUPVAR .EQ. 0) CYCLE IF (IW(SUPVAR).NE.0) THEN LEN(I) = -IW(SUPVAR) ELSE IW(SUPVAR) = I ENDIF ENDDO IW(N+1:2*N) = 0 NZ = 0_8 DO SUPVAR = 1,NSUP I = IW(SUPVAR) DO K1 = XNODEL(I),XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2),XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J).GE.0) THEN IF ((I.NE.J) .AND. (IW(N+J).NE.I)) THEN IW(N+J) = I LEN(I) = LEN(I) + 1 ENDIF ENDIF ENDIF ENDDO ENDDO NZ = NZ + int(LEN(I),8) ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G11_ELT SUBROUTINE DMUMPS_ANA_G12_ELT(N, NELT, NELNOD, & XELNOD, ELNOD, XNODEL, NODEL, & IW, LW, IPE, LEN, FLAG, IWFR) IMPLICIT NONE INTEGER N,NELT,NELNOD INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(OUT) :: IWFR INTEGER(8), INTENT(OUT) :: IPE(N) INTEGER XELNOD(NELT+1), ELNOD(NELNOD) INTEGER LEN(N) INTEGER XNODEL(N+1), NODEL(NELNOD), & IW(LW), FLAG(N) INTEGER I,J,K1,K2,K3 IWFR = 1_8 DO I = 1,N IF (LEN(I).GT.0) THEN IWFR = IWFR + int(LEN(I),8) IPE(I) = IWFR ELSE IPE(I) = 0_8 ENDIF ENDDO FLAG(1:N) = 0 DO I = 1,N IF (LEN(I).LE.0) CYCLE DO K1 = XNODEL(I), XNODEL(I+1)-1 K2 = NODEL(K1) DO K3 = XELNOD(K2), XELNOD(K2+1)-1 J = ELNOD(K3) IF ((J.GE.1) .AND. (J.LE.N)) THEN IF (LEN(J) .GT. 0) THEN IF ((I.NE.J) .AND. (FLAG(J).NE.I)) THEN IPE(I) = IPE(I) - 1 IW(IPE(I)) = J FLAG(J) = I ENDIF ENDIF ENDIF ENDDO ENDDO ENDDO RETURN END SUBROUTINE DMUMPS_ANA_G12_ELT SUBROUTINE DMUMPS_SUPVAR(N,NELT,NZ,ELTVAR,ELTPTR,NSUP,SVAR, & LIW,IW,LP,INFO) INTEGER LIW,LP,N,NELT,NSUP,NZ INTEGER INFO(6) INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER IW(LIW),SVAR(0:N) INTEGER FLAG,NEW,VARS EXTERNAL DMUMPS_SUPVARB INFO(1) = 0 INFO(2) = 0 INFO(3) = 0 INFO(4) = 0 IF (N.LT.1) GO TO 10 IF (NELT.LT.1) GO TO 20 IF (NZ.LT.ELTPTR(NELT+1)-1) GO TO 30 IF (LIW.LT.6) THEN INFO(4) = 3*N + 3 GO TO 40 END IF NEW = 1 VARS = NEW + LIW/3 FLAG = VARS + LIW/3 CALL DMUMPS_SUPVARB(N,NELT,ELTPTR,NZ,ELTVAR,SVAR,NSUP,LIW/3-1, & IW(NEW),IW(VARS),IW(FLAG),INFO) IF (INFO(1).EQ.-4) THEN INFO(4) = 3*N + 3 GO TO 40 ELSE INFO(4) = 3*NSUP + 3 END IF GO TO 50 10 INFO(1) = -1 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 20 INFO(1) = -2 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 30 INFO(1) = -3 IF (LP.GT.0) WRITE (LP,FMT=9000) INFO(1) GO TO 50 40 INFO(1) = -4 IF (LP.GT.0) THEN WRITE (LP,FMT=9000) INFO(1) WRITE (LP,FMT=9010) INFO(4) END IF 50 RETURN 9000 FORMAT (/3X,'Error message from DMUMPS_SUPVAR: INFO(1) = ',I2) 9010 FORMAT (3X,'LIW is insufficient. Upper bound on required work', & 'space is ',I8) END SUBROUTINE DMUMPS_SUPVAR SUBROUTINE DMUMPS_SUPVARB( N, NELT, ELTPTR, NZ, ELTVAR, & SVAR, NSUP, MAXSUP, NEW, VARS, FLAG, INFO ) INTEGER MAXSUP,N,NELT,NSUP,NZ INTEGER ELTPTR(NELT+1),ELTVAR(NZ) INTEGER INFO(6) INTEGER FLAG(0:MAXSUP), NEW(0:MAXSUP),SVAR(0:N), & VARS(0:MAXSUP) INTEGER I,IS,J,JS,K,K1,K2 DO 10 I = 0,N SVAR(I) = 0 10 CONTINUE VARS(0) = N + 1 NEW(0) = -1 FLAG(0) = 0 NSUP = 0 DO 40 J = 1,NELT K1 = ELTPTR(J) K2 = ELTPTR(J+1) - 1 DO 20 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) THEN INFO(2) = INFO(2) + 1 GO TO 20 END IF IS = SVAR(I) IF (IS.LT.0) THEN ELTVAR(K) = 0 INFO(3) = INFO(3) + 1 GO TO 20 END IF SVAR(I) = SVAR(I) - N - 2 VARS(IS) = VARS(IS) - 1 20 CONTINUE DO 30 K = K1,K2 I = ELTVAR(K) IF (I.LT.1 .OR. I.GT.N) GO TO 30 IS = SVAR(I) + N + 2 IF (FLAG(IS).LT.J) THEN FLAG(IS) = J IF (VARS(IS).GT.0) THEN NSUP = NSUP + 1 IF (NSUP.GT.MAXSUP) THEN INFO(1) = -4 RETURN END IF VARS(NSUP) = 1 FLAG(NSUP) = J NEW(IS) = NSUP SVAR(I) = NSUP ELSE VARS(IS) = 1 NEW(IS) = IS SVAR(I) = IS END IF ELSE JS = NEW(IS) VARS(JS) = VARS(JS) + 1 SVAR(I) = JS END IF 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE DMUMPS_SUPVARB MUMPS_5.4.1/src/zfac_lr.F0000664000175000017500000030166114102210525015243 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_LR USE ZMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL ZMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS POSELTD = 1_8 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL ZMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J), BLR_LS(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO IF (IFLAG.LT.0) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL ZMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J), BLR_LS(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif RETURN END SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if defined(BLR_MT) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL zgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL zgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL zgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & ZMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL zgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL zgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL zgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL zgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL zgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL zgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL ZMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if defined(BLR_MT) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), & BLR_L(IND_L), MIDBLK_COMPRESS, & MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE COMPLEX(kind=8), TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & ZMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE ZMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN COMPLEX(kind=8), INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: NCB, MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NCB = NFRONT - NASS ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'ZMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC INTEGER :: FRONT_CB_BLR_SAVINGS LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) ACC_LRB => ACC_LUA(1) FRONT_CB_BLR_SAVINGS = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if defined(BLR_MT) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in ZMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL ZMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL ZMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL ZMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & LRB%M*LRB%N - LRB%M*LRB%K - LRB%N*LRB%K ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL ZMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL ZMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL ZMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NFRONT-NASS, NFRONT-NASS, 0, 1, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, 0, 1, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif ENDIF END SUBROUTINE ZMUMPS_BLR_UPD_CB_LEFT SUBROUTINE ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN, CBASM_TOFIX_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN LOGICAL,OPTIONAL,intent(in) :: CBASM_TOFIX_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I, ONLY_NELIM LOGICAL :: CBASM_TOFIX #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT COMPLEX(kind=8) :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF IF (present(CBASM_TOFIX_IN)) THEN CBASM_TOFIX = CBASM_TOFIX_IN ELSE CBASM_TOFIX = .FALSE. ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP = BEGS_BLR_FIRST_OFFDIAG #if !defined(BLR_MT) IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(I)%N ELSE BIP = BIP + BLR_PANEL(I)%M ENDIF ENDDO ENDIF #endif #if defined(BLR_MT) LAST_IP = CURRENT_BLR+1 CHUNK = 1 !$OMP DO PRIVATE(POSELT_BLOCK, M, N, K, I) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN IF (CBASM_TOFIX) THEN POSELT_BLOCK = POSELT & + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) + int(BIP-1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21 & .AND..NOT.CBASM_TOFIX) THEN CALL zgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL zgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL zgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL zgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF (CBASM_TOFIX) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSEIF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ENDIF #endif ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE ZMUMPS_DECOMPRESS_PANEL SUBROUTINE ZMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK COMPLEX(kind=8), TARGET, DIMENSION(:,:) :: BLOCK COMPLEX(kind=8), TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO, FRONT_CB_BLR_SAVINGS INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if defined(BLR_MT) INTEGER :: CHUNK #endif DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX(kind=8), POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL ZMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif FRONT_CB_BLR_SAVINGS = 0 OMP_NUM = 0 IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL ZMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL zungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF END IF FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO #endif #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NROWS, NCOLS, SYM, NIV, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, SYM, NIV, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif END SUBROUTINE ZMUMPS_COMPRESS_CB SUBROUTINE ZMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, K480, & BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK COMPLEX(kind=8), TARGET, DIMENSION(:,:) :: BLOCK COMPLEX(kind=8), TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTRINSIC maxval INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR COMPLEX(kind=8) :: ONE, ALPHA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) INTEGER :: OMP_NUM DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR COMPLEX(kind=8), POINTER, DIMENSION(:,:) :: BLOCK_THR COMPLEX(kind=8), POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if defined(BLR_MT) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN ZMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (M.NE.BLR_PANEL(IP-CURRENT_BLR)%M) THEN write(*,*) 'Internal error in ZMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & BLR_PANEL(IP-CURRENT_BLR)%M CALL MUMPS_ABORT() ENDIF IF (N.NE.BLR_PANEL(IP-CURRENT_BLR)%N) THEN write(*,*) 'Internal error in ZMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & BLR_PANEL(IP-CURRENT_BLR)%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(dble(M*N)/dble(M+N)) IF (BLR_PANEL(IP-CURRENT_BLR)%K.GT.MAXRANK) THEN write(*,*) 'Internal error in ZMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & BLR_PANEL(IP-CURRENT_BLR)%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL ZMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) GOTO 3000 IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J), & JPVT_THR(J)) = & BLOCK_THR(1:MIN(RANK,J),J) IF(J.LT.RANK) BLR_PANEL(IP-CURRENT_BLR)% & R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO ENDDO CALL zungqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = BLOCK_THR(1:M,I) END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS( & BLR_PANEL(IP-CURRENT_BLR), FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR), & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF 3000 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE ZMUMPS_COMPRESS_PANEL SUBROUTINE ZMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if defined(BLR_MT) INTEGER :: CHUNK #endif COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in ZMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL ZMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE ZMUMPS_BLR_PANEL_LRTRSM END MODULE ZMUMPS_FAC_LR MUMPS_5.4.1/src/zend_driver.F0000664000175000017500000003735114102210526016141 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_END_DRIVER( id ) USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF USE ZMUMPS_BUF IMPLICIT NONE include 'mpif.h' TYPE( ZMUMPS_STRUC ) :: id LOGICAL I_AM_SLAVE INTEGER IERR INTEGER MASTER PARAMETER ( MASTER = 0 ) C Explicit needed because of pointer arguments INTERFACE SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES END INTERFACE I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. id%KEEP(46) .NE. 0 ) C ---------------------------------- C Special stuff for implementations C where MPI_CANCEL does not exist or C is not correctly implemented. C At the moment, this is only C required for the slaves. C ---------------------------------- IF (id%KEEP(201).GT.0 .AND. I_AM_SLAVE) THEN CALL ZMUMPS_CLEAN_OOC_DATA(id,IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 ENDIF END IF CALL MUMPS_PROPINFO(id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%root%gridinit_done) THEN IF ( id%KEEP(38).NE.0 .and. id%root%yes ) THEN CALL blacs_gridexit( id%root%CNTXT_BLACS ) id%root%gridinit_done = .FALSE. END IF END IF IF ( id%MYID .NE. MASTER .OR. id%KEEP(46) .ne. 0 ) THEN C Note that on some old platforms, COMM_NODES would have been C freed inside BLACS_GRIDEXIT, which may cause problems C in the call to MPI_COMM_FREE. (This was the case on the C old SP2 in Bonn.) CALL MPI_COMM_FREE( id%COMM_NODES, IERR ) C Free communicator related to load messages. CALL MPI_COMM_FREE( id%COMM_LOAD, IERR ) END IF C ----------------------------------- C Right-hand-side is always user data C We do not free it. C ----------------------------------- IF (associated(id%MEM_DIST)) THEN DEALLOCATE(id%MEM_DIST) NULLIFY(id%MEM_DIST) ENDIF C C C C --------------------------------- C Allocated by ZMUMPS, Used by user. C ZMUMPS deallocates. User should C use them before ZMUMPS_END_DRIVER or C copy. C --------------------------------- IF (associated(id%MAPPING)) THEN DEALLOCATE(id%MAPPING) NULLIFY(id%MAPPING) END IF NULLIFY(id%SCHUR_CINTERFACE) C C ------------------------------------- C Always deallocate scaling arrays C if they are associated, except C when provided by the user (on master) C ------------------------------------- IF ( id%KEEP(52) .NE. -1 .or. id%MYID .ne. MASTER ) THEN IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF END IF IF (associated(id%PTLUST_S)) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) END IF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF IF (associated(id%STEP)) THEN DEALLOCATE(id%STEP) NULLIFY(id%STEP) ENDIF C Begin PRUN_NODES C Info for pruning tree IF (associated(id%Step2node)) THEN DEALLOCATE(id%Step2node) NULLIFY(id%Step2node) ENDIF C END PRUN_NODES c --------------------- IF (associated(id%NE_STEPS)) THEN DEALLOCATE(id%NE_STEPS) NULLIFY(id%NE_STEPS) ENDIF IF (associated(id%ND_STEPS)) THEN DEALLOCATE(id%ND_STEPS) NULLIFY(id%ND_STEPS) ENDIF IF (associated(id%FRERE_STEPS)) THEN DEALLOCATE(id%FRERE_STEPS) NULLIFY(id%FRERE_STEPS) ENDIF IF (associated(id%DAD_STEPS)) THEN DEALLOCATE(id%DAD_STEPS) NULLIFY(id%DAD_STEPS) ENDIF IF (associated(id%SYM_PERM)) THEN DEALLOCATE(id%SYM_PERM) NULLIFY(id%SYM_PERM) ENDIF IF (associated(id%UNS_PERM)) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF IF (associated(id%PIVNUL_LIST)) THEN DEALLOCATE(id%PIVNUL_LIST) NULLIFY(id%PIVNUL_LIST) ENDIF IF (associated(id%FILS)) THEN DEALLOCATE(id%FILS) NULLIFY(id%FILS) ENDIF IF (associated(id%PTRAR)) THEN DEALLOCATE(id%PTRAR) NULLIFY(id%PTRAR) ENDIF IF (associated(id%FRTPTR)) THEN DEALLOCATE(id%FRTPTR) NULLIFY(id%FRTPTR) ENDIF IF (associated(id%FRTELT)) THEN DEALLOCATE(id%FRTELT) NULLIFY(id%FRTELT) ENDIF IF (associated(id%NA)) THEN DEALLOCATE(id%NA) NULLIFY(id%NA) ENDIF IF (associated(id%PROCNODE_STEPS)) THEN DEALLOCATE(id%PROCNODE_STEPS) NULLIFY(id%PROCNODE_STEPS) ENDIF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C ------------------------------------------------ C For hybrid host and element entry, C and DBLARR have not been allocated C on the master except if there was scaing. C ------------------------------------------------ IF (id%KEEP(46).eq.1 .and. & id%KEEP(55).ne.0 .and. & id%MYID .eq. MASTER .and. & id%KEEP(52) .eq. 0 ) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF IF (associated(id%INTARR)) THEN DEALLOCATE(id%INTARR) NULLIFY(id%INTARR) ENDIF IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF C IPIV is used both for ScaLAPACK and RR C Keep it outside ZMUMPS_RR_FREE_POINTERS IF (associated(id%root%IPIV)) THEN DEALLOCATE(id%root%IPIV) NULLIFY(id%root%IPIV) ENDIF IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) ENDIF IF (associated(id%root%RHS_ROOT))THEN DEALLOCATE(id%root%RHS_ROOT) NULLIFY(id%root%RHS_ROOT) ENDIF CALL ZMUMPS_RR_FREE_POINTERS(id) IF (associated(id%ELTPROC)) THEN DEALLOCATE(id%ELTPROC) NULLIFY(id%ELTPROC) ENDIF C id%CANDIDATES,id%I_AM_CAND and id%ISTEP_TO_INIV2 C can be allocated on non-working master C in the case of arrowheads distribution IF (associated(id%CANDIDATES)) THEN DEALLOCATE(id%CANDIDATES) NULLIFY(id%CANDIDATES) ENDIF IF (associated(id%I_AM_CAND)) THEN DEALLOCATE(id%I_AM_CAND) NULLIFY(id%I_AM_CAND) ENDIF IF (associated(id%ISTEP_TO_INIV2)) THEN DEALLOCATE(id%ISTEP_TO_INIV2) NULLIFY(id%ISTEP_TO_INIV2) ENDIF C Node partitionning (only allocated on slaves) IF (I_AM_SLAVE) THEN IF (associated(id%TAB_POS_IN_PERE)) THEN DEALLOCATE(id%TAB_POS_IN_PERE) NULLIFY(id%TAB_POS_IN_PERE) ENDIF IF (associated(id%FUTURE_NIV2)) THEN DEALLOCATE(id%FUTURE_NIV2) NULLIFY(id%FUTURE_NIV2) ENDIF ENDIF IF(associated(id%DEPTH_FIRST))THEN DEALLOCATE(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST) ENDIF IF(associated(id%DEPTH_FIRST_SEQ))THEN DEALLOCATE(id%DEPTH_FIRST_SEQ) NULLIFY(id%DEPTH_FIRST_SEQ) ENDIF IF(associated(id%SBTR_ID))THEN DEALLOCATE(id%SBTR_ID) NULLIFY(id%SBTR_ID) ENDIF IF(associated(id%SCHED_DEP))THEN DEALLOCATE(id%SCHED_DEP) NULLIFY(id%SCHED_DEP) ENDIF IF(associated(id%SCHED_SBTR))THEN DEALLOCATE(id%SCHED_SBTR) NULLIFY(id%SCHED_SBTR) ENDIF IF(associated(id%SCHED_GRP))THEN DEALLOCATE(id%SCHED_GRP) NULLIFY(id%SCHED_GRP) ENDIF IF(associated(id%CROIX_MANU))THEN DEALLOCATE(id%CROIX_MANU) NULLIFY(id%CROIX_MANU) ENDIF IF (associated(id%MEM_SUBTREE)) THEN DEALLOCATE(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) ENDIF IF (associated(id%MY_ROOT_SBTR)) THEN DEALLOCATE(id%MY_ROOT_SBTR) NULLIFY(id%MY_ROOT_SBTR) ENDIF IF (associated(id%MY_FIRST_LEAF)) THEN DEALLOCATE(id%MY_FIRST_LEAF) NULLIFY(id%MY_FIRST_LEAF) ENDIF IF (associated(id%MY_NB_LEAF)) THEN DEALLOCATE(id%MY_NB_LEAF) NULLIFY(id%MY_NB_LEAF) ENDIF IF (associated(id%COST_TRAV)) THEN DEALLOCATE(id%COST_TRAV) NULLIFY(id%COST_TRAV) ENDIF IF (associated(id%CB_SON_SIZE)) THEN DEALLOCATE(id%CB_SON_SIZE) NULLIFY(id%CB_SON_SIZE) ENDIF IF (associated(id%SUP_PROC)) THEN DEALLOCATE(id%SUP_PROC) NULLIFY(id%SUP_PROC) ENDIF c IF (id%KEEP(201).GT.0) THEN IF(associated (id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated (id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated (id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated (id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF IF(associated (id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF c ENDIF ! IF(id%KEEP(486).NE.0) THEN IF (associated(id%LRGROUPS)) THEN DEALLOCATE(id%LRGROUPS) NULLIFY(id%LRGROUPS) ENDIF ! ENDIF CALL ZMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%MPITOOMP_PROCS_MAP)) THEN DEALLOCATE(id%MPITOOMP_PROCS_MAP) NULLIFY(id%MPITOOMP_PROCS_MAP) ENDIF IF (associated(id%SINGULAR_VALUES)) THEN DEALLOCATE(id%SINGULAR_VALUES) NULLIFY(id%SINGULAR_VALUES) ENDIF C ---------------------------------------------- C Deallocate S only after finishing the receives C (S is normally the largest memory available) C ---------------------------------------------- IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) DEALLOCATE(id%S) ENDIF NULLIFY(id%S) IF (I_AM_SLAVE) THEN C ------------------------ C Deallocate buffer for C contrib-blocks (facto/ C solve). Note that this C will cancel all possible C pending requests. C ------------------------ CALL ZMUMPS_BUF_DEALL_CB( IERR ) C Deallocate buffer for integers (facto/solve) CALL ZMUMPS_BUF_DEALL_SMALL_BUF( IERR ) END IF C Mapping information used during solve IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF IF (associated(id%IPOOL_B_L0_OMP)) THEN DEALLOCATE(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_B_L0_OMP) END IF IF (associated(id%IPOOL_A_L0_OMP)) THEN DEALLOCATE(id%IPOOL_A_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) END IF IF (associated(id%PHYS_L0_OMP)) THEN DEALLOCATE(id%PHYS_L0_OMP) NULLIFY(id%PHYS_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP)) THEN DEALLOCATE(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP) END IF IF (associated(id%VIRT_L0_OMP_MAPPING)) THEN DEALLOCATE(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%VIRT_L0_OMP_MAPPING) END IF IF (associated(id%PERM_L0_OMP)) THEN DEALLOCATE(id%PERM_L0_OMP) NULLIFY(id%PERM_L0_OMP) END IF IF (associated(id%PTR_LEAFS_L0_OMP)) THEN DEALLOCATE(id%PTR_LEAFS_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) END IF IF (associated(id%L0_OMP_MAPPING)) THEN DEALLOCATE(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_MAPPING) END IF IF (associated(id%I4_L0_OMP)) THEN DEALLOCATE(id%I4_L0_OMP) NULLIFY(id%I4_L0_OMP) END IF IF (associated(id%I8_L0_OMP)) THEN DEALLOCATE(id%I8_L0_OMP) NULLIFY(id%I8_L0_OMP) END IF RETURN END SUBROUTINE ZMUMPS_END_DRIVER SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE ZMUMPS_LR_DATA_M, only : ZMUMPS_BLR_STRUC_TO_MOD, & ZMUMPS_BLR_END_MODULE IMPLICIT NONE C C Purpose: C ======= C C Free data from modules kept from one phase to the other C and referenced through the main MUMPS structure, id. C C Both id%FDM_F_ENCODING and id%BLRARRAY_ENCODING C are concerned. C C C C Arguments: C ========= C # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) C IF (associated(id_FDM_F_ENCODING)) THEN C Allow access to FDM_F data for BLR_END_MODULE CALL MUMPS_FDM_STRUC_TO_MOD('F', id_FDM_F_ENCODING) IF (associated(id_BLRARRAY_ENCODING)) THEN C Pass id_BLRARRAY_ENCODING control to module C and terminate BLR module of current instance CALL ZMUMPS_BLR_STRUC_TO_MOD(id_BLRARRAY_ENCODING) CALL ZMUMPS_BLR_END_MODULE(0, KEEP8, & LRSOLVE_ACT_OPT=.TRUE.) ENDIF C --------------------------------------- C FDM data structures are still allocated C in the module and should be freed C --------------------------------------- CALL MUMPS_FDM_END('F') ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES MUMPS_5.4.1/src/dfac_process_maprow.F0000664000175000017500000020754214102210522017643 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, & root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_DATA_M USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR USE DMUMPS_FAC_FRONT_AUX_M, & ONLY : DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE #if ! defined(NO_FDM_MAPROW) #endif TYPE (DMUMPS_ROOT_STRUC ) :: root INTEGER LBUFR, LBUFR_BYTES INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER COMP INTEGER NSTK( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER INODE_PERE, ISON INTEGER :: NFS4FATHER INTEGER NBROWS_ALREADY_SENT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE( * ) INTEGER LMAP INTEGER TROW( LMAP ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I INTEGER I_POSMYIDIN_PERE INTEGER INDICE_PERE INTEGER PDEST, PDEST_MASTER LOGICAL :: LOCAL_ASSEMBLY_TO_BE_DONE INTEGER NROWS_TO_SEND INTEGER PDEST_MASTER_ISON, IPOS_IN_SLAVE LOGICAL DESCLU, SLAVE_ISON LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG INTEGER LP LOGICAL PACKED_CB LOGICAL IS_ERROR_BROADCASTED, IS_ofType5or6 INTEGER ITYPE_SON, TYPESPLIT INTEGER :: KEEP253_LOC INTEGER :: NVSCHUR, NSLAVES_L, NROW_L, IROW_L, NASS_L, NELIM_L LOGICAL :: CB_IS_LR INTEGER :: IWXXF_HANDLER DOUBLE PRECISION :: ADummy(1) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, RECSIZE #if ! defined(NO_FDM_MAPROW) INTEGER :: INFO_TMP(2) #endif INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC IS_ERROR_BROADCASTED = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IS_ofType5or6 = ((TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 CB_IS_LR = (IW(PTRIST(STEP(ISON))+XXLR).EQ.1 .OR. & IW(PTRIST(STEP(ISON))+XXLR).EQ.3) IWXXF_HANDLER = IW(PTRIST(STEP(ISON))+XXF) #if ! defined(NO_FDM_MAPROW) #endif ALLOCATE(SLAVES_PERE(0:max(1,NSLAVES_PERE)), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 endif IF (NSLAVES_PERE.GT.0) &SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, & ' : PB allocation NBROW in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 670 endif LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP>0) THEN write(LP,*) MYID, ' : PB allocation LMAP in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP GOTO 680 endif MAP( 1 : LMAP ) = TROW( 1 : LMAP ) PDEST_MASTER_ISON = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) SLAVE_ISON = PDEST_MASTER_ISON .NE. MYID IF (SLAVE_ISON) THEN IF ( PTRIST(STEP( ISON )) .EQ. 0 ) THEN CALL DMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END IF #if ! defined(NO_FDM_MAPROW) IF ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) & THEN INFO_TMP=0 CALL MUMPS_FMRD_SAVE_MAPROW( & IW(PTRIST(STEP(ISON))+XXA), & INODE_PERE, ISON, NSLAVES_PERE, NFRONT_PERE, & NASS_PERE, LMAP, NFS4FATHER, & SLAVES_PERE(1:NSLAVES_PERE), & MAP, & INFO_TMP) IF (INFO_TMP(1) < 0) THEN IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF GOTO 670 ELSE GOTO 10 ENDIF #endif DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 + KEEP(IXSZ) ) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 + KEEP(IXSZ) ) .NE. & IW( PTRIST(STEP(ISON)) + 3 + KEEP(IXSZ) ) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV= .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 670 ENDIF END DO ENDIF #if ! defined(NO_FDM_MAPROW) 10 CONTINUE #endif IF ( NSLAVES_PERE .EQ. 0 ) THEN NBROW( 0 ) = LMAP_LOC ELSE DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) IF (allocok .GT. 0) THEN IF (LP.GT.0) THEN write(LP,*) MYID,': PB allocation PERM_LOC in DMUMPS_MAPLIG' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 670 ENDIF KEEP253_LOC = 0 DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) IF (INDICE_PERE > NFRONT_PERE - KEEP(253)) THEN KEEP253_LOC = KEEP253_LOC + 1 ENDIF CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((LMAP_LOC-KEEP253_LOC).GT.0) & ) THEN IF (ITYPE_SON.EQ.1) THEN NELIM_L = IW(PTLUST(STEP(ISON))+1+KEEP(IXSZ)) NASS_L = NELIM_L + & IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ)) IROW_L = PTLUST(STEP(ISON))+6+KEEP(IXSZ)+NASS_L NROW_L = LMAP_LOC ELSE NROW_L = LMAP_LOC NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ENDIF CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW_L-KEEP253_LOC, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF PDEST_MASTER = SLAVES_PERE(0) I_POSMYIDIN_PERE = -99999 LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. DO I = 0, NSLAVES_PERE IF (SLAVES_PERE(I) .EQ. MYID) THEN I_POSMYIDIN_PERE = I LOCAL_ASSEMBLY_TO_BE_DONE = .TRUE. #if ! defined(NO_FDM_DESCBAND) IF (PTRIST(STEP(INODE_PERE)) .EQ. 0 & .AND. MYID .NE. PDEST_MASTER) THEN CALL DMUMPS_TREAT_DESCBAND( INODE_PERE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF #endif ENDIF END DO IF (KEEP(120).NE.0 .AND. LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL DMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF DO I = NSLAVES_PERE, 0, -1 PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN DESCLU = .FALSE. NBROWS_ALREADY_SENT = 0 IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS).EQ.S_CB1COMP) IERR = -1 DO WHILE (IERR .EQ. -1) IF ( IW ( PTRIST(STEP(ISON) )+KEEP(IXSZ) ) & .GT. N + KEEP(253) ) THEN WRITE(*,*) MYID,': Internal error in Maplig' WRITE(*,*) MYID,': PTRIST(STEP(ISON))/N=', & PTRIST(STEP(ISON)), N WRITE(*,*) MYID,': I, NBROW(I)=',I, NBROW(I) WRITE(*,*) MYID,': NSLAVES_PERE=',NSLAVES_PERE WRITE(*,*) MYID,': ISON, INODE_PERE=',ISON,INODE_PERE WRITE(*,*) MYID,': Son header=', & IW(PTRIST(STEP(ISON)): PTRIST(STEP(ISON))+5+KEEP(IXSZ)) CALL MUMPS_ABORT() END IF IF (NROWS_TO_SEND .EQ. 0 .AND. PDEST.NE.PDEST_MASTER) THEN IERR = 0 CYCLE ENDIF IF (CB_IS_LR) THEN CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2( & NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2( NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, ISON, & NROWS_TO_SEND, LMAP_LOC, MAP, & PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW( PTRIST(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, & COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PACKED_CB, & KEEP253_LOC, NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IFLAG = -17 IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: SEND BUFFER TOO SMALL IN DMUMPS_MAPLIG" ENDIF IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GO TO 600 END IF IF ( IERR .EQ. -3 ) THEN IF (LP .GT. 0) THEN WRITE(LP,*) & "FAILURE: RECV BUFFER TOO SMALL IN DMUMPS_MAPLIG" ENDIF IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * IW(PTRIST(STEP(ISON))+KEEP(IXSZ)) & * KEEP( 35 ) GOTO 600 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = NFS4FATHER IF (LP .GT. 0) THEN WRITE(LP, *) & "FAILURE: MAX_ARRAY allocation failed IN DMUMPS_MAPLIG" ENDIF GO TO 600 END IF END IF IF ( IERR .EQ. -1 ) THEN IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL DMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ELSE BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) THEN IS_ERROR_BROADCASTED=.TRUE. GOTO 600 ENDIF END IF END IF ENDDO ENDIF END DO IF (LOCAL_ASSEMBLY_TO_BE_DONE) THEN CALL DMUMPS_LOCAL_ASSEMBLY_TYPE2(I_POSMYIDIN_PERE, & SLAVES_PERE(I_POSMYIDIN_PERE), & MYID, PDEST_MASTER, ISON, INODE_PERE, & NSLAVES_PERE, NASS_PERE, NFRONT_PERE, NFS4FATHER, & LMAP_LOC, MAP, NBROW, PERM_LOC, & IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & ITYPE_SON, LRGROUPS) LOCAL_ASSEMBLY_TO_BE_DONE = .FALSE. IF (IFLAG < 0) THEN GOTO 600 ENDIF ENDIF IF (CB_IS_LR) THEN CALL DMUMPS_BLR_FREE_CB_LRB(IWXXF_HANDLER, & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL DMUMPS_BLR_END_FRONT(IWXXF_HANDLER, IFLAG, KEEP8) ENDIF ENDIF IF (KEEP(214) .EQ. 2) THEN CALL DMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, & COMM, KEEP,KEEP8, DKEEP, ITYPE_SON ) IF (IFLAG .LT. 0) THEN IS_ERROR_BROADCASTED = .TRUE. GOTO 600 ENDIF ENDIF CALL DMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, IW, LIW, & A, LA, LRLU, LRLUS, IWPOSCB, IPTRLU, & STEP, MYID, KEEP, KEEP8, ITYPE_SON &) 600 CONTINUE DEALLOCATE(PERM_LOC) 670 CONTINUE DEALLOCATE(MAP) 680 CONTINUE DEALLOCATE(NBROW) DEALLOCATE(SLAVES_PERE) 700 CONTINUE IF (IFLAG .LT. 0 .AND. .NOT. IS_ERROR_BROADCASTED) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE DMUMPS_MAPLIG SUBROUTINE DMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & & INODE_PERE, ISON, NSLAVES_PERE, LIST_SLAVES_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, LMAP, TROW, & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, & LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_FAC_LR, ONLY: DMUMPS_DECOMPRESS_PANEL USE DMUMPS_FAC_FRONT_AUX_M, & ONLY : DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT USE DMUMPS_LR_DATA_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR & , DMUMPS_DM_FREE_BLOCK IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER ICNTL( 60 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER SLAVEF, NBFIN INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS, POSFAC INTEGER IWPOS, IWPOSCB INTEGER N, LIW DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMP INTEGER IFLAG, IERROR, COMM, MYID INTEGER LPOOL, LEAF INTEGER INODE_PERE, ISON INTEGER NFS4FATHER DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE INTEGER LIST_SLAVES_PERE(NSLAVES_PERE) INTEGER NELIM, LMAP, TROW( LMAP ), NASS DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPTRAR, NELT INTEGER IW( LIW ) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ) INTEGER NSTK( KEEP(28) ), ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PERM(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER NOSLA, I, ISTCHK, ISTCHK_LOC INTEGER NBROWS_ALREADY_SENT INTEGER INDICE_PERE INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER PDEST, PDEST_MASTER, NFRONT LOGICAL SAME_PROC, DESCLU INTEGER(8) :: IACHK, POSROW, ASIZE, RECSIZE DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYNSIZE INTEGER NSLSON, NBCOLS, NROW, NROWS_TO_SEND, & NPIV, NROWS_TO_STACK, II, IROW_SON, & IPOS_IN_SLAVE, DECR, ITYPE_SON INTEGER NBCOLS_EFF LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL PACKED_CB LOGICAL :: CB_IS_LR INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_BLR_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC INTEGER :: NVSCHUR, IROW_L INTEGER(8) :: LA_TEMP DOUBLE PRECISION :: ADummy(1) DOUBLE PRECISION, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER LMAP_LOC, allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROW INTEGER, ALLOCATABLE, DIMENSION(:) :: SLAVES_PERE INTEGER, ALLOCATABLE, DIMENSION(:) :: MAP, PERM_LOC LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 if (NSLAVES_PERE.le.0) then write(6,*) ' error 2 in maplig_fils_niv1 ', NSLAVES_PERE CALL MUMPS_ABORT() endif ALLOCATE(NBROW(0:NSLAVES_PERE), stat=allocok) IF (allocok .GT. 0) THEN IF (LP > 0) & write(LP,*) MYID, & ' : PB allocation NBROW in DMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF ALLOCATE(SLAVES_PERE(0:NSLAVES_PERE), stat =allocok) IF ( allocok .GT. 0 ) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation SLAVES_PERE in DMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = NSLAVES_PERE+1 GOTO 700 ENDIF SLAVES_PERE(1:NSLAVES_PERE) = LIST_SLAVES_PERE(1:NSLAVES_PERE) SLAVES_PERE(0) = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(INODE_PERE)), & KEEP(199) ) LMAP_LOC = LMAP ALLOCATE(MAP(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) write(LP,*) MYID, & ' : PB allocation LMAP in DMUMPS_MAPLIG_FILS_NIV1' IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif MAP( 1 : LMAP_LOC ) = TROW( 1 : LMAP_LOC ) DO I = 0, NSLAVES_PERE NBROW( I ) = 0 END DO IF (NSLAVES_PERE == 0) THEN NBROW(0) = LMAP_LOC ELSE DO I = 1, LMAP_LOC INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) NBROW( NOSLA ) = NBROW( NOSLA ) + 1 END DO DO I = 1, NSLAVES_PERE NBROW(I)=NBROW(I)+NBROW(I-1) ENDDO ENDIF ALLOCATE(PERM_LOC(LMAP_LOC), stat=allocok) if (allocok .GT. 0) THEN IF (LP > 0) THEN write(LP,*) MYID, & ': PB allocation PERM_LOC in DMUMPS_MAPLIG_FILS_NIV1' ENDIF IFLAG =-13 IERROR = LMAP_LOC GOTO 700 endif ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) DO I = LMAP_LOC, 1, -1 INDICE_PERE = MAP( I ) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) PERM_LOC( NBROW( NOSLA ) ) = I NBROW( NOSLA ) = NBROW( NOSLA ) - 1 ENDDO DO I = 0, NSLAVES_PERE NBROW(I)=NBROW(I)+1 END DO PDEST_MASTER = MYID IF ( SLAVES_PERE(0) .NE. MYID ) THEN WRITE(*,*) 'Error 1 in MAPLIG_FILS_NIV1:',MYID, SLAVES_PERE CALL MUMPS_ABORT() END IF PDEST = PDEST_MASTER I = 0 ISTCHK = PIMASTER(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NELIM = IW(ISTCHK+1+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NASS = NPIV+NELIM IF (NPIV.LT.0) THEN write(6,*) ' Error 2 in DMUMPS_MAPLIG_FILS_NIV1 ', NPIV CALL MUMPS_ABORT() ENDIF NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS PACKED_CB=(IW(PTRIST(STEP(ISON))+XXS) .eq. S_CB1COMP) IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_STACK=NBROW(I+1)-NBROW(I) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(50).EQ.2) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) + NASS CALL DMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR ) ELSE NVSCHUR = 0 ENDIF DECR=1 IW(PTLUST(STEP(INODE_PERE))+XXNBPR) = & IW(PTLUST(STEP(INODE_PERE))+XXNBPR) - DECR IW(PTRIST(STEP(ISON))+XXNBPR) = & IW(PTRIST(STEP(ISON))+XXNBPR) - DECR CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL DMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR) NB_BLR_ROWS = size(BEGS_BLR) - 1 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_BLR_SHIFT) PANEL2DECOMPRESS = -1 DO II=NB_BLR_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR(II+1)-1-NASS.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR) - 1 ELSE NB_BLR_COLS = PANEL2DECOMPRESS ENDIF CURRENT_PANEL_SIZE = BEGS_BLR(PANEL2DECOMPRESS+1) & - BEGS_BLR(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR(PANEL2DECOMPRESS) + NASS NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_BLR_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_BLR_SHIFT, & 1:NB_BLR_COLS-NB_BLR_SHIFT), & 0, 'V', 5, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON=PERM_LOC(NBROW(I)+II-1) INDICE_PERE = MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, INODE_PERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF (PACKED_CB) THEN IF (NELIM.EQ.0) THEN POSROW = IACHK + & int(IROW_SON,8)*int(IROW_SON-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+IROW_SON,8)*int(NELIM+IROW_SON-1,8)/2_8 ENDIF ELSE POSROW = IACHK + & int(NELIM+IROW_SON-1,8)*int(NBCOLS,8) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = NELIM + IROW_SON ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF (CB_IS_LR) THEN CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS) ELSE CALL DMUMPS_ASM_SLAVE_MASTER(N, INODE_PERE, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, IWPOSCB, & MYID, KEEP,KEEP8,.FALSE.,NBCOLS_EFF) ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN POSROW = IACHK & + int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ASIZE = int(LMAP_LOC+NELIM,8)*int(NELIM+LMAP_LOC+1,8)/2_8 & - int(NELIM+NBROW(1),8)*int(NELIM+NBROW(1)-1,8)/2_8 ELSE POSROW = IACHK + & int(NELIM+NBROW(1)-1,8)*int(NBCOLS,8) ASIZE = int(LMAP_LOC-NBROW(1)+1,8) * int(NBCOLS,8) ENDIF CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP > 0) WRITE(LP,*) MYID, & ": PB allocation MAX_ARRAY during DMUMPS_MAPLIG_FILS_NIV1" IFLAG=-13 IERROR=NFS4FATHER GOTO 700 ENDIF IF ( LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR.GT. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW),ASIZE,NBCOLS, & LMAP_LOC-NBROW(1)+1-KEEP(253)-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB, & NELIM+NBROW(1)) ELSE CALL DMUMPS_SETMAXTOZERO(BUF_MAX_ARRAY, & NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL DMUMPS_ASM_MAX(N, INODE_PERE, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL DMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF IF (IW(PTRIST(STEP(ISON))+XXNBPR) .EQ. 0 & ) THEN ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF (SAME_PROC) THEN CALL DMUMPS_RESTORE_INDICES(N, ISON, INODE_PERE, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF ENDIF IF ( IW(PTLUST(STEP(INODE_PERE))+XXNBPR) .EQ. 0 & ) THEN CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, INODE_PERE+N ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF DO I = 0, NSLAVES_PERE PDEST = SLAVES_PERE( I ) IF ( PDEST .NE. MYID ) THEN NBROWS_ALREADY_SENT = 0 95 CONTINUE NFRONT = IW(PIMASTER(STEP(ISON))+KEEP(IXSZ)) NELIM = IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) DESCLU = .TRUE. IF (I == NSLAVES_PERE) THEN NROWS_TO_SEND=LMAP_LOC-NBROW(I)+1 ELSE NROWS_TO_SEND=NBROW(I+1)-NBROW(I) ENDIF IF ( NROWS_TO_SEND .EQ. 0) CYCLE ITYPE_SON = MUMPS_TYPENODE( PROCNODE_STEPS(STEP(ISON)), & KEEP(199) ) IF (CB_IS_LR) THEN CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & ADummy, 1_8, & I, PDEST, PDEST_MASTER, COMM, IERR, & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID, & NPIV_CHECK = IW(PTLUST(STEP(ISON))+3+KEEP(IXSZ))) ELSE CALL DMUMPS_DM_SET_DYNPTR( & IW(PTRIST(STEP(ISON))+XXS), & A, LA, & PAMASTER(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, RECSIZE ) CALL DMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESCLU, INODE_PERE, & NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NROWS_TO_SEND, LMAP_LOC, & MAP, PERM_LOC(min(LMAP_LOC,NBROW(I))), & IW(PIMASTER(STEP(ISON))), & SON_A(IACHK:IACHK+RECSIZE-1_8), & RECSIZE, & I, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP(253), NVSCHUR, & ITYPE_SON, MYID) ENDIF IF ( IERR .EQ. -2 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_MAPLIG_FILS_NIV1" IFLAG = -17 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 END IF IF ( IERR .EQ. -3 ) THEN IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_MAPLIG_FILS_NIV1" IFLAG = -20 IERROR = (NROWS_TO_SEND + 3 )* KEEP( 34 ) + & NROWS_TO_SEND * KEEP( 35 ) GO TO 700 ENDIF IF (KEEP(219).NE.0) THEN IF ( IERR .EQ. -4 ) THEN IFLAG = -13 IERROR = BUF_LMAX_ARRAY IF (LP > 0) WRITE(LP,*) MYID, &": FAILURE, MAX_ARRAY ALLOC FAILED DURING DMUMPS_MAPLIG_FILS_NIV1" GO TO 700 ENDIF ENDIF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 GO TO 95 END IF END IF END DO ISTCHK = PTRIST(STEP(ISON)) PTRIST(STEP( ISON )) = -77777777 IF ( IW(ISTCHK+KEEP(IXSZ)) .GE. 0 ) THEN WRITE(*,*) 'error 3 in DMUMPS_MAPLIG_FILS_NIV1' CALL MUMPS_ABORT() ENDIF CALL MUMPS_GETI8(DYNSIZE,IW(ISTCHK+XXD)) CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) IF (DYNSIZE .GT. 0_8) THEN CALL DMUMPS_DM_FREE_BLOCK( SON_A, DYNSIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF GOTO 600 700 CONTINUE CALL DMUMPS_BDC_ERROR(MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (CB_IS_LR) THEN CALL DMUMPS_BLR_FREE_CB_LRB(IW(ISTCHK+XXF), & .FALSE., & KEEP8) IF ((KEEP(486).EQ.3).OR.KEEP(486).EQ.0) THEN CALL DMUMPS_BLR_END_FRONT(IW(ISTCHK+XXF), IFLAG, KEEP8) ENDIF ENDIF IF (allocated(NBROW)) DEALLOCATE(NBROW) IF (allocated(MAP)) DEALLOCATE(MAP) IF (allocated(PERM_LOC)) DEALLOCATE(PERM_LOC) IF (allocated(SLAVES_PERE)) DEALLOCATE(SLAVES_PERE) RETURN END SUBROUTINE DMUMPS_MAPLIG_FILS_NIV1 SUBROUTINE DMUMPS_LOCAL_ASSEMBLY_TYPE2(I, PDEST, MYID, & PDEST_MASTER, ISON, IFATH, NSLAVES_PERE, NASS_PERE, & NFRONT_PERE, NFS4FATHER, LMAP_LOC, MAP, & NBROW, PERM, IS_ofType5or6, IFLAG, IERROR, & N, SLAVEF, KEEP, & IPOOL, LPOOL, STEP, & PROCNODE_STEPS, COMM_LOAD, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, & KEEP8, IW, LIW, A, LA, LRLU, LRLUS, IPTRLU, IWPOSCB, & PTRIST, PTLUST, PTRAST, PAMASTER, PIMASTER, ND, & NELT, FRTPTR, FRTELT, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, KEEP253_LOC, NVSCHUR, & FILS, DAD, & LPTRAR, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & SON_NIV, LRGROUPS) USE DMUMPS_BUF, ONLY: DMUMPS_BUF_MAX_ARRAY_MINSIZE, & BUF_MAX_ARRAY USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_LR_DATA_M USE DMUMPS_FAC_LR, ONLY: DMUMPS_DECOMPRESS_PANEL USE DMUMPS_LOAD, ONLY : DMUMPS_LOAD_POOL_UPD_NEW_POOL USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR & , DMUMPS_DM_SET_PTR, DMUMPS_DM_FREE_BLOCK IMPLICIT NONE INTEGER ICNTL(60) INTEGER, intent(in) :: I, PDEST, MYID, PDEST_MASTER, IFATH, ISON INTEGER, intent(in) :: N, SLAVEF INTEGER, intent(in) :: NSLAVES_PERE, NASS_PERE, NFRONT_PERE INTEGER, intent(in) :: NFS4FATHER INTEGER, intent(in) :: KEEP(500), STEP(N) INTEGER, intent(in) :: LMAP_LOC INTEGER, intent(in) :: NBROW(0:NSLAVES_PERE) INTEGER, intent(in) :: MAP(LMAP_LOC), PERM(LMAP_LOC) INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: LIW, NELT, LPTRAR INTEGER(8), intent(in) :: LA INTEGER(8), intent(inout) :: IPTRLU, LRLU, LRLUS INTEGER, intent(inout) :: IWPOSCB INTEGER, intent(inout) :: IW(LIW) DOUBLE PRECISION, intent(inout) :: A( LA ) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER :: PTRIST(KEEP(28)), PIMASTER(KEEP(28)), ND(KEEP(28)) INTEGER :: PTLUST(KEEP(28)) INTEGER, intent(inout) :: ITLOC(N) INTEGER, intent(in) :: FRTPTR( N+1 ), FRTELT( NELT ) DOUBLE PRECISION, intent(inout) :: OPASSW, OPELIW DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: KEEP253_LOC, NVSCHUR INTEGER, intent(in) :: FILS(N), DAD( KEEP(28) ) INTEGER(8), intent(in) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER, intent(in) :: PROCNODE_STEPS( KEEP(28) ), COMM_LOAD INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER LPOOL INTEGER IPOOL( LPOOL ) LOGICAL, intent(in) :: IS_ofType5or6 INTEGER, intent(in) :: SON_NIV INTEGER, intent(in) :: LRGROUPS(N) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INTEGER :: ISTCHK, ISTCHK_LOC, NBCOLS, & NROW, NPIV, NSLSON, & NFRONT, LDA_SON, NROWS_TO_STACK, II, INDICE_PERE, & NOSLA, COLLIST, IPOS_IN_SLAVE, IROW_SON, ITMP, & NBCOLS_EFF, DECR, NELIM LOGICAL :: PACKED_CB, SAME_PROC INTEGER(8) :: SIZFR, POSROW, SHIFTCB_SON INTEGER(8) :: IACHK INTEGER :: SON_XXS DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A_MASTER INTEGER(8) :: DYN_SIZE INTEGER :: IERR, LP INTEGER INDICE_PERE_ARRAY_ARG(1) INTEGER :: INBPROCFILS_SON LOGICAL :: CB_IS_LR DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY LOGICAL :: M_ARRAY_RETRIEVED INTEGER(8) :: POSELT INTEGER :: IOLDPS, PARPIV_T1 LOGICAL :: LR_ACTIVATED INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_BLR_COLS, NB_BLR_ROWS, & NB_COL_SHIFT, PANEL2DECOMPRESS, & CURRENT_PANEL_SIZE, PANEL_BEG_OFFSET, & allocok, NROWS_ALREADY_STACKED, NROWS_TO_STACK_LOC, & NB_ROW_SHIFT, NASS_SHIFT, NCOL_SHIFT, NROW_SHIFT INTEGER(8) :: LA_TEMP DOUBLE PRECISION, ALLOCATABLE :: A_TEMP(:) TYPE (LRB_TYPE), POINTER :: CB_LRB(:,:) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 IF (I == NSLAVES_PERE) THEN NROWS_TO_STACK = LMAP_LOC - NBROW(I) + 1 ELSE NROWS_TO_STACK = NBROW(I+1) - NBROW(I) ENDIF DECR = 1 IF ( MYID .EQ. PDEST_MASTER ) THEN IW(PTLUST(STEP(IFATH))+XXNBPR) = & IW(PTLUST(STEP(IFATH))+XXNBPR) - DECR IF ( PDEST .EQ. PDEST_MASTER .AND. DECR .NE. 0) THEN IW(PIMASTER(STEP(ISON))+XXNBPR) = & IW(PIMASTER(STEP(ISON))+XXNBPR) - DECR ENDIF ENDIF ISTCHK = PTRIST(STEP(ISON)) NBCOLS = IW(ISTCHK+KEEP(IXSZ)) NROW = IW(ISTCHK+2+KEEP(IXSZ)) NPIV = IW(ISTCHK+3+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) NFRONT = NPIV + NBCOLS SON_XXS = IW(ISTCHK+XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) CALL DMUMPS_DM_SET_DYNPTR( & SON_XXS, & A, LA, & PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR) CB_IS_LR = (IW(ISTCHK+XXLR).EQ.1 .OR. & IW(ISTCHK+XXLR).EQ.3) NELIM = -9999 IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) NELIM = IW(ISTCHK_LOC+1+KEEP(IXSZ)) NPIV = IW(ISTCHK_LOC+3+KEEP(IXSZ)) NFRONT = IW(ISTCHK_LOC+2+KEEP(IXSZ)) NROW = NFRONT - NPIV NFRONT = NBCOLS NPIV = 0 ENDIF IF (CB_IS_LR) THEN LDA_SON = NBCOLS SHIFTCB_SON = -9999 ELSE IF (SON_XXS.EQ.S_NOLCBCONTIG ) THEN LDA_SON = NBCOLS SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (IW(ISTCHK+XXS).EQ.S_NOLCLEANED) THEN LDA_SON = NBCOLS SHIFTCB_SON = 0_8 ELSE LDA_SON = NFRONT SHIFTCB_SON = int(NPIV,8) ENDIF ENDIF IF (PDEST .NE. PDEST_MASTER) THEN IF ( KEEP(55) .eq. 0 ) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP,KEEP8, MYID, LRGROUPS ) ELSE CALL DMUMPS_ELT_ASM_S_2_S_INIT(NELT, FRTPTR, FRTELT, & N, IFATH, IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, ICNTL, & KEEP, KEEP8, MYID, LRGROUPS ) ENDIF ENDIF NROWS_ALREADY_STACKED = 0 100 CONTINUE NROWS_TO_STACK_LOC = NROWS_TO_STACK PANEL_BEG_OFFSET = 0 IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN CALL DMUMPS_BLR_RETRIEVE_CB_LRB( & IW(ISTCHK+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_ROW) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN( & IW(ISTCHK+XXF), BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IW(ISTCHK+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 ELSE CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA( & IW(ISTCHK+XXF), BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C( & IW(ISTCHK+XXF), BEGS_BLR_COL, & NB_COL_SHIFT) NB_ROW_SHIFT = 0 NASS_SHIFT = 0 ENDIF PANEL2DECOMPRESS = -1 DO II=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(II+1)-1-NASS_SHIFT.GT. & NROWS_ALREADY_STACKED+NBROW(I)-1) THEN PANEL2DECOMPRESS = II EXIT ENDIF ENDDO IF (PANEL2DECOMPRESS.EQ.-1) THEN write(*,*) 'Internal error: PANEL2DECOMPRESS not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2DECOMPRESS ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV NROW_SHIFT = NBCOLS-NROW DO II=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(II+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2DECOMPRESS+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = II EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2DECOMPRESS+1) & - BEGS_BLR_ROW(PANEL2DECOMPRESS) PANEL_BEG_OFFSET = NBROW(I) + NROWS_ALREADY_STACKED & - BEGS_BLR_ROW(PANEL2DECOMPRESS) + NASS_SHIFT NROWS_TO_STACK_LOC = & min(NROWS_TO_STACK-NROWS_ALREADY_STACKED, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) LA_TEMP = CURRENT_PANEL_SIZE*NBCOLS allocate(A_TEMP(LA_TEMP),stat=allocok) IF (allocok.GT.0) THEN CALL MUMPS_SETI8TOI4(LA_TEMP,IERROR) IFLAG = -13 RETURN ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_DECOMPRESS_PANEL(A_TEMP, LA_TEMP, 1_8, & NBCOLS, NBCOLS, .TRUE., 1, 1, & NB_BLR_COLS-NB_COL_SHIFT, & CB_LRB(PANEL2DECOMPRESS-NB_ROW_SHIFT, & 1:NB_BLR_COLS-NB_COL_SHIFT), & 0, 'V', 6, & CBASM_TOFIX_IN=.TRUE., & ONLY_NELIM_IN=CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) #if defined(BLR_MT) !$OMP END PARALLEL #endif ENDIF DO II = NROWS_ALREADY_STACKED+1, & NROWS_ALREADY_STACKED+NROWS_TO_STACK_LOC IROW_SON = PERM(NBROW(I)+II-1) INDICE_PERE=MAP(IROW_SON) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IFATH, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE IF ( PACKED_CB ) THEN IF (NBCOLS - NROW .EQ. 0 ) THEN ITMP = IROW_SON POSROW = IACHK+ & int(ITMP,8) * int(ITMP-1,8) / 2_8 ELSE ITMP = IROW_SON + NBCOLS - NROW POSROW = IACHK & + int(ITMP,8) * int(ITMP-1,8) / 2_8 & - int(NBCOLS-NROW,8) * int(NBCOLS-NROW+1,8)/2_8 ENDIF ELSE POSROW = IACHK + SHIFTCB_SON & +int(IROW_SON-1,8)*int(LDA_SON,8) ENDIF IF (PDEST == PDEST_MASTER) THEN IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ((IS_ofType5or6).AND.(KEEP(50).EQ.0)) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON & ) EXIT ELSE IF ( (KEEP(50).NE.0) .AND. & (.NOT.PACKED_CB).AND.(IS_ofType5or6) ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, NROWS_TO_STACK, & NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON &) EXIT ELSE IF (CB_IS_LR) THEN CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, NBCOLS ) ELSE CALL DMUMPS_ASM_SLAVE_MASTER(N, IFATH, IW, LIW, & A, LA, ISON, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & SON_A(POSROW), PTLUST, PTRAST, & STEP, PIMASTER, OPASSW, & IWPOSCB, MYID, KEEP,KEEP8, & IS_ofType5or6, LDA_SON ) ENDIF ENDIF ELSE ISTCHK = PTRIST(STEP(ISON)) COLLIST = ISTCHK + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) + NROW + NPIV IF (CB_IS_LR.AND.(SON_NIV.EQ.1).AND. & KEEP(50).NE.0) THEN ISTCHK_LOC = PTLUST(STEP(ISON)) COLLIST = ISTCHK_LOC + 6 + KEEP(IXSZ) & + IW( ISTCHK + 5 +KEEP(IXSZ)) & + IW(ISTCHK_LOC+2+KEEP(IXSZ)) & + IW(ISTCHK_LOC+3+KEEP(IXSZ)) ENDIF IF (KEEP(50).NE.0) THEN NBCOLS_EFF = IROW_SON + NBCOLS - NROW IF (CB_IS_LR.AND.SON_NIV.EQ.1) & NBCOLS_EFF = IROW_SON + NBCOLS - (NROW-NELIM) ELSE NBCOLS_EFF = NBCOLS ENDIF INDICE_PERE_ARRAY_ARG(1) = INDICE_PERE IF ( (IS_ofType5or6) .AND. & ( & ( KEEP(50).EQ.0) & .OR. & ( (KEEP(50).NE.0).and. (.NOT.PACKED_CB) ) & ) & ) THEN IF (CB_IS_LR) THEN write(*,*) 'Compress CB + Type5or6 fronts not', & 'coded yet!!!' CALL MUMPS_ABORT() ENDIF CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, NROWS_TO_STACK, NBCOLS, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - NROWS_TO_STACK EXIT ELSE IF (CB_IS_LR) THEN CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, & INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), & A_TEMP(1+(II+PANEL_BEG_OFFSET & -NROWS_ALREADY_STACKED-1)*NBCOLS), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, NBCOLS) ELSE CALL DMUMPS_ASM_SLAVE_TO_SLAVE(N, IFATH, & IW, LIW, & A, LA, 1, NBCOLS_EFF, INDICE_PERE_ARRAY_ARG, & IW( COLLIST ), SON_A(POSROW), & OPASSW, OPELIW, STEP, PTRIST, PTRAST, & ITLOC, RHS_MUMPS, & FILS, ICNTL, KEEP,KEEP8, & MYID, IS_ofType5or6, LDA_SON) ENDIF IW( PTRIST(STEP(IFATH))+XXNBPR) = & IW( PTRIST(STEP(IFATH))+XXNBPR) - 1 ENDIF ENDIF ENDDO IF (CB_IS_LR.AND.NROWS_TO_STACK.GT.0) THEN deallocate(A_TEMP) NROWS_ALREADY_STACKED = NROWS_ALREADY_STACKED & + NROWS_TO_STACK_LOC IF (NROWS_ALREADY_STACKED.LT.NROWS_TO_STACK) THEN GOTO 100 ENDIF ENDIF IF (PDEST.EQ.PDEST_MASTER) THEN IF (KEEP(219).NE.0) THEN IF(NSLAVES_PERE.GT.0 .AND. KEEP(50).EQ.2) THEN IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW(ISTCHK+XXF), M_ARRAY) M_ARRAY_RETRIEVED = .TRUE. ELSE IF (PACKED_CB) THEN WRITE(*,*) "Error 1 in PARPIV/DMUMPS_MAPLIG" CALL MUMPS_ABORT() ELSE POSROW = IACHK + SHIFTCB_SON+ & int(NBROW(1)-1,8)*int(LDA_SON,8) ENDIF CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE.0) THEN IF (LP .GT. 0) THEN WRITE(LP, *) "MAX_ARRAY allocation failed" ENDIF IFLAG=-13 IERROR=NFS4FATHER RETURN ENDIF ITMP=-9999 IF (LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR.NE.0) & THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & SON_A(POSROW), & SIZFR-SHIFTCB_SON-int(NBROW(1)-1,8)*int(LDA_SON,8), & LDA_SON, & LMAP_LOC-NBROW(1)+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,ITMP) ELSE CALL DMUMPS_SETMAXTOZERO( & BUF_MAX_ARRAY, NFS4FATHER) ENDIF M_ARRAY => BUF_MAX_ARRAY(1:size(BUF_MAX_ARRAY)) M_ARRAY_RETRIEVED = .FALSE. ENDIF CALL DMUMPS_ASM_MAX(N, IFATH, IW, LIW, & A, LA, ISON, NFS4FATHER, & M_ARRAY(1), PTLUST, PTRAST, & STEP, PIMASTER, & OPASSW,IWPOSCB,MYID, KEEP,KEEP8) IF ( M_ARRAY_RETRIEVED ) & CALL DMUMPS_BLR_FREE_M_ARRAY ( IW(ISTCHK+XXF) ) ENDIF ENDIF ISTCHK_LOC = PIMASTER(STEP(ISON)) SAME_PROC= ISTCHK_LOC .LT. IWPOSCB IF ( SAME_PROC ) THEN INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR WRITE(*,*) & "Internal error 0 in DMUMPS_LOCAL_ASSEMBLY_TYPE2", & INBPROCFILS_SON, PIMASTER(STEP(ISON)) CALL MUMPS_ABORT() ELSE INBPROCFILS_SON = PIMASTER(STEP(ISON))+XXNBPR ENDIF IF ( IW(INBPROCFILS_SON) .EQ. 0 ) THEN IF (SAME_PROC) THEN CALL DMUMPS_RESTORE_INDICES(N, ISON, IFATH, & IWPOSCB, PIMASTER, PTLUST, IW, LIW, STEP, & KEEP,KEEP8) ENDIF IF (SAME_PROC) THEN ISTCHK_LOC = PTRIST(STEP(ISON)) PTRIST(STEP( ISON) ) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_LOC+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A_MASTER ) ENDIF CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., MYID, N, & ISTCHK_LOC, & IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB, & LA, KEEP,KEEP8, .FALSE. & ) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_FREE_BLOCK( SON_A_MASTER, DYN_SIZE, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF IF ( IW(PTLUST(STEP(IFATH))+XXNBPR) .EQ. 0 & ) THEN IOLDPS = PTLUST(STEP(IFATH)) IF (NSLAVES_PERE.EQ.0) THEN POSELT = PTRAST(STEP(IFATH)) PARPIV_T1 = -999 LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, IFATH, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT_PERE, NASS_PERE, LR_ACTIVATED, PARPIV_T1) ENDIF CALL DMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), & KEEP(47), STEP, IFATH+N ) IF (KEEP(47) .GE. 3) THEN CALL DMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF ELSE CALL DMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, IFATH, IW, LIW, & NBROW(I), STEP, PTRIST, ITLOC, RHS_MUMPS, & KEEP,KEEP8) END IF RETURN END SUBROUTINE DMUMPS_LOCAL_ASSEMBLY_TYPE2 MUMPS_5.4.1/src/sfac_driver.F0000664000175000017500000043755714102210525016130 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_DRIVER( id) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_OOC USE SMUMPS_STRUC_DEF USE SMUMPS_LR_STATS USE SMUMPS_LR_DATA_M, only: SMUMPS_BLR_INIT_MODULE, & SMUMPS_BLR_END_MODULE & , SMUMPS_BLR_STRUC_TO_MOD & , SMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE SMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE SMUMPS_ANORMINF(id, ANORMINF, LSCAL) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE SMUMPS_ANORMINF SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE SMUMPS_LR_DATA_M, only : SMUMPS_BLR_STRUC_TO_MOD, & SMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE SMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Parameters C ========== C TYPE(SMUMPS_STRUC), TARGET :: id C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: SMUMPS_LBUFR, SMUMPS_LBUFR_BYTES INTEGER(8) :: SMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: SMUMPS_LBUF, SMUMPS_LBUF_INT INTEGER(8) :: SMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, K28, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 REAL CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM C TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER MAXIS INTEGER(8) :: MAXS C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG REAL, TARGET :: S_DUMMY_ARG(1) REAL, POINTER, DIMENSION(:) :: S_PTR_ARG INTEGER NPIV_CRITICAL_PATH DOUBLE PRECISION TIME, TIMEET REAL ZERO, ONE, MONE PARAMETER( ZERO = 0.0E0, ONE = 1.0E0, MONE = -1.0E0) REAL CZERO PARAMETER( CZERO = 0.0E0 ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_LR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_DECOMP_ASM1 DOUBLE PRECISION :: TMP_TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TMP_TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2M C C Workspace. C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK REAL, DIMENSION(:), ALLOCATABLE :: WK REAL, DIMENSION(:), ALLOCATABLE :: WK_REAL INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER BUREGISTRE(12) INTEGER BUINTSZ, BURESZ, BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS REAL SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C INTEGER, POINTER :: JOB * Control parameters: see description in SMUMPSID REAL,DIMENSION(:),POINTER::RINFO, RINFOG REAL,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER:: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: MYIRN_loc, MYJCN_loc REAL, DIMENSION(:), POINTER :: MYA_loc INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) REAL, TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH INTEGER(8) :: TOTAL_BYTES INTEGER(8) :: I8TMP, LWK_USER_SUM8 C C External references C =================== INTEGER numroc EXTERNAL numroc INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED C Fwd in facto: REAL, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM C C JOB=>id%JOB RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN MYIRN_loc=>id%IRN_loc MYJCN_loc=>id%JCN_loc MYA_loc=>id%A_loc ELSE MYIRN_loc=>DUMMYIRN_loc MYJCN_loc=>DUMMYJCN_loc MYA_loc=>DUMMYA_loc ENDIF N = id%N EPS = epsilon ( ZERO ) C TIMINGS: reset to 0 id%DKEEP(92)=0.0E0 id%DKEEP(93)=0.0E0 id%DKEEP(94)=0.0E0 id%DKEEP(97)=0.0E0 id%DKEEP(98)=0.0E0 id%DKEEP(56)=0.0E0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C MIN/MAX pivots reset to 0 id%DKEEP(19)=huge(0.0E0) id%DKEEP(20)=huge(0.0E0) id%DKEEP(21)=0.0E0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C Data from factorization is now freed asap C id%S, id%IS IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 NULLIFY(id%S) ENDIF ENDIF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C Free BLR factors, if any CALL SMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C IF (id%KEEP8(24).GT.0_8) THEN C We nullify S so that later when we test C if (associated(S) we can free space and reallocate it). NULLIFY(id%S) ENDIF C C -- KEEP8(24) can now then be reset safely WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user LWK_USER_SUM8 = 0_8 CALL MPI_REDUCE ( id%KEEP8(24), LWK_USER_SUM8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0E0 id%DKEEP(5)=-1.0E0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF C ---------------------- C Broadcast KEEP options C defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5E0) THEN CNTL1 = 0.5E0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_REAL, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 0 KEEP464COPY = 0 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF KEEP465COPY=0 IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF KEEP(489)=0 C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 50 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 50 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Ignore ICNTL(23) when WK_USER is provided c by resetting ITMP to zero on each proc where WK_USER is provided IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes IF ( PROKG ) THEN NWORKING = id%NSLAVES WRITE( MPG, 172 ) NWORKING, id%ICNTL(22), KEEP(486), & KEEP(12), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, LWK_USER_SUM8, CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL(id) END IF C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0E0 ! real part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4*BUMAXMN ALLOCATE (IWK(LIWK),BURP(M),BUCP(N), & BURS(2* (id%NPROCS)),BUCS(2* (id%NPROCS)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL SMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL SMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N CXXXX IF(N > BUMAXMN) BUMAXMN = N LIWK = 1 ALLOCATE (IWK(LIWK),BURP(1),BUCP(1), & BURS(1),BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+1+1+1+1 ENDIF LWK_REAL = M + N ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (id%INFO(1) .LT. 0) GOTO 400 CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL SMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN ! internal error since LWK_REAL=BURESZ=M+N id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL SMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ---------------------------------- C Centralized scaling, options 1 to 6 C ---------------------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN C We have an explicit copy of the original C matrix in complex format which should probably C be avoided (but do we want to keep all C those old scaling options ?) LWK = id%KEEP8(28) ELSE LWK = 1_8 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL SMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF ! Scaling distributed matrices or centralized IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=real(TIMEET) C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8) & .AND. (K233+K231+K232).GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL SMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL SMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL SMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL SMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE C Fwd in facto: in case of repeated factorizations C with different Schur options we prefer to free C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF C Fwd in facto: allocate and broadcast RHS_MUMPS C to make it available on all processors. IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP(255) = N*id%KEEP(253) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(255) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_REAL, MASTER,id%COMM,IERR) END DO ENDIF C Keep a copy of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 IF (KEEP(219).NE.0) THEN CALL SMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN C ------------------------ C Error allocating SMUMPS_BUF C ------------------------ id%INFO(1) = -13 id%INFO(2) = max(KEEP(108),1) END IF ENDIF C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_REAL, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN CALL SMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ELSE ANORMINF = ZERO ENDIF C C Set BLR threshold IF (id%DKEEP(8).LT.ZERO) THEN id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ENDIF IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A,1PD16.4)') & ' Effective value of CNTL(3) =',CNTL3 ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I10)') & 'ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for postponing =',SEUIL ENDIF !end KEEP(19) SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in SMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0E0 id%DKEEP(2) = ZERO ELSE C -- Null pivot is on IF (KEEP(19).NE.0) THEN C -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1E-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF ELSE C -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(REAL(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0E10*ANORMINF, & sqrt(huge(ANORMINF))/1.0E8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST in case of null pivot detection LPN_LIST = 1 IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = N ENDIF ALLOCATE( id%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_REAL, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN CALL SMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate id%S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL SMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1E6) C ------------------------- C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL SMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & ) ENDIF ! MEM_ALLOWED C ENDIF ! (.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (I_AM_SLAVE) THEN ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL SMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL SMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), id%DKEEP(15), KEEP(375), MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to SMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL SMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) C C Out-Of-Core (OOC) issues. Case where we ran one factorization OOC C and the second one is in-core: we try to free OOC C related data from previous factorization. C CALL SMUMPS_CLEAN_OOC_DATA(id, IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version I8TMP = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * id%KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL SMUMPS_OOC_INIT_FACTO(id,MAXS) ELSE WRITE(*,*) "Internal error in SMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL SMUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL SMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead C ====================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE C ---------------------------------------- C Allocate variable lists. Systematically. C ---------------------------------------- IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( id%INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) NULLIFY(id%INTARR) GOTO 100 END IF ELSE ALLOCATE( id%INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) GOTO 100 END IF END IF C ----------------------------- C Allocate real values. C On master, if hybrid host and C no scaling, avoid the copy. C ----------------------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C -------------------------- C Simple pointer association C -------------------------- id%DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- IF ( id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF C ----------------- C Also prepare some C data for the root C ----------------- IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL SMUMPS_INIT_ROOT_FAC( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF C C 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (SMUMPS_ANA_F and SMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(54) .eq. 0 ) THEN C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) write(6,*) ' PB2 ALLOC INTARR' CALL MUMPS_ABORT() ENDIF ENDIF NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL SMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP,id%KEEP8, & id%FILS(1), IWK(1), ! workspace of size N & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1)) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL SMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP(1),id%KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1) ) #endif DEALLOCATE(IWK) ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL SMUMPS_FACTO_RECV_ARROWHD2( id%N, & id%DBLARR(1), id%KEEP8(26), & id%INTARR(1), id%KEEP8(27), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), id%KEEP8(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & id%root, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%INFO(1), id%INFO(2) ) ENDIF ELSE C C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL SMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & id%DBLARR(1), id%KEEP8(26), id%INTARR(1), & id%KEEP8(27), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, id%root, id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C ENDIF ELSE C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL SMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL SMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, id%root ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = real(TIME) IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN CALL SMUMPS_BUF_INI_MYID(id%MYID_NODES) C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Reception buffer C ---------------- IF (KEEP(486).NE.0) THEN SMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP( 35 ),8) ELSE SMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- SMUMPS_LBUFR_BYTES8 = max( SMUMPS_LBUFR_BYTES8, & 100000_8 ) C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased by more than that. C This is why we use an extra factor 2 relaxation coefficient for the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for moste messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C SMUMPS_LBUFR_BYTES8 = SMUMPS_LBUFR_BYTES8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUFR_BYTES8)/100E0, 8) SMUMPS_LBUFR_BYTES8 = min(SMUMPS_LBUFR_BYTES8, & int(huge (KEEP(44))-100,8)) SMUMPS_LBUFR_BYTES = int( SMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( real(max(PERLU,MIN_PERLU))* & real(id%KEEP8(22))/100E0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(379)) * real(KEEP(35)), 8 ) ELSE SMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)), 8 ) ENDIF SMUMPS_LBUF8 = max( SMUMPS_LBUF8, 100000_8 ) SMUMPS_LBUF8 = SMUMPS_LBUF8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(SMUMPS_LBUF8)/100E0, 8) C Make SMUMPS_LBUF8 small enough to be stored in a standard integer SMUMPS_LBUF8 = min(SMUMPS_LBUF8, int(huge (KEEP(43))-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: SMUMPS_LBUF8 = max(SMUMPS_LBUF8, SMUMPS_LBUFR_BYTES8+3*KEEP(34)) SMUMPS_LBUF = int(SMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN SMUMPS_LBUFR_BYTES=SMUMPS_LBUFR_BYTES*5 SMUMPS_LBUF=SMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C SMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN SMUMPS_LBUF_INT = SMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, SMUMPS_LBUFR_BYTES, SMUMPS_LBUF C and SMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) SMUMPS_LBUFR_BYTES, & SMUMPS_LBUF, SMUMPS_LBUF_INT END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I10, & /, & ' Size of async. emission buffer (bytes).. = ', I10,/, & ' Small emission buffer (bytes) .......... = ', I10) C -------------------------- C Allocate small send buffer C required for SMUMPS_FAC_B C -------------------------- CALL SMUMPS_BUF_ALLOC_SMALL_BUF( SMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= SMUMPS_LBUF_INT id%INFO(2)= (SMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in SMUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- SMUMPS_LBUFR = (SMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) ALLOCATE( BUFR( SMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = SMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', SMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C SMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, & MAXIS_ESTIM + 3 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine SMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in SMUMPS_LBUF module CALL SMUMPS_BUF_DIST_IRECV_SIZE( SMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, id%KEEP8(12), KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, SMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(real(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/real(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MPG,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to SMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during SMUMPS_FAC_B. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL SMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), & LDPTRAR,IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,SMUMPS_LBUFR & , SMUMPS_LBUFR_BYTES, SMUMPS_LBUF, id%INTARR(1),id%DBLARR(1), & id%root, NELT_arg, id%FRTPTR(1), id%FRTELT(1),id%COMM_LOAD, & id%ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, id%MEM_DIST(0), & id%DKEEP(1), id%PIVNUL_LIST(1), LPN_LIST, id%LRGROUPS(1) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : INTARR was not allocated C during factorization in the case C of an assembled matrix. C --------------------------------- IF ( KEEP(55) .eq. 0 ) THEN C C ---------------- C Assembled matrix C ---------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF C ELSE C C ---------------- C Elemental matrix C ---------------- IF (associated(id%INTARR)) THEN DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) ENDIF C ------------------------------------ C For the master from an hybrid host C execution without scaling, then real C values have not been copied ! C ------------------------------------- IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF C Memroy statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) ELSE IF ( id%MYID .EQ. 1 ) THEN CALL MPI_SEND( KEEP(17), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL SMUMPS_BUF_DEALL_SMALL_BUF( IERR ) C//PIV IF (KEEP(219).NE.0) THEN CALL SMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF C C Check for errors. C After SMUMPS_FAC_B every slave is aware of an error. C If master is included in computations, the call below should C not be necessary. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL SMUMPS_EXTRACT_SCHUR_REDRHS(id) IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN IF ( I_AM_SLAVE ) THEN CALL SMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN id%INFO(1)=IERR id%INFO(2)=0 ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C We want to collect statistics even in case of C error to understand if it is due to numerical C issues CC IF ( id%INFO(1) < 0 ) GOTO 500 END IF END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=real(TIME) ENDIF C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL SMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL SMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C FIXME Check if WK_USER used and indicate, total space to WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL SMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C C IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during SMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = real(id%KEEP8(6)*int(KEEP(35),8))/real(1E6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = real(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_FR, TMP_FLOP_SOLFWD_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_LR, TMP_FLOP_SOLFWD_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASM1, TMP_TIME_DECOMP_ASM1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_LOCASM2, TMP_TIME_DECOMP_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_MAPLIG1, TMP_TIME_DECOMP_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2S, TMP_TIME_DECOMP_ASMS2S & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2M, TMP_TIME_DECOMP_ASMS2M & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_SOLFWD_FR = TMP_FLOP_SOLFWD_FR FLOP_SOLFWD_LR = TMP_FLOP_SOLFWD_LR FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_DECOMP_ASM1 = TMP_TIME_DECOMP_ASM1 /id%NPROCS TIME_DECOMP_LOCASM2 = TMP_TIME_DECOMP_LOCASM2 /id%NPROCS TIME_DECOMP_MAPLIG1 = TMP_TIME_DECOMP_MAPLIG1 /id%NPROCS TIME_DECOMP_ASMS2S = TMP_TIME_DECOMP_ASMS2S /id%NPROCS TIME_DECOMP_ASMS2M = TMP_TIME_DECOMP_ASMS2M /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),id%RINFOG(3), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array IF (LPOK) THEN IF (CNTL(7) < 0.0E0) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(LP,'(/A/,A/,A/,A,A)') & ' WARNING in BLR input setting', & ' CNTL(7) < 0 is experimental: ', & ' RRQR precision = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the Users guide ' ENDIF ENDIF CALL SAVEandWRITE_GAINS(FRONTWISE, & KEEP(489), id%DKEEP, N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), KEEP(472), & KEEP(475), KEEP(478), KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0E00 ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56). INFOG(28)=KEEP(112)+KEEP(17) ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST(KEEP(109)+1:KEEP(109)+KEEP(17). C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND(id%PIVNUL_LIST(KEEP(109)+1), KEEP(17), & MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDDO ELSE CALL MPI_SEND( id%PIVNUL_LIST(1), KEEP(109), MPI_INTEGER, & MASTER,ZERO_PIV, id%COMM, IERR) CALL MPI_RECV( KEEP(220), 1, MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN DO I = 1, id%INFOG(28) CALL SMUMPS_UPDATEDETER(id%ROWSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) CALL SMUMPS_UPDATEDETER(id%COLSCA(id%PIVNUL_LIST(I)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) C In case of real arithmetic, initialize C RINFOG(13) to 0 (no imaginary part and C not touched by SMUMPS_DETER_REDUCTION) RINFOG(13)=0.0E0 IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) ENDIF C C 3/ Perform a reduction C CALL SMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL SMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, C id%STEP: used as workspace of size N still C allocated on master; restored on exit & id%STEP(1), & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see SMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN C ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 1 .OR. id%KEEP(50) == 2) THEN ! negative pivots WRITE(MPG, 99987) INFOG(12) END IF IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) c IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99977) INFOG(34) ENDIF END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free DBLARR (as in end_driver.F) C in case an error occurred after allocating C DBLARR and before freeing it above. IF (id%KEEP(46).EQ.1 .AND. & id%KEEP(55).NE.0 .AND. & id%MYID.EQ.MASTER .AND. & id%KEEP(52) .EQ. 0) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL SMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL SMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in SMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL SMUMPS_OOC_END_FACTO(id,IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL SMUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO C 517 CONTINUE C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 160 FORMAT( & /' Elapsed time to reformat/distribute matrix =',F12.4) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' Memory allowed (MB -- 0: N/A ) =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =',F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =',F12.4) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =',I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =',F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =',I16) 99981 FORMAT( ' INFOG(14) Number of memory compress =',I16) 99982 FORMAT( ' INFOG(13) Number of delayed pivots =',I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =',I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) Estimated deficiency =',I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG(2) Operations in node assembly =',1PD10.3/ & ' ------(3) Operations in node elimination =',1PD10.3/ & ' ICNTL (8) Scaling effectively used =',I16/ & ' INFOG (9) Real space for factors =',I16/ & ' INFOG(10) Integer space for factors =',I16/ & ' INFOG(11) Maximum front size =',I16/ & ' INFOG(29) Number of entries in factors =',I16) 99985 FORMAT( ' INFOG(12) Number of off diagonal pivots =',I16) 99986 FORMAT( ' INFOG(25) Number of tiny pivots(static) =',I16) 99987 FORMAT( ' INFOG(12) Number of negative pivots =',I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =',I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =',I16) END SUBROUTINE SMUMPS_FAC_DRIVER C SUBROUTINE SMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE SMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE SMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER REAL LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = real(VAL)/real(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_REAL, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE SMUMPS_AVGMAX_STAT8 C SUBROUTINE SMUMPS_EXTRACT_SCHUR_REDRHS(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in root%RHS_CNTR_MASTER_ROOT. C TYPE(SMUMPS_STRUC) :: id C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ================================= C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from id%root%RHS_CNTR_MASTER_ROOT C ================================= IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL scopy(SIZE_SCHUR, & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free root%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL SMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C ----------------------------------------- BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL scopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_REAL, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL scopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL scopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL scopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_REAL, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_REAL, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_EXTRACT_SCHUR_REDRHS MUMPS_5.4.1/src/cmumps_ooc.F0000664000175000017500000036125614102210524015774 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_OOC USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NOT_IN_MEM,BEING_READ,NOT_USED,PERMUTED,USED, & USED_NOT_PERMUTED,ALREADY_USED PARAMETER (NOT_IN_MEM=0,BEING_READ=-1,NOT_USED=-2, & PERMUTED=-3,USED=-4,USED_NOT_PERMUTED=-5,ALREADY_USED=-6) INTEGER OOC_NODE_NOT_IN_MEM,OOC_NODE_PERMUTED, & OOC_NODE_NOT_PERMUTED PARAMETER (OOC_NODE_NOT_IN_MEM=-20, & OOC_NODE_PERMUTED=-21,OOC_NODE_NOT_PERMUTED=-22) INTEGER(8), DIMENSION(:,:),POINTER :: SIZE_OF_BLOCK INTEGER, DIMENSION(:),POINTER :: TOTAL_NB_OOC_NODES INTEGER :: OOC_SOLVE_TYPE_FCT INTEGER, DIMENSION(:),ALLOCATABLE :: IO_REQ INTEGER(8), DIMENSION(:), ALLOCATABLE:: LRLUS_SOLVE INTEGER(8), DIMENSION(:), ALLOCATABLE:: SIZE_SOLVE_Z, & LRLU_SOLVE_T, POSFAC_SOLVE, IDEB_SOLVE_Z, LRLU_SOLVE_B INTEGER, DIMENSION(:),ALLOCATABLE :: PDEB_SOLVE_Z INTEGER (8),SAVE :: FACT_AREA_SIZE, & SIZE_ZONE_SOLVE,SIZE_SOLVE_EMM,TMP_SIZE_FACT, & MAX_SIZE_FACTOR_OOC INTEGER(8), SAVE :: MIN_SIZE_READ INTEGER, SAVE :: TMP_NB_NODES, MAX_NB_NODES_FOR_ZONE,MAX_NB_REQ, & CURRENT_SOLVE_READ_ZONE, & CUR_POS_SEQUENCE,NB_Z,SOLVE_STEP, & NB_ZONE_REQ,MTYPE_OOC,NB_ACT & ,NB_CALLED,REQ_ACT,NB_CALL INTEGER(8), SAVE :: OOC_VADDR_PTR INTEGER(8), SAVE :: SIZE_ZONE_REQ DOUBLE PRECISION,SAVE :: MAX_OOC_FILE_SIZE INTEGER(8), DIMENSION(:), ALLOCATABLE :: SIZE_OF_READ, READ_DEST INTEGER,DIMENSION(:),ALLOCATABLE :: FIRST_POS_IN_READ, & READ_MNG,REQ_TO_ZONE,POS_HOLE_T, & POS_HOLE_B,REQ_ID,OOC_STATE_NODE INTEGER CMUMPS_ELEMENTARY_DATA_SIZE,N_OOC INTEGER, DIMENSION(:), ALLOCATABLE :: POS_IN_MEM, INODE_TO_POS INTEGER, DIMENSION(:), ALLOCATABLE :: CURRENT_POS_T,CURRENT_POS_B LOGICAL IS_ROOT_SPECIAL INTEGER SPECIAL_ROOT_NODE PUBLIC :: CMUMPS_OOC_INIT_FACTO,CMUMPS_NEW_FACTOR, & CMUMPS_READ_OOC, & CMUMPS_SOLVE_ALLOC_FACTOR_SPACE, & CMUMPS_IS_THERE_FREE_SPACE, & CMUMPS_OOC_END_SOLVE, & CMUMPS_SOLVE_INIT_OOC_FWD,CMUMPS_SOLVE_INIT_OOC_BWD, & CMUMPS_INITIATE_READ_OPS,CMUMPS_OOC_INIT_SOLVE INTEGER, PARAMETER, PUBLIC :: TYPEF_BOTH_LU = -99976 PUBLIC CMUMPS_OOC_IO_LU_PANEL, & CMUMPS_OOC_PANEL_SIZE PRIVATE CMUMPS_OOC_STORE_LorU, & CMUMPS_OOC_WRT_IN_PANELS_LorU CONTAINS SUBROUTINE CMUMPS_SET_STRAT_IO_FLAGS( STRAT_IO_ARG, & STRAT_IO_ASYNC_ARG, WITH_BUF_ARG, LOW_LEVEL_STRAT_IO_ARG ) IMPLICIT NONE INTEGER, intent(out) :: LOW_LEVEL_STRAT_IO_ARG LOGICAL, intent(out) :: STRAT_IO_ASYNC_ARG, WITH_BUF_ARG INTEGER, intent(in) :: STRAT_IO_ARG INTEGER TMP CALL MUMPS_OOC_IS_ASYNC_AVAIL(TMP) STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.FALSE. IF(TMP.EQ.1)THEN IF((STRAT_IO_ARG.EQ.1).OR.(STRAT_IO_ARG.EQ.2))THEN STRAT_IO_ASYNC=.TRUE. WITH_BUF=.FALSE. ELSEIF((STRAT_IO_ARG.EQ.4).OR.(STRAT_IO_ARG.EQ.5))THEN STRAT_IO_ASYNC_ARG=.TRUE. WITH_BUF_ARG=.TRUE. ELSEIF(STRAT_IO_ARG.EQ.3)THEN STRAT_IO_ASYNC_ARG=.FALSE. WITH_BUF_ARG=.TRUE. ENDIF LOW_LEVEL_STRAT_IO_ARG=mod(STRAT_IO_ARG,3) ELSE LOW_LEVEL_STRAT_IO_ARG=0 IF(STRAT_IO_ARG.GE.3)THEN WITH_BUF_ARG=.TRUE. ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_STRAT_IO_FLAGS FUNCTION CMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE) IMPLICIT NONE INTEGER INODE,ZONE LOGICAL CMUMPS_IS_THERE_FREE_SPACE CMUMPS_IS_THERE_FREE_SPACE=(LRLUS_SOLVE(ZONE).GE. & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) RETURN END FUNCTION CMUMPS_IS_THERE_FREE_SPACE SUBROUTINE CMUMPS_INIT_FACT_AREA_SIZE_S(LA) IMPLICIT NONE INTEGER(8) :: LA FACT_AREA_SIZE=LA END SUBROUTINE CMUMPS_INIT_FACT_AREA_SIZE_S SUBROUTINE CMUMPS_OOC_INIT_FACTO(id, MAXS) USE CMUMPS_STRUC_DEF USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER TMPDIR_MAX_LENGTH, PREFIX_MAX_LENGTH PARAMETER (TMPDIR_MAX_LENGTH=255, PREFIX_MAX_LENGTH=63) INTEGER(8), intent(in) :: MAXS TYPE(CMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER allocok INTEGER ASYNC CHARACTER(len=1):: TMP_DIR(TMPDIR_MAX_LENGTH), & TMP_PREFIX(PREFIX_MAX_LENGTH) INTEGER DIM_DIR,DIM_PREFIX INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_FLAG_TAB INTEGER TMP INTEGER K211_LOC ICNTL1=id%ICNTL(1) MAX_SIZE_FACTOR_OOC=0_8 N_OOC=id%N ASYNC=0 SOLVE=.FALSE. IERR=0 IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE IF(IERR.LT.0)THEN IF (ICNTL1 > 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) IF (id%KEEP(201).EQ.2) THEN OOC_FCT_TYPE=1 ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS MYID_OOC=id%MYID SLAVEF_OOC=id%NSLAVES KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_VADDR=>id%OOC_VADDR IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(19),int(dble(MAXS)* & 0.9d0*0.2d0,8)) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(19) SIZE_ZONE_SOLVE=int((dble(MAXS)*0.9d0- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8) ENDIF ELSE SIZE_ZONE_SOLVE=int(dble(MAXS)*0.9d0,8) SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF CMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) SIZE_OF_BLOCK=0_8 ALLOCATE(id%OOC_NB_FILES(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF id%OOC_NB_FILES=0 OOC_VADDR_PTR=0_8 CALL CMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(99), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO ) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 MAX_NB_NODES_FOR_ZONE=0 OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE ALLOCATE(I_CUR_HBUF_NEXTPOS(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF I_CUR_HBUF_NEXTPOS = 1 IF(WITH_BUF)THEN CALL CMUMPS_INIT_OOC_BUF(id%INFO(1),id%INFO(2),IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ENDIF DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) DIM_DIR=len(trim(id%OOC_TMPDIR)) DIM_PREFIX=len(trim(id%OOC_PREFIX)) CALL CMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_DIR(1), & id%OOC_TMPDIR, TMPDIR_MAX_LENGTH, DIM_DIR ) CALL CMUMPS_CONVERT_STR_TO_CHR_ARRAY(TMP_PREFIX(1), & id%OOC_PREFIX, PREFIX_MAX_LENGTH, DIM_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_PREFIX(DIM_PREFIX, TMP_PREFIX) CALL MUMPS_LOW_LEVEL_INIT_TMPDIR(DIM_DIR, TMP_DIR) ALLOCATE(FILE_FLAG_TAB(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1 .GT. 0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_INIT_OOC' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF FILE_FLAG_TAB(1:OOC_NB_FILE_TYPE)=0 IERR=0 TMP=int(id%KEEP8(11)/1000000_8)+1 IF((id%KEEP(201).EQ.1).AND.(id%KEEP(50).EQ.0) & ) THEN TMP=max(1,TMP/2) ENDIF CALL MUMPS_LOW_LEVEL_INIT_OOC_C(MYID_OOC,TMP, & id%KEEP(35),LOW_LEVEL_STRAT_IO,K211_LOC,OOC_NB_FILE_TYPE, & FILE_FLAG_TAB,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0 ) THEN WRITE(ICNTL1,*)MYID_OOC,': PB in MUMPS_LOW_LEVEL_INIT_OOC_C' WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) ENDIF id%INFO(1) = IERR id%INFO(2) = 0 RETURN ENDIF CALL MUMPS_GET_MAX_FILE_SIZE_C(MAX_OOC_FILE_SIZE) DEALLOCATE(FILE_FLAG_TAB) RETURN END SUBROUTINE CMUMPS_OOC_INIT_FACTO SUBROUTINE CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZE,IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) :: LA INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)), SIZE COMPLEX A(LA) INTEGER IERR,NODE,ASYNC,REQUEST LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=FCT IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)=SIZE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,SIZE) OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)=OOC_VADDR_PTR OOC_VADDR_PTR=OOC_VADDR_PTR+SIZE TMP_SIZE_FACT=TMP_SIZE_FACT+SIZE TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE,TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF IF (.NOT. WITH_BUF) THEN CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (37) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 ELSE IF(SIZE.LE.HBUF_SIZE)THEN CALL CMUMPS_OOC_COPY_DATA_TO_BUFFER & (A(PTRFAC(STEP_OOC(INODE))),SIZE,IERR) OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE) = INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) = & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE) + 1 PTRFAC(STEP_OOC(INODE))=-777777_8 RETURN ELSE CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & A(PTRFAC(STEP_OOC(INODE))),SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE).GT.KEEP_OOC(28))THEN WRITE(*,*)MYID_OOC,': Internal error (38) in OOC ' CALL MUMPS_ABORT() ENDIF OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE), & OOC_FCT_TYPE)=INODE I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)= & I_CUR_HBUF_NEXTPOS(OOC_FCT_TYPE)+1 CALL CMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE) ENDIF END IF NODE=-9999 PTRFAC(STEP_OOC(INODE))=-777777_8 IF(STRAT_IO_ASYNC)THEN IERR=0 CALL MUMPS_WAIT_REQUEST(REQUEST,IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_NEW_FACTOR SUBROUTINE CMUMPS_READ_OOC(DEST,INODE,IERR & ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR,INODE COMPLEX DEST INTEGER ASYNC LOGICAL IO_C INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN GOTO 555 ENDIF IF(STRAT_IO_ASYNC)THEN ASYNC=1 ELSE ASYNC=0 ENDIF IERR=0 IO_C=.TRUE. OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_LOW_LEVEL_DIRECT_READ(DEST, & SIZE_INT1,SIZE_INT2, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) WRITE(ICNTL1,*)MYID_OOC, & ': Problem in MUMPS_LOW_LEVEL_DIRECT_READ' ENDIF RETURN ENDIF 555 CONTINUE IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_READ_OOC SUBROUTINE CMUMPS_OOC_CLEAN_PENDING(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out):: IERR IERR=0 IF (WITH_BUF) THEN CALL CMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF RETURN END SUBROUTINE CMUMPS_OOC_CLEAN_PENDING SUBROUTINE CMUMPS_OOC_END_FACTO(id,IERR) USE CMUMPS_OOC_BUFFER USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,SOLVE_OR_FACTO IERR=0 IF(WITH_BUF)THEN CALL CMUMPS_END_OOC_BUF() ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_VADDR))THEN NULLIFY(OOC_VADDR) ENDIF CALL MUMPS_OOC_END_WRITE_C(IERR) IF(IERR.LT.0)THEN IF (ICNTL1 .GT. 0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) GOTO 500 ENDIF id%OOC_MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) IF(allocated(I_CUR_HBUF_NEXTPOS))THEN DO I=1,OOC_NB_FILE_TYPE id%OOC_TOTAL_NB_NODES(I)=I_CUR_HBUF_NEXTPOS(I)-1 ENDDO DEALLOCATE(I_CUR_HBUF_NEXTPOS) ENDIF id%KEEP8(20)=MAX_SIZE_FACTOR_OOC CALL CMUMPS_STRUC_STORE_FILE_NAME(id,IERR) IF(IERR.LT.0)THEN GOTO 500 ENDIF 500 CONTINUE SOLVE_OR_FACTO=0 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_OOC_END_FACTO SUBROUTINE CMUMPS_OOC_CLEAN_FILES(id,IERR) USE CMUMPS_STRUC_DEF IMPLICIT NONE EXTERNAL MUMPS_OOC_REMOVE_FILE_C TYPE(CMUMPS_STRUC), TARGET :: id INTEGER IERR INTEGER I,J,I1,K CHARACTER(len=1):: TMP_NAME(350) IERR=0 K=1 IF(.NOT. id%ASSOCIATED_OOC_FILES) THEN IF(associated(id%OOC_FILE_NAMES).AND. & associated(id%OOC_FILE_NAME_LENGTH))THEN DO I1=1,id%OOC_NB_FILE_TYPE DO I=1,id%OOC_NB_FILES(I1) DO J=1,id%OOC_FILE_NAME_LENGTH(K) TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO CALL MUMPS_OOC_REMOVE_FILE_C(IERR, TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0)THEN WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF ENDIF K=K+1 ENDDO ENDDO ENDIF ENDIF IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF IF(associated(id%OOC_NB_FILES))THEN DEALLOCATE(id%OOC_NB_FILES) NULLIFY(id%OOC_NB_FILES) ENDIF RETURN END SUBROUTINE CMUMPS_OOC_CLEAN_FILES SUBROUTINE CMUMPS_CLEAN_OOC_DATA(id,IERR) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id INTEGER IERR IERR=0 CALL CMUMPS_OOC_CLEAN_FILES(id,IERR) IF(associated(id%OOC_TOTAL_NB_NODES))THEN DEALLOCATE(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_TOTAL_NB_NODES) ENDIF IF(associated(id%OOC_INODE_SEQUENCE))THEN DEALLOCATE(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_INODE_SEQUENCE) ENDIF IF(associated(id%OOC_SIZE_OF_BLOCK))THEN DEALLOCATE(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_SIZE_OF_BLOCK) ENDIF IF(associated(id%OOC_VADDR))THEN DEALLOCATE(id%OOC_VADDR) NULLIFY(id%OOC_VADDR) ENDIF RETURN END SUBROUTINE CMUMPS_CLEAN_OOC_DATA SUBROUTINE CMUMPS_OOC_INIT_SOLVE(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(CMUMPS_STRUC), TARGET :: id INTEGER TMP,I,J INTEGER(8) :: TMP_SIZE8 INTEGER allocok,IERR EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE INTEGER MASTER_ROOT IERR=0 ICNTL1=id%ICNTL(1) SOLVE=.TRUE. N_OOC=id%N IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(associated(KEEP_OOC))THEN NULLIFY(KEEP_OOC) ENDIF IF(associated(STEP_OOC))THEN NULLIFY(STEP_OOC) ENDIF IF(associated(PROCNODE_OOC))THEN NULLIFY(PROCNODE_OOC) ENDIF IF(associated(TOTAL_NB_OOC_NODES))THEN NULLIFY(TOTAL_NB_OOC_NODES) ENDIF IF(associated(SIZE_OF_BLOCK))THEN NULLIFY(SIZE_OF_BLOCK) ENDIF IF(associated(OOC_INODE_SEQUENCE))THEN NULLIFY(OOC_INODE_SEQUENCE) ENDIF OOC_NB_FILE_TYPE=id%OOC_NB_FILE_TYPE CALL MUMPS_OOC_INIT_FILETYPE(TYPEF_L, TYPEF_U, TYPEF_CB, & id%KEEP(201), id%KEEP(251), id%KEEP(50), TYPEF_INVALID ) DIM_ERR_STR_OOC = ERR_STR_OOC_MAX_LEN CALL MUMPS_LOW_LEVEL_INIT_ERR_STR(DIM_ERR_STR_OOC,ERR_STR_OOC) CALL CMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) IF(id%INFO(1).LT.0)THEN RETURN ENDIF STEP_OOC=>id%STEP PROCNODE_OOC=>id%PROCNODE_STEPS SLAVEF_OOC=id%NSLAVES MYID_OOC=id%MYID KEEP_OOC => id%KEEP SIZE_OF_BLOCK=>id%OOC_SIZE_OF_BLOCK OOC_INODE_SEQUENCE=>id%OOC_INODE_SEQUENCE OOC_VADDR=>id%OOC_VADDR ALLOCATE(IO_REQ(id%KEEP(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF CMUMPS_ELEMENTARY_DATA_SIZE = id%KEEP(35) MAX_NB_NODES_FOR_ZONE=id%OOC_MAX_NB_NODES_FOR_ZONE TOTAL_NB_OOC_NODES=>id%OOC_TOTAL_NB_NODES CALL CMUMPS_SET_STRAT_IO_FLAGS( id%KEEP(204), STRAT_IO_ASYNC, & WITH_BUF, LOW_LEVEL_STRAT_IO) IF(id%KEEP(107).GT.0)THEN SIZE_SOLVE_EMM=max(id%KEEP8(20), & FACT_AREA_SIZE / 5_8) SIZE_ZONE_SOLVE=max(SIZE_SOLVE_EMM, & int((dble(FACT_AREA_SIZE)- & dble(SIZE_SOLVE_EMM))/dble(id%KEEP(107)),8)) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) IF(SIZE_ZONE_SOLVE.EQ.SIZE_SOLVE_EMM)THEN SIZE_SOLVE_EMM=id%KEEP8(20) SIZE_ZONE_SOLVE=int((real(FACT_AREA_SIZE)- & real(SIZE_SOLVE_EMM))/real(id%KEEP(107)),8) SIZE_ZONE_SOLVE=max(SIZE_ZONE_SOLVE,0_8) ENDIF ELSE SIZE_ZONE_SOLVE=FACT_AREA_SIZE SIZE_SOLVE_EMM=SIZE_ZONE_SOLVE ENDIF IF(SIZE_SOLVE_EMM.LT.id%KEEP8(20))THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': More space needed for & solution step in CMUMPS_OOC_INIT_SOLVE' id%INFO(1) = -11 CALL MUMPS_SET_IERROR(id%KEEP8(20), id%INFO(2)) ENDIF TMP=MAX_NB_NODES_FOR_ZONE CALL MPI_ALLREDUCE(TMP,MAX_NB_NODES_FOR_ZONE,1, & MPI_INTEGER,MPI_MAX,id%COMM_NODES, IERR) NB_Z=KEEP_OOC(107)+1 ALLOCATE(POS_IN_MEM(MAX_NB_NODES_FOR_ZONE*NB_Z), & INODE_TO_POS(KEEP_OOC(28)), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28)+(MAX_NB_NODES_FOR_ZONE*NB_Z) RETURN ENDIF ALLOCATE(OOC_STATE_NODE(KEEP_OOC(28)),stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = id%KEEP(28) RETURN ENDIF OOC_STATE_NODE(1:KEEP_OOC(28))=0 INODE_TO_POS=0 POS_IN_MEM=0 ALLOCATE(LRLUS_SOLVE(NB_Z), LRLU_SOLVE_T(NB_Z),LRLU_SOLVE_B(NB_Z), & POSFAC_SOLVE(NB_Z),IDEB_SOLVE_Z(NB_Z), & PDEB_SOLVE_Z(NB_Z),SIZE_SOLVE_Z(NB_Z), & CURRENT_POS_T(NB_Z),CURRENT_POS_B(NB_Z), & POS_HOLE_T(NB_Z),POS_HOLE_B(NB_Z), & stat=allocok) IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 9*(NB_Z+1) RETURN ENDIF IERR=0 CALL MUMPS_GET_MAX_NB_REQ_C(MAX_NB_REQ,IERR) ALLOCATE(SIZE_OF_READ(MAX_NB_REQ),FIRST_POS_IN_READ(MAX_NB_REQ), & READ_DEST(MAX_NB_REQ),READ_MNG(MAX_NB_REQ), & REQ_TO_ZONE(MAX_NB_REQ),REQ_ID(MAX_NB_REQ),stat=allocok) SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 IF (allocok .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in CMUMPS_OOC_INIT_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = 6*(NB_Z+1) RETURN ENDIF MIN_SIZE_READ=min(max((1024_8*1024_8)/int(id%KEEP(35),8), & SIZE_ZONE_SOLVE/3_8), & SIZE_ZONE_SOLVE) TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J PDEB_SOLVE_Z(I)=J POS_HOLE_T(I)=J POS_HOLE_B(I)=J J=J+MAX_NB_NODES_FOR_ZONE TMP_SIZE8=TMP_SIZE8+SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z)=J POS_HOLE_B(NB_Z)=J IO_REQ=-77777 REQ_ACT=0 OOC_STATE_NODE(1:KEEP_OOC(28))=NOT_IN_MEM IF(KEEP_OOC(38).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(38))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(38) ELSEIF(KEEP_OOC(20).NE.0)THEN MASTER_ROOT=MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC( KEEP_OOC(20))), & KEEP_OOC(199) ) SPECIAL_ROOT_NODE=KEEP_OOC(20) ELSE MASTER_ROOT=-111111 SPECIAL_ROOT_NODE=-2222222 ENDIF IF ( KEEP_OOC(60).EQ.0 .AND. & ( & (KEEP_OOC(38).NE.0 .AND. id%root%yes) & .OR. & (KEEP_OOC(20).NE.0 .AND. MYID_OOC.EQ.MASTER_ROOT)) & ) & THEN IS_ROOT_SPECIAL = .TRUE. ELSE IS_ROOT_SPECIAL = .FALSE. ENDIF NB_ZONE_REQ=0 SIZE_ZONE_REQ=0_8 CURRENT_SOLVE_READ_ZONE=0 NB_CALLED=0 NB_CALL=0 SOLVE_STEP=-9999 RETURN END SUBROUTINE CMUMPS_OOC_INIT_SOLVE SUBROUTINE CMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER I IERR=0 IF(NB_Z.GT.1)THEN IF(STRAT_IO_ASYNC)THEN DO I=1,NB_Z-1 CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO ELSE CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_INITIATE_READ_OPS SUBROUTINE CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER ZONE CALL CMUMPS_SOLVE_SELECT_ZONE(ZONE) IERR=0 CALL CMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) RETURN END SUBROUTINE CMUMPS_SUBMIT_READ_FOR_Z SUBROUTINE CMUMPS_READ_SOLVE_BLOCK(DEST,INDICE,SIZE, & ZONE,PTRFAC,NSTEPS,POS_SEQ,NB_NODES,FLAG,IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ZONE,NSTEPS,FLAG,POS_SEQ,NB_NODES COMPLEX DEST INTEGER (8) :: INDICE, SIZE, PTRFAC(NSTEPS) INTEGER REQUEST,INODE,IERR INTEGER ADDR_INT1,ADDR_INT2 INTEGER TYPE INTEGER SIZE_INT1,SIZE_INT2 TYPE=OOC_SOLVE_TYPE_FCT IERR=0 INODE=OOC_INODE_SEQUENCE(POS_SEQ,OOC_FCT_TYPE) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & OOC_VADDR(STEP_OOC(INODE),OOC_FCT_TYPE)) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_READ_OOC_C(LOW_LEVEL_STRAT_IO, & DEST,SIZE_INT1,SIZE_INT2, & INODE,REQUEST,TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF IF(STRAT_IO_ASYNC)THEN CALL CMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL CMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,INDICE,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF END SUBROUTINE CMUMPS_READ_SOLVE_BLOCK SUBROUTINE CMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC, & NSTEPS) IMPLICIT NONE INTEGER NSTEPS,REQUEST INTEGER (8) :: PTRFAC(NSTEPS) INTEGER (8) :: LAST, POS_IN_S, J INTEGER ZONE INTEGER POS_REQ,I,TMP_NODE,POS_IN_MANAGE INTEGER (8) SIZE LOGICAL DONT_USE EXTERNAL MUMPS_TYPENODE,MUMPS_PROCNODE INTEGER MUMPS_TYPENODE,MUMPS_PROCNODE POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 SIZE=SIZE_OF_READ(POS_REQ) I=FIRST_POS_IN_READ(POS_REQ) POS_IN_S=READ_DEST(POS_REQ) POS_IN_MANAGE=READ_MNG(POS_REQ) ZONE=REQ_TO_ZONE(POS_REQ) DONT_USE=.FALSE. J=0_8 DO WHILE((J.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN I=I+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0).AND. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).LT. & -((N_OOC+1)*NB_Z)))THEN DONT_USE= & (((MTYPE_OOC.EQ.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.1).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC))) & .OR. & ((MTYPE_OOC.NE.1).AND.(KEEP_OOC(50).EQ.0).AND. & (SOLVE_STEP.EQ.0).AND. & ((MUMPS_TYPENODE(PROCNODE_OOC(STEP_OOC(TMP_NODE)), & KEEP_OOC(199)).EQ.2).AND.(MUMPS_PROCNODE( & PROCNODE_OOC(STEP_OOC(TMP_NODE)),KEEP_OOC(199)).NE. & MYID_OOC)))).OR. & (OOC_STATE_NODE(STEP_OOC(TMP_NODE)).EQ.ALREADY_USED) IF(DONT_USE)THEN PTRFAC(STEP_OOC(TMP_NODE))=-POS_IN_S ELSE PTRFAC(STEP_OOC(TMP_NODE))=POS_IN_S ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).LT. & IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Inernal error (42) in OOC ', & PTRFAC(STEP_OOC(TMP_NODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Inernal error (43) in OOC ' CALL MUMPS_ABORT() ENDIF IF(DONT_USE)THEN POS_IN_MEM(POS_IN_MANAGE)=-TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=-POS_IN_MANAGE IF(OOC_STATE_NODE(STEP_OOC(TMP_NODE)).NE. & ALREADY_USED)THEN OOC_STATE_NODE(STEP_OOC(TMP_NODE))=USED_NOT_PERMUTED ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+LAST ELSE POS_IN_MEM(POS_IN_MANAGE)=TMP_NODE INODE_TO_POS(STEP_OOC(TMP_NODE))=POS_IN_MANAGE OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED ENDIF IO_REQ(STEP_OOC(TMP_NODE))=-7777 ELSE POS_IN_MEM(POS_IN_MANAGE)=0 ENDIF POS_IN_S=POS_IN_S+LAST POS_IN_MANAGE=POS_IN_MANAGE+1 J=J+LAST I=I+1 ENDDO SIZE_OF_READ(POS_REQ)=-9999_8 FIRST_POS_IN_READ(POS_REQ)=-9999 READ_DEST(POS_REQ)=-9999_8 READ_MNG(POS_REQ)=-9999 REQ_TO_ZONE(POS_REQ)=-9999 REQ_ID(POS_REQ)=-9999 RETURN END SUBROUTINE CMUMPS_SOLVE_UPDATE_POINTERS SUBROUTINE CMUMPS_UPDATE_READ_REQ_NODE(INODE,SIZE,DEST,ZONE, & REQUEST,POS_SEQ,NB_NODES,FLAG,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER INODE,ZONE,REQUEST,FLAG,POS_SEQ,NB_NODES,NSTEPS INTEGER(8) :: SIZE INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: DEST, LOCAL_DEST, J8 INTEGER I,TMP_NODE,LOC_I,POS_REQ,NB INTEGER(8)::LAST INTEGER, intent(out) :: IERR IERR=0 IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN RETURN ENDIF NB=0 LOCAL_DEST=DEST I=POS_SEQ POS_REQ=mod(REQUEST,MAX_NB_REQ)+1 IF(REQ_ID(POS_REQ).NE.-9999)THEN CALL MUMPS_WAIT_REQUEST(REQ_ID(POS_REQ),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL CMUMPS_SOLVE_UPDATE_POINTERS(REQUEST,PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ENDIF SIZE_OF_READ(POS_REQ)=SIZE FIRST_POS_IN_READ(POS_REQ)=I READ_DEST(POS_REQ)=DEST IF(FLAG.EQ.0)THEN READ_MNG(POS_REQ)=CURRENT_POS_B(ZONE)-NB_NODES+1 ELSEIF(FLAG.EQ.1)THEN READ_MNG(POS_REQ)=CURRENT_POS_T(ZONE) ENDIF REQ_TO_ZONE(POS_REQ)=ZONE REQ_ID(POS_REQ)=REQUEST J8=0_8 IF(FLAG.EQ.0)THEN LOC_I=CURRENT_POS_B(ZONE)-NB_NODES+1 ENDIF DO WHILE((J8.LT.SIZE).AND.(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))) TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) LAST=SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 CYCLE ENDIF IF((IO_REQ(STEP_OOC(TMP_NODE)).GE.0).OR. & (INODE_TO_POS(STEP_OOC(TMP_NODE)).NE.0))THEN IF(FLAG.EQ.1)THEN POS_IN_MEM(CURRENT_POS_T(ZONE))=0 ELSEIF(FLAG.EQ.0)THEN POS_IN_MEM(CURRENT_POS_B(ZONE))=0 ENDIF ELSE IO_REQ(STEP_OOC(TMP_NODE))=REQUEST LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)-LAST IF(FLAG.EQ.1)THEN IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+LAST LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)-LAST POS_IN_MEM(CURRENT_POS_T(ZONE))=-TMP_NODE- & ((N_OOC+1)*NB_Z) INODE_TO_POS(STEP_OOC(TMP_NODE))=-CURRENT_POS_T(ZONE)- & ((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(FLAG.EQ.0)THEN LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)-LAST POS_IN_MEM(LOC_I)=-TMP_NODE-((N_OOC+1)*NB_Z) IF(LOC_I.EQ.POS_HOLE_T(ZONE))THEN IF(POS_HOLE_T(ZONE).LT.CURRENT_POS_T(ZONE))THEN POS_HOLE_T(ZONE)=POS_HOLE_T(ZONE)+1 ENDIF ENDIF INODE_TO_POS(STEP_OOC(TMP_NODE))=-LOC_I-((N_OOC+1)*NB_Z) OOC_STATE_NODE(STEP_OOC(TMP_NODE))=BEING_READ PTRFAC(STEP_OOC(TMP_NODE))=-LOCAL_DEST LOCAL_DEST=LOCAL_DEST+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE WRITE(*,*)MYID_OOC,': Internal error (39) in OOC ', & ' Invalid Flag Value in ', & ' CMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).NE.0)THEN IF(POS_IN_MEM(CURRENT_POS_T(ZONE)).EQ. & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))THEN IF(CURRENT_POS_T(ZONE).NE.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (40) in OOC ', & CURRENT_POS_T(ZONE), & PDEB_SOLVE_Z(ZONE), & POS_IN_MEM(CURRENT_POS_T(ZONE)), & POS_IN_MEM(PDEB_SOLVE_Z(ZONE)) CALL MUMPS_ABORT() ENDIF ENDIF ENDIF J8=J8+LAST IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (41) in OOC ', & ' LRLUS_SOLVE must be (1) > 0', & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF I=I+1 IF(FLAG.EQ.1)THEN CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 IF(CURRENT_POS_T(ZONE).GT. & MAX_NB_NODES_FOR_ZONE+PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (1) in OOC ' CALL MUMPS_ABORT() ENDIF POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ELSEIF(FLAG.EQ.0)THEN IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (2) in OOC ', & POS_HOLE_B(ZONE),LOC_I CALL MUMPS_ABORT() ENDIF CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) IF(POS_HOLE_B(ZONE).LT.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (3) in OOC ', & ' Invalid Flag Value in ', & ' CMUMPS_UPDATE_READ_REQ_NODE',FLAG CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LOC_I=LOC_I+1 ENDIF NB=NB+1 ENDDO IF(NB.NE.NB_NODES)THEN WRITE(*,*)MYID_OOC,': Internal error (4) in OOC ', & ' CMUMPS_UPDATE_READ_REQ_NODE ',NB,NB_NODES ENDIF IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=I ELSE CUR_POS_SEQUENCE=POS_SEQ-1 ENDIF RETURN END SUBROUTINE CMUMPS_UPDATE_READ_REQ_NODE SUBROUTINE CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,NSTEPS,A, & LA,FLAG,IERR) IMPLICIT NONE INTEGER(8) :: LA INTEGER, intent(out):: IERR COMPLEX A(LA) INTEGER INODE,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL FLAG INTEGER(8) FREE_SIZE INTEGER TMP,TMP_NODE,I,ZONE,J, FREE_HOLE_FLAG INTEGER WHICH INTEGER(8) :: DUMMY_SIZE DUMMY_SIZE=1_8 IERR = 0 WHICH=-1 IF(INODE_TO_POS(STEP_OOC(INODE)).LE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (5) in OOC ', & ' Problem in CMUMPS_FREE_FACTORS_FOR_SOLVE', & INODE, STEP_OOC(INODE), INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE).EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=0 OOC_STATE_NODE(STEP_OOC(INODE))=ALREADY_USED RETURN ENDIF CALL CMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) TMP=INODE_TO_POS(STEP_OOC(INODE)) INODE_TO_POS(STEP_OOC(INODE))=-TMP POS_IN_MEM(TMP)=-INODE PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF (KEEP_OOC(237).eq.0) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.PERMUTED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (53) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=USED LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (6) in OOC ', & ': LRLUS_SOLVE must be (2) > 0' CALL MUMPS_ABORT() ENDIF IF(ZONE.EQ.NB_Z)THEN IF(INODE.NE.SPECIAL_ROOT_NODE)THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & DUMMY_SIZE,PTRFAC,KEEP_OOC(28),ZONE,IERR) ENDIF ELSE FREE_HOLE_FLAG=0 IF(SOLVE_STEP.EQ.0)THEN IF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ELSEIF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(TMP.LT.POS_HOLE_T(ZONE))THEN WHICH=1 ELSEIF(TMP.GT.POS_HOLE_B(ZONE))THEN WHICH=0 ENDIF ENDIF IF(WHICH.EQ.1)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN GOTO 666 ENDIF ENDDO POS_HOLE_T(ZONE)=TMP 666 CONTINUE ELSEIF(WHICH.EQ.0)THEN J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE=0_8 DO I=J,TMP IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN IF(J.EQ.PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 CURRENT_POS_B(ZONE)=-9999 ENDIF GOTO 777 ENDIF ENDDO POS_HOLE_B(ZONE)=TMP 777 CONTINUE ENDIF IERR=0 ENDIF IF((NB_Z.GT.1).AND.FLAG)THEN CALL CMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IF((LRLUS_SOLVE(ZONE).GE.MIN_SIZE_READ).OR. & (LRLUS_SOLVE(ZONE).GE. & int(0.3E0*real(SIZE_SOLVE_Z(ZONE)),8)))THEN CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC,NSTEPS,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ELSE CALL CMUMPS_SOLVE_SELECT_ZONE(ZONE) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_FREE_FACTORS_FOR_SOLVE FUNCTION CMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC,NSTEPS,A,LA, & IERR) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER(8) :: LA INTEGER, INTENT(out)::IERR COMPLEX A(LA) INTEGER (8) :: PTRFAC(NSTEPS) INTEGER CMUMPS_SOLVE_IS_INODE_IN_MEM IERR=0 IF(INODE_TO_POS(STEP_OOC(INODE)).GT.0)THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE) & .EQ.INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ELSEIF(INODE_TO_POS(STEP_OOC(INODE)).LT.0)THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT.-((N_OOC+1)*NB_Z))THEN CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(INODE)),IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': Internal error (7) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF CALL CMUMPS_SOLVE_UPDATE_POINTERS(IO_REQ(STEP_OOC(INODE)), & PTRFAC,NSTEPS) REQ_ACT=REQ_ACT-1 ELSE CALL CMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE,OOC_FCT_TYPE).EQ. & INODE)THEN IF(SOLVE_STEP.EQ.0)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ELSEIF(SOLVE_STEP.EQ.1)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() ENDIF ENDIF ENDIF IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.PERMUTED)THEN CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_PERMUTED ELSE CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_PERMUTED ENDIF ELSE CMUMPS_SOLVE_IS_INODE_IN_MEM=OOC_NODE_NOT_IN_MEM ENDIF RETURN END FUNCTION CMUMPS_SOLVE_IS_INODE_IN_MEM SUBROUTINE CMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) IMPLICIT NONE INTEGER INODE IF ( (KEEP_OOC(237).EQ.0) & .AND. (KEEP_OOC(235).EQ.0) ) THEN IF(OOC_STATE_NODE(STEP_OOC(INODE)).NE.NOT_USED)THEN WRITE(*,*)MYID_OOC,': INTERNAL ERROR (51) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF ENDIF OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED END SUBROUTINE CMUMPS_SOLVE_MODIFY_STATE_NODE SUBROUTINE CMUMPS_SOLVE_UPD_NODE_INFO(INODE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE INODE_TO_POS(STEP_OOC(INODE))=-INODE_TO_POS(STEP_OOC(INODE)) POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE)))= & -POS_IN_MEM(INODE_TO_POS(STEP_OOC(INODE))) PTRFAC(STEP_OOC(INODE))=-PTRFAC(STEP_OOC(INODE)) IF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED_NOT_PERMUTED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED ELSEIF(OOC_STATE_NODE(STEP_OOC(INODE)).EQ.USED)THEN OOC_STATE_NODE(STEP_OOC(INODE))=PERMUTED ELSE WRITE(*,*)MYID_OOC,': Internal error (52) in OOC',INODE, & OOC_STATE_NODE(STEP_OOC(INODE)), & INODE_TO_POS(STEP_OOC(INODE)) CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(INODE_TO_POS(STEP_OOC(INODE)).LE.POS_HOLE_B(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).GT. & PDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)= & INODE_TO_POS(STEP_OOC(INODE))-1 ELSE CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF ENDIF IF(INODE_TO_POS(STEP_OOC(INODE)).GE.POS_HOLE_T(ZONE))THEN IF(INODE_TO_POS(STEP_OOC(INODE)).LT. & CURRENT_POS_T(ZONE)-1)THEN POS_HOLE_T(ZONE)=INODE_TO_POS(STEP_OOC(INODE))+1 ELSE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) ENDIF ENDIF CALL CMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,1) END SUBROUTINE CMUMPS_SOLVE_UPD_NODE_INFO SUBROUTINE CMUMPS_SOLVE_FIND_ZONE(INODE,ZONE,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER INODE,ZONE,NSTEPS INTEGER (8) :: PTRFAC(NSTEPS) ZONE=1 DO WHILE (ZONE.LE.NB_Z) IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN ZONE=ZONE-1 EXIT ENDIF ZONE=ZONE+1 ENDDO IF(ZONE.EQ.NB_Z+1)THEN ZONE=ZONE-1 ENDIF END SUBROUTINE CMUMPS_SOLVE_FIND_ZONE SUBROUTINE CMUMPS_SOLVE_TRY_ZONE_FOR_READ(ZONE) IMPLICIT NONE INTEGER ZONE ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1)+1 END SUBROUTINE CMUMPS_SOLVE_TRY_ZONE_FOR_READ SUBROUTINE CMUMPS_SOLVE_SELECT_ZONE(ZONE) IMPLICIT NONE INTEGER ZONE IF(NB_Z.GT.1)THEN CURRENT_SOLVE_READ_ZONE=mod((CURRENT_SOLVE_READ_ZONE+1),NB_Z-1) ZONE=CURRENT_SOLVE_READ_ZONE+1 ELSE ZONE=NB_Z ENDIF END SUBROUTINE CMUMPS_SOLVE_SELECT_ZONE SUBROUTINE CMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8, & A,IERR) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER, intent(out)::IERR INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A(FACT_AREA_SIZE) INTEGER(8) :: REQUESTED_SIZE INTEGER ZONE,IFLAG IERR=0 IFLAG=0 IF(SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) & .EQ.0_8)THEN INODE_TO_POS(STEP_OOC(INODE))=1 OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED PTRFAC(STEP_OOC(INODE))=1_8 RETURN ENDIF REQUESTED_SIZE=SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ZONE=NB_Z IF(CURRENT_POS_T(ZONE).GT. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1))THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF((LRLU_SOLVE_T(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE)).AND. & (CURRENT_POS_T(ZONE).LE. & (PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(LRLU_SOLVE_B(ZONE).GT.SIZE_OF_BLOCK(STEP_OOC(INODE), & OOC_FCT_TYPE).AND. & (CURRENT_POS_B(ZONE).GT.0))THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSE IF(CMUMPS_IS_THERE_FREE_SPACE(INODE,ZONE))THEN IF(SOLVE_STEP.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ELSE CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ELSEIF(IFLAG.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC, & KEEP(28),ZONE,IFLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IF(IFLAG.EQ.1)THEN CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ENDIF ENDIF IF(IFLAG.EQ.0)THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & REQUESTED_SIZE,PTRFAC,KEEP(28),ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8,A,ZONE) ENDIF ELSE WRITE(*,*)MYID_OOC,': Internal error (8) in OOC ', & ' Not enough space for Solve',INODE, & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (9) in OOC ', & ' LRLUS_SOLVE must be (3) > 0' CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_ALLOC_FACTOR_SPACE SUBROUTINE CMUMPS_GET_TOP_AREA_SPACE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER(8) :: REQUESTED_SIZE, LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: FREE_SIZE, FREE_HOLE, FREE_HOLE_POS COMPLEX A(LA) INTEGER I,TMP_NODE,FREE_HOLE_FLAG, J INTEGER, intent(out)::IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE).AND. & (.NOT.(CURRENT_POS_T(ZONE) & .GT.PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1)))THEN GOTO 50 ENDIF J=max(POS_HOLE_B(ZONE),PDEB_SOLVE_Z(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) DO I=POS_HOLE_T(ZONE)-1,J,-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_T(ZONE)=I+1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=POSFAC_SOLVE(ZONE) DO I=CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),-1 IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE))) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED POS_IN_MEM(I)=0 FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).EQ.0)THEN FREE_HOLE_FLAG=1 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (10) in OOC ', & ' CMUMPS_GET_TOP_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_T(ZONE),I CALL MUMPS_ABORT() ENDIF ENDDO IF(POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE))THEN IF(FREE_HOLE_FLAG.EQ.0)THEN FREE_HOLE_FLAG=1 ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_T(ZONE)-1.GT.PDEB_SOLVE_Z(ZONE))THEN I=POS_HOLE_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (11) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,PDEB_SOLVE_Z(ZONE),-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (12) in OOC ', & ' CMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.GE.PDEB_SOLVE_Z(ZONE))THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (13) in OOC', & ' CMUMPS_GET_TOP_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=FREE_HOLE_POS- & (abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDIF ELSE FREE_HOLE=FREE_HOLE_POS-IDEB_SOLVE_Z(ZONE) ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF CURRENT_POS_T(ZONE)=POS_HOLE_T(ZONE) LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+FREE_SIZE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-FREE_SIZE 50 CONTINUE IF(REQUESTED_SIZE.LE.LRLU_SOLVE_T(ZONE))THEN FLAG=1 ELSE FLAG=0 ENDIF RETURN END SUBROUTINE CMUMPS_GET_TOP_AREA_SPACE SUBROUTINE CMUMPS_GET_BOTTOM_AREA_SPACE(A,LA,REQUESTED_SIZE, & PTRFAC,NSTEPS,ZONE,FLAG,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE,FLAG INTEGER (8) :: REQUESTED_SIZE INTEGER (8) :: LA INTEGER (8) :: PTRFAC(NSTEPS) COMPLEX A(LA) INTEGER(8) :: FREE_SIZE, FREE_HOLE_POS, FREE_HOLE INTEGER I,J,TMP_NODE,FREE_HOLE_FLAG INTEGER, intent(out) :: IERR IERR=0 FLAG=0 IF(LRLU_SOLVE_B(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN GOTO 50 ENDIF IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF J=max(PDEB_SOLVE_Z(ZONE),POS_HOLE_T(ZONE)) J=min(J,PDEB_SOLVE_Z(ZONE)+MAX_NB_NODES_FOR_ZONE-1) FREE_SIZE = 0_8 DO I=POS_HOLE_B(ZONE)+1,J IF((POS_IN_MEM(I).LT.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(I).NE.0)THEN EXIT ENDIF ENDDO POS_HOLE_B(ZONE)=I-1 IF((POS_HOLE_T(ZONE).EQ.PDEB_SOLVE_Z(ZONE)).OR. & (POS_HOLE_T(ZONE).LE.POS_HOLE_B(ZONE)).OR. & (POS_HOLE_T(ZONE).EQ.POS_HOLE_B(ZONE)+1))THEN CURRENT_POS_B(ZONE)=-9999 POS_HOLE_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_T(ZONE)=PDEB_SOLVE_Z(ZONE) ENDIF FREE_HOLE=0_8 FREE_SIZE=0_8 FREE_HOLE_FLAG=0 FREE_HOLE_POS=IDEB_SOLVE_Z(ZONE) IF(POS_HOLE_B(ZONE).EQ.-9999)THEN GOTO 50 ENDIF DO I=PDEB_SOLVE_Z(ZONE),POS_HOLE_B(ZONE) IF((POS_IN_MEM(I).LE.0).AND.(POS_IN_MEM(I).GT. & -(N_OOC+1)*NB_Z))THEN TMP_NODE=-POS_IN_MEM(I) IF(TMP_NODE.NE.0)THEN IF(I.EQ.PDEB_SOLVE_Z(ZONE))THEN IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE. & IDEB_SOLVE_Z(ZONE))THEN FREE_SIZE=FREE_SIZE+abs(PTRFAC(STEP_OOC(TMP_NODE))) & -IDEB_SOLVE_Z(ZONE) ENDIF ENDIF IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=-777777_8 INODE_TO_POS(STEP_OOC(TMP_NODE))=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED FREE_SIZE=FREE_SIZE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) ELSE FREE_HOLE_FLAG=1 ENDIF POS_IN_MEM(I)=0 ELSEIF(POS_IN_MEM(I).NE.0)THEN WRITE(*,*)MYID_OOC,': Internal error (14) in OOC ', & ' CMUMPS_GET_BOTTOM_AREA_SPACE', & CURRENT_POS_T(ZONE)-1,POS_HOLE_B(ZONE),I,POS_IN_MEM(I) CALL MUMPS_ABORT() ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN IF(POS_HOLE_B(ZONE)+1.LT.CURRENT_POS_T(ZONE)-1)THEN I=POS_HOLE_B(ZONE)+1 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.(N_OOC+1)*NB_Z)THEN TMP_NODE=TMP_NODE-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (15) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))-FREE_HOLE_POS ELSEIF(TMP_NODE.EQ.0)THEN DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).NE.0) EXIT ENDDO IF(POS_IN_MEM(J).LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (16) in OOC ', & ' CMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF(J.LE.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(J) FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF ELSEIF(TMP_NODE.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (17) in OOC ', & ' CMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ELSE FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS ENDIF ELSE FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS ENDIF FREE_SIZE=FREE_SIZE+FREE_HOLE ENDIF LRLU_SOLVE_B(ZONE)=FREE_SIZE IF(POS_HOLE_B(ZONE).LT.CURRENT_POS_T(ZONE)-1)THEN TMP_NODE=POS_IN_MEM(POS_HOLE_B(ZONE)+1) IF(TMP_NODE.LT.-(N_OOC+1)*NB_Z)THEN TMP_NODE=abs(TMP_NODE)-(N_OOC+1)*NB_Z CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID_OOC,': Internal error (18) in OOC ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) CALL MUMPS_ABORT() RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ENDIF LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)+ & (abs(PTRFAC(STEP_OOC(abs(TMP_NODE))))-IDEB_SOLVE_Z(ZONE)- & LRLU_SOLVE_B(ZONE)) ENDIF CURRENT_POS_B(ZONE)=POS_HOLE_B(ZONE) 50 CONTINUE IF((POS_HOLE_B(ZONE).EQ.-9999).AND. & (LRLU_SOLVE_B(ZONE).NE.0_8))THEN WRITE(*,*)MYID_OOC,': Internal error (19) in OOC ', & 'CMUMPS_GET_BOTTOM_AREA_SPACE' CALL MUMPS_ABORT() ENDIF IF((REQUESTED_SIZE.LE.LRLU_SOLVE_B(ZONE)).AND. & (POS_HOLE_B(ZONE).NE.-9999))THEN FLAG=1 ELSE FLAG=0 ENDIF END SUBROUTINE CMUMPS_GET_BOTTOM_AREA_SPACE SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_T(INODE,PTRFAC, & KEEP,KEEP8, A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A(FACT_AREA_SIZE) INTEGER ZONE LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=POSFAC_SOLVE(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(POSFAC_SOLVE(ZONE).EQ.IDEB_SOLVE_Z(ZONE))THEN POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 ENDIF IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (20) in OOC ', & ' Problem avec debut (2)',INODE, & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE),ZONE CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_T(ZONE) POS_IN_MEM(CURRENT_POS_T(ZONE))=INODE IF(CURRENT_POS_T(ZONE).GT.(PDEB_SOLVE_Z(ZONE)+ & MAX_NB_NODES_FOR_ZONE-1))THEN WRITE(*,*)MYID_OOC,': Internal error (21) in OOC ', & ' Problem with CURRENT_POS_T', & CURRENT_POS_T(ZONE),ZONE CALL MUMPS_ABORT() ENDIF CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)+1 POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) END SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_T SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_B(INODE,PTRFAC, & KEEP,KEEP8, & A,ZONE) IMPLICIT NONE INTEGER INODE,KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A(FACT_AREA_SIZE) INTEGER ZONE IF(POS_HOLE_B(ZONE).EQ.-9999)THEN WRITE(*,*)MYID_OOC,': Internal error (22) in OOC ', & ' CMUMPS_SOLVE_ALLOC_PTR_UPD_B' CALL MUMPS_ABORT() ENDIF LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) LRLU_SOLVE_B(ZONE)=LRLU_SOLVE_B(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(INODE))=IDEB_SOLVE_Z(ZONE)+ & LRLU_SOLVE_B(ZONE) OOC_STATE_NODE(STEP_OOC(INODE))=NOT_USED IF(PTRFAC(STEP_OOC(INODE)).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (23) in OOC ', & PTRFAC(STEP_OOC(INODE)),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF INODE_TO_POS(STEP_OOC(INODE))=CURRENT_POS_B(ZONE) IF(CURRENT_POS_B(ZONE).EQ.0)THEN WRITE(*,*)MYID_OOC,': Internal error (23b) in OOC ' CALL MUMPS_ABORT() ENDIF POS_IN_MEM(CURRENT_POS_B(ZONE))=INODE CURRENT_POS_B(ZONE)=CURRENT_POS_B(ZONE)-1 POS_HOLE_B(ZONE)=CURRENT_POS_B(ZONE) END SUBROUTINE CMUMPS_SOLVE_ALLOC_PTR_UPD_B SUBROUTINE CMUMPS_FREE_SPACE_FOR_SOLVE(A,LA,REQUESTED_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IMPLICIT NONE INTEGER(8) :: LA, REQUESTED_SIZE INTEGER NSTEPS,ZONE INTEGER, intent(out) :: IERR INTEGER(8) :: PTRFAC(NSTEPS) COMPLEX A(LA) INTEGER (8) :: APOS_FIRST_FREE, & SIZE_HOLE, & FREE_HOLE, & FREE_HOLE_POS INTEGER J,I,TMP_NODE, NB_FREE, IPOS_FIRST_FREE INTEGER(8) :: K8, AREA_POINTER INTEGER FREE_HOLE_FLAG IERR=0 IF(LRLU_SOLVE_T(ZONE).EQ.SIZE_SOLVE_Z(ZONE))THEN RETURN ENDIF AREA_POINTER=IDEB_SOLVE_Z(ZONE) SIZE_HOLE=0_8 DO I=PDEB_SOLVE_Z(ZONE),CURRENT_POS_T(ZONE)-1 IF((POS_IN_MEM(I).LE.0).AND. & (POS_IN_MEM(I).GT.-((N_OOC+1)*NB_Z))) GOTO 666 TMP_NODE=abs(POS_IN_MEM(I)) IF(TMP_NODE.GT.((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) ENDIF AREA_POINTER=AREA_POINTER+ & abs(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ENDDO 666 CONTINUE IF((I.EQ.CURRENT_POS_T(ZONE)-1).AND. & (PDEB_SOLVE_Z(ZONE).NE.CURRENT_POS_T(ZONE)-1))THEN IF((POS_IN_MEM(I).GT.0).OR. & (POS_IN_MEM(I).LT.-((N_OOC+1)*NB_Z)))THEN WRITE(*,*)MYID_OOC,': Internal error (25) in OOC ', & ': There are no free blocks ', & 'in CMUMPS_FREE_SPACE_FOR_SOLVE',PDEB_SOLVE_Z(ZONE), & CURRENT_POS_T(ZONE) CALL MUMPS_ABORT() ENDIF ENDIF IF(POS_IN_MEM(I).EQ.0)THEN APOS_FIRST_FREE=AREA_POINTER FREE_HOLE_POS=AREA_POINTER ELSE TMP_NODE=abs(POS_IN_MEM(I)) APOS_FIRST_FREE=abs(PTRFAC(STEP_OOC(TMP_NODE))) ENDIF IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).NE.0)THEN IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)))- & ((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) ELSE TMP_NODE=abs(POS_IN_MEM(PDEB_SOLVE_Z(ZONE))) ENDIF IF(abs(PTRFAC(STEP_OOC(TMP_NODE))).NE.IDEB_SOLVE_Z(ZONE))THEN IF((POS_IN_MEM(I).NE.0).OR.(I.EQ.CURRENT_POS_T(ZONE)))THEN SIZE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & IDEB_SOLVE_Z(ZONE) ENDIF APOS_FIRST_FREE=IDEB_SOLVE_Z(ZONE) IF(POS_IN_MEM(PDEB_SOLVE_Z(ZONE)).GT.0)THEN DO J=PDEB_SOLVE_Z(ZONE),I-1 TMP_NODE=POS_IN_MEM(J) IF(TMP_NODE.LE.0)THEN IF(TMP_NODE.LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=abs(POS_IN_MEM(J))-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST( & IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=POS_IN_MEM(J) ELSE WRITE(*,*)MYID_OOC,': Internal error (26) in OOC ', & ' CMUMPS_FREE_SPACE_FOR_SOLVE',TMP_NODE, & J,I-1,(N_OOC+1)*NB_Z CALL MUMPS_ABORT() ENDIF ENDIF DO K8=1_8, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ENDDO ENDIF ENDIF ENDIF NB_FREE=0 FREE_HOLE=0_8 FREE_HOLE_FLAG=0 DO J=I,CURRENT_POS_T(ZONE)-1 TMP_NODE=abs(POS_IN_MEM(J)) IF(POS_IN_MEM(J).LT.-((N_OOC+1)*NB_Z))THEN TMP_NODE=TMP_NODE-((N_OOC+1)*NB_Z) CALL MUMPS_WAIT_REQUEST(IO_REQ(STEP_OOC(TMP_NODE)),IERR) IF(IERR.LT.0)THEN RETURN ENDIF REQ_ACT=REQ_ACT-1 CALL CMUMPS_SOLVE_UPDATE_POINTERS( & IO_REQ(STEP_OOC(TMP_NODE)),PTRFAC,NSTEPS) TMP_NODE=abs(POS_IN_MEM(J)) ENDIF IF(POS_IN_MEM(J).GT.0)THEN DO K8=1_8,SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) A(APOS_FIRST_FREE+K8-1_8)= & A(PTRFAC(STEP_OOC(TMP_NODE))+K8-1_8) ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) PTRFAC(STEP_OOC(TMP_NODE))=APOS_FIRST_FREE APOS_FIRST_FREE=APOS_FIRST_FREE+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) ELSEIF(POS_IN_MEM(J).EQ.0)THEN FREE_HOLE_FLAG=1 NB_FREE=NB_FREE+1 ELSE NB_FREE=NB_FREE+1 IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=abs(PTRFAC(STEP_OOC(TMP_NODE)))- & FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF FREE_HOLE_POS=abs(PTRFAC(STEP_OOC(TMP_NODE)))+ & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) SIZE_HOLE=SIZE_HOLE+SIZE_OF_BLOCK(STEP_OOC(TMP_NODE), & OOC_FCT_TYPE) PTRFAC(STEP_OOC(abs(POS_IN_MEM(J))))=-77777_8 ENDIF ENDDO IF(FREE_HOLE_FLAG.EQ.1)THEN FREE_HOLE=POSFAC_SOLVE(ZONE)-FREE_HOLE_POS FREE_HOLE_FLAG=0 SIZE_HOLE=SIZE_HOLE+FREE_HOLE ENDIF IPOS_FIRST_FREE=I DO J=I,CURRENT_POS_T(ZONE)-1 IF(POS_IN_MEM(J).LT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) INODE_TO_POS(STEP_OOC(TMP_NODE))=0 POS_IN_MEM(J)=0 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=ALREADY_USED ELSEIF(POS_IN_MEM(J).GT.0)THEN TMP_NODE=abs(POS_IN_MEM(J)) POS_IN_MEM(IPOS_FIRST_FREE)=POS_IN_MEM(J) INODE_TO_POS(STEP_OOC(TMP_NODE))=IPOS_FIRST_FREE IPOS_FIRST_FREE=IPOS_FIRST_FREE+1 ENDIF ENDDO LRLU_SOLVE_T(ZONE)=LRLU_SOLVE_T(ZONE)+SIZE_HOLE POSFAC_SOLVE(ZONE)=POSFAC_SOLVE(ZONE)-SIZE_HOLE CURRENT_POS_T(ZONE)=CURRENT_POS_T(ZONE)-NB_FREE POS_HOLE_T(ZONE)=CURRENT_POS_T(ZONE) LRLU_SOLVE_B(ZONE)=0_8 POS_HOLE_B(ZONE)=-9999 CURRENT_POS_B(ZONE)=-9999 LRLU_SOLVE_B(ZONE)=0_8 IF(LRLU_SOLVE_T(ZONE).NE.LRLUS_SOLVE(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (27) in OOC ', & LRLU_SOLVE_T(ZONE), & LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF LRLU_SOLVE_T(ZONE)=LRLUS_SOLVE(ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (28) in OOC ', & ' LRLUS_SOLVE must be (4) > 0' CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).LT.IDEB_SOLVE_Z(ZONE))THEN WRITE(*,*)MYID_OOC,': Internal error (29) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).NE.(IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE)))THEN WRITE(*,*)MYID_OOC,': Internal error (30) in OOC ', & ' Problem avec debut POSFAC_SOLVE', & POSFAC_SOLVE(ZONE),(SIZE_SOLVE_Z(ZONE)- & LRLUS_SOLVE(ZONE))+IDEB_SOLVE_Z(ZONE),LRLUS_SOLVE(ZONE) CALL MUMPS_ABORT() ENDIF IF(POSFAC_SOLVE(ZONE).GT. & (IDEB_SOLVE_Z(ZONE)+SIZE_SOLVE_Z(ZONE)-1_8))THEN WRITE(*,*)MYID_OOC,': Internal error (31) in OOC ', & POSFAC_SOLVE(ZONE),IDEB_SOLVE_Z(ZONE)+ & SIZE_SOLVE_Z(ZONE)-1_8 CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE CMUMPS_FREE_SPACE_FOR_SOLVE SUBROUTINE CMUMPS_OOC_UPDATE_SOLVE_STAT(INODE,PTRFAC,NSTEPS,FLAG) IMPLICIT NONE INTEGER INODE,NSTEPS,FLAG INTEGER (8) :: PTRFAC(NSTEPS) INTEGER ZONE IF((FLAG.LT.0).OR.(FLAG.GT.1))THEN WRITE(*,*)MYID_OOC,': Internal error (32) in OOC ', & ' CMUMPS_OOC_UPDATE_SOLVE_STAT' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SEARCH_SOLVE(PTRFAC(STEP_OOC(INODE)),ZONE) IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (33) in OOC ', & ' LRLUS_SOLVE must be (5) ++ > 0' CALL MUMPS_ABORT() ENDIF IF(FLAG.EQ.0)THEN LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)+ & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ELSE LRLUS_SOLVE(ZONE)=LRLUS_SOLVE(ZONE)- & SIZE_OF_BLOCK(STEP_OOC(INODE),OOC_FCT_TYPE) ENDIF IF(LRLUS_SOLVE(ZONE).LT.0_8)THEN WRITE(*,*)MYID_OOC,': Internal error (34) in OOC ', & ' LRLUS_SOLVE must be (5) > 0' CALL MUMPS_ABORT() ENDIF END SUBROUTINE CMUMPS_OOC_UPDATE_SOLVE_STAT SUBROUTINE CMUMPS_SEARCH_SOLVE(ADDR,ZONE) IMPLICIT NONE INTEGER (8) :: ADDR INTEGER ZONE INTEGER I I=1 DO WHILE (I.LE.NB_Z) IF(ADDR.LT.IDEB_SOLVE_Z(I))THEN EXIT ENDIF I=I+1 ENDDO ZONE=I-1 END SUBROUTINE CMUMPS_SEARCH_SOLVE FUNCTION CMUMPS_SOLVE_IS_END_REACHED() IMPLICIT NONE LOGICAL CMUMPS_SOLVE_IS_END_REACHED CMUMPS_SOLVE_IS_END_REACHED=.FALSE. IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.GT.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN CMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.LT.1)THEN CMUMPS_SOLVE_IS_END_REACHED=.TRUE. ENDIF ENDIF RETURN END FUNCTION CMUMPS_SOLVE_IS_END_REACHED SUBROUTINE CMUMPS_SOLVE_ZONE_READ(ZONE,A,LA,PTRFAC,NSTEPS,IERR) IMPLICIT NONE INTEGER NSTEPS,ZONE INTEGER(8), INTENT(IN) :: LA INTEGER, intent(out) :: IERR COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) INTEGER(8) :: SIZE, DEST INTEGER(8) :: NEEDED_SIZE INTEGER FLAG,TMP_FLAG,POS_SEQ,TMP_NODE, & NB_NODES IERR=0 TMP_FLAG=0 FLAG=0 IF(CMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF IF(SOLVE_STEP.EQ.0)THEN IF(CUR_POS_SEQUENCE.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 IF(CMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ELSEIF(SOLVE_STEP.EQ.1)THEN IF(CUR_POS_SEQUENCE.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE(SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE).GT. & SIZE_SOLVE_Z(ZONE)) CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 IF(CMUMPS_SOLVE_IS_END_REACHED())THEN RETURN ENDIF TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) ENDDO CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() NEEDED_SIZE=max(MIN_SIZE_READ, & SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE)) ELSE NEEDED_SIZE=MIN_SIZE_READ ENDIF ENDIF IF(LRLUS_SOLVE(ZONE).LT.NEEDED_SIZE)THEN RETURN ELSEIF((LRLU_SOLVE_T(ZONE).LT.NEEDED_SIZE).AND. & (LRLU_SOLVE_B(ZONE).LT.NEEDED_SIZE).AND. & (dble(LRLUS_SOLVE(ZONE)).LT.0.3d0* & dble(SIZE_SOLVE_Z(ZONE)))) THEN RETURN ENDIF IF((LRLU_SOLVE_T(ZONE).GT.NEEDED_SIZE).AND.(SOLVE_STEP.EQ.0).AND. & ((CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1).LT. & MAX_NB_NODES_FOR_ZONE))THEN FLAG=1 ELSE IF(SOLVE_STEP.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 IF(TMP_FLAG.EQ.0)THEN CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 ENDIF ELSE CALL CMUMPS_GET_BOTTOM_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=0 IF(TMP_FLAG.EQ.0)THEN CALL CMUMPS_GET_TOP_AREA_SPACE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,TMP_FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF IF(TMP_FLAG.EQ.0)THEN CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,FACT_AREA_SIZE, & NEEDED_SIZE,PTRFAC,NSTEPS,ZONE,IERR) IF(IERR.LT.0)THEN RETURN ENDIF FLAG=1 ENDIF ENDIF CALL CMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IF(SIZE.EQ.0_8)THEN RETURN ENDIF NB_ZONE_REQ=NB_ZONE_REQ+1 SIZE_ZONE_REQ=SIZE_ZONE_REQ+SIZE REQ_ACT=REQ_ACT+1 CALL CMUMPS_READ_SOLVE_BLOCK(A(DEST),DEST,SIZE,ZONE,PTRFAC,NSTEPS, & POS_SEQ,NB_NODES,FLAG,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END SUBROUTINE CMUMPS_SOLVE_ZONE_READ SUBROUTINE CMUMPS_SOLVE_COMPUTE_READ_SIZE(ZONE,SIZE,DEST,POS_SEQ, & NB_NODES,FLAG,PTRFAC,NSTEPS) IMPLICIT NONE INTEGER(8) :: SIZE, DEST INTEGER ZONE,FLAG,POS_SEQ,NSTEPS INTEGER(8) :: PTRFAC(NSTEPS), MAX_SIZE, LAST, J8 INTEGER I,START_NODE,K,MAX_NB, & NB_NODES INTEGER NB_NODES_LOC LOGICAL ALREADY IF(CMUMPS_SOLVE_IS_END_REACHED())THEN SIZE=0_8 RETURN ENDIF IF(FLAG.EQ.0)THEN MAX_SIZE=LRLU_SOLVE_B(ZONE) MAX_NB=max(0,CURRENT_POS_B(ZONE)-PDEB_SOLVE_Z(ZONE)+1) ELSEIF(FLAG.EQ.1)THEN MAX_SIZE=LRLU_SOLVE_T(ZONE) MAX_NB=MAX_NB_NODES_FOR_ZONE ELSE WRITE(*,*)MYID_OOC,': Internal error (35) in OOC ', & ' Unknown Flag value in ', & ' CMUMPS_SOLVE_COMPUTE_READ_SIZE',FLAG CALL MUMPS_ABORT() ENDIF CALL CMUMPS_OOC_SKIP_NULL_SIZE_NODE() I=CUR_POS_SEQUENCE START_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ALREADY=.FALSE. NB_NODES=0 NB_NODES_LOC=0 IF(ZONE.EQ.NB_Z)THEN SIZE=SIZE_OF_BLOCK(STEP_OOC(START_NODE),OOC_FCT_TYPE) ELSE J8=0_8 IF(FLAG.EQ.0)THEN K=0 ELSEIF(FLAG.EQ.1)THEN K=CURRENT_POS_T(ZONE)-PDEB_SOLVE_Z(ZONE)+1 ENDIF IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE DO WHILE(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I+1 ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND. & (I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (K.LT.MAX_NB) ) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC+1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE+1 I=I+1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I+1 K=K+1 NB_NODES_LOC=NB_NODES_LOC+1 NB_NODES=NB_NODES+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF DO WHILE (CUR_POS_SEQUENCE+NB_NODES_LOC-1.GE. & CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE+NB_NODES-1, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE ELSEIF(SOLVE_STEP.EQ.1)THEN DO WHILE(I.GE.1) IF(SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) & .NE.0_8)THEN EXIT ENDIF I=I-1 ENDDO CUR_POS_SEQUENCE=max(I,1) I=CUR_POS_SEQUENCE DO WHILE((J8.LE.MAX_SIZE).AND.(I.GE.1).AND. & (K.LT.MAX_NB)) LAST=SIZE_OF_BLOCK(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE)), & OOC_FCT_TYPE) IF(LAST.EQ.0_8)THEN IF(.NOT.ALREADY)THEN CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 ENDIF NB_NODES_LOC=NB_NODES_LOC+1 I=I-1 CYCLE ENDIF IF((INODE_TO_POS(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))) & .NE.0).OR. & (IO_REQ(STEP_OOC(OOC_INODE_SEQUENCE(I, & OOC_FCT_TYPE))).GE. & 0))THEN IF(.NOT.ALREADY)THEN I=I-1 CUR_POS_SEQUENCE=CUR_POS_SEQUENCE-1 CYCLE ELSE EXIT ENDIF ENDIF ALREADY=.TRUE. J8=J8+LAST I=I-1 K=K+1 NB_NODES=NB_NODES+1 NB_NODES_LOC=NB_NODES_LOC+1 ENDDO IF(J8.GT.MAX_SIZE)THEN SIZE=J8-LAST NB_NODES=NB_NODES-1 NB_NODES_LOC=NB_NODES_LOC-1 ELSE SIZE=J8 ENDIF I=CUR_POS_SEQUENCE-NB_NODES_LOC+1 DO WHILE (I.LE.CUR_POS_SEQUENCE) IF(SIZE_OF_BLOCK(STEP_OOC( & OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE)), & OOC_FCT_TYPE).NE.0_8)THEN EXIT ENDIF I=I+1 NB_NODES_LOC=NB_NODES_LOC-1 ENDDO POS_SEQ=CUR_POS_SEQUENCE-NB_NODES_LOC+1 ENDIF ENDIF IF(FLAG.EQ.0)THEN DEST=IDEB_SOLVE_Z(ZONE)+LRLU_SOLVE_B(ZONE)-SIZE ELSE DEST=POSFAC_SOLVE(ZONE) ENDIF END SUBROUTINE CMUMPS_SOLVE_COMPUTE_READ_SIZE SUBROUTINE CMUMPS_OOC_END_SOLVE(IERR) IMPLICIT NONE INTEGER SOLVE_OR_FACTO INTEGER, intent(out) :: IERR IERR=0 IF(allocated(LRLUS_SOLVE))THEN DEALLOCATE(LRLUS_SOLVE) ENDIF IF(allocated(LRLU_SOLVE_T))THEN DEALLOCATE(LRLU_SOLVE_T) ENDIF IF(allocated(LRLU_SOLVE_B))THEN DEALLOCATE(LRLU_SOLVE_B) ENDIF IF(allocated(POSFAC_SOLVE))THEN DEALLOCATE(POSFAC_SOLVE) ENDIF IF(allocated(IDEB_SOLVE_Z))THEN DEALLOCATE(IDEB_SOLVE_Z) ENDIF IF(allocated(PDEB_SOLVE_Z))THEN DEALLOCATE(PDEB_SOLVE_Z) ENDIF IF(allocated(SIZE_SOLVE_Z))THEN DEALLOCATE(SIZE_SOLVE_Z) ENDIF IF(allocated(CURRENT_POS_T))THEN DEALLOCATE(CURRENT_POS_T) ENDIF IF(allocated(CURRENT_POS_B))THEN DEALLOCATE(CURRENT_POS_B) ENDIF IF(allocated(POS_HOLE_T))THEN DEALLOCATE(POS_HOLE_T) ENDIF IF(allocated(POS_HOLE_B))THEN DEALLOCATE(POS_HOLE_B) ENDIF IF(allocated(OOC_STATE_NODE))THEN DEALLOCATE(OOC_STATE_NODE) ENDIF IF(allocated(POS_IN_MEM))THEN DEALLOCATE(POS_IN_MEM) ENDIF IF(allocated(INODE_TO_POS))THEN DEALLOCATE(INODE_TO_POS) ENDIF IF(allocated(IO_REQ))THEN DEALLOCATE(IO_REQ) ENDIF IF(allocated(SIZE_OF_READ))THEN DEALLOCATE(SIZE_OF_READ) ENDIF IF(allocated(FIRST_POS_IN_READ))THEN DEALLOCATE(FIRST_POS_IN_READ) ENDIF IF(allocated(READ_DEST))THEN DEALLOCATE(READ_DEST) ENDIF IF(allocated(READ_MNG))THEN DEALLOCATE(READ_MNG) ENDIF IF(allocated(REQ_TO_ZONE))THEN DEALLOCATE(REQ_TO_ZONE) ENDIF IF(allocated(REQ_ID))THEN DEALLOCATE(REQ_ID) ENDIF SOLVE_OR_FACTO=1 CALL MUMPS_CLEAN_IO_DATA_C(MYID_OOC,SOLVE_OR_FACTO,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF END SUBROUTINE CMUMPS_OOC_END_SOLVE SUBROUTINE CMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS, & A,LA) IMPLICIT NONE INTEGER, INTENT(in) :: NSTEPS INTEGER(8), INTENT(INOUT) :: PTRFAC(NSTEPS) INTEGER(8), INTENT(IN) :: LA COMPLEX :: A(LA) INTEGER :: I, TMP, ZONE, IPAS, IBEG, IEND INTEGER(8) :: SAVE_PTR LOGICAL :: COMPRESS_TO_BE_DONE, SET_POS_SEQUENCE INTEGER :: J, IERR INTEGER(8) :: DUMMY_SIZE COMPRESS_TO_BE_DONE = .FALSE. DUMMY_SIZE = 1_8 IERR = 0 SET_POS_SEQUENCE = .TRUE. IF(SOLVE_STEP.EQ.0)THEN IBEG = 1 IEND = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IPAS = 1 ELSE IBEG = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) IEND = 1 IPAS = -1 ENDIF DO I=IBEG,IEND,IPAS J = OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) TMP=INODE_TO_POS(STEP_OOC(J)) IF(TMP.EQ.0)THEN IF (SET_POS_SEQUENCE) THEN SET_POS_SEQUENCE = .FALSE. CUR_POS_SEQUENCE = I ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN OOC_STATE_NODE(STEP_OOC(J)) = NOT_IN_MEM ENDIF CYCLE ELSE IF(TMP.LT.0)THEN IF(TMP.GT.-(N_OOC+1)*NB_Z)THEN SAVE_PTR=PTRFAC(STEP_OOC(J)) PTRFAC(STEP_OOC(J)) = abs(SAVE_PTR) CALL CMUMPS_SOLVE_FIND_ZONE(J, & ZONE,PTRFAC,NSTEPS) PTRFAC(STEP_OOC(J)) = SAVE_PTR IF(ZONE.EQ.NB_Z)THEN IF(J.NE.SPECIAL_ROOT_NODE)THEN WRITE(*,*)MYID_OOC,': Internal error 6 ', & ' Node ', J, & ' is in status USED in the & emmergency buffer ' CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (OOC_STATE_NODE(STEP_OOC(J)).EQ.NOT_IN_MEM) THEN OOC_STATE_NODE(STEP_OOC(J)) = USED IF((SOLVE_STEP.NE.0).AND.(J.NE.SPECIAL_ROOT_NODE) & .AND.(ZONE.NE.NB_Z))THEN CALL CMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF CYCLE ELSEIF(OOC_STATE_NODE(STEP_OOC(J)).EQ.USED) & THEN COMPRESS_TO_BE_DONE = .TRUE. ELSE WRITE(*,*)MYID_OOC,': Internal error Mila 4 ', & ' wrong node status :', OOC_STATE_NODE(STEP_OOC(J)), & ' on node ', J CALL MUMPS_ABORT() ENDIF ENDIF IF (KEEP_OOC(237).EQ.0 .AND. KEEP_OOC(235).EQ.0) THEN CALL CMUMPS_SOLVE_UPD_NODE_INFO(J,PTRFAC,NSTEPS) ENDIF ENDIF ENDIF ENDDO IF (KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0) & THEN IF (COMPRESS_TO_BE_DONE) THEN DO ZONE=1,NB_Z-1 CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,ZONE,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error Mila 5 ', & ' IERR on return to CMUMPS_FREE_SPACE_FOR_SOLVE =', & IERR CALL MUMPS_ABORT() ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_PREPARE_PREF SUBROUTINE CMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,NSTEPS,MTYPE, & A,LA,DOPREFETCH,IERR) IMPLICIT NONE INTEGER NSTEPS,MTYPE INTEGER, intent(out)::IERR INTEGER(8) :: LA COMPLEX A(LA) INTEGER(8) :: PTRFAC(NSTEPS) LOGICAL DOPREFETCH INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR = 0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("F",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) THEN OOC_SOLVE_TYPE_FCT = FCT ENDIF SOLVE_STEP=0 CUR_POS_SEQUENCE=1 MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL CMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) ELSE CALL CMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) ENDIF IF (DOPREFETCH) THEN CALL CMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC, & KEEP_OOC(28),IERR) ELSE CUR_POS_SEQUENCE = TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_INIT_OOC_FWD SUBROUTINE CMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,NSTEPS,MTYPE, & I_WORKED_ON_ROOT,IROOT,A,LA,IERR) IMPLICIT NONE INTEGER NSTEPS INTEGER(8) :: LA INTEGER(8) :: PTRFAC(NSTEPS) INTEGER MTYPE INTEGER IROOT LOGICAL I_WORKED_ON_ROOT INTEGER, intent(out):: IERR COMPLEX A(LA) INTEGER(8) :: DUMMY_SIZE INTEGER ZONE INTEGER MUMPS_OOC_GET_FCT_TYPE EXTERNAL MUMPS_OOC_GET_FCT_TYPE IERR=0 OOC_FCT_TYPE=MUMPS_OOC_GET_FCT_TYPE("B",MTYPE,KEEP_OOC(201), & KEEP_OOC(50)) OOC_SOLVE_TYPE_FCT = OOC_FCT_TYPE - 1 IF (KEEP_OOC(201).NE.1) OOC_SOLVE_TYPE_FCT=FCT SOLVE_STEP=1 CUR_POS_SEQUENCE=TOTAL_NB_OOC_NODES(OOC_FCT_TYPE) MTYPE_OOC=MTYPE IF ( KEEP_OOC(201).NE.1 & .OR. KEEP_OOC(50).NE.0 & ) THEN CALL CMUMPS_SOLVE_PREPARE_PREF(PTRFAC,NSTEPS,A,LA) IF (I_WORKED_ON_ROOT.AND. $ ((IROOT.GT.0)))THEN IF(SIZE_OF_BLOCK(STEP_OOC(IROOT),OOC_FCT_TYPE).NE.0) THEN IF (.NOT.(KEEP_OOC(237).NE.0 .OR. KEEP_OOC(235).NE.0)) & THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE ( IROOT, & PTRFAC, KEEP_OOC(28), A, LA,.FALSE.,IERR) IF (IERR .LT. 0) RETURN ENDIF CALL CMUMPS_SOLVE_FIND_ZONE(IROOT, & ZONE,PTRFAC,NSTEPS) IF(ZONE.EQ.NB_Z)THEN DUMMY_SIZE=1_8 CALL CMUMPS_FREE_SPACE_FOR_SOLVE(A,LA, & DUMMY_SIZE,PTRFAC, & NSTEPS,NB_Z,IERR) IF (IERR .LT. 0) THEN WRITE(*,*)MYID_OOC,': Internal error in & CMUMPS_FREE_SPACE_FOR_SOLVE', & IERR CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF IF (NB_Z.GT.1) THEN CALL CMUMPS_SUBMIT_READ_FOR_Z(A,LA,PTRFAC, & KEEP_OOC(28),IERR) IF (IERR .LT. 0) RETURN ENDIF ELSE CALL CMUMPS_SOLVE_STAT_REINIT_PANEL(KEEP_OOC(28), & KEEP_OOC(38), KEEP_OOC(20) ) CALL CMUMPS_INITIATE_READ_OPS(A,LA,PTRFAC,KEEP_OOC(28),IERR) IF (IERR .LT. 0 ) RETURN ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_INIT_OOC_BWD SUBROUTINE CMUMPS_STRUC_STORE_FILE_NAME(id,IERR) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id INTEGER, intent(out) :: IERR INTEGER I,DIM,J,TMP,SIZE,K,I1 CHARACTER(len=1):: TMP_NAME(350) EXTERNAL MUMPS_OOC_GET_NB_FILES_C, MUMPS_OOC_GET_FILE_NAME_C IERR=0 SIZE=0 DO J=1,OOC_NB_FILE_TYPE TMP=J-1 CALL MUMPS_OOC_GET_NB_FILES_C(TMP,I) id%OOC_NB_FILES(J)=I SIZE=SIZE+I ENDDO IF(associated(id%OOC_FILE_NAMES))THEN DEALLOCATE(id%OOC_FILE_NAMES) NULLIFY(id%OOC_FILE_NAMES) ENDIF ALLOCATE(id%OOC_FILE_NAMES(SIZE,350),stat=IERR) IF (IERR .GT. 0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'CMUMPS_STRUC_STORE_FILE_NAME' ENDIF IERR=-1 IF(id%INFO(1).GE.0)THEN id%INFO(1) = -13 id%INFO(2) = SIZE*350 RETURN ENDIF ENDIF IF(associated(id%OOC_FILE_NAME_LENGTH))THEN DEALLOCATE(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAME_LENGTH) ENDIF ALLOCATE(id%OOC_FILE_NAME_LENGTH(SIZE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0) THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in CMUMPS_STRUC_STORE_FILE_NAME' ENDIF id%INFO(1) = -13 id%INFO(2) = SIZE RETURN ENDIF ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE TMP=I1-1 DO I=1,id%OOC_NB_FILES(I1) CALL MUMPS_OOC_GET_FILE_NAME_C(TMP,I,DIM,TMP_NAME(1)) DO J=1,DIM+1 id%OOC_FILE_NAMES(K,J)=TMP_NAME(J) ENDDO id%OOC_FILE_NAME_LENGTH(K)=DIM+1 K=K+1 ENDDO ENDDO END SUBROUTINE CMUMPS_STRUC_STORE_FILE_NAME SUBROUTINE CMUMPS_OOC_OPEN_FILES_FOR_SOLVE(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC), TARGET :: id CHARACTER(len=1):: TMP_NAME(350) INTEGER I,I1,TMP,J,K,L,DIM,IERR INTEGER, DIMENSION(:),ALLOCATABLE :: NB_FILES INTEGER K211 ALLOCATE(NB_FILES(OOC_NB_FILE_TYPE),stat=IERR) IF (IERR .GT. 0) THEN IERR=-1 IF(id%INFO(1).GE.0)THEN IF (ICNTL1.GT.0) THEN WRITE(ICNTL1,*) & 'PB allocation in CMUMPS_OOC_OPEN_FILES_FOR_SOLVE' ENDIF id%INFO(1) = -13 id%INFO(2) = OOC_NB_FILE_TYPE RETURN ENDIF ENDIF IERR=0 NB_FILES=id%OOC_NB_FILES I=id%MYID K=id%KEEP(35) L=mod(id%KEEP(204),3) K211=id%KEEP(211) CALL MUMPS_OOC_ALLOC_POINTERS_C(OOC_NB_FILE_TYPE,NB_FILES,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF CALL MUMPS_OOC_INIT_VARS_C(I,K,L,K211,IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=1 DO I1=1,OOC_NB_FILE_TYPE DO I=1,NB_FILES(I1) DIM=id%OOC_FILE_NAME_LENGTH(K) DO J=1,DIM TMP_NAME(J)=id%OOC_FILE_NAMES(K,J) ENDDO TMP=I1-1 CALL MUMPS_OOC_SET_FILE_NAME_C(TMP,I,DIM,IERR,TMP_NAME(1)) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ', & ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF K=K+1 ENDDO ENDDO CALL MUMPS_OOC_START_LOW_LEVEL(IERR) IF(IERR.LT.0)THEN IF (ICNTL1.GT.0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) id%INFO(1)=IERR RETURN ENDIF DEALLOCATE(NB_FILES) RETURN END SUBROUTINE CMUMPS_OOC_OPEN_FILES_FOR_SOLVE SUBROUTINE CMUMPS_CONVERT_STR_TO_CHR_ARRAY(DEST,SRC,NB,NB_EFF) IMPLICIT NONE INTEGER NB, NB_EFF CHARACTER(LEN=NB):: SRC CHARACTER(len=1):: DEST(NB) INTEGER I DO I=1,NB_EFF DEST(I)=SRC(I:I) ENDDO END SUBROUTINE CMUMPS_CONVERT_STR_TO_CHR_ARRAY SUBROUTINE CMUMPS_FORCE_WRITE_BUF(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF CALL CMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE,IERR) IF (IERR < 0) THEN RETURN ENDIF RETURN END SUBROUTINE CMUMPS_FORCE_WRITE_BUF SUBROUTINE CMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER I IERR=0 IF(.NOT.WITH_BUF)THEN RETURN ENDIF DO I=1,OOC_NB_FILE_TYPE CALL CMUMPS_OOC_DO_IO_AND_CHBUF(I,IERR) IF (IERR < 0) RETURN ENDDO RETURN END SUBROUTINE CMUMPS_OOC_FORCE_WRT_BUF_PANEL SUBROUTINE CMUMPS_SOLVE_STAT_REINIT_PANEL(NSTEPS, & KEEP38, KEEP20) IMPLICIT NONE INTEGER NSTEPS INTEGER I, J INTEGER(8) :: TMP_SIZE8 INTEGER KEEP38, KEEP20 INODE_TO_POS = 0 POS_IN_MEM = 0 OOC_STATE_NODE(1:NSTEPS)=0 TMP_SIZE8=1_8 J=1 DO I=1,NB_Z-1 IDEB_SOLVE_Z(I)=TMP_SIZE8 PDEB_SOLVE_Z(I)=J POSFAC_SOLVE(I)=TMP_SIZE8 LRLUS_SOLVE(I) =SIZE_ZONE_SOLVE LRLU_SOLVE_T(I)=SIZE_ZONE_SOLVE LRLU_SOLVE_B(I)=0_8 SIZE_SOLVE_Z(I)=SIZE_ZONE_SOLVE CURRENT_POS_T(I)=J CURRENT_POS_B(I)=J POS_HOLE_T(I) =J POS_HOLE_B(I) =J J = J + MAX_NB_NODES_FOR_ZONE TMP_SIZE8 = TMP_SIZE8 + SIZE_ZONE_SOLVE ENDDO IDEB_SOLVE_Z(NB_Z)=TMP_SIZE8 PDEB_SOLVE_Z(NB_Z)=J POSFAC_SOLVE(NB_Z)=TMP_SIZE8 LRLUS_SOLVE(NB_Z) =SIZE_SOLVE_EMM LRLU_SOLVE_T(NB_Z)=SIZE_SOLVE_EMM LRLU_SOLVE_B(NB_Z)=0_8 SIZE_SOLVE_Z(NB_Z)=SIZE_SOLVE_EMM CURRENT_POS_T(NB_Z)=J CURRENT_POS_B(NB_Z)=J POS_HOLE_T(NB_Z) =J POS_HOLE_B(NB_Z) =J IO_REQ=-77777 SIZE_OF_READ=-9999_8 FIRST_POS_IN_READ=-9999 READ_DEST=-9999_8 READ_MNG=-9999 REQ_TO_ZONE=-9999 REQ_ID=-9999 RETURN END SUBROUTINE CMUMPS_SOLVE_STAT_REINIT_PANEL SUBROUTINE CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, & MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, & UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER(8) :: TMPSIZE_OF_BLOCK INTEGER :: TempFTYPE LOGICAL WRITE_L, WRITE_U LOGICAL DO_U_FIRST INCLUDE 'mumps_headers.h' IERR = 0 IF (KEEP_OOC(50).EQ.0 & .AND.KEEP_OOC(251).EQ.2) THEN WRITE_L = .FALSE. ELSE WRITE_L = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_L) ENDIF WRITE_U = (TYPEFile.EQ.TYPEF_BOTH_LU .OR. TYPEFile.EQ.TYPEF_U) DO_U_FIRST = .FALSE. IF ( TYPEFile.EQ.TYPEF_BOTH_LU ) THEN IF ( LNextPiv2beWritten .GT. UNextPiv2beWritten ) THEN DO_U_FIRST = .TRUE. END IF END IF IF (DO_U_FIRST) GOTO 200 100 IF (WRITE_L .AND. TYPEF_L > 0 ) THEN TempFTYPE = TYPEF_L IF ((MonBloc%Typenode.EQ.2).AND.(.NOT.MonBloc%MASTER)) & THEN TMPSIZE_OF_BLOCK = SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE), & TempFTYPE) IF (TMPSIZE_OF_BLOCK .LT. 0_8) THEN TMPSIZE_OF_BLOCK = -TMPSIZE_OF_BLOCK - 1_8 ENDIF LNextPiv2beWritten = & int( & TMPSIZE_OF_BLOCK & / int(MonBloc%NROW,8) & ) & + 1 ENDIF CALL CMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & LNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL ) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 300 ENDIF 200 IF (WRITE_U) THEN TempFTYPE = TYPEF_U CALL CMUMPS_OOC_STORE_LorU( STRAT, & TempFTYPE, AFAC, LAFAC, MonBloc, & IERR, & UNextPiv2beWritten, & OOC_VADDR(STEP_OOC(MonBloc%INODE),TempFTYPE), & SIZE_OF_BLOCK(STEP_OOC(MonBloc%INODE),TempFTYPE), & FILESIZE, LAST_CALL) IF (IERR .LT. 0) RETURN IF (DO_U_FIRST) GOTO 100 ENDIF 300 CONTINUE RETURN END SUBROUTINE CMUMPS_OOC_IO_LU_PANEL SUBROUTINE CMUMPS_OOC_STORE_LorU( STRAT, TYPEF, & AFAC, LAFAC, MonBloc, & IERR, & LorU_NextPiv2beWritten, & LorU_AddVirtNodeI8, LorUSIZE_OF_BLOCK, & FILESIZE, LAST_CALL & ) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT INTEGER, INTENT(IN) :: TYPEF INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER(8), INTENT(IN) :: LAFAC COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LorU_NextPiv2beWritten INTEGER(8), INTENT(INOUT) :: LorU_AddVirtNodeI8 INTEGER(8), INTENT(INOUT) :: LorUSIZE_OF_BLOCK TYPE(IO_BLOCK), INTENT(INOUT) :: MonBloc INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL INTEGER NNMAX INTEGER(8) :: TOTSIZE, EFFSIZE INTEGER(8) :: TailleEcrite INTEGER SIZE_PANEL INTEGER(8) :: AddVirtCour LOGICAL VIRT_ADD_RESERVED_BEF_CALL LOGICAL VIRTUAL_ADDRESS_JUST_RESERVED LOGICAL HOLE_PROCESSED_BEFORE_CALL LOGICAL TMP_ESTIM INTEGER ICUR, INODE_CUR, ILAST INTEGER(8) :: ADDR_LAST IERR = 0 IF (TYPEF == TYPEF_L ) THEN NNMAX = MonBloc%NROW ELSE NNMAX = MonBloc%NCOL ENDIF SIZE_PANEL = CMUMPS_OOC_PANEL_SIZE(NNMAX) IF ( (.NOT.MonBloc%Last) .AND. & (MonBloc%LastPiv-LorU_NextPiv2beWritten+1.LT.SIZE_PANEL)) & THEN RETURN ENDIF TMP_ESTIM = .TRUE. TOTSIZE = CMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%NFS, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) IF (MonBloc%Last) THEN TMP_ESTIM=.FALSE. EFFSIZE = CMUMPS_OOC_NBENTRIES_PANEL_123 & (MonBloc%LastPiv, NNMAX, SIZE_PANEL, MonBloc, TMP_ESTIM) ELSE EFFSIZE = -1034039740327_8 ENDIF IF (MonBloc%Typenode.EQ.3.AND. MonBloc%NFS.NE.MonBloc%NCOL) THEN WRITE(*,*) 'Internal error in CMUMPS_OOC_STORE_LorU for type3', & MonBloc%NFS,MonBloc%NCOL CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.3.AND. TYPEF.NE.TYPEF_L) THEN WRITE(*,*) 'Internal error in CMUMPS_OOC_STORE_LorU,TYPEF=', & TYPEF, 'for typenode=3' CALL MUMPS_ABORT() ENDIF IF (MonBloc%Typenode.EQ.2.AND. & TYPEF.EQ.TYPEF_U.AND. & .NOT. MonBloc%MASTER ) THEN WRITE(*,*) 'Internal error in CMUMPS_OOC_STORE_LorU', & MonBloc%MASTER,MonBloc%Typenode, TYPEF CALL MUMPS_ABORT() ENDIF HOLE_PROCESSED_BEFORE_CALL = (LorUSIZE_OF_BLOCK .LT. 0_8) IF (HOLE_PROCESSED_BEFORE_CALL.AND.(.NOT.MonBloc%Last)) THEN WRITE(6,*) ' Internal error in CMUMPS_OOC_STORE_LorU ', & ' last is false after earlier calls with last=true' CALL MUMPS_ABORT() ENDIF IF (HOLE_PROCESSED_BEFORE_CALL) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 TOTSIZE = -99999999_8 ENDIF VIRTUAL_ADDRESS_JUST_RESERVED = .FALSE. VIRT_ADD_RESERVED_BEF_CALL = & ( LorUSIZE_OF_BLOCK .NE. 0_8 .OR. & HOLE_PROCESSED_BEFORE_CALL ) IF (MonBloc%Last .AND. .NOT. HOLE_PROCESSED_BEFORE_CALL) THEN KEEP_OOC(228) = max(KEEP_OOC(228), & (MonBloc%LastPiv+SIZE_PANEL-1) / SIZE_PANEL) IF (VIRT_ADD_RESERVED_BEF_CALL) THEN IF (AddVirtLibre(TYPEF).EQ. & (LorU_AddVirtNodeI8+TOTSIZE) ) THEN AddVirtLibre(TYPEF) = LorU_AddVirtNodeI8 + EFFSIZE ENDIF ELSE VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. IF (EFFSIZE .EQ. 0_8) THEN LorU_AddVirtNodeI8 = -9999_8 ELSE LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) ENDIF AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + EFFSIZE ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL & ) THEN LorU_AddVirtNodeI8 = AddVirtLibre(TYPEF) AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) + TOTSIZE ENDIF ENDIF AddVirtCour = LorU_AddVirtNodeI8 + LorUSIZE_OF_BLOCK CALL CMUMPS_OOC_WRT_IN_PANELS_LorU( STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & LorU_NextPiv2beWritten, AddVirtCour, & TailleEcrite, & IERR ) IF ( IERR .LT. 0 ) RETURN LorUSIZE_OF_BLOCK = LorUSIZE_OF_BLOCK + TailleEcrite IF (LorUSIZE_OF_BLOCK.EQ.0_8 ) THEN IF ( .NOT. VIRT_ADD_RESERVED_BEF_CALL & .AND. .NOT. VIRTUAL_ADDRESS_JUST_RESERVED ) & THEN AddVirtLibre(TYPEF) = AddVirtLibre(TYPEF) - TOTSIZE LorU_AddVirtNodeI8 = 0_8 ENDIF ELSE IF (.NOT. VIRT_ADD_RESERVED_BEF_CALL ) THEN VIRTUAL_ADDRESS_JUST_RESERVED = .TRUE. ENDIF IF ( VIRTUAL_ADDRESS_JUST_RESERVED) THEN OOC_INODE_SEQUENCE(I_CUR_HBUF_NEXTPOS(TYPEF), & TYPEF) = MonBloc%INODE I_CUR_HBUF_NEXTPOS(TYPEF) = I_CUR_HBUF_NEXTPOS(TYPEF) + 1 IF (MonBloc%Last) THEN MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,EFFSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+EFFSIZE ELSE MAX_SIZE_FACTOR_OOC=max(MAX_SIZE_FACTOR_OOC,TOTSIZE) TMP_SIZE_FACT=TMP_SIZE_FACT+TOTSIZE ENDIF TMP_NB_NODES=TMP_NB_NODES+1 IF(TMP_SIZE_FACT.GT.SIZE_ZONE_SOLVE)THEN MAX_NB_NODES_FOR_ZONE=max(MAX_NB_NODES_FOR_ZONE, & TMP_NB_NODES) TMP_SIZE_FACT=0_8 TMP_NB_NODES=0 ENDIF ENDIF IF (MonBloc%Last) THEN LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ENDIF IF (LAST_CALL) THEN IF (.NOT.MonBloc%Last) THEN WRITE(6,*) ' Internal error in CMUMPS_OOC_STORE_LorU ', & ' LAST and LAST_CALL are incompatible ' CALL MUMPS_ABORT() ENDIF LorUSIZE_OF_BLOCK = - LorUSIZE_OF_BLOCK - 1_8 ICUR = I_CUR_HBUF_NEXTPOS(TYPEF) - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) ADDR_LAST = AddVirtLibre(TYPEF) IF ( INODE_CUR .NE. MonBloc%INODE .AND. & OOC_VADDR(STEP_OOC(MonBloc%INODE),TYPEF) .NE. -9999 ) THEN 10 CONTINUE ILAST = ICUR IF ( OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) .NE. -9999_8) THEN ADDR_LAST = OOC_VADDR(STEP_OOC(INODE_CUR), TYPEF) ENDIF ICUR = ICUR - 1 INODE_CUR = OOC_INODE_SEQUENCE(ICUR,TYPEF) IF (INODE_CUR .EQ. MonBloc%INODE) THEN LorUSIZE_OF_BLOCK = ADDR_LAST - & OOC_VADDR(STEP_OOC(INODE_CUR),TYPEF) ELSE IF (ICUR .LE. 1) THEN WRITE(*,*) "Internal error in CMUMPS_OOC_STORE_LorU" WRITE(*,*) "Did not find current node in sequence" CALL MUMPS_ABORT() ENDIF GOTO 10 ENDIF ENDIF FILESIZE = FILESIZE + LorUSIZE_OF_BLOCK ENDIF RETURN END SUBROUTINE CMUMPS_OOC_STORE_LorU SUBROUTINE CMUMPS_OOC_WRT_IN_PANELS_LorU( & STRAT, TYPEF, MonBloc, & SIZE_PANEL, & AFAC, LAFAC, & NextPiv2beWritten, AddVirtCour, & TailleEcrite, IERR ) USE CMUMPS_OOC_BUFFER IMPLICIT NONE INTEGER, INTENT(IN) :: STRAT, TYPEF, SIZE_PANEL INTEGER(8) :: LAFAC INTEGER(8), INTENT(IN) :: AddVirtCour COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: NextPiv2beWritten TYPE(IO_BLOCK),INTENT(INOUT) :: MonBloc INTEGER(8), INTENT(OUT) :: TailleEcrite INTEGER, INTENT(OUT) :: IERR INTEGER :: I, NBeff, LPANELeff, IEND INTEGER(8) :: AddVirtDeb IERR = 0 TailleEcrite = 0_8 AddVirtDeb = AddVirtCour I = NextPiv2beWritten IF ( NextPiv2beWritten .GT. MonBloc%LastPiv ) THEN RETURN ENDIF 10 CONTINUE NBeff = min(SIZE_PANEL,MonBloc%LastPiv-I+1 ) IF ((NBeff.NE.SIZE_PANEL) .AND. (.NOT.MonBloc%Last)) THEN GOTO 20 ENDIF IF (TYPEF.EQ.TYPEF_L.AND.MonBloc%MASTER.AND. & KEEP_OOC(50).EQ.2 .AND. MonBloc%Typenode.NE.3) THEN IF (MonBloc%INDICES(NBeff+I-1) < 0) & THEN NBeff=NBeff+1 ENDIF ENDIF IEND = I + NBeff -1 CALL CMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtDeb, I, IEND, LPANELeff, & IERR) IF ( IERR .LT. 0 ) THEN RETURN ENDIF IF ( IERR .EQ. 1 ) THEN IERR=0 GOTO 20 ENDIF IF (TYPEF .EQ. TYPEF_L) THEN MonBloc%LastPanelWritten_L = MonBloc%LastPanelWritten_L+1 ELSE MonBloc%LastPanelWritten_U = MonBloc%LastPanelWritten_U+1 ENDIF AddVirtDeb = AddVirtDeb + int(LPANELeff,8) TailleEcrite = TailleEcrite + int(LPANELeff,8) I=I+NBeff IF ( I .LE. MonBloc%LastPiv ) GOTO 10 20 CONTINUE NextPiv2beWritten = I RETURN END SUBROUTINE CMUMPS_OOC_WRT_IN_PANELS_LorU INTEGER(8) FUNCTION CMUMPS_OOC_NBENTRIES_PANEL_123 & (NFSorNPIV, NNMAX, SIZE_PANEL, MonBloc, ESTIM) IMPLICIT NONE TYPE(IO_BLOCK), INTENT(IN):: MonBloc INTEGER, INTENT(IN) :: NFSorNPIV, NNMAX, SIZE_PANEL LOGICAL, INTENT(IN) :: ESTIM INTEGER :: I, NBeff INTEGER(8) :: TOTSIZE TOTSIZE = 0_8 IF (NFSorNPIV.EQ.0) GOTO 100 IF (.NOT. MonBloc%MASTER .OR. MonBloc%Typenode.EQ.3) THEN TOTSIZE = int(NFSorNPIV,8) * int(NNMAX,8) ELSE I = 1 10 CONTINUE NBeff = min(SIZE_PANEL, NFSorNPIV-I+1) IF (KEEP_OOC(50).EQ.2) THEN IF (ESTIM) THEN NBeff = NBeff + 1 ELSE IF (MonBloc%INDICES(I+NBeff-1) < 0) THEN NBeff = NBeff + 1 ENDIF ENDIF ENDIF TOTSIZE = TOTSIZE + & int(NNMAX-I+1,8) * int(NBeff,8) I = I + NBeff IF ( I .LE. NFSorNPIV ) GOTO 10 ENDIF 100 CONTINUE CMUMPS_OOC_NBENTRIES_PANEL_123 = TOTSIZE RETURN END FUNCTION CMUMPS_OOC_NBENTRIES_PANEL_123 INTEGER FUNCTION CMUMPS_OOC_PANEL_SIZE( NNMAX ) IMPLICIT NONE INTEGER, INTENT(IN) :: NNMAX INTEGER CMUMPS_OOC_GET_PANEL_SIZE CMUMPS_OOC_PANEL_SIZE=CMUMPS_OOC_GET_PANEL_SIZE( & int(KEEP_OOC(223),8), NNMAX, KEEP_OOC(227),KEEP_OOC(50)) RETURN END FUNCTION CMUMPS_OOC_PANEL_SIZE SUBROUTINE CMUMPS_OOC_SKIP_NULL_SIZE_NODE() IMPLICIT NONE INTEGER I,TMP_NODE IF(.NOT.CMUMPS_SOLVE_IS_END_REACHED())THEN IF(SOLVE_STEP.EQ.0)THEN I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I+1 IF(I.LE.TOTAL_NB_OOC_NODES(OOC_FCT_TYPE))THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=min(I,TOTAL_NB_OOC_NODES(OOC_FCT_TYPE)) ELSE I=CUR_POS_SEQUENCE TMP_NODE=OOC_INODE_SEQUENCE(CUR_POS_SEQUENCE, & OOC_FCT_TYPE) DO WHILE ((I.GE.1).AND. & (SIZE_OF_BLOCK(STEP_OOC(TMP_NODE),OOC_FCT_TYPE) & .EQ.0_8)) INODE_TO_POS(STEP_OOC(TMP_NODE))=1 OOC_STATE_NODE(STEP_OOC(TMP_NODE))=NOT_USED I=I-1 IF(I.GE.1)THEN TMP_NODE=OOC_INODE_SEQUENCE(I,OOC_FCT_TYPE) ENDIF ENDDO CUR_POS_SEQUENCE=max(I,1) ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_OOC_SKIP_NULL_SIZE_NODE SUBROUTINE CMUMPS_OOC_SET_STATES_ES(N,KEEP201, & Pruned_List,nb_prun_nodes,STEP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP201, nb_prun_nodes INTEGER, INTENT(IN) :: STEP(N), & Pruned_List(nb_prun_nodes) INTEGER I, ISTEP IF (KEEP201 .GT. 0) THEN OOC_STATE_NODE(:) = ALREADY_USED DO I = 1, nb_prun_nodes ISTEP = STEP(Pruned_List(I)) OOC_STATE_NODE(ISTEP) = NOT_IN_MEM ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_OOC_SET_STATES_ES END MODULE CMUMPS_OOC MUMPS_5.4.1/src/smumps_driver.F0000664000175000017500000030320714102210525016520 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C =========================== C FORTRAN 90 Driver for SMUMPS C (MPI based code) C =========================== C SUBROUTINE SMUMPS( id ) USE SMUMPS_OOC USE MUMPS_MEMORY_MOD USE SMUMPS_STRUC_DEF USE SMUMPS_STATIC_PTR_M ! For Schur pointer USE SMUMPS_SAVE_RESTORE C !$ USE OMP_LIB C IMPLICIT NONE C C ======= C Purpose C ======= C C TO SOLVE a SPARSE SYSTEM OF LINEAR EQUATIONS. C GIVEN AN UNSYMMETRIC, SYMMETRIC, OR SYMMETRIC POSITIVE DEFINITE C SPARSE MATRIX A AND AN N-VECTOR B, THIS SUBROUTINE SOLVES THE C SYSTEM A x = b or ATRANSPOSE x = b. C C List of main functionalities provided by the package: C ---------------------------------------------------- C -Unsymmetric solver with partial pivoting (LU factorization) C -Symmetric positive definite solver (LDLT factorization) C -General symmetric solver with pivoting C -Either elemental or assembled matrix input C -Analysis/Factorization/Solve callable separately C -Deficient matrices (symmetric or unsymmetric) C -Rank revealing C -Null space basis computation C -Solution C -Return the Schur complement matrix while C also providing solution of interior problem C -Distributed input matrix and analysis phase C -Sequential or parallel MPI version (any number of processors) C -Error analysis and iterative refinement C -Out-of-Core factorization and solution C -Solution phase: C -Multiple Right-Hand-sides (RHS) C -Sparse RHS C -Distributed RHS C -Computation of selected entries of the inverse of C original matrix. C - Block Low-Rank (BLR) approximation based factorization C C Method C ------ C The method used is a parallel direct method C based on a sparse multifrontal variant C of Gaussian elimination with partial numerical pivoting. C An initial ordering for the pivotal sequence C is chosen using the pattern of the matrix A + A^T and is C later modified for reasons of numerical stability. Thus this code C performs best on matrices whose pattern is symmetric, or nearly so. C For symmetric sparse matrices or for very unsymmetric and C very sparse matrices, other software might be more appropriate. C C C References : C ----------- C C P. Amestoy, J.-Y. L'Excellent, G. Moreau, On exploiting sparsity of C multiple right-hand sides in sparse direct solvers, C SIAM Journal on Scientific Computing, volume 41, number 2, C pages A269-A291 (2019) C C G. Moreau, PhD Thesis, ENS-Lyon, University of Lyon, C On the solution phase of direct methods for sparse linear systems C with multiple sparse right-hand sides, December 10th, 2018 C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C Performance and scalability of the block low-rank multifrontal C factorization on multicore architectures, C ACM Transactions on Mathematical Software (2018) C C T. Mary, PhD Thesis, University of Toulouse, C Block Low-Rank multifrontal solvers: complexity, performance, and C scalability, November 2017. C C S. de la Kethulle de Ryhove, P. Jaysaval and D.V. Shantsev, C P. R. Amestoy, J.-Y. L'Excellent and T. Mary, C Large-scale 3D EM modeling with a Block Low-Rank MUMPS solver, C Geophysical Journal International, volume 209, number 3, C pages 1558-1571 (2017) . C C P. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, C On the complexity of the Block Low-Rank multifrontal factorization, C SIAM Journal on Scientific Computing, volume 39, C number 4, pages A1710-A1740 (2017). C C P. Amestoy, R. Brossier, A. Buttari, J.-Y. L'Excellent, T. Mary, C L. Metivier, A. Miniussi, and S. Operto. C Fast 3D frequency-domain full waveform inversion with a parallel C Block Low-Rank multifrontal direct solver: application to OBC data C from the North Sea, Geophysics, 81(6):R363--R383, (2016). C C P. Amestoy, C. Ashcraft, O. Boiteau, A. Buttari, J.-Y. L'Excellent, C and C. Weisbecker. C Improving multifrontal methods by means of block low-rank representations. C SIAM Journal on Scientific Computing, 37(3):A1451--A1474 (2015). C C W. M. Sid-Lakhdar, PhD Thesis from Universite de Lyon prepared at ENS Lyon, C Scaling the solution of large sparse linear systems using multifrontal C methods on hybrid shared-distributed memory architectures (2014). C C P. Amestoy, J.-Y. L'Excellent, W. Sid-Lakhdar, C Characterizing asynchronous broadcast trees for multifrontal factorizations, C Workshop on Combinatorial Scientific Computing, C Lyon, France, July 21-23 (2014). C C P. Amestoy, J.-Y. L'Excellent, F.-H. Rouet, W. Sid-Lakhdar, C Modeling 1D distributed-memory dense kernels for an asynchronous C multifrontal sparse solver, High-Performance Computing for Computational C Science, VECPAR 2014, Eugene, Oregon, USA, June 30 - July 3 (2014). C C J.-Y. L'Excellent and W. M. Sid-Lakhdar, C Introduction of shared-memory parallelism in a distributed-memroy C multifrontal solver, Parallel Computing (40):3-4, pages 34-46 (2014). C C C. Weisbecker, PhD Thesis supported by EDF, INPT-IRIT, C Improving multifrontal solvers by means of algebraic block low-rank C representations (2013). C C E. Agullo, P. Amestoy, A. Buttari, A. Guermouche, G. Joslin, J.-Y. C L'Excellent, X. S. Li, A. Napov, F.-H. Rouet, M. Sid-Lakhdar, S. Wang, C. C Weisbecker, I. Yamazaki, C Recent Advances in Sparse Direct Solvers, 22nd Conference on Structural C Mechanics in Reactor Technology, San Francisco (2013). C C P. Amestoy, A. Buttari, G. Joslin, J.-Y. L'Excellent, W. Sid-Lakhdar, C. C Weisbecker, M. Forzan, C. Pozza, R. Perrin, V. Pellissier, C Shared memory parallelism and low-rank approximation techniques applied C applied to direct solvers in FEM simulation in IEEE Transactions on C Magnetics, IEEE, Special issue, Compumag 2013 (2013). C C L. Boucher, P. Amestoy, A, Buttari, F.-H. Rouet and M. Chauvin, C INTEGRAL/SPI data segmentation to retrieve sources intensity variations, C Astronomy & Astrophysics, Article 52, 20 pages, C http://dx.doi.org/10.1051/0004-6361/201219605 (2013). C C F.-H. Rouet, PhD thesis from INPT, Toulouse, France, C Memory and Performance issues in parallel multifrontal factorization and C triangular solutions with sparse right-hand sides (2014). C C J.-Y. L'Excellent, Habilitation thesis from ENS Lyon, C Multifrontal methods: Parallelism, Memory Usage and Numerical C Aspects (2012). C C P. Amestoy, I.S. Duff, J.-Y. L'Excellent, Y. Robert, F.H. Rouet C and B. Ucar, On computing inverse entries of a sparse matrix in C an out-of-core environment, C SIAM J. on Scientific Computing Vol. 34 N. 4, p. 1975-1999 (2012). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C The Multifrontal Method, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Amestoy, Buttari, Duff, Guermouche, L'Excellent, and Ucar C MUMPS, Encyclopedia of Parallel Computing, C editor David Padua, Springer (2011). C C Agullo, Guermouche and L'Excellent, Reducing the {I/O} Volume in C Sparse Out-of-core Multifrontal Methods}, SIAM SISC, Vol 31, Nb. 6, C 4774-4794 (2010). C C Amestoy, Duff, Guermouche, Slavova, Analysis of the Solution Phase of a C Parallel Multifrontal Approach, Parallel Computing, Vol. 36, 3--15 (2010). C C Tzvetomila Slavova, PhD from INPT prepared at CERFACS, C Parallel triangular solution in the out-of-core multifrontal approach C for solving large sparse linear systems, available as CERFACS C Report TH/PA/09/59 (2009). C C Agullo, Guermouche and L'Excellent, A Parallel Out-of-core Multifrontal C Method: Storage of Factors on Disk and Analysis of Models for an C Out-of-core Active Memory, Parallel Computing, Special Issue on Parallel C Matrix Algorithms, Vol. 34, Nb 6-8, 296--317 (2008). C C Emmanuel Agullo, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C On the Out-of-core Factorization of Large Sparse Matrices (Nov 2008). C C Amestoy, Duff, Ruiz, and Ucar, "A parallel C matrix scaling algorithm". C In proceedings of VECPAR'08-International Meeting-High C Performance Computing for Computational Science, (Jan 2008). C C Guermouche and L'Excellent, Constructing Memory-minimizing Schedules C for Multifrontal Methods, ACM TOMS, Vol. 32, Nb. 1, 17--32 (2006). C C Amestoy, Guermouche, L'Excellent, and Pralet, C Hybrid scheduling for the parallel solution C of linear systems. Vol 32 (2), pp 136-156 (2006). C C Stephane Pralet, PhD from INPT prepared at CERFACS, C Constrained orderings and scheduling for parallel sparse linear algebra, C available as CERFACS technical report, TH/PA/04/105, (Sept 2004). C C Abdou Guermouche, PhD Thesis from LIP-Ecole Normale Superieure de Lyon, C Etude et optimisation du comportement memoire dans les methodes paralleles C de factorisation de matrices creuses (2004). C C Guermouche, L'Excellent and Utard, Impact of Reordering on the Memory of a C Multifrontal Solver, Parallel Computing, Vol. 29, Nb. 9, 1191--1218 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Impact of the Implementation C of MPI Point-to-Point Communications on the Performance of Two General C Sparse Solvers, Parallel Computing, Vol. 29, Nb 7, 833--847 (2003). C C Amestoy, Duff, L'Excellent and Xiaoye S. Li, Analysis and Comparison of C Two General Sparse Solvers for Distributed Memory Computers, ACM TOMS, C Vol. 27, Nb 4, 388--421 (2001). C C Amestoy, Duff, Koster and L'Excellent (2001), C A fully asynchronous multifrontal solver using distributed dynamic C scheduling, SIAM Journal of Matrix Analysis and Applications, C Vol 23, No 1, pp 15-41 (2001). C C Amestoy, Duff and L'Excellent (2000), C Multifrontal parallel distributed symmetric and unsymmetric solvers, C Comput. Methods in Appl. Mech. Eng., 184, 501-520 (2000) C C Amestoy, Duff and L'Excellent (1998), C Parallelisation de la factorisation LU de matrices C creuses non-symmetriques pour des architectures a memoire distribuee, C Calculateurs Paralleles Reseaux et systemes repartis, C Vol 10(5), 509-520 (1998). C C PARASOL Deliverable D2.1d (final report), C SMUMPS Version 3.1, A MUltifrontal Massively Parallel Solver, C PARASOL project, EU ESPRIT IV LTR project 20160, (June 1999). C C Jacko Koster, PhD from INPT prepared at CERFACS, On the parallel solution C and the reordering of unsymmetric sparse linear systems (1997). C C Vincent Espirat, Master's thesis from INPT(ENSEEIHT)-IRIT, Developpement C d'une approche multifrontale pour machines a memoire distribuee et C reseau heterogene de stations de travail (1996). C C Patrick Amestoy, PhD from INPT prepared at CERFACS, Factorization of large C sparse matrices based on a multifrontal approach in a multiprocessor C environment, Available as CERFACS report TH/PA/91/2 (1991). C C============================================ C Argument lists and calling sequences C============================================ C C There is only one entry: * * A Fortran 90 driver subroutine SMUMPS has been designed as a user * friendly interface to the multifrontal code. * This driver, in addition to providing the * normal functionality of a sparse solver, incorporates some * pre- and post-processing. * This driver enables the user to preprocess the matrix to obtain a * maximum * transversal so that the permuted matrix has a zero-free diagonal, * to perform prescaling * of the original matrix (a choice of scaling strategies is provided), * to use iterative refinement to improve the solution, * and finally to perform error analysis. * * The driver routine SMUMPS offers similar functionalities to other * sparse direct solvers, depending on the value of one of * its parameters (JOB). The main ones are: * * (i) JOB = -1 C initializes an instance of the package. This must be C called before any other call to the package concerning that instance. C It sets default values for other C components of SMUMPS_STRUC, which may then be altered before C subsequent calls to SMUMPS. C Note that three components of the structure must always be set by the C user (on all processors) before a call with JOB=-1. These are C id%COMM, C id%SYM, and C id%PAR. C CNTL, ICNTL can then be modified (see documentation) by the user. C * A value of JOB = -1 cannot be combined with other values for JOB * * (ii) JOB = 1 accepts the pattern of matrix A and chooses pivots * from the diagonal using a selection criterion to * preserve sparsity. It uses the pattern of A + A^T * but ignores numerical values. It subsequently constructs subsidiary * information for the actual factorization by a call with JOB_=_2. * An option exists for the user to * input the pivot sequence, in which case only the necessary * information for a JOB = 2 entry will be generated. We call the JOB=1 * entry, the analysis phase. C The following components of the structure define the centralized matrix C pattern and must be set by the user (on the host only) C before a call with JOB=1: C --- id%N, id%NZ (32-bit int) or id%NNZ (64-bit int), C id%IRN, and id%JCN C if the user wishes to input the structure of the C matrix in assembled format (ICNTL(5)=0, and ICNTL(18) $\neq$ 3), C --- id%ELTPTR, and id%ELTVAR C if the user wishes to input the matrix in elemental C format (ICNTL(5)=1). C A distributed matrix format is also available (see documentation) C * (iii) JOB = 2 factorizes a matrix A using the information * from a previous call with JOB = 1. The actual pivot sequence * used may differ slightly from that of this earlier call if A is not * diagonally dominant. * * (iv) JOB = 3 uses the factors generated by a JOB = 2 call to solve * a system of equations A X = B or A^T X =B, where X and B are matrices * that can be either dense or sparse. * The sparsity of B is exploited to limit the number of operations * performed during solution. When only part of the solution is * also needed (such as when computing selected entries of A^1) then * further reduction of the number of operations is performed. * This is particularly beneficial in the context of an * out-of-core factorization. * * (v) JOB = -2 frees all internal data allocated by the package. * * A call with JOB=3 must be preceded by a call with JOB=2, * which in turn must be preceded by a call with JOB=1, which * in turn must be preceded by a call with JOB=-1. Since the * information passed from one call to the next is not * corrupted by the second, several calls with JOB=2 for matrices * with the same sparsity pattern but different values may follow * a single call with JOB=1, and similarly several calls with JOB=3 * can be used for different right-hand sides. * Values 4, 5, 6 for the parameter JOB can invoke combinations * of the three basic operations corresponding to JOB=1, 2 or 3. * C ********* C -------------------------------------- C Explicit interface needed for routines C using a target argument if they appear C in the same compilation unit. C -------------------------------------- INTERFACE SUBROUTINE SMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE SMUMPS_CHECK_DENSE_RHS SUBROUTINE SMUMPS_ANA_DRIVER( id ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id END SUBROUTINE SMUMPS_ANA_DRIVER SUBROUTINE SMUMPS_FAC_DRIVER( id ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id END SUBROUTINE SMUMPS_FAC_DRIVER SUBROUTINE SMUMPS_SOLVE_DRIVER( id ) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET :: id END SUBROUTINE SMUMPS_SOLVE_DRIVER SUBROUTINE SMUMPS_PRINT_ICNTL(id, LP) USE SMUMPS_STRUC_DEF TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP END SUBROUTINE SMUMPS_PRINT_ICNTL END INTERFACE * MPI * === INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) INTEGER IERR * * ========== * Parameters * ========== TYPE (SMUMPS_STRUC) :: id C C Main components of the structure are: C ------------------------------------ C C (see documentation for a complete description) C C JOB is an INTEGER variable which must be set by the user to C characterize the factorization step. Possible values of JOB C are given below C C 1 Analysis: Ordering and symbolic factorization steps. C 2 Scaling and Numerical Factorization C 3 Solve and Error analysis C 4 Analysis followed by numerical factorization C 5 Numerical factorization followed by Solving step C 6 Analysis, Numerical factorization and Solve C C N is an INTEGER variable which must be set by the user to the C order n of the matrix A. It is not altered by the C subroutine. C C NZ / NNZ are INTEGER / INTEGER(8) variables which must be set by the user C to the number of entries being input, in case of centralized assembled C entry. It is not altered by the subroutine. Only used if C ICNTL(5).eq.0 and ICNTL(18) .ne. 3 (assembled matrix entry, C or, at least, centralized matrix graph during analysis). C C Restriction: NZ > 0 or NNZ > 0. C If NNZ is different from 0, NNZ is used. Otherwise, NZ is used. C C NELT is an INTEGER variable which must be set by the user to the C number of elements being input. It is not altered by the C subroutine. Only used if ICNTL(5).eq.1 (elemental matrix entry). C Restriction: NELT > 0. C C IRN and JCN are INTEGER arrays of length [N]NZ. C IRN(k) and JCN(k), k=1..[N]NZ must be set on entry to hold C the row and column indices respectively. C They are not altered by the subroutine except when ICNTL(6) = 1. C (in which case only the column indices are modified). C The arrays are only used if ICNTL(5).eq.0 (assembled entry) C or out-of-range. C C ELTPTR is an INTEGER array of length NELT+1. C ELTVAR is an INTEGER array of length ELTPTR(NELT+1)-1. C ELTPTR(I) points in ELTVAR to the first variable in the list of C variables that correspond to element I. ELTPTR(NELT+1) points C to the first unused location in ELTVAR. C The positions ELTVAR(I) .. ELTPTR(I+1)-1 contain the variables C for element I. No free space is allowed between variable lists. C ELTPTR/ELTVAR are not altered by the subroutine. C The arrays are only used if ICNTL(5).ne.0 (element entry). C C A is a REAL array of length [N]NZ. C The user must set A(k) to the value C of the entry in row IRN(k) and column JCN(k) of the matrix. C It is not altered by the subroutine. C (Note that the matrix can also be provided in a distributed C assembled input format) C C RHS is a REAL array of length N that is only accessed when C JOB = 3, 5, or 6. On entry, RHS(i) C must hold the i th component of the right-hand side of the C equations being solved. C On exit, RHS(i) will hold the i th component of the C solution vector. For other values of JOB, RHS is not accessed and C can be declared to have size one. C RHS should only be available on the host processor. If C it is associated on other processors, an error is raised. C (Note that the right-hand sides can also be provided in a C sparse format). C C COLSCA, ROWSCA are REAL C arrays of length N that are used to hold C the values used to scale the columns and the rows C of the original matrix, respectively. C These arrays need to be set by the user C only if ICNTL(8) is set to -1. If ICNTL(8)=0, C COLSCA and ROWSCA are not accessed and C so can be declared to have size one. C For any other values of ICNTL(8), C the scaling arrays are computed before C numerical factorization. The factors of the scaled matrix C diag(ROWSCA(i)) 0 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ENDIF ENDIF C Initialize id%MYID now because it is C required by MUMPS_PROPINFO. id%MYID C used to be initialized inside SMUMPS_INI_DRIVER, C leading to an uninitialized access here. CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR) CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) THEN C C If there was an error, then initialization C was already called and we can rely on the null C or non null value of the pointers related to OOC C stuff. C We use SMUMPS_CLEAN_OOC_DATA that should work even C on the master. Note that KEEP(201) was also C initialized in a previous call to Mumps. C C If SMUMPS_END_DRIVER or SMUMPS_FAC_DRIVER is called after C this error, then SMUMPS_CLEAN_OOC_DATA will be called C a second time, though. C IF (id%KEEP(201).GT.0) THEN CALL SMUMPS_CLEAN_OOC_DATA(id, IERR) ENDIF GOTO 499 ENDIF C ---------------------------------------- C Initialization SMUMPS_INI_DRIVER C ---------------------------------------- C - Default values for ICNTL, KEEP,KEEP8, CNTL C - Attach emission buffer for buffered Send C - Nullify pointers in the structure C - Get rank and size of the communicator C ---------------------------------------- CALL SMUMPS_INI_DRIVER( id ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 END IF IF ( JOB .EQ. -2 ) THEN C ------------------------------------- C Deallocation of the instance id C ------------------------------------- id%KEEP(40)= -2 - 456789 CALL SMUMPS_END_DRIVER( id ) GOTO 500 END IF C C TIMINGS: for JOBS different from -1 and -2, C we measure TIMETOTAL: C IF (id%MYID.EQ.MASTER) THEN id%DKEEP(70)=0.0E0 CALL MUMPS_SECDEB(TIMETOTAL) ENDIF C C---------------------------------------------------------------- C C JOB = 7 : SAVE THE INSTANCE C C JOB = 8 : RESTORE THE INSTANCE C---------------------------------------------------------------- C IF ( JOB .EQ. 7 .OR. JOB .EQ. 8 ) THEN IF( JOB.EQ.8 .AND. OLDJOB.NE.-1) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 IF ( JOB .EQ. 7 ) THEN IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL SMUMPS_SAVE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in save structure driver= ', TIMEG END IF ENDIF ELSE IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIMEG) ENDIF CALL SMUMPS_RESTORE( id ) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEG) IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in restore structure driver= ' & , TIMEG ENDIF END IF ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C JOB = -3 : REMOVE SAVED INSTANCE C C---------------------------------------------------------------- C IF (JOB .EQ. -3) THEN CALL SMUMPS_REMOVE_SAVED(id) IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF IF (JOB.EQ.9) THEN C Check that factorization was performed IF ( OLDJOB .LT. 2 ) THEN id%INFO(1)=-3 id%INFO(2)=JOB ELSE CALL SMUMPS_SOL_INIT_IRHS_loc(id) ENDIF IF ( id%INFO(1) .LT. 0 ) GOTO 499 GOTO 500 ENDIF C C---------------------------------------------------------------- C C MAIN DRIVER C OTHER VALUES OF JOB : 1 to 6 C C---------------------------------------------------------------- CALL MUMPS_MEMORY_SET_DATA_SIZES() IF (id%MYID.EQ.MASTER) THEN C ----------------------------- C Check incompatibility between C par (=0) and nprocs (=1) C ----------------------------- IF ( (id%KEEP(46).EQ.0).AND.(id%NPROCS.LE.1) ) & THEN id%INFO(1) = -21 id%INFO(2) = id%NPROCS ENDIF END IF C C Propagate possible error to all nodes CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 499 C C Print ICNTL and KEEP C IF (PROK) CALL SMUMPS_PRINT_ICNTL(id, MP) C----------------------------------------------------------------------- C C CHECK SEQUENCE C C----------------------------------------------------------------------- IF ( LANA ) THEN IF ( PROKG .AND. OLDJOB .EQ. -1 ) THEN C Print compilation options at first call to analysis CALL MUMPS_PRINT_IF_DEFINED(MPG) ENDIF C C User wants to perform analysis. Previous value of C JOB must be -1, 1, 2 or 3. C IF ( OLDJOB .EQ. 0 .OR. OLDJOB .GT. 3 .OR. OLDJOB .LT. -1 ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF IF ( OLDJOB .GE. 2 ) THEN C ----------------------------------------- C Previous step was factorization or solve. C As analysis is now performed, deallocate C at least some big arrays from facto. C ----------------------------------------- IF (associated(id%IS)) THEN DEALLOCATE (id%IS) NULLIFY (id%IS) END IF IF (associated(id%S)) THEN DEALLOCATE (id%S) NULLIFY (id%S) END IF END IF END IF IF ( LFACTO ) THEN C ------------------------------------ C User wants to perform factorization. C Analysis must have been performed. C ------------------------------------ IF ( OLDJOB .LT. 1 .and. .NOT. LANA ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF IF ( LSOLVE ) THEN C ------------------------------- C User wants to perform solve. C Facto must have been performed. C ------------------------------- IF ( OLDJOB .LT. 2 .AND. .NOT. LFACTO ) THEN id%INFO(1) = -3 id%INFO(2) = JOB GOTO 499 END IF END IF C ------------------------------------------ C Permute JCN on entry to JOB if no analysis C to be performed and IRN/JCN are needed. C (facto: arrowheads + solve: iterative C refinement and error analysis) C ------------------------------------------ #if ! defined (LARGEMATRICES) NOERRORBEFOREPERM =.TRUE. UNS_PERM_DONE=.FALSE. IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0) THEN IF ( id%JOB .EQ. 2 .OR. id%JOB .EQ. 5 .OR. & (id%JOB .EQ. 3 .AND. (id%ICNTL(10) .NE.0 .OR. & id%ICNTL(11).NE. 0))) THEN UNS_PERM_DONE = .TRUE. ALLOCATE(UNS_PERM_INV(id%N),stat=IERR) IF (IERR .GT. 0) THEN C -------------------------------- C Exit with an error. C We are not able to permute C JCN correctly after a MAX-TRANS C permutation resulting from a C previous call to SMUMPS. C -------------------------------- id%INFO(1)=-13 id%INFO(2)=id%N IF (LPOK) WRITE(LP,99993) GOTO 510 ENDIF DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I END DO DO I8 = 1_8, id%KEEP8(28) J = id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=UNS_PERM_INV(J) END DO DEALLOCATE(UNS_PERM_INV) END IF END IF #endif C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 * ********* * MaxTrans-Analysis-Distri, Scale-Arrowhead-factorize, and * Solve-IR-Error_Analysis (depending on the value of JOB) ********* * C IF ( LANA ) THEN C----------------------------------------------------- C- C- ANALYSIS : Max-Trans, Analysis, Distribution C- C----------------------------------------------------- C C Few checks + allocations C C IS : will be allocated on the slaves later C PROCNODE : on the master only, C because slave does not know N yet. C Will be allocated in analysis for the slave. C C For assembled entry: C IRN, JCN : check that they have been allocated by the C user on the master, and if their size is adequate C C For element entry: C ELTPTR, ELTVAR : check that they have been allocated by the C user on the master, and if their size is adequate C ---------------------------- C Reset KEEP(40) to -1 for the C case where an error occurs C ---------------------------- id%KEEP(40)=-1 -456789 C IF (id%MYID.EQ.MASTER) THEN C Check N, [N]NZ, NELT IF ((id%N.LE.0).OR.((id%N+id%N+id%N)/3.NE.id%N)) THEN id%INFO(1) = -16 id%INFO(2) = id%N GOTO 100 END IF IF (id%ICNTL(5).NE.1) THEN C Assembled input IF (id%ICNTL(18) .LT. 1 .OR. id%ICNTL(18) .GT. 3) THEN C Centralized input IF (id%KEEP8(28) .LE. 0_8) THEN id%INFO(1) = -2 CALL MUMPS_SET_IERROR(id%KEEP8(28), id%INFO(2)) GOTO 100 ENDIF ENDIF ELSE C Element entry: check NELT on the master IF (id%NELT .LE. 0) THEN id%INFO(1) = -24 id%INFO(2) = id%NELT GOTO 100 ENDIF ENDIF C -- initialize values of respectively C icntl(6), (7) and (12) to not done/chosen id%INFOG(7) = -9999 id%INFOG(23) = 0 id%INFOG(24) = 1 C --------------------------------------- C Element entry: allocate ELTPROC(1:NELT) C --------------------------------------- IF ( id%ICNTL(5) .EQ. 1 ) THEN ! Elemental matrix IF ( associated( id%ELTPROC ) ) & DEALLOCATE( id%ELTPROC ) ALLOCATE( id%ELTPROC(id%NELT), stat=IERR ) IF (IERR.gt.0) THEN id%INFO(1) = -7 id%INFO(2) = id%NELT IF ( LPOK ) WRITE(LP,'(A)') & 'Problem in allocating work array ELTPROC' GOTO 100 END IF END IF C --------------------------------------------------- C Assembled centralized entry: check input parameters C IRN/JCN C Element entry: check input parameters ELTPTR/ELTVAR C --------------------------------------------------- IF ( id%ICNTL(5) .NE. 1 ) THEN ! Assembled matrix id%KEEP8(30)=0_8 IF ( id%ICNTL(18) .LT. ICNTL18DIST_MIN & .OR. id%ICNTL(18) .GT. ICNTL18DIST_MAX ) THEN IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available before f2002. One can C still check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 END IF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: IRN/JCN badly allocated.' END IF ELSE IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE id%LELTVAR = id%ELTPTR( id%NELT+1 ) - 1 IF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSE C If no error, we compute KEEP8(30) (formerly NA_ELT), C required for SMUMPS_MAX_MEM already in analysis, and C then later during facto to check the size of A_ELT id%KEEP8(30) = 0_8 IF ( id%KEEP(50) .EQ. 0 ) THEN C Unsymmetric elements (but symmetric structure) DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + int(J,8) * int(J,8) ENDDO ELSE C Symmetric elements DO I = 1,id%NELT J = id%ELTPTR(I+1) - id%ELTPTR(I) id%KEEP8(30) = id%KEEP8(30) + & (int(J,8) *int(J+1,8))/2_8 ENDDO ENDIF ENDIF END IF IF ( id%INFO( 1 ) .eq. -22 ) THEN IF ( LPOK ) WRITE(LP,'(A)') & 'Error in analysis: ELTPTR/ELTVAR badly allocated.' END IF ENDIF 100 CONTINUE END IF C C Propagate possible error CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 C ----------------------------------------- C Call analysis procedure SMUMPS_ANA_DRIVER C ----------------------------------------- IF (id%MYID .eq. MASTER) THEN id%DKEEP(71)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C ------------------------------------------------- C Set scaling option for analysis in KEEP(52) C (ICNTL(8) only defined on host at analysis phase) C ------------------------------------------------- IF (id%MYID.EQ.MASTER) THEN C{ id%KEEP(52) = id%ICNTL(8) C Out-of-range values => automatic choice IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF ((id%KEEP(52).EQ.77).AND.(id%KEEP(50).EQ.1)) THEN ! for SPD matrices default is no scaling id%KEEP(52) = 0 ENDIF IF ( id%KEEP(52).EQ.77 .OR. id%KEEP(52).LE.-2) THEN C -- suppress scaling computed during analysis C -- if centralized matrix is not associated IF (.not.associated(id%A)) id%KEEP(52) = 0 ENDIF C deactivate analysis scaling if scaling given IF(id%KEEP(52) .EQ. -1) id%KEEP(52) = 0 C C deactivate analysis scaling if C permutation to zero-free diagonal not requested IF (id%ICNTL(6).EQ.0) id%KEEP(52) = 0 C deactivate analysis scaling for SPD matrices IF (id%KEEP(50).EQ.1) id%KEEP(52) = 0 C IF (id%KEEP(52).EQ.-2) THEN C deallocate scalings in case of ordering allocated/computed C during analysis. This is needed because in case of C KEEP(52)=-2 then one cannot be sure that C scaling will be effectivly computed during analysis C Thus to test if scaling was effectively allocated/computed C during analysis after SMUMPS_ANA_DRIVER one must C be sure that scaling arrays are nullified. IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF C C} ENDIF C C ANALYSIS PHASE: CALL SMUMPS_ANA_DRIVER( id ) C C Check and save scaling option in INFOG(33) IF (id%MYID .eq. MASTER) THEN C{ IF (id%KEEP(52).EQ.0) id%INFOG(33)=id%ICNTL(8) IF (id%KEEP(52).EQ.-2) THEN C Scaling should have been computed during IF (.not.associated(id%COLSCA).OR. & .not.associated(id%ROWSCA) & ) THEN C scaling was not computed reset KEEP(52) C the user can then decide during factorization C to activate scaling id%KEEP(52) =0 id%INFOG(33)=0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' Warning; scaling was not computed during analysis' ENDIF IF ( associated(id%COLSCA)) THEN DEALLOCATE( id%COLSCA ) NULLIFY(id%COLSCA) ENDIF IF ( associated(id%ROWSCA)) THEN DEALLOCATE( id%ROWSCA ) NULLIFY(id%ROWSCA) ENDIF ENDIF ENDIF IF (id%KEEP(52) .NE. 0) THEN id%INFOG(33)=id%KEEP(52) ENDIF C} ENDIF C return value of ICNTL(12) effectively used C that was saved on the master in KEEP(95) IF (id%MYID .eq. MASTER) id%INFOG(24)=id%KEEP(95) C TIMINGS: IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(71) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in analysis driver= ', TIMEG END IF C ----------------------- C Return in case of error C ----------------------- IF ( id%INFO( 1 ) .LT. 0 ) GO TO 499 id%KEEP(40) = 1 -456789 END IF C C------------------------------------------------------- C- C C BEGIN FACTORIZATION PHASE C C- C------------------------------------------------------- IF ( LFACTO ) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(91)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C ---------------------- C Reset KEEP(40) to 1 in C case of error in facto C ---------------------- id%KEEP(40) = 1 - 456789 C C------------------------------------------------------- C- C- CHECKS, SCALING, ARROWHEAD + FACTORIZATION PHASE C- C------------------------------------------------------- C IF ( id%MYID .EQ. MASTER ) THEN C ------------------------- C Check if Schur complement C is allocated. C ------------------------- IF (id%KEEP(60).EQ.1) THEN IF ( associated( id%SCHUR_CINTERFACE)) THEN C Called from C interface... C Since id%SCHUR_CINTERFACE is of size 1, C instruction below which causes bound check C errors should be avoided. We cheat by first C setting a static pointer with a routine with C implicit interface, and then copying this pointer C into id%SCHUR. CALL SMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SIZE_SCHUR,8)*int(id%SIZE_SCHUR,8)) CALL SMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF ( size(id%SCHUR) .LT. & id%SIZE_SCHUR * id%SIZE_SCHUR ) THEN IF (LP.GT.0) & write(LP,'(A)') & ' SCHUR allocated but too small' id%INFO(1)=-22 id%INFO(2)=9 END IF END IF C ------------------------------------------------------------ C Assembled entry: check input parameterd IRN,JCN,A C Element entry: check input parameters ELTPTR,ELTVAR,A_ELT C ------------------------------------------------------------ IF ( id%KEEP(54) .EQ. 0 ) THEN IF ( id%KEEP(55).eq.0 ) THEN C Assembled entry IF ( .not. associated( id%IRN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN, KIND=8 ) < id%KEEP8(28) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ can be stored in a 32-bit integer, C the 32-bit size(id%IRN) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%IRN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%JCN ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size(id%JCN) < int(id%KEEP8(28)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 #if defined(MUMPS_F2003) ELSE IF ( size( id%A, KIND=8 ) < id%KEEP8(28) ) THEN #else C Same as for IRN/JCN above ELSE IF ( id%KEEP8(28) .LE. int(huge(id%NZ),8) .AND. & size( id%A ) < int(id%KEEP8(28)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 END IF ELSE C Element entry IF ( .not. associated( id%ELTPTR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( size( id%ELTPTR ) < id%NELT+1 ) THEN id%INFO(1) = -22 id%INFO(2) = 1 ELSE IF ( .not. associated( id%ELTVAR ) ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( size( id%ELTVAR ) < id%LELTVAR ) THEN id%INFO(1) = -22 id%INFO(2) = 2 ELSEIF ( .not. associated( id%A_ELT ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ELSE #if defined(MUMPS_F2003) IF ( size( id%A_ELT, KIND=8 ) < id%KEEP8(30) ) THEN #else IF ( id%KEEP8(30) < int(huge(id%NZ),8) .AND. & size( id%A_ELT ) < int(id%KEEP8(30)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 4 ENDIF END IF ENDIF ENDIF C ---------------------- C Get the value of PERLU C ---------------------- CALL MUMPS_GET_PERLU(id%KEEP(12),id%ICNTL(14), & id%KEEP(50),id%KEEP(54),id%ICNTL(6),id%ICNTL(8)) C C ---------------------- C Get null space options C Note that nullspace is forbidden in case of Schur complement C ---------------------- CALL SMUMPS_GET_NS_OPTIONS_FACTO(id%N,id%KEEP(1), & id%ICNTL(1),MPG) C ======================================== C Decode and set scaling options for facto C ======================================== IF (.NOT. ((id%KEEP(52).EQ.-2).AND.(id%ICNTL(8).EQ.77)) ) & THEN C if scaling was computed during analysis and automatic C choice of scaling then we do not recompute scaling id%KEEP(52)=id%ICNTL(8) ENDIF IF ( id%KEEP(52) .GT. 8 .OR. id%KEEP(52).LT.-2) & id%KEEP(52) = 77 IF ( id%KEEP(52) .EQ. 2 .OR. id%KEEP(52).EQ.5 & .OR. id%KEEP(52) .EQ. 6 ) & id%KEEP(52) = 77 IF (id%KEEP(52).EQ.77) THEN IF (id%KEEP(50).EQ.1) THEN ! for SPD matrices the default is "no scaling" id%KEEP(52) = 0 ELSE ! SYM .ne. 1 the default is cheap SIMSCA id%KEEP(52) = 7 ENDIF ENDIF IF (id%KEEP(23) .NE. 0 .AND. id%ICNTL(8) .EQ. -1) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** WARNING : SCALING' WRITE(MPG,'(A)') & ' ** column permutation applied:' WRITE(MPG,'(A)') & ' ** column scaling has to be permuted' ENDIF ENDIF C ------------------------ C If Schur has been asked C for, scaling is disabled C ------------------------ IF ( id%KEEP(60) .ne. 0 .and. id%KEEP(52) .ne. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .AND. id%ICNTL(8) .NE. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') ' ** (incompatibility with Schur)' END IF END IF C ------------------------------- C If matrix is distributed on C entry, only options 7 and 8 C of scaling are allowed. C ------------------------------- IF (id%KEEP(54) .NE. 0 .AND. & id%KEEP(52).NE.7 .AND. id%KEEP(52).NE.8 .AND. & id%KEEP(52) .NE. 0 ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 .and. id%ICNTL(8) .ne. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: This scaling option not available' WRITE(MPG,'(A)') ' ** for distributed matrix entry' END IF END IF C ------------------------------------ C If matrix is symmetric, only scaling C options -1 (given scaling), 1 C (diagonal scaling), 7 and 8 (SIMSCALING) C are allowed. C ------------------------------------ IF ( id%KEEP(50) .NE. 0 ) THEN IF ( id%KEEP(52).ne. 1 .and. & id%KEEP(52).ne. -1 .and. & id%KEEP(52).ne. 0 .and. & id%KEEP(52).ne. 7 .and. & id%KEEP(52).ne. 8 .and. & id%KEEP(52).ne. -2 .and. & id%KEEP(52).ne. 77) THEN IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') & ' ** Warning: Scaling option n.a. for symmetric matrix' END IF id%KEEP(52) = 0 END IF END IF C ---------------------------------- C If matrix is elemental on entry, C automatic scaling is now forbidden C ---------------------------------- IF (id%KEEP(55) .NE. 0 .AND. & ( id%KEEP(52) .gt. 0 ) ) THEN id%KEEP(52) = 0 IF ( MPG .GT. 0 ) THEN WRITE(MPG,'(A)') ' ** Warning: Scaling not applied.' WRITE(MPG,'(A)') & ' ** (only user scaling av. for elt. entry)' END IF END IF C -------------------------------------- C Check input parameters ROWSCA / COLSCA C -------------------------------------- IF ( id%KEEP(52) .eq. -1 ) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF END IF C C Allocate -- if required, C ROWSCA and COLSCA on the master C C Allocation of scaling arrays. C IF (KEEP(52)==-2 then scaling should have been allocated C and computed during analysis C C If ICNTL(8) == -1, ROWSCA and COLSCA must have been associated and C filled by the user. If ICNTL(8) is >0 and <= 8, the scaling is C computed at the beginning of SMUMPS_FAC_DRIVER and is allocated now. C IF (id%KEEP(52).GT.0 .AND. & id%KEEP(52) .LE.8) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF ALLOCATE( id%ROWSCA(id%N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=id%N ENDIF END IF C C Allocate scaling arrays of size 1 if C they are not used to avoid problems C when passing them in arguments C IF (.NOT. associated(id%COLSCA)) THEN ALLOCATE( id%COLSCA(1), stat=IERR) END IF IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (.NOT. associated(id%ROWSCA)) & ALLOCATE( id%ROWSCA(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) WRITE(LP,'(A)') & 'Problems in allocations before facto' GOTO 200 END IF IF (id%KEEP(252) .EQ. 1) THEN CALL SMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) C Sets KEEP(221) and do some checks CALL SMUMPS_SET_K221(id) CALL SMUMPS_CHECK_REDRHS(id) ENDIF 200 CONTINUE END IF ! End of IF (MYID .eq. MASTER) C KEEP(221) was set in SMUMPS_SET_K221 but not broadcast CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) C C Check distributed matrices on all processors. I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (I_AM_SLAVE .AND. & id%KEEP(54).NE.0 .AND. id%KEEP8(29).GT.0_8) THEN IF ( .not. associated( id%IRN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%IRN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C size with kind=8 output not available. One can still C check that if NZ_loc can be stored in a 32-bit integer, C the 32-bit size(id%IRN_loc) (which we then assume not C to overflow...) is large enough ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%IRN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSE IF ( .not. associated( id%JCN_loc ) ) THEN id%INFO(1) = -22 id%INFO(2) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%JCN_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size(id%JCN_loc) < int(id%KEEP8(29)) ) THEN #endif id%INFO(1) = -22 id%INFO(2) = 16 ELSEIF ( .not. associated( id%A_loc ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 #if defined(MUMPS_F2003) ELSE IF ( size( id%A_loc, KIND=8 ) < id%KEEP8(29) ) THEN #else C Same as for IRN_loc/JCN_loc above ELSE IF ( id%KEEP8(29) .LE. int(huge(id%NZ_loc),8) .AND. & size( id%A_loc ) < int(id%KEEP8(29)) ) THEN #endif id%INFO( 1 ) = -22 id%INFO( 2 ) = 16 END IF ENDIF C C Check Schur complement on all processors. C SMUMPS_PROPINFO will be called right after those checks. C IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF ( id%root%yes ) THEN IF ( associated( id%SCHUR_CINTERFACE )) THEN C Called from C interface... C The next instruction may cause C bound check errors at runtime C id%SCHUR=>id%SCHUR_CINTERFACE C & (1:id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ C & id%root%SCHUR_MLOC) C Instead, we set a temporary C pointer and then retrieve it CALL SMUMPS_SET_TMP_PTR(id%SCHUR_CINTERFACE(1), & int(id%SCHUR_LLD,8)*int(id%root%SCHUR_NLOC-1,8)+ & int(id%root%SCHUR_MLOC,8)) CALL SMUMPS_GET_TMP_PTR(id%SCHUR) NULLIFY(id%SCHUR_CINTERFACE) ENDIF C Check that SCHUR_LLD is large enough IF (id%SCHUR_LLD < id%root%SCHUR_MLOC) THEN IF (LP.GT.0) write(LP,*) & ' SCHUR leading dimension SCHUR_LLD ', & id%SCHUR_LLD, 'too small with respect to', & id%root%SCHUR_MLOC id%INFO(1)=-30 id%INFO(2)=id%SCHUR_LLD ELSE IF ( .NOT. associated (id%SCHUR)) THEN IF (LP.GT.0) write(LP,'(A)') & ' SCHUR not associated' id%INFO(1)=-22 id%INFO(2)=9 ELSE IF (size(id%SCHUR) < & id%SCHUR_LLD*(id%root%SCHUR_NLOC-1)+ & id%root%SCHUR_MLOC) THEN IF (LP.GT.0) THEN write(LP,'(A)') & ' SCHUR allocated but too small' write(LP,*) id%MYID, ' : Size Schur=', & size(id%SCHUR), & ' SCHUR_LLD= ', id%SCHUR_LLD, & ' SCHUR_MLOC=', id%root%SCHUR_NLOC, & ' SCHUR_NLOC=', id%root%SCHUR_NLOC ENDIF id%INFO(1)=-22 id%INFO(2)= 9 ELSE C We initialize the pointer that C we will use within SMUMPS here. id%root%SCHUR_LLD=id%SCHUR_LLD IF (id%root%SCHUR_NLOC==0) THEN ALLOCATE(id%root%SCHUR_POINTER(1), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF ( LPOK ) THEN WRITE(LP,'(A)') & 'Problems in allocations before facto' ENDIF END IF ELSE id%root%SCHUR_POINTER=>id%SCHUR ENDIF ENDIF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 C ----------------------------------------------- C Call factorization procedure SMUMPS_FAC_DRIVER C ----------------------------------------------- CALL SMUMPS_FAC_DRIVER(id) C Save scaling in INFOG(33) IF (id%MYID .eq. MASTER) id%INFOG(33)=id%KEEP(52) C C In the case of Schur, free or not associated C id%root%SCHUR_POINTER now rather than in end_driver.F C (Case of repeated factorizations). IF (id%KEEP(60).EQ.2.OR.id%KEEP(60).EQ.3) THEN IF (id%root%yes) THEN IF (id%root%SCHUR_NLOC==0) THEN DEALLOCATE(id%root%SCHUR_POINTER) NULLIFY(id%root%SCHUR_POINTER) ELSE NULLIFY(id%root%SCHUR_POINTER) ENDIF ENDIF ENDIF C root%RG2L_ROW and root%RG2L_COL C are not used outside of the facto IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(91) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in factorization driver= ', TIMEG END IF C C Check for errors after FACTO C (it was propagated inside) IF(id%INFO(1).LT.0) THEN C Free id%S if facto failed if (associated(id%S)) then DEALLOCATE(id%S) NULLIFY(id%S) endif GO TO 499 ENDIF C C Update last successful step C id%KEEP(40) = 2 - 456789 END IF C------------------------------------------------------- C- C C BEGIN SOLVE PHASE C C- C------------------------------------------------------- IF (LSOLVE) THEN IF (id%MYID .eq. MASTER) THEN id%DKEEP(111)=0.0E0 CALL MUMPS_SECDEB(TIMEG) END IF C --------------------- C Reset KEEP(40) to 2. C (last successful step C was facto) C --------------------- id%KEEP(40) = 2 -456789 C ------------------------------------------ C Call solution procedure SMUMPS_SOLVE_DRIVER C ------------------------------------------ IF (id%MYID .eq. MASTER) THEN KEEP235SAVE = id%KEEP(235) KEEP242SAVE = id%KEEP(242) KEEP243SAVE = id%KEEP(243) KEEP495SAVE = id%KEEP(495) KEEP497SAVE = id%KEEP(497) ! if no permutation of RHS asked then suppress request ! to interleave the RHS ! to interleave the RHS on ordering given then ! using option to set permutation to identity should be ! used (note though that ! they # with A-1/sparseRHS and Null Space) IF (id%KEEP(242).EQ.0) id%KEEP(243)=0 C -------------------------------------- C Check input parameters ROWSCA / COLSCA C Only if KEEP(52).NE.0 because C only 0 means that no colsca/rowsca are needed C -------------------------------------- IF ( id%KEEP(52) .ne. 0) THEN IF ( .not. associated( id%ROWSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( size( id%ROWSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 5 ELSE IF ( .not. associated( id%COLSCA ) ) THEN id%INFO(1) = -22 id%INFO(2) = 6 ELSE IF ( size( id%COLSCA ) < id%N ) THEN id%INFO(1) = -22 id%INFO(2) = 6 END IF ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 499 CALL SMUMPS_SOLVE_DRIVER(id) IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMEG) id%DKEEP(111) = real(TIMEG) ENDIF IF (PROKG) THEN WRITE( MPG,'(/A,F12.4)') & ' Elapsed time in solve driver= ', TIMEG END IF IF (id%MYID .eq. MASTER) THEN id%KEEP(235) = KEEP235SAVE id%KEEP(242) = KEEP242SAVE id%KEEP(243) = KEEP243SAVE id%KEEP(495) = KEEP495SAVE id%KEEP(497) = KEEP497SAVE ENDIF IF (id%INFO(1).LT.0) GOTO 499 C --------------------------- C Update last successful step C --------------------------- id%KEEP(40) = 3 -456789 ENDIF C C What was actually done is saved in KEEP(40) C IF (PROK) CALL SMUMPS_PRINT_ICNTL(id, MP) GOTO 500 * *================= * ERROR section *================= 499 CONTINUE * Print error message if PROK IF (LPOK) WRITE (LP,99995) id%INFO(1) IF (LPOK) WRITE (LP,99994) id%INFO(2) * 500 CONTINUE #if ! defined(LARGEMATRICES) C --------------------------------- C Permute JCN on output to SMUMPS if C KEEP(23) is different from 0. C --------------------------------- IF (id%MYID .eq. MASTER .AND. id%KEEP(23) .NE. 0 & .AND. NOERRORBEFOREPERM) THEN C ------------------------------- C IF JOB=3 and PERM was not C done (no iterative refinement/ C error analysis), then we do not C permute JCN back. C ------------------------------- IF (id%JOB .NE. 3 .OR. UNS_PERM_DONE) THEN IF (.not.associated(id%UNS_PERM)) THEN C I may happen C (for ex in case of error -7 during analysis: C UNS_PERM can be not associated, C KEEP(23) was set to to automatic choice(=7) and C an error of memory allocation occurs during analysis C before having decided value of KEEP(23)) C UNS_PERM not associated and KEEP(23).NE.0 C Permuting JCN back does not make sense and KEEP(23) C should be reset to zero id%KEEP(23) = 0 ELSE DO I8 = 1_8, id%KEEP8(28) J=id%JCN(I8) C -- skip out-of range (that are ignored in ANA_O) IF (J.LE.0.OR.J.GT.id%N) CYCLE id%JCN(I8)=id%UNS_PERM(J) END DO ENDIF END IF END IF #endif 510 CONTINUE C ------------------------------------ C Set INFOG(1:2): same value on all C processors + broadcast other entries C ------------------------------------ CALL SMUMPS_SET_INFOG(id%INFO(1), id%INFOG(1), id%COMM, id%MYID) C C -------------------------------- C Broadcast RINFOG entries to make C them available on all procs. C -------------------------------- CALL MPI_BCAST( id%RINFOG(1), 40, MPI_REAL, MASTER, & id%COMM, IERR ) IF (id%INFOG(1).GE.0 .AND. JOB.NE.-1 & .AND. JOB.NE.-2 ) THEN IF (id%MYID .eq. MASTER) THEN CALL MUMPS_SECFIN(TIMETOTAL) id%DKEEP(70) = real(TIMETOTAL) ENDIF ENDIF *======================= * Compute space for save *======================= IF (id%INFOG(1).GE.0) THEN CALL SMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) id%KEEP8(55)=FILE_SIZE call MPI_ALLREDUCE(id%KEEP8(55),id%KEEP8(57),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%KEEP8(56)=STRUC_SIZE call MPI_ALLREDUCE(id%KEEP8(56),id%KEEP8(58),1, & MPI_INTEGER8, MPI_SUM,id%COMM,IERR) id%RINFO(7)=REAL(id%KEEP8(55))/1E6 id%RINFO(8)=REAL(id%KEEP8(56))/1E6 id%RINFOG(17)=REAL(id%KEEP8(57))/1E6 id%RINFOG(18)=REAL(id%KEEP8(58))/1E6 ENDIF !$ IF (ICNTL16_LOC .GT. 0) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL omp_set_num_threads(int(PREVIOUS_OMP_THREADS_NUM,4)) #else !$ CALL omp_set_num_threads(PREVIOUS_OMP_THREADS_NUM) #endif !$ ICNTL16_LOC = 0 !$ ENDIF *=============== * ERRORG section *=============== IF (id%MYID.EQ.MASTER.and.MPG.GT.0.and. & id%INFOG(1).lt.0) THEN WRITE(MPG,'(A,I16)') ' On return from SMUMPS, INFOG(1)=', & id%INFOG(1) WRITE(MPG,'(A,I16)') ' On return from SMUMPS, INFOG(2)=', & id%INFOG(2) END IF C ------------------------- C Restore user communicator C ------------------------- CALL MPI_COMM_FREE( id%COMM, IERR ) id%COMM = COMM_SAVE RETURN * 99995 FORMAT (' ** ERROR RETURN ** FROM SMUMPS INFO(1)=', I5) 99994 FORMAT (' ** INFO(2)=', I16) 99993 FORMAT (' ** Allocation error: could not permute JCN.') END SUBROUTINE SMUMPS * SUBROUTINE SMUMPS_SET_INFOG( INFO, INFOG, COMM, MYID ) IMPLICIT NONE INCLUDE 'mpif.h' C C Purpose: C ======= C C If one proc has INFO(1).lt.0 and INFO(1) .ne. -1, C puts INFO(1:2) of this proc on all procs in INFOG C C Arguments: C ========= C INTEGER, PARAMETER :: SIZE_INFOG = 80 INTEGER :: INFO(80) INTEGER :: INFOG(SIZE_INFOG) ! INFOG(80) INTEGER :: COMM, MYID C C Local variables C =============== C #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TMP1(2),TMP(2) #else INTEGER :: TMP1(2),TMP(2) #endif INTEGER ROOT, IERR INTEGER MASTER PARAMETER (MASTER=0) C C IF ( INFO(1) .ge. 0 ) THEN C C This can only happen if the phase was successful C on all procs. If one proc failed, then all other C procs would have INFO(1)=-1. C INFOG(1) = INFO(1) INFOG(2) = INFO(2) ELSE C --------------------- C Find who has smallest C error code INFO(1) C --------------------- INFOG(1) = INFO(1) C INFOG(2) = MYID TMP1(1) = INFO(1) TMP1(2) = MYID CALL MPI_ALLREDUCE(TMP1,TMP,1,MPI_2INTEGER, & MPI_MINLOC,COMM,IERR ) INFOG(2) = INFO(2) ROOT = TMP(2) CALL MPI_BCAST( INFOG(1), 1, MPI_INTEGER, ROOT, COMM, IERR ) CALL MPI_BCAST( INFOG(2), 1, MPI_INTEGER, ROOT, COMM, IERR ) END IF C C Make INFOG available on all procs: C CALL MPI_BCAST(INFOG(3), SIZE_INFOG-2, MPI_INTEGER, & MASTER, COMM, IERR ) RETURN END SUBROUTINE SMUMPS_SET_INFOG C-------------------------------------------------------------------- SUBROUTINE SMUMPS_PRINT_ICNTL (id, LP) USE SMUMPS_STRUC_DEF * * Purpose: * Print main control parameters CNTL and ICNTL * * ========== * Parameters * ========== TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER :: LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL REAL, DIMENSION(:),POINTER::CNTL INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL CNTL=>id%CNTL IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF ((ICNTL(6).EQ.5).OR.(ICNTL(6).EQ.6).OR. & (ICNTL(12).NE.1) ) THEN WRITE (LP,992) ICNTL(8) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) CASE(2); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,992) ICNTL(8) IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(5); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF WRITE (LP,992) ICNTL(8) WRITE (LP,993) ICNTL(14) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) CASE(6); WRITE (LP,980) WRITE (LP,981) CNTL(1), CNTL(3), CNTL(4), CNTL(5), CNTL(7) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (id%SYM.EQ.2) THEN WRITE (LP,991) ICNTL(5),ICNTL(6),ICNTL(7),ICNTL(12), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ELSE WRITE (LP,891) ICNTL(5),ICNTL(6),ICNTL(7), & ICNTL(13), & ICNTL(18),ICNTL(19),ICNTL(22) ENDIF IF (id%ICNTL(19).NE.0) & WRITE(LP,998) id%SIZE_SCHUR WRITE (LP,992) ICNTL(8) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) ICNTL(14) WRITE (LP,923) ICNTL(24), ICNTL(31), ICNTL(32), ICNTL(33), & ICNTL(35), ICNTL(36) END SELECT ENDIF 980 FORMAT (/'***********CONTROL PARAMETERS (ICNTL)**************'/) 981 FORMAT ( & ' CNTL(1) Threshold for numerical pivoting =',D16.4/ & ' CNTL(3) Null pivot detection threshold =',D16.4/ & ' CNTL(4) Threshold for static pivoting =',D16.4/ & ' CNTL(5) Fixation for null pivots =',D16.4/ & ' CNTL(7) Dropping threshold for BLR compression =',D16.4) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 891 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=off, >0=on) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy =',I10) 923 FORMAT ( & 'ICNTL(24) Null pivot detection (0=off) =',I10/ & 'ICNTL(31) Discard factors (0=off, else=on) =',I10/ & 'ICNTL(32) Forward elimination during facto (0=off)=',I10/ & 'ICNTL(33) Compute determinant (0=off) =',I10/ & 'ICNTL(35) Block Low Rank (BLR, 0=off >0=on) =',I10/ & 'ICNTL(36) BLR variant =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis (1=all,2=some,else=off) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) 998 FORMAT ( & ' Size of SCHUR matrix (SIZE_SHUR) =',I10) END SUBROUTINE SMUMPS_PRINT_ICNTL C-------------------------------------------------------------------- SUBROUTINE SMUMPS_PRINT_KEEP(id, LP) USE SMUMPS_STRUC_DEF * * ========== * Parameters * ========== TYPE (SMUMPS_STRUC), TARGET, INTENT(IN) :: id INTEGER ::LP ** Local Variables INTEGER, POINTER :: JOB INTEGER,DIMENSION(:),POINTER::ICNTL, KEEP INTEGER MASTER PARAMETER( MASTER = 0 ) IF (LP.LE.0) RETURN JOB=>id%JOB ICNTL=>id%ICNTL KEEP=>id%KEEP IF (id%MYID.EQ.MASTER) THEN SELECT CASE (JOB) CASE(1); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6))THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(2); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(3); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) CASE(4); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) IF (KEEP(23).NE.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),ICNTL(20),ICNTL(21) WRITE (LP,993) KEEP(12) CASE(5); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,993) KEEP(12) CASE(6); WRITE (LP,980) WRITE (LP,990) ICNTL(1),ICNTL(2),ICNTL(3),ICNTL(4) WRITE (LP,991) KEEP(55),KEEP(23),ICNTL(7),KEEP(95), & ICNTL(13),KEEP(54),KEEP(60),ICNTL(22) IF ((KEEP(23).EQ.5).OR.(KEEP(23).EQ.6) & .OR. (KEEP(23).EQ.7)) THEN WRITE (LP,992) KEEP(52) ENDIF IF (KEEP(23).EQ.0)THEN WRITE (LP,992) KEEP(52) ENDIF WRITE (LP,995) & ICNTL(9),ICNTL(10),ICNTL(11),KEEP(248),ICNTL(21) WRITE (LP,993) KEEP(12) END SELECT ENDIF 980 FORMAT (/'******INTERNAL VALUE OF PARAMETERS (ICNTL/KEEP)****'/) 990 FORMAT ( & 'ICNTL(1) Output stream for error messages =',I10/ & 'ICNTL(2) Output stream for diagnostic messages =',I10/ & 'ICNTL(3) Output stream for global information =',I10/ & 'ICNTL(4) Level of printing =',I10) 991 FORMAT ( & 'ICNTL(5) Matrix format ( keep(55) ) =',I10/ & 'ICNTL(6) Maximum transversal ( keep(23) ) =',I10/ & 'ICNTL(7) Ordering =',I10/ & 'ICNTL(12) LDLT ordering strat ( keep(95) ) =',I10/ & 'ICNTL(13) Parallel root (0=on, 1=off) =',I10/ & 'ICNTL(18) Distributed matrix ( keep(54) ) =',I10/ & 'ICNTL(19) Schur option ( keep(60) 0=off,else=on ) =',I10/ & 'ICNTL(22) Out-off-core option (0=Off, >0=ON) =',I10) 992 FORMAT ( & 'ICNTL(8) Scaling strategy ( keep(52) ) =',I10) 993 FORMAT ( & 'ICNTL(14) Percent of memory increase ( keep(12) ) =',I10) 995 FORMAT ( & 'ICNTL(9) Solve A x=b (1) or A''x = b (else) =',I10/ & 'ICNTL(10) Max steps iterative refinement =',I10/ & 'ICNTL(11) Error analysis ( 0= off, else=on) =',I10/ & 'ICNTL(20) Den.(0)/sparse(1,2,3)/dist.(10,11) RHS =',I10/ & 'ICNTL(21) Gathered (0) or distributed(1) solution =',I10) END SUBROUTINE SMUMPS_PRINT_KEEP SUBROUTINE SMUMPS_CHECK_DENSE_RHS & (idRHS, idINFO, idN, idNRHS, idLRHS) IMPLICIT NONE C C Purpose: C ======= C C Check that the dense RHS is associated and of C correct size. Called on master only, when dense C RHS is supposed to be allocated. This can be used C either at the beginning of the solve phase or C at the beginning of the factorization phase C if forward solve is done during factorization C (see ICNTL(32)) ; idINFO(1), idINFO(2) may be C modified. C C C Arguments: C ========= C C id* : see corresponding components of the main C MUMPS structure. C REAL, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) IF ( .not. associated( idRHS ) ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ELSE IF (idNRHS.EQ.1) THEN IF ( size( idRHS ) < idN ) THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 ENDIF ELSE IF (idLRHS < idN) & THEN idINFO( 1 ) = -26 idINFO( 2 ) = idLRHS ELSE IF #if defined(MUMPS_F2003) & (size(idRHS,kind=8) < & int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN) #else C size with kind=8 not available. One can still C perform the check if minimal size small enough. & (int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN & .LE. int(huge(idN),8) & .and. & size(idRHS) < int(int(idNRHS,8)*int(idLRHS,8)-idLRHS+idN)) #endif & THEN idINFO( 1 ) = -22 idINFO( 2 ) = 7 END IF RETURN END SUBROUTINE SMUMPS_CHECK_DENSE_RHS C SUBROUTINE SMUMPS_SET_K221(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C Sets KEEP(221) on master. C Constraint: must be called before SMUMPS_CHECK_REDRHS. C Can be called at factorization or solve phase C TYPE (SMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID.EQ.MASTER) THEN id%KEEP(221)=id%ICNTL(26) IF (id%KEEP(221).ne.0 .and. id%KEEP(221) .NE.1 & .AND.id%KEEP(221).ne.2) id%KEEP(221)=0 ENDIF RETURN END SUBROUTINE SMUMPS_SET_K221 C SUBROUTINE SMUMPS_CHECK_REDRHS(id) USE SMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose: C ======= C C * Decode API related to REDRHS and check REDRHS C * Can be called at factorization or solve phase C * Constraints: C - Must be called after solve phase. C - KEEP(60) must have been set (ok to check C since KEEP(60) was set during analysis phase) C * Remark that during solve phase, ICNTL(26)=1 is C forbidden in case of fwd in facto. C TYPE (SMUMPS_STRUC) :: id INTEGER MASTER PARAMETER( MASTER = 0 ) IF (id%MYID .EQ. MASTER) THEN IF ( id%KEEP(221) == 1 .or. id%KEEP(221) == 2 ) THEN IF (id%KEEP(221) == 2 .and. id%JOB == 2) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF (id%KEEP(221) == 1 .and. id%KEEP(252) == 1 & .and. id%JOB == 3) THEN id%INFO(1)=-35 id%INFO(2)=id%KEEP(221) ENDIF IF ( id%KEEP(60).eq. 0 .or. id%SIZE_SCHUR.EQ.0 ) THEN id%INFO(1)=-33 id%INFO(2)=id%KEEP(221) GOTO 333 ENDIF IF ( .NOT. associated( id%REDRHS)) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ELSE IF (id%NRHS.EQ.1) THEN IF (size(id%REDRHS) < id%SIZE_SCHUR ) THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ELSE IF (id%LREDRHS < id%SIZE_SCHUR) THEN id%INFO(1)=-34 id%INFO(2)=id%LREDRHS GOTO 333 ELSE IF & (size(id%REDRHS)< & id%NRHS*id%LREDRHS-id%LREDRHS+id%SIZE_SCHUR) & THEN id%INFO(1)=-22 id%INFO(2)=15 GOTO 333 ENDIF ENDIF ENDIF 333 CONTINUE C Error is not propagated. It should be propagated outside. C The reason to propagate it outside is that there can be C one call to PROPINFO instead of several ones. RETURN END SUBROUTINE SMUMPS_CHECK_REDRHS MUMPS_5.4.1/src/zfac_distrib_ELT.F0000664000175000017500000004676614102210524017005 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ELT_DISTRIB( & N, NELT, NA_ELT8, & COMM, MYID, SLAVEF, & IELPTR_LOC8, RELPTR_LOC8, & ELTVAR_LOC, ELTVAL_LOC, & LINTARR, LDBLARR, & KEEP,KEEP8, MAXELT_SIZE, & FRTPTR, FRTELT, A, LA, FILS, & id, root ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, NELT INTEGER(8) :: NA_ELT8 INTEGER COMM, MYID, SLAVEF, MAXELT_SIZE, MSGLEN INTEGER(8), intent(IN) :: LA INTEGER FRTPTR( N+1 ) INTEGER FRTELT( NELT ), FILS ( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: IELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(INOUT) :: RELPTR_LOC8( NELT + 1 ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER ELTVAR_LOC( LINTARR ) COMPLEX(kind=8) ELTVAL_LOC( LDBLARR ) COMPLEX(kind=8) A( LA ) TYPE(ZMUMPS_STRUC) :: id TYPE(ZMUMPS_ROOT_STRUC) :: root INTEGER numroc EXTERNAL numroc INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGTAG INTEGER allocok INTEGER I, DEST, MAXELT_REAL_SIZE, MPG, IEL, SIZEI, SIZER INTEGER NBRECORDS, NBUF INTEGER(8) :: RECV_IELTPTR8 INTEGER(8) :: RECV_RELTPTR8 INTEGER INODE INTEGER(8) :: IELTPTR8, RELTPTR8 LOGICAL FINI, PROKG, I_AM_SLAVE, EARLYT3ROOTINS INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, LP, IBEG, IGLOB, JGLOB INTEGER ARROW_ROOT INTEGER IELT, J, NB_REC, IREC INTEGER(8) :: K8, IVALPTR8 INTEGER ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, IPTR INTEGER JCOL_GRID, IROW_GRID INTEGER NBELROOT INTEGER MASTER PARAMETER( MASTER = 0 ) COMPLEX(kind=8) VAL COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, DIMENSION( :, : ), ALLOCATABLE :: BUFI COMPLEX(kind=8), DIMENSION( :, : ), ALLOCATABLE :: BUFR COMPLEX(kind=8), DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_R INTEGER, DIMENSION( : ), ALLOCATABLE :: TEMP_ELT_I INTEGER(8), DIMENSION( : ), ALLOCATABLE :: ELROOTPOS8 INTEGER, DIMENSION( : ), ALLOCATABLE, TARGET :: RG2LALLOC INTEGER, DIMENSION( : ), POINTER :: RG2L MPG = id%ICNTL(3) LP = id%ICNTL(1) I_AM_SLAVE = ( KEEP(46) .eq. 1 .or. MYID .ne.MASTER ) PROKG = ( MPG > 0 .and. MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) KEEP(49) = 0 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( MYID .eq. MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUF = SLAVEF ELSE NBUF = SLAVEF - 1 END IF NBRECORDS = KEEP(39) IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS = int(NA_ELT8) ENDIF IF ( KEEP(50) .eq. 0 ) THEN MAXELT_REAL_SIZE = MAXELT_SIZE * MAXELT_SIZE ELSE MAXELT_REAL_SIZE = MAXELT_SIZE * (MAXELT_SIZE+1)/2 END IF IF ( MAXELT_REAL_SIZE .GT. KEEP(39) ) THEN NBRECORDS = MAXELT_REAL_SIZE IF ( MPG .GT. 0 ) THEN WRITE(MPG,*) & ' ** Warning : For element distrib NBRECORDS set to ', & MAXELT_REAL_SIZE,' because one element is large' END IF END IF ALLOCATE( BUFI( 2*NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 2*NBRECORDS + 1 GOTO 100 END IF ALLOCATE( BUFR( NBRECORDS+1, NBUF ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS + 1 GOTO 100 END IF IF ( KEEP(52) .ne. 0 ) THEN ALLOCATE( TEMP_ELT_R( MAXELT_REAL_SIZE ), stat =allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_REAL_SIZE GOTO 100 END IF END IF ALLOCATE( TEMP_ELT_I( MAXELT_SIZE ), stat=allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXELT_SIZE GOTO 100 END IF IF ( KEEP(38) .ne. 0 ) THEN NBELROOT = FRTPTR(KEEP(38)+1)-FRTPTR(KEEP(38)) IF ( EARLYT3ROOTINS ) THEN ALLOCATE( ELROOTPOS8( max(NBELROOT,1) ), & stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBELROOT GOTO 100 END IF ENDIF IF (KEEP(46) .eq. 0 ) THEN ALLOCATE( RG2LALLOC( N ), stat = allocok ) IF ( allocok .gt. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = N GOTO 100 END IF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2LALLOC( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO RG2L => RG2LALLOC ELSE RG2L => root%RG2L_ROW END IF END IF DO I = 1, NBUF BUFI( 1, I ) = 0 BUFR( 1, I ) = ZERO END DO END IF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MPI_BCAST( NBRECORDS, 1, MPI_INTEGER, MASTER, & COMM, IERR_MPI ) RECV_IELTPTR8 = 1_8 RECV_RELTPTR8 = 1_8 IF ( MYID .eq. MASTER ) THEN NBELROOT = 0 RELTPTR8 = 1_8 RELPTR_LOC8(1) = 1 DO IEL = 1, NELT IELTPTR8 = int(id%ELTPTR( IEL ),8) SIZEI = int(int(id%ELTPTR( IEL + 1 ),8) - IELTPTR8) IF ( KEEP( 50 ) .eq. 0 ) THEN SIZER = SIZEI * SIZEI ELSE SIZER = SIZEI * ( SIZEI + 1 ) / 2 END IF DEST = id%ELTPROC( IEL ) IF ( DEST .eq. -2 ) THEN NBELROOT = NBELROOT + 1 FRTELT( FRTPTR(KEEP(38)) + NBELROOT - 1 ) = IEL ELROOTPOS8( NBELROOT ) = RELTPTR8 GOTO 200 END IF IF ( DEST .ge. 0 .and. KEEP(46) .eq. 0 ) DEST = DEST + 1 IF ( KEEP(52) .ne. 0 ) THEN CALL ZMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & id%ELTVAR( IELTPTR8 ), id%A_ELT( RELTPTR8 ), & TEMP_ELT_R(1), MAXELT_REAL_SIZE, & id%ROWSCA(1), id%COLSCA(1), KEEP(50) ) END IF IF ( DEST .eq. 0 .or. ( DEST .eq. -1 .and. KEEP(46) .ne. 0 ) ) & THEN ELTVAR_LOC( RECV_IELTPTR8: RECV_IELTPTR8 + SIZEI - 1 ) & = id%ELTVAR( IELTPTR8: IELTPTR8 + SIZEI - 1 ) RECV_IELTPTR8 = RECV_IELTPTR8 + SIZEI IF ( KEEP(52) .ne. 0 ) THEN ELTVAL_LOC( RECV_RELTPTR8: RECV_RELTPTR8 + SIZER - 1) & = TEMP_ELT_R( 1: SIZER ) RECV_RELTPTR8 = RECV_RELTPTR8 + SIZER END IF END IF IF ( DEST .NE. 0 .AND. DEST. NE. -3 ) THEN IF ( KEEP(52) .eq. 0 ) THEN CALL ZMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) ELSE CALL ZMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & TEMP_ELT_R( 1 ), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) END IF END IF 200 CONTINUE RELTPTR8 = RELTPTR8 + SIZER IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN RELPTR_LOC8( IEL + 1 ) = RELTPTR8 ELSE RELPTR_LOC8( IEL + 1 ) = RECV_RELTPTR8 ENDIF END DO IF ( KEEP(46) .eq. 0 .OR. KEEP(52) .eq. 0 ) THEN KEEP8(26) = RELTPTR8 - 1_8 ELSE KEEP8(26) = RECV_RELTPTR8 - 1_8 ENDIF IF ( RELTPTR8 - 1_8 .NE. NA_ELT8 ) THEN WRITE(*,*) " ** Internal error in ZMUMPS_ELT_DISTRIB", & RELTPTR8 - 1_8, NA_ELT8 CALL MUMPS_ABORT() END IF DEST = -2 IELTPTR8 = 1_8 RELTPTR8 = 1_8 SIZEI = 1 SIZER = 1 CALL ZMUMPS_ELT_FILL_BUF( & id%ELTVAR(IELTPTR8), & id%A_ELT (RELTPTR8), & SIZEI, SIZER, & & DEST, NBUF, NBRECORDS, & BUFI, BUFR, COMM ) IF ( KEEP(52) .NE. 0 ) DEALLOCATE( TEMP_ELT_R ) ELSE FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) DO WHILE ( .not. FINI ) CALL MPI_PROBE( MASTER, MPI_ANY_TAG, & COMM, STATUS, IERR_MPI ) MSGTAG = STATUS( MPI_TAG ) SELECT CASE ( MSGTAG ) CASE( ELT_INT ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAR_LOC( RECV_IELTPTR8 ), MSGLEN, & MPI_INTEGER, MASTER, ELT_INT, & COMM, STATUS, IERR_MPI ) RECV_IELTPTR8 = RECV_IELTPTR8 + MSGLEN CASE( ELT_REAL ) CALL MPI_GET_COUNT( STATUS, MPI_DOUBLE_COMPLEX, & MSGLEN, IERR_MPI ) CALL MPI_RECV( ELTVAL_LOC( RECV_RELTPTR8 ), MSGLEN, & MPI_DOUBLE_COMPLEX, MASTER, ELT_REAL, & COMM, STATUS, IERR_MPI ) RECV_RELTPTR8 = RECV_RELTPTR8 + MSGLEN END SELECT FINI = ( RECV_IELTPTR8 .eq. IELPTR_LOC8( NELT+1 ) & .and. RECV_RELTPTR8 .eq. RELPTR_LOC8( NELT+1 ) ) END DO END IF IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN IF ( I_AM_SLAVE .and. root%yes ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) END IF IF ( MYID .NE. MASTER ) THEN ALLOCATE( BUFI( NBRECORDS * 2 + 1, 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS * 2 + 1 GOTO 250 END IF ALLOCATE( BUFR( NBRECORDS, 1 ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = NBRECORDS END IF END IF 250 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), COMM, MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN IF ( MYID .eq. MASTER ) THEN DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) SIZEI = id%ELTPTR( IELT + 1 ) - id%ELTPTR( IELT ) DO I = 1, SIZEI TEMP_ELT_I( I ) = RG2L & ( id%ELTVAR( id%ELTPTR(IELT) + I - 1 ) ) END DO IVALPTR8 = ELROOTPOS8( IPTR - FRTPTR(KEEP(38)) + 1 ) - 1 K8 = 1_8 DO J = 1, SIZEI JGLOB = id%ELTVAR( id%ELTPTR( IELT ) + J - 1 ) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = id%ELTVAR( id%ELTPTR( IELT ) + I - 1 ) IF ( KEEP(52) .eq. 0 ) THEN VAL = id%A_ELT( IVALPTR8 + K8 ) ELSE VAL = id%A_ELT( IVALPTR8 + K8 ) * & id%ROWSCA( IGLOB ) * id%COLSCA( JGLOB ) END IF IF ( KEEP(50).eq.0 ) THEN IPOSROOT = TEMP_ELT_I( I ) JPOSROOT = TEMP_ELT_I( J ) ELSE IF ( TEMP_ELT_I(I) .GT. TEMP_ELT_I(J) ) THEN IPOSROOT = TEMP_ELT_I(I) JPOSROOT = TEMP_ELT_I(J) ELSE IPOSROOT = TEMP_ELT_I(J) JPOSROOT = TEMP_ELT_I(I) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( KEEP(46) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF IF ( DEST .eq. MASTER ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 ARROW_ROOT = ARROW_ROOT + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & + VAL ENDIF ELSE CALL ZMUMPS_ARROW_FILL_SEND_BUF( & IPOSROOT, JPOSROOT, VAL, DEST, BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) END IF K8 = K8 + 1_8 END DO END DO END DO CALL ZMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, & NBUF, LP, COMM, KEEP(46) ) ELSE FINI = .FALSE. DO WHILE ( .not. FINI ) CALL MPI_RECV( BUFI(1,1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR_MPI ) NB_REC = BUFI(1,1) ARROW_ROOT = ARROW_ROOT + NB_REC IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1,1), NBRECORDS, MPI_DOUBLE_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR_MPI ) DO IREC = 1, NB_REC IPOSROOT = BUFI( IREC * 2, 1 ) JPOSROOT = BUFI( IREC * 2 + 1, 1 ) VAL = BUFR( IREC, 1 ) ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60).eq.0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & = A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) & + VAL ELSE root%SCHUR_POINTER(int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF END DO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) END IF END IF IF ( MYID .eq. MASTER ) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) IF (allocated(ELROOTPOS8)) DEALLOCATE(ELROOTPOS8) IF (KEEP(38).ne.0) THEN IF (KEEP(46) .eq. 0 ) THEN DEALLOCATE(RG2LALLOC) ENDIF ENDIF DEALLOCATE( TEMP_ELT_I ) END IF KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_ELT_DISTRIB SUBROUTINE ZMUMPS_ELT_FILL_BUF( & ELNODES, ELVAL, SIZEI, SIZER, & DEST, NBUF, NBRECORDS, BUFI, BUFR, COMM ) IMPLICIT NONE INTEGER SIZEI, SIZER, DEST, NBUF, NBRECORDS, COMM INTEGER ELNODES( SIZEI ), BUFI( 2*NBRECORDS + 1, NBUF ) COMPLEX(kind=8) ELVAL( SIZER ), BUFR( NBRECORDS + 1, NBUF ) INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER I, IBEG, IEND, IERR_MPI, NBRECR INTEGER NBRECI COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) IF ( DEST .lt. 0 ) THEN IBEG = 1 IEND = NBUF ELSE IBEG = DEST IEND = DEST END IF DO I = IBEG, IEND NBRECI = BUFI(1,I) IF ( NBRECI .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECI + SIZEI .GT. 2*NBRECORDS ) ) THEN CALL MPI_SEND( BUFI(2, I), NBRECI, MPI_INTEGER, & I, ELT_INT, COMM, IERR_MPI ) BUFI(1,I) = 0 NBRECI = 0 END IF NBRECR = int(dble(BUFR(1,I))+0.5D0) IF ( NBRECR .ne.0 .and. & ( DEST.eq.-2 .or. & NBRECR + SIZER .GT. NBRECORDS ) ) THEN CALL MPI_SEND( BUFR(2, I), NBRECR, MPI_DOUBLE_COMPLEX, & I, ELT_REAL, COMM, IERR_MPI ) BUFR(1,I) = ZERO NBRECR = 0 END IF IF ( DEST .ne. -2 ) THEN BUFI( 2 + NBRECI : 2 + NBRECI + SIZEI - 1, I ) = & ELNODES( 1: SIZEI ) BUFR( 2 + NBRECR : 2 + NBRECR + SIZER - 1, I ) = & ELVAL( 1: SIZER ) BUFI(1,I) = NBRECI + SIZEI BUFR(1,I) = cmplx( NBRECR + SIZER, kind=kind(BUFR) ) END IF END DO RETURN END SUBROUTINE ZMUMPS_ELT_FILL_BUF SUBROUTINE ZMUMPS_MAXELT_SIZE( ELTPTR, NELT, MAXELT_SIZE ) INTEGER NELT, MAXELT_SIZE INTEGER ELTPTR( NELT + 1 ) INTEGER I, S MAXELT_SIZE = 0 DO I = 1, NELT S = ELTPTR( I + 1 ) - ELTPTR( I ) MAXELT_SIZE = max( S, MAXELT_SIZE ) END DO RETURN END SUBROUTINE ZMUMPS_MAXELT_SIZE SUBROUTINE ZMUMPS_SCALE_ELEMENT( N, SIZEI, SIZER, & ELTVAR, ELTVAL, & SELTVAL, LSELTVAL, & ROWSCA, COLSCA, K50 ) INTEGER N, SIZEI, SIZER, LSELTVAL, K50 INTEGER ELTVAR( SIZEI ) COMPLEX(kind=8) ELTVAL( SIZER ) COMPLEX(kind=8) SELTVAL( LSELTVAL ) DOUBLE PRECISION ROWSCA( N ), COLSCA( N ) INTEGER I, J, K K = 1 IF ( K50 .eq. 0 ) THEN DO J = 1, SIZEI DO I = 1, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI DO I = J, SIZEI SELTVAL(K) = ELTVAL(K) * & ROWSCA(ELTVAR(I)) * & COLSCA(ELTVAR(J)) K = K + 1 END DO END DO END IF RETURN END SUBROUTINE ZMUMPS_SCALE_ELEMENT MUMPS_5.4.1/src/ctools.F0000664000175000017500000021762114102210523015126 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE CMUMPS_LOAD USE CMUMPS_OOC !$ USE OMP_LIB USE CMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER IWPOS, LDLT INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(N), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I, SIZESHIFT, ITMP8 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR INTEGER PARPIV_T1 LOGICAL LR_ACTIVATED IERR=0 LDLT = KEEP(50) IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF (LDLT.EQ.0) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF IF ( TYPE .EQ. 2 ) THEN IF (LDLT.EQ.0) THEN SIZECB = int(NELIM,8) * int(LCONT,8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN SIZECB = int(NELIM+1,8) * int(NELIM + NPIV,8) ELSE SIZECB = int(NELIM,8) * int(NELIM + NPIV,8) ENDIF ENDIF ELSE LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (LDLT.EQ.0) THEN CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(LCONT,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ELSE CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(NROW,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZELU ELSE SIZESHIFT = 0_8 IF (SIZECB.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL CMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in CMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ MOVEPTRAST = .FALSE. DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 CMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 CMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 CMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZESHIFT MOVEPTRAST = .TRUE. PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 CMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 CMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZECB+SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZELU-SIZESHIFT, POSFAC-SIZECB-SIZESHIFT-1_8 A( I ) = A( I + SIZECB + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - (SIZECB+SIZESHIFT) LRLU = LRLU + (SIZECB+SIZESHIFT) ITMP8 = (SIZECB+SIZESHIFT) - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU-SIZESHIFT,-(SIZECB+SIZESHIFT)+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL CMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE CMUMPS_COMPRESS_LU SUBROUTINE CMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE CMUMPS_OOC USE CMUMPS_LOAD USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE COMPLEX A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL CMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL CMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL CMUMPS_COMPRE_NEW( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress CMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL CMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+LREQA ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN CALL CMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in CMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL CMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL CMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL CMUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_STACK_BAND SUBROUTINE CMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR, & CMUMPS_DM_FREE_BLOCK IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) COMPLEX A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE COMPLEX, DIMENSION(:), POINTER :: FORTRAN_POINTER ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL CMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE CMUMPS_FREE_BAND SUBROUTINE CMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF END SUBROUTINE CMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE CMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: CMUMPS_LBUF_INT INTEGER(8) :: CMUMPS_LBUFR_BYTES8, CMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8 * N8 IF (KEEP(23).ne.0 .and. I_AM_MASTER) NB_INT=NB_INT + N8 IF (KEEP(55).eq.0) THEN NB_INT = NB_INT + 2_8 * N8 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) ENDIF IF (KEEP(55) .ne. 0 ) THEN NB_INT = NB_INT + N8 + 1_8 + NELT8 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 CALL CMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF NB_REAL = NB_REAL + KEEP8(26) IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF IF ( I_AM_SLAVE .and. KEEP(38) .ne. 0 ) THEN NB_INT = NB_INT + 2_8 * N8 END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = max( NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + (NB_REAL+TEMPR) * int(KEEP(35),8) & , TEMP ) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN CMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE CMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF CMUMPS_LBUFR_BYTES8 = max( CMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(489).GT.0) THEN CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( 0.5E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0,8) ELSE CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0,8) ENDIF CMUMPS_LBUFR_BYTES8 = min(CMUMPS_LBUFR_BYTES8, & int(huge (KEEP(43))-100,8)) NB_BYTES = NB_BYTES + CMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 & * real(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF CMUMPS_LBUF8 = max( CMUMPS_LBUF8, 100000_8 ) CMUMPS_LBUF8 = CMUMPS_LBUF8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUF8)/100E0, 8) CMUMPS_LBUF8 = min(CMUMPS_LBUF8, int(huge (KEEP(43)-100),8)) CMUMPS_LBUF8 = max(CMUMPS_LBUF8, CMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + CMUMPS_LBUF8 ENDIF CMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(CMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN NB_INT = NB_INT + N8*KEEP(400) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 2 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 2 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI IF (KEEP(494).NE.0) THEN NB_INT = NB_INT + N8 ENDIF ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( real(MEMORY_BYTES) / real(1000000) ) RETURN END SUBROUTINE CMUMPS_MAX_MEM SUBROUTINE CMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL CMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE CMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE CMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(36)) * ( 1.0E0 - & real(ICNTL38)/real(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -real(KEEP8(11)-KEEP8(32)) * & real(ICNTL38) / 1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(38)) * ( 1.0E0 - & real(ICNTL38+ICNTL39)/ & real(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL38+ICNTL39)/1000.0E0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & real(KEEP8(37)) * ( 1.0E0 - & real(ICNTL39)/real(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -real(KEEP8(39))* & real(ICNTL39)/1000.0E0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (KEEP8(4)/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF CALL CMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, & .FALSE., & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) 500 CONTINUE RETURN END SUBROUTINE CMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE CMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL CMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE CMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE CMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE REAL M_ARRAY(M_SIZE) REAL ZERO PARAMETER (ZERO=0.0E0) M_ARRAY=ZERO RETURN END SUBROUTINE CMUMPS_SETMAXTOZERO SUBROUTINE CMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE CMUMPS_COMPUTE_NBROWSinF SUBROUTINE CMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE CMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB COMPLEX A(ASIZE) REAL M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW REAL ZERO,TMP PARAMETER (ZERO=0.0E0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE CMUMPS_COMPUTE_MAXPERCOL SUBROUTINE CMUMPS_SIZE_IN_STRUCT( id, NB_INT, NB_CMPLX, NB_CHAR ) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE(CMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) NB_INT=NB_INT+size(id%STEP) IF (associated(id%NE_STEPS )) NB_INT=NB_INT+size(id%NE_STEPS ) IF (associated(id%ND_STEPS)) NB_INT=NB_INT+size(id%ND_STEPS) IF (associated(id%Step2node)) NB_INT=NB_INT+size(id%Step2node) IF (associated(id%FRERE_STEPS)) NB_INT=NB_INT+size(id%FRERE_STEPS) IF (associated(id%DAD_STEPS)) NB_INT=NB_INT+size(id%DAD_STEPS) IF (associated(id%FILS)) NB_INT=NB_INT+size(id%FILS) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) NB_INT=NB_INT+size(id%KEEP8) * id%KEEP(10) IF (associated(id%PTRFAC)) NB_INT=NB_INT+size(id%PTRFAC) * & id%KEEP(10) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%NA)) NB_INT=NB_INT+size(id%NA) IF (associated(id%PROCNODE_STEPS)) & NB_INT=NB_INT+size(id%PROCNODE_STEPS) IF (associated(id%PTLUST_S)) NB_INT=NB_INT+size(id%PTLUST_S) IF (associated(id%INTARR)) NB_INT=NB_INT+id%KEEP8(27) IF (associated(id%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES) IF (associated(id%SYM_PERM)) & NB_INT=NB_INT+size(id%SYM_PERM) IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE) IF (associated(id%I_AM_CAND)) & NB_INT=NB_INT+size(id%I_AM_CAND) IF (associated(id%MEM_DIST)) & NB_INT=NB_INT+size(id%MEM_DIST) IF (associated(id%POSINRHSCOMP_ROW)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_ROW) IF(id%POSINRHSCOMP_COL_ALLOC.AND.associated(id%POSINRHSCOMP_COL)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_COL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) & NB_INT=NB_INT+size(id%LRGROUPS) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(id%root%RG2L_COL)) & NB_INT=NB_INT+size(id%root%RG2L_COL) IF (associated(id%root%RG2L_ROW)) & NB_INT=NB_INT+size(id%root%RG2L_ROW) IF (associated(id%root%IPIV)) & NB_INT=NB_INT+size(id%root%IPIV) IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_CNTR_MASTER_ROOT) IF (associated(id%root%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(id%root%SCHUR_POINTER) IF (associated(id%root%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(id%root%QR_TAU) IF (associated(id%root%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_ROOT) IF (associated(id%root%SVD_U)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_U) IF (associated(id%root%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_VT) IF (associated(id%root%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%root%SINGULAR_VALUES) IF (associated(id%DBLARR)) NB_CMPLX=NB_CMPLX+id%KEEP8(26) IF (associated(id%RHSCOMP)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL/2_8 NB_CMPLX = NB_CMPLX + id%KEEP8(71) + id%KEEP8(64) RETURN END SUBROUTINE CMUMPS_SIZE_IN_STRUCT SUBROUTINE CMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 COMPLEX, intent(in) :: SRC(N8) COMPLEX, intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL ccopy(N8, SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL ccopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE CMUMPS_COPYI8SIZE SUBROUTINE CMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE CMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 COMPLEX, INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL CMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE CMUMPS_SET_TMP_PTR SUBROUTINE CMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE CMUMPS_OOC, ONLY : IO_BLOCK, & CMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL CMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE CMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) USE CMUMPS_BUF, ONLY : CMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT CALL CMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) RETURN END SUBROUTINE CMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL CMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE CMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE CMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR COMPLEX, intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) COMPLEX :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) REAL,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) REAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL CMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE CMUMPS_COMPRESS_CB_I SUBROUTINE CMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, OMP_NUM & ) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) COMPLEX, intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER REAL :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) COMPLEX :: WORK(MAXI_CLUSTER*MAXI_CLUSTER*OMP_NUM) COMPLEX :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM REAL,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL CMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE CMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE CMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA COMPLEX, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL CMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE CMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL CMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE CMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE CMUMPS_LR_TYPE, ONLY : LRB_TYPE USE CMUMPS_FAC_LR, ONLY : CMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX, INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT REAL,intent(in) :: TOLEPS CALL CMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE CMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I MUMPS_5.4.1/src/mumps_thread.c0000664000175000017500000000167414102210474016354 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #define USLEEP F_SYMBOL(usleep,USLEEP) #include "mumps_common.h" #if defined(MUMPS_WIN32) # include void MUMPS_CALL USLEEP(MUMPS_INT* time) { /* int* time : in microseconds */ /* Sleep: milliseconds */ Sleep((unsigned long)(*time)/1000); } #else # include void MUMPS_CALL USLEEP(MUMPS_INT* time) { /* int* time : in microseconds */ /* usleep: microseconds */ usleep((unsigned int)*time); } #endif MUMPS_5.4.1/src/cfac_process_contrib_type1.F0000664000175000017500000001163614102210523021115 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER LBUFR, LBUFR_BYTES INTEGER KEEP(500), BUFR( LBUFR ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP, FPERE LOGICAL FLAG INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER IFLAG, IERROR, COMM INTEGER POSITION, FINODE, FLCONT, LREQ INTEGER(8) :: LREQCB INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET INTEGER SIZE_PACKET INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INCLUDE 'mumps_headers.h' LOGICAL PACKED_CB COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE FLAG = .FALSE. POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & FLCONT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, MPI_INTEGER, & COMM, IERR) PACKED_CB = (FLCONT.LT.0) IF (PACKED_CB) THEN FLCONT = -FLCONT LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 ELSE LREQCB = int(FLCONT,8) * int(FLCONT,8) ENDIF IF (NBROWS_ALREADY_SENT == 0) THEN LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) CALL CMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PIMASTER(STEP( FINODE )) = IWPOSCB + 1 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 IF (PACKED_CB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), & MPI_INTEGER, COMM, IERR) ENDIF IF (PACKED_CB) THEN ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * & int(NBROWS_ALREADY_SENT+1,8) / 2_8 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + & NBROWS_ALREADY_SENT * NBROWS_PACKET ELSE ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) SIZE_PACKET = NBROWS_PACKET * FLCONT ENDIF IF (NBROWS_PACKET.NE.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(FINODE))+XXD)) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(FINODE)), & DYN_SIZE, SON_A ) IPOS_NODE = 1_8 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & SON_A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_COMPLEX, COMM, IERR) ELSE IPOS_NODE = PAMASTER(STEP(FINODE)) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & A(IPOS_NODE + ISHIFT_PACKET), & SIZE_PACKET, MPI_COMPLEX, COMM, IERR) ENDIF ENDIF IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN FLAG = . TRUE. END IF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_NODE MUMPS_5.4.1/src/dmumps_ooc_buffer.F0000664000175000017500000004333714102210522017321 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC DOUBLE PRECISION, DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE DMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE DMUMPS_OOC_NEXT_HBUF SUBROUTINE DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL DMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL DMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE DMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE DMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE DMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE DMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE DMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in DMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'DMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL DMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL DMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE DMUMPS_INIT_OOC_BUF SUBROUTINE DMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_END_OOC_BUF SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL DMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE DMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK DOUBLE PRECISION BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL DMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE DMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL DMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE DMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE DMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL DMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL DMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE DMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE DMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE DMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE DMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' DMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL DMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL DMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'DMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL DMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL dcopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL dcopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL dcopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE DMUMPS_COPY_LU_TO_BUFFER END MODULE DMUMPS_OOC_BUFFER MUMPS_5.4.1/src/cfac_process_bf.F0000664000175000017500000000103114102210523016706 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_BF_RETURN() RETURN END SUBROUTINE CMUMPS_PROCESS_BF_RETURN MUMPS_5.4.1/src/sini_defaults.F0000664000175000017500000014006514102210525016453 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE SMUMPS_SET_TYPE_SIZES( K34, K35, K16, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (REAL, DOUBLE PRECISION, C REAL or DOUBLE REAL) in K35 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (REAL for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K35: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K16 = K35 for S and D arithmetics C K16 = K35 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C C INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) REAL R(2) ! Will be DOUBLE PRECISION if 0 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K16 = int(SIZE_REAL_OR_DOUBLE) K35 = K16 RETURN END SUBROUTINE SMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE SMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C SMUMPS, SMUMPS_ANA_DRIVER, SMUMPS_FAC_DRIVER, SMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C REAL DKEEP(230) REAL CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C SMUMPS Default values C are set by SMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of SMUMPS. C C CNTL(1) threshold for partial pivoting C has default value 0.0 when SYM=1 and 0.01 otherwise C Values and less than zero as treated as zero. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS 10^{-5} ||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by SMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in SMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in SMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in SMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C SMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by SMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 1. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then SMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in SMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12), INFOG(34) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C C ICNTL(34) Must be set before a call to MUMPS with JOB=-2 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UCFS variant, no recompression: Compress step is C performed before the Solve; pivoting strategy is adapted C to pe performed on low-rank blocks; the low-rank updates are not C recompressed C C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 333 C (when factors of BLR fronts are compressed, C their size is 33.3% of their full- rank size). C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see SMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see SMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all SMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots. C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of SMUMPS. C C C RINFOG is a REAL/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of SMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for REAL parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0E0 RINFOG(1:40)= 0.0E0 CNTL(1:15) = 0.0E0 DKEEP(1:230) = 0.0E0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting IF ( KEEP(50) .NE. 1 ) THEN CNTL(1) = 0.01E0 ELSE CNTL(1) = 0.0E0 END IF CNTL(2) = sqrt(epsilon(0.0E0)) CNTL(3) = 0.0E0 CNTL(4) = -1.0E0 CNTL(5) = 0.0E0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off ICNTL(13) = 0 C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (33.3%) ICNTL(38) = 333 ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 1 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 50 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 50 END IF KEEP(63) = 60 KEEP(48) = 5 CALL SMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(real(NSLAVES+1))*real(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 ! old splitting IF (NSLAVES.GT.4) THEN KEEP(78)=max( & int(log(real(NSLAVES))/log(real(2))) - 2 & , 0 ) ENDIF KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 KEEP(82) = 30 KEEP(83) = min(8,NSLAVES/4) KEEP(83) = max(min(4,NSLAVES),max(KEEP(83),1)) KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)=min(8, NSLAVES) KEEP(91) = max(min(4,NSLAVES),min(KEEP(83),KEEP(91))) IF(NSLAVES.LT.48)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.128)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.256)THEN KEEP(102)=200 ELSEIF(NSLAVES.LT.512)THEN KEEP(102)=300 ELSEIF(NSLAVES.GE.512)THEN KEEP(102)=400 ENDIF #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=15 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(211)=2 IF (NSLAVES .EQ. 2) THEN KEEP(213) = 101 ELSE KEEP(213) = 201 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 KEEP(219)=1 IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0E0 DKEEP(5) = -1.0E0 C#if defined(try_null_space) DKEEP(10) = -9E0 ! default value is 10E-1 set in fac_driver.F DKEEP(13) = -9E0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0E0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0E0 ! gap precision C#endif KEEP(238)=14 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0E0 DKEEP(18)= 1.0E12 KEEP(242) = -9 KEEP(243) = -1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 C OMP parallelization of arrowheads KEEP(399) = 1 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(461) = 10 KEEP(462) = 10 KEEP(464) = 333 KEEP(465) = 200 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 512 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE SMUMPSID SUBROUTINE SMUMPS_SET_KEEP72(id, LP) USE SMUMPS_STRUC_DEF IMPLICIT NONE TYPE (SMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1E0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 ELSE IF (id%KEEP(72)==2) THEN id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(62) = 10 ! default is 50 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs id%KEEP(213) = 121 ! default is 201 END IF RETURN END SUBROUTINE SMUMPS_SET_KEEP72 MUMPS_5.4.1/src/cfac_sispointers_m.F0000664000175000017500000000151214102210526017466 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_S_IS_POINTERS_M C ---------------------------------- C This module defines a type used in C CMUMPS_FAC_DRIVER and CMUMPS_FAC_B C ---------------------------------- TYPE S_IS_POINTERS_T COMPLEX, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IW END TYPE S_IS_POINTERS_T END MODULE CMUMPS_FAC_S_IS_POINTERS_M MUMPS_5.4.1/src/smumps_f77.F0000664000175000017500000003577314102210521015636 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, NBLK, ICNTL, & CNTL, KEEP, DKEEP, KEEP8, NZ, NNZ, IRN, IRNhere, JCN, & JCNhere, A, Ahere, NZ_loc, NNZ_loc, IRN_loc, IRN_lochere, & JCN_loc, JCN_lochere, A_loc, A_lochere, NELT, ELTPTR, & ELTPTRhere, ELTVAR, ELTVARhere, A_ELT, A_ELThere, & BLKPTR, BLKPTRhere, BLKVAR, BLKVARhere, & PERM_IN, PERM_INhere, RHS, RHShere, REDRHS, REDRHShere, & INFO, RINFO, INFOG, RINFOG, DEFICIENCY, LWK_USER, & SIZE_SCHUR, LISTVAR_SCHUR, LISTVAR_SCHURhere, SCHUR, & SCHURhere, WK_USER, WK_USERhere, COLSCA, COLSCAhere, & ROWSCA, ROWSCAhere, INSTANCE_NUMBER, NRHS, LRHS, LREDRHS, & RHS_SPARSE, RHS_SPARSEhere, SOL_loc, SOL_lochere, & RHS_loc, RHS_lochere, & IRHS_SPARSE, IRHS_SPARSEhere, IRHS_PTR, IRHS_PTRhere, & ISOL_loc, ISOL_lochere, IRHS_loc, IRHS_lochere, NZ_RHS, & LSOL_loc, LRHS_loc, Nloc_RHS, & SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD, & MBLOCK, NBLOCK, NPROW, NPCOL, & OOC_TMPDIR, OOC_PREFIX, WRITE_PROBLEM, & SAVE_DIR, SAVE_PREFIX, & TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN, & SAVE_DIRLEN, SAVE_PREFIXLEN, & METIS_OPTIONS & ) USE SMUMPS_STRUC_DEF IMPLICIT NONE INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH INTEGER PB_MAX_LENGTH PARAMETER(OOC_PREFIX_MAX_LENGTH=63, OOC_TMPDIR_MAX_LENGTH=255) PARAMETER(PB_MAX_LENGTH=255) INTEGER, PARAMETER :: SAVE_DIR_MAX_LENGTH = 255 INTEGER, PARAMETER :: SAVE_PREFIX_MAX_LENGTH = 255 INTEGER JOB, SYM, PAR, COMM_F77, N, NBLK, NZ, NZ_loc, NELT, & DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER, & NRHS, LRHS, & NZ_RHS, LSOL_loc,Nloc_RHS, LRHS_loc, LREDRHS INTEGER(8) :: NNZ, NNZ_loc INTEGER ICNTL(60), INFO(80), INFOG(80), KEEP(500) INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD INTEGER MBLOCK, NBLOCK, NPROW, NPCOL INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230) INTEGER(8) KEEP8(150) INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*) INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*) INTEGER, TARGET :: LISTVAR_SCHUR(*) INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*) INTEGER, TARGET :: ISOL_loc(*), IRHS_loc(*) INTEGER, TARGET :: BLKPTR(*), BLKVAR(*) REAL, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*) REAL, TARGET :: WK_USER(*) REAL, TARGET :: REDRHS(*) REAL, TARGET :: ROWSCA(*), COLSCA(*) REAL, TARGET :: SCHUR(*) REAL, TARGET :: RHS_SPARSE(*), SOL_loc(*), RHS_loc(*) INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH) INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH) INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH) INTEGER SAVE_DIRLEN, SAVE_PREFIXLEN INTEGER, INTENT(in) :: SAVE_DIR(SAVE_DIR_MAX_LENGTH) INTEGER, INTENT(in) :: SAVE_PREFIX(SAVE_PREFIX_MAX_LENGTH) INTEGER METIS_OPTIONS(40) INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere, & A_ELThere, BLKPTRhere, BLKVARhere, PERM_INhere, & WK_USERhere, & RHShere, REDRHShere, IRN_lochere, & JCN_lochere, A_lochere, LISTVAR_SCHURhere, & SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere, & SOL_lochere, RHS_lochere, IRHS_PTRhere, IRHS_SPARSEhere, & ISOL_lochere, IRHS_lochere INCLUDE 'mpif.h' TYPE SMUMPS_STRUC_PTR TYPE (SMUMPS_STRUC), POINTER :: PTR END TYPE SMUMPS_STRUC_PTR TYPE (SMUMPS_STRUC), POINTER :: mumps_par TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE :: & mumps_par_array TYPE (SMUMPS_STRUC_PTR), DIMENSION (:), POINTER :: & mumps_par_array_bis INTEGER, SAVE :: SMUMPS_STRUC_ARRAY_SIZE = 0 INTEGER, SAVE :: N_INSTANCES = 0 INTEGER I, Np, IERR INTEGER(8) :: A_ELT_SIZE, NNZ_i INTEGER SMUMPS_STRUC_ARRAY_SIZE_INIT PARAMETER (SMUMPS_STRUC_ARRAY_SIZE_INIT=10) EXTERNAL MUMPS_ASSIGN_MAPPING, & MUMPS_ASSIGN_PIVNUL_LIST, & MUMPS_ASSIGN_SYM_PERM, & MUMPS_ASSIGN_UNS_PERM EXTERNAL SMUMPS_ASSIGN_COLSCA, & SMUMPS_ASSIGN_ROWSCA IF (JOB == -1) THEN DO I = 1, SMUMPS_STRUC_ARRAY_SIZE IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10 END DO ALLOCATE( mumps_par_array_bis(SMUMPS_STRUC_ARRAY_SIZE + & SMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR) IF (IERR /= 0) THEN WRITE(*,*) ' ** Allocation Error 1 in SMUMPS_F77.' CALL MUMPS_ABORT() END IF DO I = 1, SMUMPS_STRUC_ARRAY_SIZE mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR ENDDO IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array) mumps_par_array=>mumps_par_array_bis NULLIFY(mumps_par_array_bis) DO I = SMUMPS_STRUC_ARRAY_SIZE+1, SMUMPS_STRUC_ARRAY_SIZE + & SMUMPS_STRUC_ARRAY_SIZE_INIT NULLIFY(mumps_par_array(I)%PTR) ENDDO I = SMUMPS_STRUC_ARRAY_SIZE+1 SMUMPS_STRUC_ARRAY_SIZE = SMUMPS_STRUC_ARRAY_SIZE + & SMUMPS_STRUC_ARRAY_SIZE_INIT 10 CONTINUE INSTANCE_NUMBER = I N_INSTANCES = N_INSTANCES+1 ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR ) IF (IERR /= 0) THEN WRITE(*,*) '** Allocation Error 2 in SMUMPS_F77.' CALL MUMPS_ABORT() ENDIF ICNTL(1:60) = 0 CNTL(1:15) = 0.0E0 KEEP(1:500) = 0 DKEEP(1:230) = 0.0E0 KEEP8(1:150) = 0_8 METIS_OPTIONS(1:40) = 0 mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER = & INSTANCE_NUMBER END IF IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT. & SMUMPS_STRUC_ARRAY_SIZE ) THEN WRITE(*,*) ' ** Instance Error 1 in SMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) ) & THEN WRITE(*,*) ' Instance Error 2 in SMUMPS_F77', & INSTANCE_NUMBER CALL MUMPS_ABORT() END IF mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR mumps_par%SYM = SYM mumps_par%PAR = PAR mumps_par%JOB = JOB mumps_par%N = N mumps_par%NBLK = NBLK mumps_par%NZ = NZ mumps_par%NNZ = NNZ mumps_par%NZ_loc = NZ_loc mumps_par%NNZ_loc = NNZ_loc mumps_par%LWK_USER = LWK_USER mumps_par%SIZE_SCHUR = SIZE_SCHUR mumps_par%NELT= NELT mumps_par%ICNTL(1:60)=ICNTL(1:60) mumps_par%CNTL(1:15)=CNTL(1:15) mumps_par%KEEP(1:500)=KEEP(1:500) mumps_par%DKEEP(1:230)=DKEEP(1:230) mumps_par%KEEP8(1:150)=KEEP8(1:150) mumps_par%METIS_OPTIONS(1:40)=METIS_OPTIONS(1:40) mumps_par%NRHS = NRHS mumps_par%LRHS = LRHS mumps_par%LREDRHS = LREDRHS mumps_par%NZ_RHS = NZ_RHS mumps_par%LSOL_loc = LSOL_loc mumps_par%Nloc_RHS = Nloc_RHS mumps_par%LRHS_loc = LRHS_loc mumps_par%SCHUR_MLOC = SCHUR_MLOC mumps_par%SCHUR_NLOC = SCHUR_NLOC mumps_par%SCHUR_LLD = SCHUR_LLD mumps_par%MBLOCK = MBLOCK mumps_par%NBLOCK = NBLOCK mumps_par%NPROW = NPROW mumps_par%NPCOL = NPCOL IF ( COMM_F77 .NE. -987654 ) THEN mumps_par%COMM = COMM_F77 ELSE mumps_par%COMM = MPI_COMM_WORLD ENDIF CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR) CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i) IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i) IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i) IF ( Ahere /= 0 ) mumps_par%A => A(1:NNZ_i) CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i) IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i) IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i) IF ( A_lochere /= 0 ) mumps_par%A_loc => A_loc(1:NNZ_i) IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1) IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR => & ELTVAR(1:ELTPTR(NELT+1)-1) IF ( A_ELThere /= 0 ) THEN A_ELT_SIZE = 0_8 DO I = 1, NELT Np = ELTPTR(I+1) -ELTPTR(I) IF (SYM == 0) THEN A_ELT_SIZE = A_ELT_SIZE + Np * Np ELSE A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2 END IF END DO mumps_par%A_ELT => A_ELT(1_8:A_ELT_SIZE) END IF IF ( BLKPTRhere /= 0 ) mumps_par%BLKPTR => BLKPTR(1:NBLK+1) IF ( BLKVARhere /= 0 ) mumps_par%BLKVAR => BLKVAR(1:N) IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N) IF ( LISTVAR_SCHURhere /= 0) & mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR) IF ( SCHURhere /= 0 ) THEN mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1) ENDIF IF (NRHS .NE. 1) THEN IF ( RHShere /= 0 ) mumps_par%RHS => & RHS(1_8:int(NRHS,8)*int(LRHS,8)) IF (REDRHShere /= 0)mumps_par%REDRHS=> & REDRHS(1_8:int(NRHS,8)*int(LREDRHS,8)) ELSE IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N) IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR) ENDIF IF ( WK_USERhere /=0 ) THEN IF (LWK_USER > 0 ) THEN mumps_par%WK_USER => WK_USER(1:LWK_USER) ELSE mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8) ENDIF ENDIF IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N) IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N) IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=> & RHS_SPARSE(1:NZ_RHS) IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=> & IRHS_SPARSE(1:NZ_RHS) IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=> & SOL_loc(1_8:int(LSOL_loc,8)*int(NRHS,8)) IF ( RHS_lochere /=0 ) mumps_par%RHS_loc=> & RHS_loc(1_8:int(LRHS_loc,8)*int(NRHS,8)) IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=> & ISOL_loc(1:LSOL_loc) IF ( IRHS_lochere /=0 ) mumps_par%IRHS_loc=> & IRHS_loc(1:LRHS_loc) IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=> & IRHS_PTR(1:NRHS+1) DO I=1,TMPDIRLEN mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I)) ENDDO DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH mumps_par%OOC_TMPDIR(I:I)=' ' ENDDO DO I=1,PREFIXLEN mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I)) ENDDO DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH mumps_par%OOC_PREFIX(I:I)=' ' ENDDO DO I=1,WRITE_PROBLEMLEN mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I)) ENDDO DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH mumps_par%WRITE_PROBLEM(I:I)=' ' ENDDO DO I=1,SAVE_DIRLEN mumps_par%SAVE_DIR(I:I)=char(SAVE_DIR(I)) ENDDO DO I=SAVE_DIRLEN+1,SAVE_DIR_MAX_LENGTH mumps_par%SAVE_DIR(I:I)=' ' ENDDO DO I=1,SAVE_PREFIXLEN mumps_par%SAVE_PREFIX(I:I)=char(SAVE_PREFIX(I)) ENDDO DO I=SAVE_PREFIXLEN+1,SAVE_PREFIX_MAX_LENGTH mumps_par%SAVE_PREFIX(I:I)=' ' ENDDO CALL SMUMPS( mumps_par ) INFO(1:80)=mumps_par%INFO(1:80) INFOG(1:80)=mumps_par%INFOG(1:80) RINFO(1:40)=mumps_par%RINFO(1:40) RINFOG(1:40)=mumps_par%RINFOG(1:40) ICNTL(1:60) = mumps_par%ICNTL(1:60) CNTL(1:15) = mumps_par%CNTL(1:15) KEEP(1:500) = mumps_par%KEEP(1:500) DKEEP(1:230) = mumps_par%DKEEP(1:230) KEEP8(1:150) = mumps_par%KEEP8(1:150) METIS_OPTIONS(1:40) = mumps_par%METIS_OPTIONS(1:40) SYM = mumps_par%SYM PAR = mumps_par%PAR JOB = mumps_par%JOB N = mumps_par%N NBLK = mumps_par%NBLK NZ = mumps_par%NZ NNZ = mumps_par%NNZ NRHS = mumps_par%NRHS LRHS = mumps_par%LRHS LREDRHS = mumps_par%LREDRHS NZ_loc = mumps_par%NZ_loc NNZ_loc = mumps_par%NNZ_loc NZ_RHS = mumps_par%NZ_RHS LSOL_loc = mumps_par%LSOL_loc Nloc_RHS = mumps_par%Nloc_RHS LRHS_loc = mumps_par%LRHS_loc SIZE_SCHUR = mumps_par%SIZE_SCHUR LWK_USER = mumps_par%LWK_USER NELT = mumps_par%NELT DEFICIENCY = mumps_par%Deficiency SCHUR_MLOC = mumps_par%SCHUR_MLOC SCHUR_NLOC = mumps_par%SCHUR_NLOC SCHUR_LLD = mumps_par%SCHUR_LLD MBLOCK = mumps_par%MBLOCK NBLOCK = mumps_par%NBLOCK NPROW = mumps_par%NPROW NPCOL = mumps_par%NPCOL IF ( associated (mumps_par%MAPPING) ) THEN CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1)) ELSE CALL MUMPS_NULLIFY_C_MAPPING() ENDIF IF ( associated (mumps_par%PIVNUL_LIST) ) THEN CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1)) ELSE CALL MUMPS_NULLIFY_C_PIVNUL_LIST() ENDIF IF ( associated (mumps_par%SYM_PERM) ) THEN CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_SYM_PERM() ENDIF IF ( associated (mumps_par%UNS_PERM) ) THEN CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1)) ELSE CALL MUMPS_NULLIFY_C_UNS_PERM() ENDIF IF (associated( mumps_par%COLSCA)) THEN CALL SMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1)) ELSE CALL SMUMPS_NULLIFY_C_COLSCA() ENDIF IF (associated( mumps_par%ROWSCA)) THEN CALL SMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1)) ELSE CALL SMUMPS_NULLIFY_C_ROWSCA() ENDIF TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR) DO I=1,OOC_TMPDIR_MAX_LENGTH OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I)) ENDDO PREFIXLEN=len_trim(mumps_par%OOC_PREFIX) DO I=1,OOC_PREFIX_MAX_LENGTH OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I)) ENDDO IF ( JOB == -2 ) THEN IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR) NULLIFY (mumps_par_array(INSTANCE_NUMBER)%PTR) N_INSTANCES = N_INSTANCES - 1 IF ( N_INSTANCES == 0 ) THEN DEALLOCATE(mumps_par_array) SMUMPS_STRUC_ARRAY_SIZE = 0 END IF ELSE WRITE(*,*) "** Warning: instance already freed" WRITE(*,*) " this should normally not happen." ENDIF END IF RETURN END SUBROUTINE SMUMPS_F77 MUMPS_5.4.1/src/zbcast_int.F0000664000175000017500000000307714102210524015762 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_MCAST2(DATA, LDATA, MPITYPE, ROOT, COMMW, TAG, &SLAVEF, KEEP) USE ZMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER LDATA, ROOT, COMMW, TAG, MPITYPE, SLAVEF INTEGER DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER DATA(LDATA) DO 10 DEST = 0, SLAVEF - 1 IF (DEST .NE. ROOT) THEN IF ( LDATA .EQ. 1 .and. MPITYPE .EQ. MPI_INTEGER ) THEN CALL ZMUMPS_BUF_SEND_1INT( DATA(1), DEST, TAG, & COMMW, KEEP, IERR ) ELSE WRITE(*,*) 'Error : bad argument to ZMUMPS_MCAST2' CALL MUMPS_ABORT() END IF ENDIF 10 CONTINUE RETURN END SUBROUTINE ZMUMPS_MCAST2 SUBROUTINE ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) INTEGER MYID, SLAVEF, COMM INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY (1) DUMMY(1) = -98765 CALL ZMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERREUR, SLAVEF, KEEP ) RETURN END SUBROUTINE ZMUMPS_BDC_ERROR MUMPS_5.4.1/src/dfac_front_type2_aux.F0000664000175000017500000007133114102210523017724 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_FRONT_TYPE2_AUX_M CONTAINS SUBROUTINE DMUMPS_FAC_I_LDLT_NIV2( & DIAG_ORIG, SIZEDIAG_ORIG, GW_FACTCUMUL, & NFRONT, NASS, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK, & NASS2, TIPIV, & N, INODE, IW, LIW, A, LA, NNEGW, NB22T2W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & INOPV, IFLAG, & IOLDPS, POSELT, UU, & SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled, & PIVOT_OPTION, & Inextpiv, IEND_BLR, LR_ACTIVATED, & OOC_EFFECTIVE_ON_FRONT) USE MUMPS_OOC_COMMON, ONLY : TYPEF_L USE DMUMPS_FAC_FRONT_AUX_M IMPLICIT NONE INTEGER SIZEDIAG_ORIG DOUBLE PRECISION DIAG_ORIG(SIZEDIAG_ORIG) DOUBLE PRECISION GW_FACTCUMUL INTEGER NFRONT,NASS,N,LIW,INODE,IFLAG,INOPV INTEGER NASS2, IBEG_BLOCK_TO_SEND, IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout) :: NNEGW, NB22T2W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW DOUBLE PRECISION, intent(inout) :: DET_MANTW INTEGER TIPIV( NASS2 ) INTEGER PIVSIZ,LPIV INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER(8) :: LA DOUBLE PRECISION A(LA) DOUBLE PRECISION UU, UULOC, SEUIL DOUBLE PRECISION CSEUIL INTEGER IW(LIW) INTEGER IOLDPS INTEGER(8) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled include 'mpif.h' INTEGER(8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX INTEGER :: IPIVNUL, HF DOUBLE PRECISION RMAX,AMAX,TMAX,RMAX_NORELAX DOUBLE PRECISION MAXPIV, ABS_PIVOT DOUBLE PRECISION RMAX_NOSLAVE, TMAX_NOSLAVE DOUBLE PRECISION PIVOT,DETPIV DOUBLE PRECISION ABSDETPIV INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX INTEGER(8) :: APOS INTEGER(8) :: J1, J2, JJ, KK DOUBLE PRECISION :: GROWTH, RSWOP DOUBLE PRECISION :: UULOCM1 INTEGER :: LDAFS INTEGER(8) :: LDAFS8 DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 DOUBLE PRECISION ZERO, ONE PARAMETER( ZERO = 0.0D0 ) PARAMETER( ONE = 1.0D0 ) DOUBLE PRECISION PIVNUL, VALTMP DOUBLE PRECISION FIXA INTEGER NPIV,IPIV,K219 INTEGER NPIVP1,ILOC,K,J INTEGER ISHIFT, K206, IPIV_END, IPIV_SHIFT INTRINSIC max INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L DOUBLE PRECISION GW_FACT GW_FACT = RONE AMAX = RZERO RMAX = RZERO TMAX = RZERO RMAX_NOSLAVE = RZERO PIVOT = ONE HF = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) K206 = KEEP(206) PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDAFS = NASS LDAFS8 = int(LDAFS,8) IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+KEEP(IXSZ)) & +KEEP(IXSZ), & IW, LIW) ENDIF UULOC = UU K219 = KEEP(219) IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE K219=0 UULOCM1 = RONE ENDIF IF (K219.LT.2) GW_FACTCUMUL = RONE PIVSIZ = 1 NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NPIVP1 = NPIV + 1 ILOC = NPIVP1 - IBEG_BLOCK_TO_SEND + 1 TIPIV( ILOC ) = ILOC APOSMAX = POSELT+LDAFS8*LDAFS8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + LDAFS8*int(NPIVP1-1,8) + int(NPIV,8) POSPV1 = APOS CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 IF ((K219.GE.2).AND.(NPIVP1.EQ.1)) THEN GW_FACTCUMUL = RONE IF (K219.EQ.3) THEN DO IPIV=1,NASS DIAG_ORIG (IPIV) = abs(A(POSELT + & (LDAFS8+1_8)*int(IPIV-1,8))) ENDDO ELSE IF (K219.GE.4) THEN DIAG_ORIG = RZERO DO IPIV=1,NASS APOS = POSELT + LDAFS8*int(IPIV-1,8) POSPV1 = APOS + int(IPIV - 1,8) DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DO J=IPIV+1,NASS DIAG_ORIG(IPIV) = max( abs(A(POSPV1)), DIAG_ORIG(IPIV) ) DIAG_ORIG(IPIV+J-IPIV) = max( abs(A(POSPV1)), & DIAG_ORIG(IPIV+J-IPIV) ) POSPV1 = POSPV1 + LDAFS8 ENDDO ENDDO ENDIF ENDIF ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDAFS8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (ABS_PIVOT.EQ.RZERO) GO TO 630 IF (PIVOT.LT.RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL DMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF AMAX = -RONE JMAX = 0 J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDAFS8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDAFS8 ENDDO RMAX_NOSLAVE = RZERO IF (PIVOT_OPTION.EQ.2) THEN DO J=1,NASS - IEND_BLOCK RMAX_NOSLAVE = max(abs(A(J1+LDAFS8*int(J-1,8))), & RMAX_NOSLAVE) ENDDO ENDIF IF (K219.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) RMAX = RMAX_NORELAX IF (K219.GE.2) THEN IF (ABS_PIVOT.NE.RZERO.AND. & ABS_PIVOT.GE.UULOC*max(RMAX,RMAX_NOSLAVE,AMAX)) & THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = ABS_PIVOT ELSE GROWTH = ABS_PIVOT / DIAG_ORIG(IPIV) ENDIF ELSE IF (K219.GE.4) THEN IF (DIAG_ORIG(IPIV).EQ.RZERO) THEN DIAG_ORIG(IPIV) = max(AMAX,RMAX_NOSLAVE) ELSE GROWTH = max(ABS_PIVOT,AMAX,RMAX_NOSLAVE)/ & DIAG_ORIG(IPIV) ENDIF ENDIF RMAX = RMAX*max(GROWTH,GW_FACTCUMUL) ENDIF ENDIF ELSE RMAX = RZERO RMAX_NORELAX = RZERO ENDIF RMAX_NOSLAVE = max(RMAX_NORELAX,RMAX_NOSLAVE) RMAX = max(RMAX,RMAX_NOSLAVE) IF (max(AMAX,RMAX,ABS_PIVOT).LE.PIVNUL) THEN CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF (dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO DO J=1, NASS-IPIV A(POSPV1+int(J,8)*LDAFS8) = ZERO ENDDO VALTMP = max(1.0D10*RMAX, sqrt(huge(RMAX))/1.0D8) A(POSPV1) = VALTMP ENDIF PIVOT = A(POSPV1) ABS_PIVOT = abs(PIVOT) GO TO 415 ENDIF IF (ABS_PIVOT.GE.UULOC*max(RMAX,AMAX) & .AND. ABS_PIVOT .GT. max(SEUIL, tiny(RMAX))) THEN IF (A(POSPV1).LT.RZERO) NNEGW = NNEGW+1 CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( ABS_PIVOT, DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL DMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX .EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF (RMAX_NOSLAVE.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX_NOSLAVE = max(RMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO J=1,NASS-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX_NOSLAVE = max(abs(A(POSPV1+LDAFS8*int(J,8))), & RMAX_NOSLAVE) ENDIF ENDDO RMAX = max(RMAX, RMAX_NOSLAVE) ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDAFS8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX_NOSLAVE = RZERO IF(JMAX .LT. IPIV) THEN JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 IF (JMAX+K.NE.IPIV) THEN TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDIF ENDDO DO KK = APOSJ, POSPV2-1_8 TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDDO ELSE JJ = POSPV2 DO K = 1, NASS-JMAX JJ = JJ+LDAFS8 TMAX_NOSLAVE=max(TMAX_NOSLAVE,abs(A(JJ))) ENDDO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX_NOSLAVE = max(TMAX_NOSLAVE,abs(A(KK))) ENDIF ENDDO ENDIF IF (K219.NE.0) THEN TMAX = max(SEUIL*UULOCM1,dble(A(APOSMAX+int(JMAX,8)))) ELSE TMAX = SEUIL*UULOCM1 ENDIF IF (K219.GE.2) THEN GROWTH = RONE IF (K219.EQ.3) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX) = abs(A(POSPV2)) ELSE GROWTH = abs(A(POSPV2))/DIAG_ORIG(JMAX) ENDIF ELSE IF (K219.EQ.4) THEN IF (DIAG_ORIG(JMAX).EQ.RZERO) THEN DIAG_ORIG(JMAX)=max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) ELSE GROWTH = max(abs(A(POSPV2)),AMAX,TMAX_NOSLAVE) & / DIAG_ORIG(JMAX) ENDIF ENDIF TMAX = TMAX*max(GROWTH,GW_FACTCUMUL) ENDIF TMAX = max (TMAX,TMAX_NOSLAVE) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)*A(OFFDAG) ABSDETPIV = abs(DETPIV) IF (SEUIL.GT.RZERO) THEN IF (sqrt(ABSDETPIV) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & ABSDETPIV .OR. ABSDETPIV .EQ. RZERO) THEN GO TO 460 ENDIF CALL DMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258).NE.0) THEN CALL DMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T2W = NB22T2W+1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2 ) THEN IF (K==1) THEN LPIV = min(IPIV, JMAX) TIPIV(ILOC) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ELSE LPIV = max(IPIV, JMAX) TIPIV(ILOC+1) = -(LPIV - IBEG_BLOCK_TO_SEND + 1) ENDIF ELSE LPIV = IPIV TIPIV(ILOC) = IPIV - IBEG_BLOCK_TO_SEND + 1 ENDIF IF (LPIV.EQ.NPIVP1) THEN GOTO 416 ENDIF KEEP8(80) = KEEP8(80)+1 CALL DMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, NASS, & LDAFS, NFRONT, 2, K219, KEEP(50), & KEEP(IXSZ), IBEG_BLOCK_TO_SEND ) IF (K219.GE.3) THEN RSWOP = DIAG_ORIG(LPIV) DIAG_ORIG(LPIV) = DIAG_ORIG(NPIVP1) DIAG_ORIG(NPIVP1) = RSWOP ENDIF 416 CONTINUE IF ((KEEP(50).NE.1) .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL DMUMPS_STORE_PERMINFO( & IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1+1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+LDAFS8*int(NPIV,8)+int(NPIV+1,8)) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE IFLAG = -10 420 CONTINUE IF (K219.GE.2) THEN IF(INOPV .EQ. 0) THEN IF(PIVSIZ .EQ. 1) THEN GW_FACT = max(AMAX,RMAX_NOSLAVE)/ABS_PIVOT ELSE IF(PIVSIZ .EQ. 2) THEN GW_FACT = max( & (abs(A(POSPV2))*RMAX_NOSLAVE+AMAX*TMAX_NOSLAVE) & / ABSDETPIV , & (abs(A(POSPV1))*TMAX_NOSLAVE+AMAX*RMAX_NOSLAVE) & / ABSDETPIV & ) ENDIF GW_FACT = min(GW_FACT, UULOCM1) GW_FACTCUMUL = max(GW_FACT,GW_FACTCUMUL) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_I_LDLT_NIV2 SUBROUTINE DMUMPS_FAC_MQ_LDLT_NIV2 & (IEND_BLOCK, & NASS, NPIV, INODE, A, LA, LDAFS, & POSELT,IFINB,PIVSIZ, & K219, PIVOT_OPTION, IEND_BLR, LR_ACTIVATED) IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: K219 DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: NPIV, PIVSIZ INTEGER, intent(in) :: NASS,INODE,LDAFS INTEGER, intent(out) :: IFINB INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED DOUBLE PRECISION VALPIV INTEGER NCB1 INTEGER(8) :: APOS, APOSMAX INTEGER(8) :: LPOS, LPOS1, LPOS2, K1POS INTEGER(8) :: JJ, K1, K2 INTEGER(8) :: POSPV1, POSPV2, OFFDAG, OFFDAG_OLD INTEGER(8) :: LDAFS8 INTEGER NEL2 DOUBLE PRECISION ONE, ALPHA DOUBLE PRECISION ZERO INTEGER NPIV_NEW, I INTEGER(8) :: IBEG, IEND, IROW, J8 INTEGER :: J2 DOUBLE PRECISION SWOP,DETPIV,MULT1,MULT2, A11, A22, A12 PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO=0.0D0) INCLUDE 'mumps_headers.h' LDAFS8 = int(LDAFS,8) NPIV_NEW = NPIV + PIVSIZ IFINB = 0 NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDAFS8 DO I = 1, NEL2 K1POS = LPOS + int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO IF (PIVOT_OPTION.EQ.2) THEN NCB1 = NASS - IEND_BLOCK ELSE NCB1 = IEND_BLR - IEND_BLOCK ENDIF !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDAFS8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) A(APOSMAX) = A(APOSMAX) * abs(VALPIV) DO J8 = 1_8, int(NEL2+NCB1,8) A(APOSMAX+J8) = A(APOSMAX+J8) + & A(APOSMAX) * abs(A(APOS+J8)) ENDDO ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(LDAFS8 + 1_8) POSPV2 = POSPV1+LDAFS8+1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1+1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDAFS8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL dcopy(NASS-NPIV_NEW, A(LPOS1), LDAFS, A(POSPV1+2_8), 1) CALL dcopy(NASS-NPIV_NEW, A(LPOS2), LDAFS, A(POSPV2+1_8), 1) JJ = POSPV2 + int(NASS-1,8) IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS + 1,8) JJ = JJ+int(NASS,8) ENDDO IEND = IEND-1_8 DO J2 = IEND_BLOCK+1,NASS K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1+2_8 K2 = POSPV2+1_8 DO IROW = IBEG,IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = -MULT1 A(JJ+1_8) = -MULT2 IBEG = IBEG + int(NASS,8) IEND = IEND + int(NASS,8) JJ = JJ+int(NASS,8) ENDDO IF (K219.eq. -1) THEN APOSMAX = POSELT + int(NASS,8) * LDAFS8 + int(NPIV,8) JJ = APOSMAX K1 = JJ K2 = JJ + 1_8 MULT1 = abs(A11)*A(K1)+abs(A12)*A(K2) MULT2 = abs(A12)*A(K1)+abs(A22)*A(K2) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 IBEG = APOSMAX + 2_8 IEND = APOSMAX + 1_8 + NASS - NPIV_NEW DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*abs(A(K1)) + MULT2*abs(A(K2)) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A(JJ) = MULT1 A(JJ+1_8) = MULT2 ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_FAC_MQ_LDLT_NIV2 SUBROUTINE DMUMPS_SEND_FACTORED_BLK( COMM_LOAD, ASS_IRECV, N, & INODE, FPERE, IW, LIW, IOLDPS, POSELT, A, LA, LDA_FS, & IBEG_BLOCK, IEND, TIPIV, LPIV, LASTBL, NB_BLOC_FAC, & COMM, MYID, BUFR, LBUFR,LBUFR_BYTES,NBFIN,LEAF, & IFLAG, IERROR, IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST_S, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_S,PERM,PROCNODE_STEPS, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , NELIM, LR_ACTIVATED, NPARTSASS, CURRENT_BLR_PANEL & , BLR_LorU & , LRGROUPS & ) USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_TYPE USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, INODE, FPERE, LIW, IBEG_BLOCK, IEND, LPIV, & IOLDPS, LDA_FS, NB_BLOC_FAC INTEGER(8) :: POSELT, LA INTEGER IW(LIW), TIPIV(LPIV) LOGICAL LASTBL DOUBLE PRECISION A(LA) INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER NBFIN, IFLAG, IERROR, LEAF, LPOOL, & SLAVEF, ICNTL(60) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB, COMP INTEGER BUFR( LBUFR ), IPOOL(LPOOL), & ITLOC(N+KEEP(253)), FILS(N), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), & PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:) :: BLR_LorU INTEGER, intent(in) :: LRGROUPS(N) INTEGER :: NELIM INTEGER, intent(in) :: NPARTSASS, CURRENT_BLR_PANEL INCLUDE 'mumps_headers.h' INTEGER(8) :: APOS, LREQA INTEGER NPIV, NCOL, PDEST, NSLAVES, WIDTH INTEGER IERR, LREQI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION FLOP1,FLOP2 LOGICAL COMPRESS_CB COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (NSLAVES.EQ.0) THEN WRITE(6,*) ' ERROR 1 in DMUMPS_SEND_FACTORED_BLK ' CALL MUMPS_ABORT() ENDIF NPIV = IEND - IBEG_BLOCK + 1 NCOL = LDA_FS - IBEG_BLOCK + 1 APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) IF (IBEG_BLOCK > 0) THEN CALL MUMPS_GET_FLOPS_COST( LDA_FS, IBEG_BLOCK-1, LPIV, & KEEP(50),2,FLOP1) ELSE FLOP1=0.0D0 ENDIF CALL MUMPS_GET_FLOPS_COST( LDA_FS, IEND, LPIV, & KEEP(50),2,FLOP2) FLOP2 = FLOP1 - FLOP2 CALL DMUMPS_LOAD_UPDATE(1, .FALSE., FLOP2, KEEP,KEEP8) IF ((NPIV.GT.0) .OR. & ((NPIV.EQ.0).AND.(LASTBL)) & ) THEN IF ((NPIV.EQ.0).AND.(LASTBL)) THEN IF (COMPRESS_CB) THEN IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 COMPRESS_CB = .FALSE. ENDIF ENDIF PDEST = IOLDPS + 6 + KEEP(IXSZ) IF (( NPIV .NE. 0 ).AND.(KEEP(50).NE.0)) THEN NB_BLOC_FAC = NB_BLOC_FAC + 1 END IF IERR = -1 DO WHILE (IERR .EQ.-1) WIDTH = NSLAVES CALL DMUMPS_BUF_SEND_BLOCFACTO( INODE, LDA_FS, NCOL, & NPIV, FPERE, LASTBL, TIPIV, A(APOS), & IW(PDEST), NSLAVES, KEEP, & NB_BLOC_FAC, & NSLAVES, WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & IERR ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF (MESSAGE_RECEIVED) THEN POSELT = PTRAST(STEP(INODE)) APOS = POSELT + int(LDA_FS,8)*int(IBEG_BLOCK-1,8) + & int(IBEG_BLOCK - 1,8) ENDIF IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2 .OR. IERR.EQ.-3 ) THEN IF (IERR.EQ.-2) IFLAG = -17 IF (IERR.EQ.-3) IFLAG = -20 LREQA = int(NCOL,8)*int(NPIV,8) LREQI = NPIV + 6 + 2*NSLAVES + 2 CALL MUMPS_SET_IERROR( & int(LREQI,8) * int(KEEP(34),8) + LREQA * int(KEEP(35),8), & IERROR) GOTO 300 ENDIF ENDIF GOTO 500 300 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_SEND_FACTORED_BLK END MODULE DMUMPS_FAC_FRONT_TYPE2_AUX_M MUMPS_5.4.1/src/ssol_c.F0000664000175000017500000023513514102210521015103 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_SOL_C(root, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, POSINRHSCOMP_BWD, & NZ_RHS, NBCOL_INBLOC, NRHS_ORIG, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS & ) USE SMUMPS_OOC USE SMUMPS_SOL_ES USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( SMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) REAL, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSCOMP, NB_FS_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT REAL A(LA), W(LWC), & W2(KEEP(133)) REAL :: RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP_FWD(N), & POSINRHSCOMP_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT REAL RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IERR INTEGER(8) :: IAPOS INTEGER IOLDPS, & LOCAL_M, & LOCAL_N #if defined(V_T) INTEGER soln_c_class, forw_soln, back_soln, root_soln #endif LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL SWITCH_OFF_ES LOGICAL DUMMY_BOOL INTEGER :: IDUMMY REAL, PARAMETER :: ZERO = 0.0E0 INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS INTEGER nb_nodes_RHS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER nb_prun_roots, JAM1 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in SMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. SWITCH_OFF_ES = .FALSE. IF ( KEEP(111).NE.0 .OR. KEEP(252).NE.0 ) THEN DOFORWARD = .FALSE. ENDIF IF (KEEP(221).eq.1) DOBACKWARD = .FALSE. IF (KEEP(221).eq.2) DOFORWARD = .FALSE. IF ( KEEP(60).EQ.0 .AND. & ( & (KEEP(38).NE.0 .AND. root%yes) & .OR. & (KEEP(20).NE.0 .AND. MYID_NODES.EQ.MASTER_ROOT) & ) & .AND. KEEP(252).EQ.0 & ) &THEN DOROOT = .TRUE. ELSE DOROOT = .FALSE. ENDIF DOROOT_BWD_PANEL = DOROOT .AND. MTYPE.NE.1 .AND. KEEP(50).EQ.0 & .AND. KEEP(201).EQ.1 DOROOT_FWD_OOC = DOROOT .AND. .NOT.DOROOT_BWD_PANEL AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN = (Exploit_Sparsity.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity = .FALSE. DO_PRUN = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in SMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF IF ( DO_PRUN ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN ) THEN nb_prun_nodes = 0 nb_prun_roots = 0 Pruned_SONS(:) = -1 IF ( Exploit_Sparsity ) THEN nb_nodes_RHS = 0 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ELSE IF ( AM1 ) THEN nb_nodes_RHS = 0 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF CALL SMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) CALL SMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL SMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity) MODE_RHS_BOUNDS = 2 CALL SMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL SMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL SMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) SWITCH_OFF_ES = .TRUE. ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF CALL SMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) IF (DO_PRUN) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM SMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=real(TIME_FWD) + DKEEP(117) ENDIF IF (DO_PRUN.AND.SWITCH_OFF_ES) THEN DO_PRUN = .FALSE. Exploit_Sparsity = .FALSE. IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF IF ( DOBACKWARD .AND. DO_PRUN ) THEN nb_prun_leaves = 0 IF ( Exploit_Sparsity .AND. (KEEP(111).EQ.0) ) THEN nb_nodes_RHS = nb_prun_roots ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nodes_RHS(1:nb_prun_roots)=Pruned_Roots(1:nb_prun_roots) DEALLOCATE(Pruned_Roots) ELSE nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF IF ( Exploit_Sparsity ) THEN CALL SMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) CALL SMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL SMUMPS_TREE_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), & KEEP8(31), & STEP, & Pruned_List, & nb_prun_nodes, OOC_FCT_TYPE_TMP) ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL SMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL SMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after SMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL SMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL SMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after SMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=real(TIME_SpecialRoot) + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity.AND.(KEEP(111).EQ.0) ) & .OR. AM1 ) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN OOC_STATE_NODE(STEP(KEEP(38)))=-4 ENDIF ENDIF IF (Exploit_Sparsity.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = AM1 IF ( AM1 ) THEN CALL SMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL SMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL SMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL SMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL SMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL SMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL SMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSCOMP_F.NE.NB_FS_IN_RHSCOMP_TOT)) THEN DO I =1, N II = POSINRHSCOMP_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSCOMP_F)) THEN DO K=1,NRHS RHSCOMP(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( DO_PRUN & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF CALL SMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & ) CALL SMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=real(TIME_BWD)+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSCOMP,1).GT.0) & WRITE (MP,99993) (RHSCOMP(I,1),I=1,K) IF (size(RHSCOMP,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (Exploit_Sparsity.OR.AM1.OR.SWITCH_OFF_ES) THEN IF ( allocated(nodes_RHS)) DEALLOCATE (nodes_RHS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5E14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5E14.6)) 99992 FORMAT (//' LEAVING SOLVE (SMUMPS_SOL_C) WITH') END SUBROUTINE SMUMPS_SOL_C SUBROUTINE SMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSCOMP REAL RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSCOMP, POSINRHSCOMP(LPOS_N) REAL, intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER :: JCOL_RHS INTEGER :: K242 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in SMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_REAL, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in SMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL SMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL SMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL SMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_REAL, & COMM, IERR) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO ENDIF ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE SMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: LOCAL_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN LOCAL_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LOCAL_LSCAL) THEN RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSCOMP= POSINRHSCOMP(IW(J1)) DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL SMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE SMUMPS_NPIV_BLOCK_ADD SUBROUTINE SMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE SMUMPS_NPIV_BLOCK_SEND END SUBROUTINE SMUMPS_GATHER_SOLUTION SUBROUTINE SMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSCOMP, LRHSCOMP, NRHSCOMP_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, & LSCAL, SCALING, LSCALING, & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSCOMP, LPOS_ROW, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSCOMP, NRHSCOMP_COL REAL, intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSCOMP INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP(LPOS_ROW) REAL :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING REAL, intent(in) :: SCALING(LSCALING) INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSCOMP INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_REAL, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in SMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(II) IF (IPOSINRHSCOMP.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL SMUMPS_AM1_BLOCK_ADD ( .TRUE. ) IRHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & I RHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & RHS_SPARSE_COPY(IZ) K = K+1 ELSE CALL SMUMPS_AM1_BLOCK_ADD ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL SMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_REAL, & COMM, IERR) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE SMUMPS_AM1_BLOCK_ADD ( SCALE_ONLY ) LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN III = I IF (KEEP(23).NE.0) III = UNS_PERM_INV(I) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS_SPARSE_COPY(IZ)*SCALING(III) ENDIF RETURN ENDIF CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_REAL, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL SMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE SMUMPS_AM1_BLOCK_ADD SUBROUTINE SMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE SMUMPS_AM1_BLOCK_SEND END SUBROUTINE SMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE SMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, scaling_data, LSCAL & , IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) LOGICAL LSCAL LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_DISTSOL_INDICES SUBROUTINE SMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSCOMP, LRHSCOMP, NBRHS_EFF, & POSINRHSCOMP, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t TYPE (scaling_data_t) :: scaling_data LOGICAL LSCAL INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSCOMP INTEGER POSINRHSCOMP(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS REAL SOL_LOC( LSOL_LOC, NRHS ) REAL RHSCOMP( LRHSCOMP, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSCOMP, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: ROOT !$ LOGICAL :: OMP_FLAG REAL, PARAMETER :: ZERO = 0.0E0 INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN ROOT=.false. IF (KEEP(38).ne.0) ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) ROOT = STEP(KEEP(20))==ISTEP IF ( ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSCOMP) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE SMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSCOMP, NCOL_RHSCOMP INTEGER ICNTL(60), INFO(80) REAL, intent(in) :: RHS (LRHS, NCOL_RHS) REAL, intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), NB_FS_IN_RHSCOMP_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX REAL, ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS REAL, ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok REAL ZERO PARAMETER( ZERO = 0.0E0 ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_REAL, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_REAL, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL SMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL SMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE SMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_REAL, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_REAL, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSCOMP( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE SMUMPS_GET_BUF_INDX_RHS END SUBROUTINE SMUMPS_SCATTER_RHS SUBROUTINE SMUMPS_BUILD_POSINRHSCOMP & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & NBENT_RHSCOMP, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP, NB_FS_IN_RHSCOMP INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 ENDDO IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) = IPOSINRHSCOMP+JJ-JCOL ENDDO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO NB_FS_IN_RHSCOMP = IPOSINRHSCOMP -1 IF (POSINRHSCOMP_COL_ALLOC) IPOSINRHSCOMP_COL=IPOSINRHSCOMP IF (IPOSINRHSCOMP.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(J1+JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN POSINRHSCOMP_COL(IW(JCOL+JJ)) = - IPOSINRHSCOMP_COL IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSCOMP = IPOSINRHSCOMP - 1 IF (POSINRHSCOMP_COL_ALLOC) & NBENT_RHSCOMP = max(NBENT_RHSCOMP, IPOSINRHSCOMP_COL-1) RETURN END SUBROUTINE SMUMPS_BUILD_POSINRHSCOMP SUBROUTINE SMUMPS_BUILD_POSINRHSCOMP_AM1 & (NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, SIZE_UNS_PERM_INV & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW, & SIZE_UNS_PERM_INV INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP INTEGER, intent(out):: NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER I, JAM1 INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSCOMP_ROW, IPOSINRHSCOMP_COL INTEGER NBENT_RHSCOMP_ROW, NBENT_RHSCOMP_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF(KEEP(237).EQ.0) THEN WRITE(*,*)'BUILD_POSINRHSCOMP_SPARSE available for A-1 only !' CALL MUMPS_ABORT() END IF POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP_ROW = 0 IPOSINRHSCOMP_COL = 0 DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_ROW(IW(J1)).EQ.0) THEN DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) & = IPOSINRHSCOMP_ROW + JJ - J1 + 1 ENDDO IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + NPIV IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) & = - N - (IPOSINRHSCOMP_COL + JJ - JCOL + 1) ENDDO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ENDIF ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO NB_FS_IN_RHSCOMP_FWD = IPOSINRHSCOMP_ROW IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_COL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ))) = & IPOSINRHSCOMP_COL+JJ-JCOL+1 END DO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ELSE IF (POSINRHSCOMP_COL(ABSJCOL).LT.-N) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ)))= & -(N+POSINRHSCOMP_COL(abs(IW(JJ)))) END DO ELSE IF ((POSINRHSCOMP_COL(ABSJCOL).LT.0).AND. & (POSINRHSCOMP_COL(ABSJCOL).GE.-N))THEN WRITE(*,*)'Internal error 7 in BUILD...SPARSE' CALL MUMPS_ABORT() ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSCOMP_TOT = IPOSINRHSCOMP_COL IF (NSLAVES.NE.1) THEN DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + 1 POSINRHSCOMP_ROW(IW(JJ+J1)) & = -IPOSINRHSCOMP_ROW END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = -IPOSINRHSCOMP_COL ELSE IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).LT.-N) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = POSINRHSCOMP_COL(IW(JCOL+JJ)) + N END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSCOMP_ROW = IPOSINRHSCOMP_ROW NBENT_RHSCOMP_COL = IPOSINRHSCOMP_COL NBENT_RHSCOMP = max(NBENT_RHSCOMP_ROW,NBENT_RHSCOMP_COL) RETURN END SUBROUTINE SMUMPS_BUILD_POSINRHSCOMP_AM1 MUMPS_5.4.1/src/sini_driver.F0000664000175000017500000002222214102210525016131 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_INI_DRIVER( id ) USE SMUMPS_STRUC_DEF C C Purpose: C ======= C C Initialize an instance of the SMUMPS package. C USE SMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL SMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) id%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is SMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in SMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in SMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C C Module needs to know the size of an INTEGER CALL SMUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) C This number, 18, corresponds to METIS_OPTIONS_NUMBERING which C tells METIS to use fortran numbering and is found in metis.h C In Metis 5.0.3 and Parmetis 4.0.2, METIS_OPTIONS_NUMBERING C was METIS_OPTIONS(17). MUMPS doesnot support those versions anymore. C To use them, just change METIS_OPTIONS(18) into METIS_OPTIONS(17) C like that: METIS_OPTIONS(17) = 1 id%METIS_OPTIONS(18) = 1 #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%INTARR) NULLIFY(id%DBLARR) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSCOMP) NULLIFY(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MPITOOMP_PROCS_MAP) C Must be nullified because of routine C SMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the root C NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_ROOT) NULLIFY(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_COL) NULLIFY(id%root%IPIV) NULLIFY(id%root%SCHUR_POINTER) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) CALL SMUMPS_RR_INIT_POINTERS(id) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C SMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF RETURN END SUBROUTINE SMUMPS_INI_DRIVER MUMPS_5.4.1/src/csol_root_parallel.F0000664000175000017500000000735014102210523017476 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ROOT_SOLVE( NRHS, DESCA_PAR, & CNTXT_PAR,LOCAL_M,LOCAL_N,MBLOCK,NBLOCK, & IPIV,LPIV,MASTER_ROOT,MYID,COMM, & RHS_SEQ,SIZE_ROOT,A,INFO,MTYPE,LDLT ) IMPLICIT NONE INTEGER NRHS, MTYPE INTEGER DESCA_PAR( 9 ) INTEGER LOCAL_M, LOCAL_N, MBLOCK, NBLOCK INTEGER CNTXT_PAR, MASTER_ROOT, SIZE_ROOT INTEGER MYID, COMM INTEGER LPIV, IPIV( LPIV ) INTEGER INFO(80), LDLT COMPLEX RHS_SEQ( SIZE_ROOT *NRHS) COMPLEX A( LOCAL_M, LOCAL_N ) INTEGER IERR, NPROW, NPCOL, MYROW, MYCOL INTEGER LOCAL_N_RHS COMPLEX, ALLOCATABLE, DIMENSION( :,: ) ::RHS_PAR EXTERNAL numroc INTEGER numroc INTEGER allocok CALL blacs_gridinfo( CNTXT_PAR, NPROW, NPCOL, MYROW, MYCOL ) LOCAL_N_RHS = numroc(NRHS, NBLOCK, MYCOL, 0, NPCOL) LOCAL_N_RHS = max(1,LOCAL_N_RHS) ALLOCATE(RHS_PAR(LOCAL_M, LOCAL_N_RHS),stat=allocok) IF (allocok > 0 ) THEN WRITE(*,*) ' Problem during solve of the root.' WRITE(*,*) ' Reduce number of right hand sides.' CALL MUMPS_ABORT() ENDIF CALL CMUMPS_SCATTER_ROOT( MYID, SIZE_ROOT, NRHS, RHS_SEQ, & LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) CALL CMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) CALL CMUMPS_GATHER_ROOT( MYID, SIZE_ROOT, NRHS, & RHS_SEQ, LOCAL_M, LOCAL_N_RHS, & MBLOCK, NBLOCK, RHS_PAR, MASTER_ROOT, & NPROW, NPCOL, COMM ) DEALLOCATE(RHS_PAR) RETURN END SUBROUTINE CMUMPS_ROOT_SOLVE SUBROUTINE CMUMPS_SOLVE_2D_BCYCLIC (SIZE_ROOT, NRHS, MTYPE, & A, DESCA_PAR, LOCAL_M, LOCAL_N, LOCAL_N_RHS, & IPIV, LPIV, RHS_PAR, LDLT, & MBLOCK, NBLOCK, CNTXT_PAR, & IERR) IMPLICIT NONE INTEGER, intent (in) :: SIZE_ROOT, NRHS, LDLT, LOCAL_M, & LOCAL_N, LOCAL_N_RHS, & MBLOCK, NBLOCK, CNTXT_PAR, MTYPE INTEGER, intent (in) :: DESCA_PAR( 9 ) INTEGER, intent (in) :: LPIV, IPIV( LPIV ) COMPLEX, intent (in) :: A( LOCAL_M, LOCAL_N ) COMPLEX, intent (inout) :: RHS_PAR(LOCAL_M, LOCAL_N_RHS) INTEGER, intent (out) :: IERR INTEGER :: DESCB_PAR( 9 ) IERR = 0 CALL DESCINIT( DESCB_PAR, SIZE_ROOT, & NRHS, MBLOCK, NBLOCK, 0, 0, & CNTXT_PAR, LOCAL_M, IERR ) IF (IERR.NE.0) THEN WRITE(*,*) 'After DESCINIT, IERR = ', IERR CALL MUMPS_ABORT() END IF IF ( LDLT .eq. 0 .OR. LDLT .eq. 2 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL pcgetrs('N',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR,1,1,DESCB_PAR,IERR) ELSE CALL pcgetrs('T',SIZE_ROOT,NRHS,A,1,1,DESCA_PAR,IPIV, & RHS_PAR, 1, 1, DESCB_PAR,IERR) END IF ELSE CALL pcpotrs( 'L', SIZE_ROOT, NRHS, A, 1, 1, DESCA_PAR, & RHS_PAR, 1, 1, DESCB_PAR, IERR ) END IF IF ( IERR .LT. 0 ) THEN WRITE(*,*) ' Problem during solve of the root' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE CMUMPS_SOLVE_2D_BCYCLIC MUMPS_5.4.1/src/dini_defaults.F0000664000175000017500000014025614102210525016436 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE DMUMPS_SET_TYPE_SIZES( K34, K35, K16, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (DOUBLE PRECISION, DOUBLE PRECISION, C DOUBLE PRECISION or DOUBLE DOUBLE PRECISION) in K35 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (DOUBLE PRECISION for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K35: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K16 = K35 for S and D arithmetics C K16 = K35 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C C INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) DOUBLE PRECISION R(2) ! Will be DOUBLE PRECISION if 1 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K16 = int(SIZE_REAL_OR_DOUBLE) K35 = K16 RETURN END SUBROUTINE DMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE DMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C DMUMPS, DMUMPS_ANA_DRIVER, DMUMPS_FAC_DRIVER, DMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C DMUMPS Default values C are set by DMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of DMUMPS. C C CNTL(1) threshold for partial pivoting C has default value 0.0 when SYM=1 and 0.01 otherwise C Values and less than zero as treated as zero. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS 10^{-5} ||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by DMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in DMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in DMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in DMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C DMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by DMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 1. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then DMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in DMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12), INFOG(34) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C C ICNTL(34) Must be set before a call to MUMPS with JOB=-2 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UCFS variant, no recompression: Compress step is C performed before the Solve; pivoting strategy is adapted C to pe performed on low-rank blocks; the low-rank updates are not C recompressed C C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 333 C (when factors of BLR fronts are compressed, C their size is 33.3% of their full- rank size). C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see DMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see DMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all DMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots. C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of DMUMPS. C C C RINFOG is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of DMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for DOUBLE PRECISION parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0D0 RINFOG(1:40)= 0.0D0 CNTL(1:15) = 0.0D0 DKEEP(1:230) = 0.0D0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting IF ( KEEP(50) .NE. 1 ) THEN CNTL(1) = 0.01D0 ELSE CNTL(1) = 0.0D0 END IF CNTL(2) = sqrt(epsilon(0.0D0)) CNTL(3) = 0.0D0 CNTL(4) = -1.0D0 CNTL(5) = 0.0D0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off ICNTL(13) = 0 C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (33.3%) ICNTL(38) = 333 ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 1 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 50 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 50 END IF KEEP(63) = 60 KEEP(48) = 5 CALL DMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(dble(NSLAVES+1))*dble(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 ! old splitting IF (NSLAVES.GT.4) THEN KEEP(78)=max( & int(log(dble(NSLAVES))/log(dble(2))) - 2 & , 0 ) ENDIF KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 KEEP(82) = 30 KEEP(83) = min(8,NSLAVES/4) KEEP(83) = max(min(4,NSLAVES),max(KEEP(83),1)) KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)=min(8, NSLAVES) KEEP(91) = max(min(4,NSLAVES),min(KEEP(83),KEEP(91))) IF(NSLAVES.LT.48)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.128)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.256)THEN KEEP(102)=200 ELSEIF(NSLAVES.LT.512)THEN KEEP(102)=300 ELSEIF(NSLAVES.GE.512)THEN KEEP(102)=400 ENDIF #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=150 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(211)=2 IF (NSLAVES .EQ. 2) THEN KEEP(213) = 101 ELSE KEEP(213) = 201 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 KEEP(219)=1 IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0D0 DKEEP(5) = -1.0D0 C#if defined(try_null_space) DKEEP(10) = -9D0 ! default value is 10D-1 set in fac_driver.F DKEEP(13) = -9D0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0D0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0D0 ! gap precision C#endif KEEP(238)=14 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0D0 DKEEP(18)= 1.0D12 KEEP(242) = -9 KEEP(243) = -1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 C OMP parallelization of arrowheads KEEP(399) = 1 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(461) = 10 KEEP(462) = 10 KEEP(464) = 333 KEEP(465) = 200 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 512 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE DMUMPSID SUBROUTINE DMUMPS_SET_KEEP72(id, LP) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1D0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 ELSE IF (id%KEEP(72)==2) THEN id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(62) = 10 ! default is 50 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs id%KEEP(213) = 121 ! default is 201 END IF RETURN END SUBROUTINE DMUMPS_SET_KEEP72 MUMPS_5.4.1/src/dlr_stats.F0000664000175000017500000006045514102210523015623 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_LR_STATS USE DMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: MRY_CB_FR, & MRY_CB_LRGAIN, & MRY_LU_FR, & MRY_LU_LRGAIN, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_LRGAIN, & FLOP_FACTO_FR, & FLOP_FACTO_LR, & FLOP_PANEL, & FLOP_TRSM, & FLOP_TRSM_FR, & FLOP_TRSM_LR, & FLOP_UPDATE_FR, & FLOP_UPDATE_LR, & FLOP_UPDATE_LRLR1, & FLOP_UPDATE_LRLR2, & FLOP_UPDATE_LRLR3, & FLOP_UPDATE_FRLR, & FLOP_UPDATE_FRFR DOUBLE PRECISION :: FLOP_COMPRESS, & FLOP_CB_COMPRESS, & FLOP_MIDBLK_COMPRESS, & FLOP_FRSWAP_COMPRESS, & FLOP_ACCUM_COMPRESS, & FLOP_DECOMPRESS, & FLOP_CB_DECOMPRESS, & FLOP_FRFRONTS, & FLOP_SOLFWD_FR, & FLOP_SOLFWD_LR DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: TIME_UPDATE DOUBLE PRECISION :: TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TIME_UPDATE_FRLR DOUBLE PRECISION :: TIME_UPDATE_FRFR DOUBLE PRECISION :: TIME_COMPRESS DOUBLE PRECISION :: TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TIME_CB_COMPRESS DOUBLE PRECISION :: TIME_LR_MODULE DOUBLE PRECISION :: TIME_UPD_NELIM DOUBLE PRECISION :: TIME_LRTRSM DOUBLE PRECISION :: TIME_FRTRSM DOUBLE PRECISION :: TIME_PANEL DOUBLE PRECISION :: TIME_FAC_I DOUBLE PRECISION :: TIME_FAC_MQ DOUBLE PRECISION :: TIME_FAC_SQ DOUBLE PRECISION :: TIME_FRFRONTS DOUBLE PRECISION :: TIME_DIAGCOPY DOUBLE PRECISION :: TIME_DECOMP DOUBLE PRECISION :: TIME_DECOMP_UCFS DOUBLE PRECISION :: TIME_DECOMP_ASM1 DOUBLE PRECISION :: TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TIME_DECOMP_ASMS2M DOUBLE PRECISION :: TIME_LRANA_LRGROUPING DOUBLE PRECISION :: TIME_LRANA_SEPGROUPING DOUBLE PRECISION :: TIME_LRANA_GETHALO DOUBLE PRECISION :: TIME_LRANA_KWAY DOUBLE PRECISION :: TIME_LRANA_GNEW DOUBLE PRECISION :: AVG_FLOP_FACTO_LR DOUBLE PRECISION :: MIN_FLOP_FACTO_LR DOUBLE PRECISION :: MAX_FLOP_FACTO_LR INTEGER :: TOTAL_NBLOCKS_ASS, TOTAL_NBLOCKS_CB INTEGER :: MIN_BLOCKSIZE_ASS, MAX_BLOCKSIZE_ASS INTEGER :: MIN_BLOCKSIZE_CB, MAX_BLOCKSIZE_CB DOUBLE PRECISION :: AVG_BLOCKSIZE_ASS, AVG_BLOCKSIZE_CB CONTAINS SUBROUTINE COLLECT_BLOCKSIZES(CUT,NPARTSASS,NPARTSCB) INTEGER, INTENT(IN) :: NPARTSASS, NPARTSCB INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: LOC_MIN_ASS, LOC_MIN_CB, LOC_MAX_ASS, LOC_MAX_CB, & LOC_TOT_ASS, LOC_TOT_CB DOUBLE PRECISION :: LOC_AVG_ASS, LOC_AVG_CB INTEGER :: I LOC_TOT_ASS = 0 LOC_TOT_CB = 0 LOC_AVG_ASS = 0.D0 LOC_AVG_CB = 0.D0 LOC_MIN_ASS = 100000 LOC_MIN_CB = 100000 LOC_MAX_ASS = 0 LOC_MAX_CB = 0 DO I = 1,NPARTSASS LOC_AVG_ASS = ( LOC_TOT_ASS * LOC_AVG_ASS & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_ASS + 1) LOC_TOT_ASS = LOC_TOT_ASS + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_ASS) THEN LOC_MIN_ASS = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_ASS) THEN LOC_MAX_ASS = CUT(I+1) - CUT(I) END IF END DO DO I = NPARTSASS+1,NPARTSASS+NPARTSCB LOC_AVG_CB = ( LOC_TOT_CB * LOC_AVG_CB & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_CB + 1) LOC_TOT_CB = LOC_TOT_CB + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_CB) THEN LOC_MIN_CB = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_CB) THEN LOC_MAX_CB = CUT(I+1) - CUT(I) END IF END DO AVG_BLOCKSIZE_ASS = (TOTAL_NBLOCKS_ASS*AVG_BLOCKSIZE_ASS & + LOC_TOT_ASS*LOC_AVG_ASS) / (TOTAL_NBLOCKS_ASS+LOC_TOT_ASS) AVG_BLOCKSIZE_CB = (TOTAL_NBLOCKS_CB*AVG_BLOCKSIZE_CB & + LOC_TOT_CB*LOC_AVG_CB) / (TOTAL_NBLOCKS_CB+LOC_TOT_CB) TOTAL_NBLOCKS_ASS = TOTAL_NBLOCKS_ASS + LOC_TOT_ASS TOTAL_NBLOCKS_CB = TOTAL_NBLOCKS_CB + LOC_TOT_CB MIN_BLOCKSIZE_ASS = min(MIN_BLOCKSIZE_ASS,LOC_MIN_ASS) MIN_BLOCKSIZE_CB = min(MIN_BLOCKSIZE_CB,LOC_MIN_CB) MAX_BLOCKSIZE_ASS = max(MAX_BLOCKSIZE_ASS,LOC_MAX_ASS) MAX_BLOCKSIZE_CB = max(MAX_BLOCKSIZE_CB,LOC_MAX_CB) END SUBROUTINE COLLECT_BLOCKSIZES SUBROUTINE UPD_FLOP_DECOMPRESS(F, CB) DOUBLE PRECISION, INTENT(IN) :: F LOGICAL, INTENT(IN) :: CB !$OMP ATOMIC UPDATE FLOP_DECOMPRESS = FLOP_DECOMPRESS + F !$OMP END ATOMIC IF (CB) THEN !$OMP ATOMIC UPDATE FLOP_CB_DECOMPRESS = FLOP_CB_DECOMPRESS + F !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE UPD_FLOP_DECOMPRESS SUBROUTINE UPD_FLOP_COMPRESS(LR_B, REC_ACC, & CB_COMPRESS, FRSWAP) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST,BUILDQ_COST, & HR_AND_BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC, CB_COMPRESS, FRSWAP M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(K*K*K/3_8 + 4_8*K*M*N - (2_8*M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(2_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF HR_AND_BUILDQ_COST = HR_COST + BUILDQ_COST !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + HR_AND_BUILDQ_COST !$OMP END ATOMIC IF (present(REC_ACC)) THEN IF (REC_ACC) THEN !$OMP ATOMIC UPDATE FLOP_ACCUM_COMPRESS = FLOP_ACCUM_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(CB_COMPRESS)) THEN IF (CB_COMPRESS) THEN !$OMP ATOMIC UPDATE FLOP_CB_COMPRESS = FLOP_CB_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(FRSWAP)) THEN IF (FRSWAP) THEN !$OMP ATOMIC UPDATE FLOP_FRSWAP_COMPRESS = FLOP_FRSWAP_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE UPD_FLOP_COMPRESS SUBROUTINE UPD_FLOP_TRSM(LRB, LorU) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: LorU DOUBLE PRECISION :: LR_COST, FR_COST, LR_GAIN IF (LorU.EQ.0) THEN FR_COST = dble(LRB%M*LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%K*LRB%N*LRB%N) ELSE LR_COST = FR_COST ENDIF ELSE FR_COST = dble(LRB%M-1)*dble(LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%N-1)*dble(LRB%N*LRB%K) ELSE LR_COST = FR_COST ENDIF ENDIF LR_GAIN = FR_COST - LR_COST !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_TRSM SUBROUTINE UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS, RANK_IN, BUILDQ, & IS_SYMDIAG, LUA_ACTIVATED, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 LOGICAL, INTENT(IN) :: BUILDQ, IS_SYMDIAG, LUA_ACTIVATED INTEGER, INTENT(IN) :: RANK_IN, MIDBLK_COMPRESS LOGICAL, INTENT(IN), OPTIONAL :: REC_ACC DOUBLE PRECISION :: COST_FR, COST_LR, COST_LRLR1, COST_LRLR2, & COST_LRLR3, COST_FRLR, COST_FRFR, & COST_COMPRESS, COST_LR_AND_COMPRESS, LR_GAIN DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK LOGICAL :: REC_ACC_LOC M1 = dble(LRB1%M) N1 = dble(LRB1%N) K1 = dble(LRB1%K) M2 = dble(LRB2%M) N2 = dble(LRB2%N) K2 = dble(LRB2%K) RANK = dble(RANK_IN) COST_LRLR1 = 0.0D0 COST_LRLR2 = 0.0D0 COST_LRLR3 = 0.0D0 COST_FRLR = 0.0D0 COST_FRFR = 0.0D0 COST_COMPRESS = 0.0D0 IF (present(REC_ACC)) THEN REC_ACC_LOC = REC_ACC ELSE REC_ACC_LOC = .FALSE. ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN COST_FRFR = 2.0D0*M1*M2*N1 COST_LR = 2.0D0*M1*M2*N1 COST_FR = 2.0D0*M1*M2*N1 ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN COST_FRLR = 2.0D0*K1*M2*N1 COST_LRLR3 = 2.0D0*M1*M2*K1 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN COST_FRLR = 2.0D0*M1*K2*N1 COST_LRLR3 = 2.0D0*M1*M2*K2 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSE IF (MIDBLK_COMPRESS.GE.1) THEN COST_COMPRESS = RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & (2.0D0*K1+K2)*RANK*RANK IF (BUILDQ) THEN COST_COMPRESS = COST_COMPRESS + 4.0D0*RANK*RANK*K1 & - RANK*RANK*RANK ENDIF ENDIF COST_LRLR1 = 2.0D0*K1*K2*N1 IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN COST_LRLR2 = 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK COST_LRLR3 = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN COST_LRLR2 = 2.0D0*K1*M1*K2 COST_LRLR3 = 2.0D0*M1*M2*K2 ELSE COST_LRLR2 = 2.0D0*K1*M2*K2 COST_LRLR3 = 2.0D0*M1*M2*K1 ENDIF ENDIF COST_LR = COST_LRLR1 + COST_LRLR2 + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ENDIF IF (IS_SYMDIAG) THEN COST_FR = COST_FR/2.0D0 COST_LRLR3 = COST_LRLR3/2.0D0 COST_FRFR = COST_FRFR/2.0D0 COST_LR = COST_LR - COST_LRLR3 - COST_FRFR ENDIF IF (LUA_ACTIVATED) THEN COST_LR = COST_LR - COST_LRLR3 COST_LRLR3 = 0.0D0 IF (REC_ACC_LOC) THEN COST_LR_AND_COMPRESS = COST_LR + COST_COMPRESS !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_LR_AND_COMPRESS !$OMP END ATOMIC ENDIF ENDIF IF (.NOT.REC_ACC_LOC) THEN !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_COMPRESS !$OMP END ATOMIC LR_GAIN = COST_FR - COST_LR !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC ENDIF END SUBROUTINE UPD_FLOP_UPDATE SUBROUTINE UPD_FLOP_UPDATE_LRLR3(LRB, NIV) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV DOUBLE PRECISION :: FLOP_COST FLOP_COST = 2.0D0*dble(LRB%M)*dble(LRB%N)*dble(LRB%K) !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN - FLOP_COST !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_UPDATE_LRLR3 SUBROUTINE UPD_FLOP_ROOT(KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + COST_PER_PROC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_ROOT SUBROUTINE INIT_STATS_GLOBAL(id) USE DMUMPS_STRUC_DEF TYPE (DMUMPS_STRUC), TARGET :: id MRY_LU_FR = 0.D0 MRY_LU_LRGAIN = 0.D0 MRY_CB_FR = 0.D0 MRY_CB_LRGAIN = 0.D0 FLOP_FACTO_FR = 0.D0 FLOP_FACTO_LR = 0.D0 FLOP_LRGAIN = 0.D0 FLOP_CB_COMPRESS = 0.D0 FLOP_CB_DECOMPRESS = 0.D0 FLOP_DECOMPRESS = 0.D0 FLOP_UPDATE_FR = 0.D0 FLOP_UPDATE_LR = 0.D0 FLOP_UPDATE_LRLR1 = 0.D0 FLOP_UPDATE_LRLR2 = 0.D0 FLOP_UPDATE_LRLR3 = 0.D0 FLOP_UPDATE_FRLR = 0.D0 FLOP_UPDATE_FRFR = 0.D0 FLOP_MIDBLK_COMPRESS = 0.D0 FLOP_TRSM_FR = 0.D0 FLOP_TRSM_LR = 0.D0 FLOP_COMPRESS = 0.D0 FLOP_ACCUM_COMPRESS = 0.D0 FLOP_FRSWAP_COMPRESS = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 FLOP_FRFRONTS = 0.D0 FLOP_SOLFWD_FR = 0.D0 FLOP_SOLFWD_LR = 0.D0 TOTAL_NBLOCKS_ASS = 0 TOTAL_NBLOCKS_CB = 0 AVG_BLOCKSIZE_ASS = 0.D0 AVG_BLOCKSIZE_CB = 0.D0 MIN_BLOCKSIZE_ASS = huge(1) MAX_BLOCKSIZE_ASS = 0 MIN_BLOCKSIZE_CB = huge(1) MAX_BLOCKSIZE_CB = 0 CNT_NODES = 0 TIME_UPDATE = 0.D0 TIME_MIDBLK_COMPRESS = 0.D0 TIME_UPDATE_LRLR1 = 0.D0 TIME_UPDATE_LRLR2 = 0.D0 TIME_UPDATE_LRLR3 = 0.D0 TIME_UPDATE_FRLR = 0.D0 TIME_UPDATE_FRFR = 0.D0 TIME_COMPRESS = 0.D0 TIME_CB_COMPRESS = 0.D0 TIME_LR_MODULE = 0.D0 TIME_UPD_NELIM = 0.D0 TIME_LRTRSM = 0.D0 TIME_FRTRSM = 0.D0 TIME_PANEL = 0.D0 TIME_FAC_I = 0.D0 TIME_FAC_MQ = 0.D0 TIME_FAC_SQ = 0.D0 TIME_FRFRONTS = 0.D0 TIME_DIAGCOPY = 0.D0 TIME_FRSWAP_COMPRESS = 0.D0 TIME_DECOMP = 0.D0 TIME_DECOMP_UCFS = 0.D0 TIME_DECOMP_ASM1 = 0.D0 TIME_DECOMP_LOCASM2 = 0.D0 TIME_DECOMP_MAPLIG1 = 0.D0 TIME_DECOMP_ASMS2S = 0.D0 TIME_DECOMP_ASMS2M = 0.D0 END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE UPD_MRY_LU_FR(NASS, NCB, SYM, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, NELIM DOUBLE PRECISION :: MRY INTEGER :: NPIV NPIV = NASS - NELIM IF (SYM .GT. 0) THEN MRY = dble(NPIV)*(dble(NPIV)+1.D0)/2.D0 & + dble(NPIV)*dble(NCB+NELIM) ELSE MRY = dble(NPIV)*dble(NPIV) & + 2.0D0*dble(NPIV)*dble(NCB+NELIM) END IF !$OMP ATOMIC UPDATE MRY_LU_FR = MRY_LU_FR + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_FR SUBROUTINE UPD_MRY_CB(NROWS, NCOLS, & SYM, NIV, LRGAIN) INTEGER,INTENT(IN) :: NROWS, NCOLS, SYM, NIV, LRGAIN DOUBLE PRECISION :: MRY, LRGAIND IF (SYM.EQ.0) THEN MRY = dble(NCOLS)*dble(NROWS) ELSE MRY = dble(NCOLS-NROWS)*dble(NROWS) + & dble(NROWS)*dble(NROWS+1)/2.D0 ENDIF !$OMP ATOMIC UPDATE MRY_CB_FR = MRY_CB_FR + MRY !$OMP END ATOMIC LRGAIND=dble(LRGAIN) !$OMP ATOMIC UPDATE MRY_CB_LRGAIN = MRY_CB_LRGAIN + LRGAIND !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_CB SUBROUTINE UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_INASM, & NB_INCB, DIR) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR DOUBLE PRECISION :: FLOPFR, FLOPLR, MRY INTEGER :: I FLOPFR = 0.0D0 FLOPLR = 0.0D0 MRY = 0.0D0 IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN FLOPFR = FLOPFR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) FLOPLR = FLOPLR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) ENDIF DO I = 1, NB_INASM+NB_INCB IF (DIR .EQ. 'V') THEN FLOPFR = FLOPFR + & 2.0D0*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN FLOPLR = FLOPLR + & 2.0D0*dble((BLR_PANEL(I)%M+BLR_PANEL(I)%N) & *BLR_PANEL(I)%K) ELSE FLOPLR = FLOPLR + & 2.0D0*dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N) ENDIF ENDIF IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ENDIF ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE UPD_FLOP_FACTO_FR( NFRONT, NASS, NPIV, SYM, NIV) INTEGER,INTENT(IN) :: NFRONT, SYM, NASS, NPIV, NIV DOUBLE PRECISION :: FLOP CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP) !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC END SUBROUTINE UPD_FLOP_FACTO_FR SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2( NROW1, NCOL1, & NASS1, KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FAC CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FAC) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP_FAC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONTS SUBROUTINE UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NB_ENTRIES_FACTOR_withLR, & PROKG, MPG) INTEGER(8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: MPG LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION, INTENT(IN) :: FLOP_NUMBER INTEGER(8), INTENT(OUT) :: & NB_ENTRIES_FACTOR_withLR IF (NB_ENTRIES_FACTOR < 0) THEN IF (PROKG.AND.MPG.GT.0) THEN WRITE(MPG,*) "NEGATIVE NUMBER OF ENTRIES IN FACTOR" WRITE(MPG,*) "===> OVERFLOW ?" END IF END IF IF (MRY_LU_FR .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & MRY_LU_LRGAIN/MRY_LU_FR ENDIF IF (MRY_CB_FR .EQ. 0) THEN MRY_CB_FR = 100.0D0 END IF NB_ENTRIES_FACTOR_withLR = NB_ENTRIES_FACTOR - & int(MRY_LU_LRGAIN,8) IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & MRY_LU_FR/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*MRY_LU_LRGAIN/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN + FLOP_COMPRESS & + FLOP_DECOMPRESS RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & ICNTL36, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, & K8110, K849, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,DEPTH, N, & ICNTL36, BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, & K472, K475, K478, K480, K481, K483, K484, & SYM, NPROCS INTEGER(8), INTENT(IN) :: K8110, K849 LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION :: DKEEP(230) LOGICAL PROK PROK = (PROKG.AND.(MPG.GE.0)) IF (PROK) THEN WRITE(MPG,'(/A,A)') & '-------------- Beginning of BLR statistics -------------------', & '--------------' WRITE(MPG,'(A,I2)') & ' ICNTL(36) BLR variant = ', ICNTL36 WRITE(MPG,'(A,ES8.1)') & ' CNTL(7) Dropping parameter controlling accuracy = ', & DKEEP(8) WRITE(MPG,'(A)') & ' Statistics after BLR factorization :' WRITE(MPG,'(A,I8)') & ' Number of BLR fronts = ', & CNT_NODES ENDIF IF (PROK) WRITE(MPG,'(A,F8.1,A)') & ' Fraction of factors in BLR fronts =', & FACTOR_PROCESSED_FRACTION,'% ' IF (PROK) THEN WRITE(MPG,'(A)') & ' Statistics on the number of entries in factors :' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(29) Theoretical nb of entries in factors =' & ,dble(K8110),' (100.0%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(35) Effective nb of entries (% of INFOG(29)) =' & ,dble(K849),' (' & ,dble(100)*(dble(K849)/dble(max(K8110,1_8))) & ,'%)' ENDIF IF (PROK) WRITE(MPG,'(A)') & ' Statistics on operation counts (OPC):' TOTAL_FLOP = MAX(TOTAL_FLOP,EPSILON(1.0D0)) DKEEP(55)=dble(TOTAL_FLOP) DKEEP(60)=dble(100) DKEEP(56)=dble(FLOP_FACTO_LR+FLOP_FRFRONTS) DKEEP(61)=dble(100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(3) Total theoretical operations counts =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(14) Total effective OPC (% of RINFOG(3)) =' & ,FLOP_FACTO_LR+FLOP_FRFRONTS,' (' &,100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP &,'%)' ENDIF IF (PROK) WRITE(MPG,'(A,A)') & '-------------- End of BLR statistics -------------------------', & '--------------' RETURN END SUBROUTINE SAVEandWRITE_GAINS END MODULE DMUMPS_LR_STATS MUMPS_5.4.1/src/csol_bwd_aux.F0000664000175000017500000020622314102210523016270 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A, LA, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) USE CMUMPS_OOC USE CMUMPS_BUF USE CMUMPS_SOL_LR, only : CMUMPS_SOL_BWD_LR_SU INTEGER :: KEEP( 500 ) INTEGER(8) :: KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER :: INFO(80) INTEGER, INTENT( IN ) :: INODE, N, NRHS, MTYPE, LIW, LIWW INTEGER, INTENT( IN ) :: SLAVEF, COMM, MYID INTEGER, INTENT (IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: NE_STEPS(KEEP(28)) INTEGER(8), INTENT( IN ) :: LA, LWC INTEGER(8), INTENT( INOUT ) :: POSWCB, PLEFTW INTEGER, INTENT( INOUT ) :: POSIWCB INTEGER, INTENT( IN ) :: LPANEL_POS INTEGER :: PANEL_POS(LPANEL_POS) LOGICAL, INTENT(INOUT) :: DEJA_SEND(0:SLAVEF-1) INTEGER, INTENT(IN) :: LPOOL INTEGER, INTENT(INOUT) :: IPOOL(LPOOL), IIPOOL INTEGER, INTENT(INOUT) :: NBFINF, MYLEAF_LEFT INTEGER :: PTRIST(KEEP(28)), PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX :: A(LA), W(LWC) COMPLEX :: W2(KEEP(133)) INTEGER :: IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT( IN ) :: PRUN_BELOW INTEGER, INTENT(IN) :: SIZE_TO_PROCESS LOGICAL, INTENT(IN) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, INTENT(IN) :: DO_NBSPARSE INTEGER, INTENT(IN) :: LRHS_BOUNDS INTEGER, INTENT(IN) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, INTENT(IN) :: FROM_PP LOGICAL, INTENT( OUT ) :: ERROR_WAS_BROADCASTED LOGICAL, INTENT( OUT ) :: DO_MCAST2_TERMBWD INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR LOGICAL FLAG INCLUDE 'mumps_headers.h' LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL LTLEVEL2, IN_SUBTREE INTEGER TYPENODE INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL NO_CHILDREN LOGICAL :: ALLOW_OTHERS_TO_LEAVE INTEGER :: K, JBDEB, JBFIN, NRHS_B INTEGER IWHDLR INTEGER NPIV INTEGER IPOS,LIELL,NELIM,JJ,I INTEGER J1,J2,J,NCB INTEGER NSLAVES INTEGER IN,IF,LONG,POOL_FIRST_POS,TMP INTEGER :: NBFILS INTEGER :: PROCDEST, DEST INTEGER(8) :: PTWCB, PPIV_COURANT INTEGER :: Offset, EffectiveSize, ISLAVE, FirstIndex INTEGER :: POSINDICES, IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER(8) :: APOS, IST INTEGER(8) :: IFR INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF INTEGER BEG_PANEL LOGICAL TWOBYTWO INTEGER NPANELS, IPANEL COMPLEX ALPHA,ONE,ZERO PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. NO_CHILDREN = .FALSE. IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) NRHS_B = JBFIN-JBDEB+1 ELSE JBDEB = 1 JBFIN = NRHS NRHS_B = NRHS ENDIF IF ( INODE .EQ. KEEP( 38 ) .OR. INODE .EQ. KEEP( 20 ) ) THEN IPOS = PTRIST(STEP(INODE))+KEEP(IXSZ) NPIV = IW(IPOS+3) LIELL = IW(IPOS) + NPIV IPOS = PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) IF ( MTYPE .EQ. 1 .AND. KEEP(50) .EQ. 0) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + LIELL + NPIV ELSE J1 = IPOS + 1 J2 = IPOS + NPIV END IF IFR = 0_8 IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) CALL CMUMPS_SOL_CPY_FS2RHSCOMP(JBDEB, JBFIN, J2-J1+1, & KEEP, RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, & RHS_ROOT(1+NPIV*(JBDEB-1)), NPIV, 1) IN = INODE 270 IN = FILS(IN) IF (IN .GT. 0) GOTO 270 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN LONG = NPIV NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1030 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1030 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)),KEEP(199)) & .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.NOT. DEJA_SEND( PROCDEST )) THEN 600 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, & LONG, LONG, IW( J1 ), & RHS_ROOT( 1+NPIV*(JBDEB-1) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, & NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, & MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 600 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LONG * KEEP(35) + & ( LONG + 4 ) * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .NE. 0 ) THEN WRITE(*,*) "Internal error 2 CMUMPS_SOLVE_NODE_BWD", & IERR CALL MUMPS_ABORT() END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF ENDIF IF = FRERE(STEP(IF)) ENDDO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) ENDIF IF ( KEEP(31). NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF IF (IIPOOL.NE.POOL_FIRST_POS) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP = IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1) = IPOOL(IIPOOL-I) IPOOL(IIPOOL-I) = TMP ENDDO ENDIF RETURN END IF IN_SUBTREE = MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) TYPENODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) LTLEVEL2= ( & (TYPENODE .eq.2 ) .AND. & (MTYPE.NE.1) ) NPIV = IW(PTRIST(STEP(INODE))+2+KEEP(IXSZ)+1) IF ((NPIV.NE.0).AND.(LTLEVEL2)) THEN IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV - NELIM IPOS = IPOS + 2 NSLAVES = IW( IPOS ) Offset = 0 IPOS = IPOS + NSLAVES IW(PTRIST(STEP(INODE))+XXS)= C_FINI+NSLAVES IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB-int(NCB,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(NCB * NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(NCB,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = NCB*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IF ( NCB.EQ.0 ) THEN write(6,*) ' Internal Error type 2 node with no CB ' CALL MUMPS_ABORT() ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + NELIM +1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + NELIM +1 J2 = IPOS + LIELL END IF IFR = PTRACB(STEP( INODE )) - 1_8 CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), NCB, 1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(NCB,8)) = ZERO ENDIF ENDDO ENDDO ENDIF DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & EffectiveSize, & FirstIndex ) 500 CONTINUE DEST = IW( PTRIST(STEP(INODE))+5+ISLAVE+KEEP(IXSZ)) CALL CMUMPS_BUF_SEND_BACKVEC(NRHS_B, INODE, & W(Offset+PTRACB(STEP(INODE))), & EffectiveSize, & NCB, DEST, & BACKSLV_MASTER2SLAVE, JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, & PROCNODE_STEPS, PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 500 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * EffectiveSize * KEEP(35) + & 2 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF Offset = Offset + EffectiveSize END DO IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) RETURN ENDIF LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) NCB = LIELL - NPIV IPOS = IPOS + 1 IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF APOS = PTRFAC(IW(IPOS)) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 + NSLAVES IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) IF (MTYPE.NE.1) THEN TYPEF = TYPEF_L ELSE TYPEF = TYPEF_U ENDIF PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE( LIELL ) IF (KEEP(50).NE.1) THEN CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF LONG = 0 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IF (IN_SUBTREE) THEN PTWCB = PLEFTW IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB .LT. int(LIELL,8)*int(NRHS_B,8) ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(int(LIELL,8)*int(NRHS_B,8)-POSWCB, & INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF ELSE IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB ) IF ( POSWCB-int(LIELL,8)*int(NRHS_B,8) .LT. PLEFTW-1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( int(LIELL,8)*int(NRHS_B,8)- & POSWCB-PLEFTW+1_8, & INFO(2) ) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - int(LIELL,8)*int(NRHS_B,8) PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF PTWCB = PTRACB(STEP( INODE )) ENDIF IF (J2.GE.J1) THEN IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) ELSE IPOSINRHSCOMP = -99999 ENDIF IF (J2.GE.J1) THEN DO K=JBDEB, JBFIN IF (KEEP(252).NE.0) THEN DO JJ = J1, J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = ZERO ENDDO ENDIF END DO ENDIF IFR = PTWCB + int(NPIV - 1,8) IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTWCB), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR = IFR + int(J2-KEEP(253)-J1+1,8) IF (KEEP(252).NE.0) THEN DO JJ = J2-KEEP(253)+1, J2 IFR = IFR + 1_8 DO K=JBDEB, JBFIN IF (K.EQ.JJ-J2+KEEP(253)) THEN W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ALPHA ELSE W(IFR+int(K-JBDEB,8)*int(LIELL,8)) = ZERO ENDIF ENDDO ENDDO ENDIF NCB = LIELL - NPIV IF (NPIV .EQ. 0) GOTO 160 ENDIF IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. & ((TYPENODE.EQ.1.AND.KEEP(103).GT.0) .OR. & (TYPENODE.EQ.2.AND.KEEP(105).GT.0)) IF (TWOBYTWO) THEN CALL CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, LPANEL_POS, & IW(IPOS+1+LIELL), NPIV, NPANELS, LIELL, & NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(LIELL,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL = NPANELS, 1, -1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = LIELL-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB_PANEL = PTWCB + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ IF (KEEP(50).NE.1 .AND. MUST_BE_PERMUTED) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL CMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL cgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE CALL ctrsv('L','T','N', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ENDIF ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+int(NPIV,8) ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF IF (MTYPE.NE.1) THEN CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ELSE CALL ctrsm('L','L','T','N',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL CMUMPS_SOL_BWD_LR_SU ( & INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ELSE IF ( LIELL .GT. NPIV ) THEN IF ( MTYPE .eq. 1 ) THEN IST = APOS + int(NPIV,8) #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL cgemv( 'T', NCB, NPIV, ALPHA, A(IST), LIELL, & W(PTWCB+int(NPIV,8)), 1, & ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL cgemm('T','N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), LIELL, & W(PTWCB+int(NPIV,8)), LIELL, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL cgemv( 'N', NPIV, NCB, ALPHA, A( IST ), NPIV, & W( PTWCB + int(NPIV,8) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1 ) ELSE #endif CALL cgemm( 'N', 'N', NPIV, NRHS_B, NCB, ALPHA, & A(IST), NPIV, W(PTWCB+int(NPIV,8)),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB),LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF ENDIF IF ( MTYPE .eq. 1 ) THEN LDAJ = LIELL ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=LIELL ELSE LDAJ=NPIV ENDIF END IF PPIV_COURANT = int(JBDEB-1,8)*int(LRHSCOMP,8) & + int(IPOSINRHSCOMP,8) CALL CMUMPS_SOLVE_BWD_TRSOLVE( A(1), LA, APOS, & NPIV, LDAJ, & NRHS_B, RHSCOMP(1,1), KEEP8(25), LRHSCOMP, PPIV_COURANT, & MTYPE, KEEP) ENDIF ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN J1 = IPOS + LIELL + 1 ELSE J1 = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) 160 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. RETURN ENDIF ENDIF IN = INODE 170 IN = FILS(IN) IF (IN .GT. 0) GOTO 170 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 IF (.NOT. IN_SUBTREE ) THEN IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( KEEP(31) .NE. 0 .AND. & .NOT. IN_SUBTREE ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31).EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF RETURN ENDIF IF = -IN NBFILS = NE_STEPS(STEP(INODE)) IF ( PRUN_BELOW ) THEN I = NBFILS NBFILS = 0 DO WHILE (I.GT.0) IF ( TO_PROCESS(STEP(IF)) ) NBFILS = NBFILS+1 IF = FRERE(STEP(IF)) I = I -1 ENDDO IF (NBFILS.EQ.0) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF IF = -IN ENDIF IF (IN_SUBTREE) THEN DO I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1010 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1010 ENDIF NO_CHILDREN = .FALSE. ENDIF IPOOL((IIPOOL-I+1)+NBFILS-I) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ENDDO IF (PRUN_BELOW .AND. NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF (ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF ELSE DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO POOL_FIRST_POS=IIPOOL DO 190 I = 1, NBFILS IF ( PRUN_BELOW ) THEN 1020 IF ( .NOT.TO_PROCESS(STEP(IF)) ) THEN IF = FRERE(STEP(IF)) GOTO 1020 ENDIF NO_CHILDREN = .FALSE. ENDIF IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL) = IF IIPOOL = IIPOOL + 1 IF = FRERE(STEP(IF)) ELSE PROCDEST = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) IF (.not. DEJA_SEND( PROCDEST )) THEN 400 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IF, 0, 0, LIELL, & LIELL - KEEP(253), & IW( POSINDICES ), & W ( PTRACB(STEP( INODE )) ), & JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, & KEEP, PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW , TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. RETURN ENDIF GOTO 400 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * LIELL * KEEP(35) + 4 * KEEP(34) ERROR_WAS_BROADCASTED = .FALSE. RETURN END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF IF = FRERE(STEP(IF)) ENDIF 190 CONTINUE IF ( PRUN_BELOW .AND. NO_CHILDREN ) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0) IF ( ALLOW_OTHERS_TO_LEAVE ) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 RETURN ENDIF ENDIF DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO IF ( KEEP(31) .NE. 0 ) & THEN KEEP(31) = KEEP(31) - 1 ALLOW_OTHERS_TO_LEAVE = (KEEP(31) .EQ. 1) IF (ALLOW_OTHERS_TO_LEAVE) THEN DO_MCAST2_TERMBWD = .TRUE. NBFINF = NBFINF - 1 ENDIF ENDIF IWCB(PTRICB(STEP(INODE))+1) = IWCB(PTRICB(STEP(INODE))+1)-1 CALL CMUMPS_FREETOPSO(N, KEEP(28), IWCB, LIWW, & W, LWC, & POSWCB,POSIWCB,PTRICB,PTRACB) ENDIF RETURN END SUBROUTINE CMUMPS_SOLVE_NODE_BWD RECURSIVE SUBROUTINE CMUMPS_BACKSLV_RECV_AND_TREAT( & BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ, FLAG INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL INTEGER IPOOL( LPOOL ) INTEGER LPANEL_POS INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ), FRERE( KEEP(28) ) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER PTRIST(KEEP(28)), IW( LIW ) INTEGER (8) :: PTRFAC(KEEP(28)) COMPLEX A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR FLAG = .FALSE. IF ( BLOQ ) THEN CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF (FLAG) THEN KEEP(266)=KEEP(266)-1 MSGSOU=STATUS(MPI_SOURCE) MSGTAG=STATUS(MPI_TAG) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN IF (NBFINF .NE. 0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ELSE CALL MPI_RECV(BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, COMM, STATUS, IERR) CALL CMUMPS_BACKSLV_TRAITER_MESSAGE( MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE CMUMPS_BACKSLV_RECV_AND_TREAT RECURSIVE SUBROUTINE CMUMPS_BACKSLV_TRAITER_MESSAGE( & MSGTAG, MSGSOU, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) USE CMUMPS_OOC USE CMUMPS_SOL_LR, ONLY: CMUMPS_SOL_SLAVE_LR_U, & CMUMPS_SOL_BWD_LR_SU USE CMUMPS_BUF IMPLICIT NONE INTEGER MSGTAG, MSGSOU INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER MYID, SLAVEF, COMM INTEGER N, LIWW INTEGER IWCB( LIWW ) INTEGER(8), intent(in) :: LWC COMPLEX W( LWC ) INTEGER POSIWCB INTEGER IIPOOL, LPOOL, LPANEL_POS INTEGER IPOOL( LPOOL ) INTEGER PANEL_POS( LPANEL_POS ) INTEGER NBFINF, INFO(80), KEEP(500) INTEGER(8) :: POSWCB, PLEFTW INTEGER(8) KEEP8(150) REAL, INTENT(INOUT) :: DKEEP(230) INTEGER PTRICB(KEEP(28)), STEP( N ), FILS( N ) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER FRERE(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER LIW INTEGER(8) :: LA INTEGER IW( LIW ), PTRIST( KEEP(28) ) INTEGER(8) :: PTRFAC(KEEP(28)) COMPLEX A( LA ), W2( KEEP(133) ) INTEGER NRHS INTEGER MYLEAF_LEFT, MTYPE INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) COMPLEX RHSCOMP(LRHSCOMP,NRHS) LOGICAL, INTENT(IN) :: PRUN_BELOW INTEGER SIZE_TO_PROCESS LOGICAL TO_PROCESS(SIZE_TO_PROCESS), NO_CHILDREN LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER POSITION, IF, INODE, IERR, LONG, DUMMY(1) INTEGER :: LIELL, K INTEGER(8) :: APOS, IST INTEGER NPIV, NROW_L, IPOS, NROW_RECU INTEGER(8) :: IFR8 INTEGER I, JJ, IN, PROCDEST, J1, J2, LDA INTEGER NSLAVES, NELIM, J, POSINDICES, INODEPOS, & IPOSINRHSCOMP, IPOSINRHSCOMP_PANEL INTEGER JBDEB, JBFIN, NRHS_B, allocok INTEGER(8) :: P_UPDATE, P_SOL_MAS INTEGER :: IWHDLR, MTYPE_SLAVE, LDA_SLAVE LOGICAL FLAG COMPLEX ZERO, ALPHA, ONE PARAMETER (ZERO=(0.0E0,0.0E0), & ONE=(1.0E0,0.0E0), & ALPHA=(-1.0E0,0.0E0)) INCLUDE 'mumps_headers.h' INTEGER POOL_FIRST_POS, TMP LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: NCB INTEGER(8) :: APOSDEB, NBENTRIES_ALLPANELS INTEGER(8) :: PTWCB, PTWCB_PANEL INTEGER LDAJ, NBJ, LIWFAC, & NBJLAST, NPIV_LAST, PANEL_SIZE, & NCB_PANEL, TYPEF LOGICAL TWOBYTWO INTEGER BEG_PANEL INTEGER IPANEL, NPANELS INTEGER TMP_NBPANELS, I_PIVRPTR, I_PIVR LOGICAL MUST_BE_PERMUTED LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR INTEGER, EXTERNAL :: MUMPS_PROCNODE ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then INFO(1)=-13 INFO(2)=SLAVEF WRITE(6,*) MYID,' Allocation error of DEJA_SEND ' & //'in bwd solve COMPSO' GOTO 260 END IF DUMMY(1)=0 IF (MSGTAG .EQ. TERMBWD) THEN NBFINF = NBFINF - 1 ELSE IF (MSGTAG .EQ. NOEUD) THEN POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, & COMM, IERR) NRHS_B = JBFIN-JBDEB+1 IF ( POSIWCB - LONG .LT. 0 & .OR. POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN CALL CMUMPS_COMPSO(N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF (POSIWCB - LONG .LT. 0) THEN INFO(1)=-14 INFO(2)=-POSIWCB + LONG WRITE(6,*) MYID,' Internal error 1 in bwd solve COMPSO' GOTO 260 END IF IF ( POSWCB - PLEFTW + 1_8 .LT. LONG ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG + PLEFTW - POSWCB - 1_8, & INFO(2)) WRITE(6,*) MYID,' Internal error 2 in bwd solve COMPSO' GOTO 260 END IF ENDIF POSIWCB = POSIWCB - LONG POSWCB = POSWCB - LONG IF (LONG .GT. 0) THEN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IWCB(POSIWCB + 1), & LONG, MPI_INTEGER, COMM, IERR) DO K=JBDEB,JBFIN CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & W(POSWCB + 1), LONG, & MPI_COMPLEX, COMM, IERR) DO JJ=0, LONG-1 IPOSINRHSCOMP = abs( POSINRHSCOMP_BWD( IWCB( & POSIWCB+1+JJ ) ) ) IF ( (IPOSINRHSCOMP.EQ.0) .OR. & ( IPOSINRHSCOMP.GT.N ) ) CYCLE RHSCOMP(IPOSINRHSCOMP,K) = W(POSWCB+1+JJ) ENDDO ENDDO POSIWCB = POSIWCB + LONG POSWCB = POSWCB + LONG ENDIF POOL_FIRST_POS = IIPOOL IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(INODE))) & GOTO 1010 ENDIF IPOOL( IIPOOL ) = INODE IIPOOL = IIPOOL + 1 1010 CONTINUE IF = FRERE( STEP(INODE) ) DO WHILE ( IF .GT. 0 ) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IF)), & KEEP(199)) .eq. MYID ) THEN IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IF))) THEN IF = FRERE(STEP(IF)) CYCLE ENDIF ENDIF IPOOL( IIPOOL ) = IF IIPOOL = IIPOOL + 1 END IF IF = FRERE( STEP( IF ) ) END DO DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ELSE IF ( MSGTAG .EQ. BACKSLV_MASTER2SLAVE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NROW_RECU, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST( STEP(INODE) ) + KEEP(IXSZ) NPIV = - IW( IPOS ) NROW_L = IW( IPOS + 1 ) IF ( NROW_L .NE. NROW_RECU ) THEN WRITE(*,*) 'Error1 : NROW L/RECU=',NROW_L, NROW_RECU CALL MUMPS_ABORT() END IF LONG = NROW_L + NPIV IF ( POSWCB - int(LONG,8)*int(NRHS_B,8) .LT. PLEFTW - 1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LONG*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(LONG * NRHS_B- POSWCB,INFO(2)) WRITE(6,*) MYID,' Internal error 3 in bwd solve COMPSO' GOTO 260 END IF END IF P_UPDATE = PLEFTW P_SOL_MAS = PLEFTW + int(NPIV,8) * int(NRHS_B,8) PLEFTW = P_SOL_MAS + int(NROW_L,8) * int(NRHS_B,8) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W( P_SOL_MAS+(K-JBDEB)*NROW_L),NROW_L, & MPI_COMPLEX, & COMM, IERR ) ENDDO IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF APOS = PTRFAC( STEP(INODE)) IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) MTYPE_SLAVE = 0 W(P_UPDATE:P_UPDATE+NPIV*NRHS_B-1)=ZERO CALL CMUMPS_SOL_SLAVE_LR_U(INODE, IWHDLR, -9999, & W, LWC, & NROW_L, NPIV, & P_SOL_MAS, P_UPDATE, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN MTYPE_SLAVE = 1 LDA_SLAVE = NROW_L ELSE MTYPE_SLAVE = 0 LDA_SLAVE = NPIV ENDIF CALL CMUMPS_SOLVE_GEMM_UPDATE( & A, LA, APOS, NROW_L, & LDA_SLAVE, & NPIV, & NRHS_B, W, LWC, & P_SOL_MAS, NROW_L, & P_UPDATE, NPIV, & MTYPE_SLAVE, KEEP, ZERO) ENDIF IF (KEEP(201) .EQ. 1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTW = PLEFTW - int(NROW_L,8) * int(NRHS_B,8) 100 CONTINUE CALL CMUMPS_BUF_SEND_BACKVEC( NRHS_B, INODE, & W(P_UPDATE), & NPIV, NPIV, & MSGSOU, & BACKSLV_UPDATERHS, & JBDEB, JBFIN, & KEEP, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 100 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NRHS_B * NPIV * KEEP(35) + 4 * KEEP(34) GOTO 260 END IF PLEFTW = PLEFTW - NPIV * NRHS_B ELSE IF ( MSGTAG .EQ. BACKSLV_UPDATERHS ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & INODE, 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 NELIM = IW(IPOS-1) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 NSLAVES = IW( IPOS + 1 ) IPOS = IPOS + 1 + NSLAVES INODEPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 4 IF ( KEEP(50) .eq. 0 ) THEN LDA = LIELL ELSE LDA = NPIV ENDIF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + 1 J2 = IPOS + NPIV + LIELL ELSE J1 = IPOS + 1 J2 = IPOS + NPIV ENDIF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) DO K=JBDEB, JBFIN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & W2, NPIV, MPI_COMPLEX, & COMM, IERR ) I = 1 IF ( (KEEP(253).NE.0) .AND. & (IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI+NSLAVES) & ) THEN DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = W2(I) I = I+1 ENDDO ELSE DO JJ = J1,J2 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) + W2(I) I = I+1 ENDDO ENDIF ENDDO IW(PTRIST(STEP(INODE))+XXS) = & IW(PTRIST(STEP(INODE))+XXS) - 1 IF ( IW(PTRIST(STEP(INODE))+XXS).EQ.C_FINI ) THEN IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN CALL CMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL CMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL), & MUST_BE_PERMUTED ) ENDIF ENDIF APOS = PTRFAC(IW(INODEPOS)) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN LIWFAC = IW(PTRIST(STEP(INODE))+XXI) TYPEF = TYPEF_L NROW_L = NPIV+NELIM PANEL_SIZE = CMUMPS_OOC_PANEL_SIZE(NROW_L) IF (PANEL_SIZE.LT.0) THEN WRITE(6,*) ' Internal error in bwd solve PANEL_SIZE=', & PANEL_SIZE CALL MUMPS_ABORT() ENDIF ENDIF IF ( POSIWCB - 2 .LT. 0 .or. & POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN CALL CMUMPS_COMPSO( N, KEEP(28), IWCB, & LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) IF ( POSWCB - LIELL*NRHS_B .LT. PLEFTW - 1_8 ) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR( LIELL*NRHS_B - POSWCB-PLEFTW+1_8, & INFO(2) ) GOTO 260 END IF IF ( POSIWCB - 2 .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = 2 - POSIWCB GO TO 260 END IF END IF POSIWCB = POSIWCB - 2 POSWCB = POSWCB - LIELL*NRHS_B PTRICB(STEP( INODE )) = POSIWCB + 1 PTRACB(STEP( INODE )) = POSWCB + 1_8 IWCB( PTRICB(STEP( INODE )) ) = LIELL*NRHS_B IWCB( PTRICB(STEP( INODE )) + 1 ) = 1 IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 5 + NSLAVES IF ( MTYPE.EQ.1 .AND. KEEP(50).EQ.0 ) THEN POSINDICES = IPOS + LIELL + 1 ELSE POSINDICES = IPOS + 1 END IF IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(J1)) IFR8 = PTRACB(STEP( INODE )) IFR8 = PTRACB(STEP(INODE))+NPIV-1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN J1 = IPOS + LIELL + NPIV + 1 J2 = IPOS + 2 * LIELL ELSE J1 = IPOS + NPIV + 1 J2 = IPOS + LIELL END IF CALL CMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, & W(PTRACB(STEP(INODE))), LIELL, NPIV+1, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) IFR8 = IFR8 + J2-KEEP(253)-J1+1 IF ( KEEP(201).EQ.1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR .AND. & (( NELIM .GT. 0 ).OR. (MTYPE.NE.1 ))) THEN J = NPIV / PANEL_SIZE TWOBYTWO = KEEP(50).EQ.2 .AND. KEEP(105).GT.0 IF (TWOBYTWO) THEN CALL CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LPANEL_POS, IW(IPOS+1+LIELL), NPIV, NPANELS, & NROW_L, NBENTRIES_ALLPANELS) ELSE IF (NPIV.EQ.J*PANEL_SIZE) THEN NPIV_LAST = NPIV NBJLAST = PANEL_SIZE NPANELS = J ELSE NPIV_LAST = (J+1)* PANEL_SIZE NBJLAST = NPIV-J*PANEL_SIZE NPANELS = J+1 ENDIF NBENTRIES_ALLPANELS = & int(NROW_L,8) * int(NPIV,8) & - int( ( J * ( J - 1 ) ) /2,8 ) & * int(PANEL_SIZE,8) * int(PANEL_SIZE,8) & - int(J,8) & * int(mod(NPIV, PANEL_SIZE),8) & * int(PANEL_SIZE,8) JJ=NPIV_LAST ENDIF APOSDEB = APOS + NBENTRIES_ALLPANELS DO IPANEL=NPANELS,1,-1 IF (TWOBYTWO) THEN NBJ = PANEL_POS(IPANEL+1)-PANEL_POS(IPANEL) BEG_PANEL = PANEL_POS(IPANEL) ELSE IF (JJ.EQ.NPIV_LAST) THEN NBJ = NBJLAST ELSE NBJ = PANEL_SIZE ENDIF BEG_PANEL = JJ- PANEL_SIZE+1 ENDIF LDAJ = NROW_L-BEG_PANEL+1 APOSDEB = APOSDEB - int(NBJ,8)*int(LDAJ,8) PTWCB = PTRACB(STEP(INODE)) PTWCB_PANEL = PTRACB(STEP(INODE)) + int(BEG_PANEL - 1,8) IPOSINRHSCOMP_PANEL = IPOSINRHSCOMP + BEG_PANEL - 1 NCB_PANEL = LDAJ - NBJ NCB = NROW_L - NPIV IF (KEEP(50).NE.1 .AND.MUST_BE_PERMUTED) THEN CALL CMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS + 1 + 2 * LIELL, IW, LIW) CALL CMUMPS_PERMUTE_PANEL( & IW(I_PIVR + IW(I_PIVRPTR+IPANEL-1)-IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, BEG_PANEL-1) ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB.NE. 0) THEN CALL cgemv( 'T', NCB_PANEL-NCB, NBJ, ALPHA, & A( APOSDEB + int(NBJ,8) ), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF IF (NCB .NE. 0) THEN CALL cgemv( 'T', NCB, NBJ, ALPHA, & A( APOSDEB + int(LDAJ-NCB,8) ), LDAJ, & W( PTWCB + NPIV ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1 ) ENDIF ENDIF CALL ctrsv('L','T','U', NBJ, A(APOSDEB), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), 1) ELSE #endif IF (NCB_PANEL.NE.0) THEN IF (NCB_PANEL - NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, & NCB_PANEL-NCB, ALPHA, & A(APOSDEB +int(NBJ,8)), LDAJ, & RHSCOMP(IPOSINRHSCOMP_PANEL+NBJ,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) ENDIF IF (NCB .NE. 0) THEN CALL cgemm( 'T', 'N', NBJ, NRHS_B, NCB, ALPHA, & A(APOSDEB +int(LDAJ-NCB,8)), LDAJ, & W( PTWCB+NPIV ), LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB),LRHSCOMP) ENDIF ENDIF CALL ctrsm('L','L','T','U',NBJ, NRHS_B, ONE, & A(APOSDEB), & LDAJ, RHSCOMP(IPOSINRHSCOMP_PANEL,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) ENDIF #endif IF (.NOT. TWOBYTWO) JJ=BEG_PANEL-1 ENDDO GOTO 1234 ENDIF IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 & .AND. KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL CMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV, NSLAVES, & LIELL, W, LWC, NRHS_B, PTRACB(STEP(INODE)), & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & INFO(1), INFO(1) ) ELSE IF (NELIM .GT.0) THEN IF ( KEEP(50) .eq. 0 ) THEN IST = APOS + int(NPIV,8) * int(LIELL,8) ELSE IST = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NRHS_B == 1 ) THEN CALL cgemv( 'N', NPIV, NELIM, ALPHA, & A( IST ), NPIV, & W( NPIV + PTRACB(STEP(INODE)) ), & 1, ONE, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE CALL cgemm( 'N', 'N', NPIV, NRHS_B, NELIM, ALPHA, & A(IST), NPIV, W(NPIV+PTRACB(STEP(INODE))),LIELL, & ONE, RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) END IF ENDIF #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL ctrsv( 'U', 'N', 'U', NPIV, A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), 1) ELSE #endif CALL ctrsm( 'L','U', 'N', 'U', NPIV, NRHS_B, ONE, & A(APOS), LDA, & RHSCOMP(IPOSINRHSCOMP,JBDEB), LRHSCOMP) #if defined(MUMPS_USE_BLAS2) END IF #endif ENDIF 1234 CONTINUE IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL CMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IPOS = PTRIST(STEP(INODE)) + KEEP(IXSZ) + 6 + NSLAVES IPOSINRHSCOMP = POSINRHSCOMP_BWD(IW(IPOS)) IN = INODE 200 IN = FILS(IN) IF (IN .GT. 0) GOTO 200 IF (IN .EQ. 0) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) IF (KEEP(31) .NE. 0) THEN IF (.NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IWCB( PTRICB(STEP(INODE)) + 1 ) = 0 CALL CMUMPS_FREETOPSO(N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) GOTO 270 ENDIF DO I = 0, SLAVEF - 1 DEJA_SEND( I ) = .FALSE. END DO IN = -IN IF ( PRUN_BELOW ) THEN NO_CHILDREN = .TRUE. ELSE NO_CHILDREN = .FALSE. ENDIF DO WHILE (IN.GT.0) IF ( PRUN_BELOW ) THEN IF (.NOT.TO_PROCESS(STEP(IN))) THEN IN = FRERE(STEP(IN)) CYCLE ELSE NO_CHILDREN = .FALSE. ENDIF ENDIF POOL_FIRST_POS = IIPOOL IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)), & KEEP(199)) .EQ. MYID) THEN IPOOL(IIPOOL ) = IN IIPOOL = IIPOOL + 1 ELSE PROCDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IN)), & KEEP(199) ) IF ( .NOT. DEJA_SEND( PROCDEST ) ) THEN 110 CONTINUE CALL CMUMPS_BUF_SEND_VCB( NRHS_B, IN, 0, 0, & LIELL, LIELL-KEEP(253), & IW( POSINDICES ) , & W( PTRACB(STEP(INODE)) ), JBDEB, JBFIN, & RHSCOMP(1, 1), NRHS, LRHSCOMP, & IPOSINRHSCOMP, NPIV, KEEP, & PROCDEST, NOEUD, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL CMUMPS_BACKSLV_RECV_AND_TREAT( & .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, STEP, & FRERE, FILS, PROCNODE_STEPS, PLEFTW, & KEEP, KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 110 ELSE IF ( IERR .eq. -2 ) THEN INFO(1) = -17 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 ELSE IF ( IERR .eq. -3 ) THEN INFO(1) = -20 INFO(2) = LIELL * NRHS_B * KEEP(35) + & ( LIELL + 4 ) * KEEP(34) GOTO 260 END IF DEJA_SEND( PROCDEST ) = .TRUE. END IF END IF IN = FRERE( STEP( IN ) ) END DO ALLOW_OTHERS_TO_LEAVE = .FALSE. IF (NO_CHILDREN) THEN MYLEAF_LEFT = MYLEAF_LEFT - 1 ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ENDIF IF (KEEP(31) .NE. 0) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) ) THEN KEEP(31) = KEEP(31) - 1 IF (KEEP(31) .EQ. 1) THEN ALLOW_OTHERS_TO_LEAVE = .TRUE. ENDIF ENDIF ENDIF IF ( ALLOW_OTHERS_TO_LEAVE ) THEN CALL CMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, & COMM, TERMBWD, SLAVEF, KEEP ) NBFINF = NBFINF - 1 ENDIF IF ( .NOT. NO_CHILDREN ) THEN DO I=1,(IIPOOL-POOL_FIRST_POS)/2 TMP=IPOOL(POOL_FIRST_POS+I-1) IPOOL(POOL_FIRST_POS+I-1)=IPOOL(IIPOOL-I) IPOOL(IIPOOL-I)=TMP ENDDO ENDIF IWCB( PTRICB(STEP( INODE )) + 1 ) = 0 CALL CMUMPS_FREETOPSO( N, KEEP(28), & IWCB, LIWW, W, LWC, & POSWCB, POSIWCB, PTRICB, PTRACB) END IF ELSE IF (MSGTAG.EQ.TERREUR) THEN INFO(1) = -001 INFO(2) = MSGSOU GO TO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1) = -100 INFO(2) = MSGTAG GOTO 260 ENDIF GO TO 270 260 CONTINUE IF (NBFINF .NE. 0) THEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 270 CONTINUE IF (allocated(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE CMUMPS_BACKSLV_TRAITER_MESSAGE SUBROUTINE CMUMPS_BUILD_PANEL_POS(PANEL_SIZE, PANEL_POS, & LEN_PANEL_POS, INDICES, NPIV, & NPANELS, NFRONT_OR_NASS, & NBENTRIES_ALLPANELS) IMPLICIT NONE INTEGER, intent (in) :: PANEL_SIZE, NPIV INTEGER, intent (in) :: INDICES(NPIV) INTEGER, intent (in) :: LEN_PANEL_POS INTEGER, intent (out) :: NPANELS INTEGER, intent (out) :: PANEL_POS(LEN_PANEL_POS) INTEGER, intent (in) :: NFRONT_OR_NASS INTEGER(8), intent(out):: NBENTRIES_ALLPANELS INTEGER NPANELS_MAX, I, NBeff INTEGER(8) :: NBENTRIES_THISPANEL NBENTRIES_ALLPANELS = 0_8 NPANELS_MAX = (NPIV+PANEL_SIZE-1)/PANEL_SIZE IF (LEN_PANEL_POS .LT. NPANELS_MAX + 1) THEN WRITE(*,*) "Error 1 in CMUMPS_BUILD_PANEL_POS", & LEN_PANEL_POS,NPANELS_MAX CALL MUMPS_ABORT() ENDIF I = 1 NPANELS = 0 IF (I .GT. NPIV) RETURN 10 CONTINUE NPANELS = NPANELS + 1 PANEL_POS(NPANELS) = I NBeff = min(PANEL_SIZE, NPIV-I+1) IF ( INDICES(I+NBeff-1) < 0) THEN NBeff=NBeff+1 ENDIF NBENTRIES_THISPANEL = int(NFRONT_OR_NASS-I+1,8) * int(NBeff,8) NBENTRIES_ALLPANELS = NBENTRIES_ALLPANELS + NBENTRIES_THISPANEL I=I+NBeff IF ( I .LE. NPIV ) GOTO 10 PANEL_POS(NPANELS+1)=NPIV+1 RETURN END SUBROUTINE CMUMPS_BUILD_PANEL_POS MUMPS_5.4.1/src/zfac_process_blocfacto.F0000664000175000017500000010005014102210524020304 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE ZMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE ZMUMPS_LOAD USE ZMUMPS_LR_CORE USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_FAC_LR USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_HAVE_SET_K117 INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL, KEEP_BEGS_BLR_L LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED COMPLEX(kind=8) ONE,ALPHA PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: INFO_TMP(2) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER :: allocok INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 NULLIFY(BEGS_BLR_U) I_HAVE_SET_K117 = .FALSE. DYNAMIC_ALLOC = .FALSE. FPERE = -1 POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) ENDIF CALL ZMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_DOUBLE_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL ZMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_DOUBLE_COMPLEX, & COMM, IERR ) LD_BLOCFACTO = NCOL ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL ZMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL ZMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL ZMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 IF (DYNAMIC_ALLOC) THEN DO I = 1, NPIV IF (DYN_PIVINFO(I).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+DYN_PIVINFO(I)) IW(ICT11+DYN_PIVINFO(I)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + DYN_PIVINFO(I) - 1,8) CALL zswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ELSE DO I = 1, NPIV IF (IW(IPIV+I-1).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1)) IW(ICT11+IW(IPIV+I-1)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8) CALL zswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNAMIC_ALLOC) THEN CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A_PTR(LPOS2), NCOL1) ELSE CALL ztrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_L = NPARTSCB IF (IPANEL.EQ.1) THEN BEGS_BLR_COL=>BEGS_BLR_U ELSE ALLOCATE(BEGS_BLR_COL(size(BEGS_BLR_U)+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = size(BEGS_BLR_U)+IPANEL-1 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF BEGS_BLR_COL(1:IPANEL-1) = 1 DO I=1,size(BEGS_BLR_U) BEGS_BLR_COL(IPANEL+I-1) = BEGS_BLR_U(I) ENDDO ENDIF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IPANEL.NE.1) THEN DEALLOCATE(BEGS_BLR_COL) ENDIF IF (IFLAG.LT.0) GOTO 700 ELSE CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U) IF (LASTBL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ELSE CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL ZMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN UPOS = 1_8+int(NPIV,8) IF (DYNAMIC_ALLOC) THEN CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE IF (DYNAMIC_ALLOC) THEN UPOS = int(NPIV+1,8) CALL zgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,DYN_BLOCFACTO(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL zgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF ENDIF IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV IF (LASTBL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) ) ENDIF IF ( .not. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8) DEALLOCATE(BLR_U) IF (KEEP(486).EQ.3) THEN CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8) DEALLOCATE(BLR_L) ELSE CALL UPD_MRY_LU_LRGAIN(BLR_L, 0, NPARTSCB, 'V') ENDIF ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV ENDIF FLOP1 = dble( NPIV1*NROW1 ) + & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1) & - & dble((NPIV1+NPIV)*NROW1 ) - & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1) CALL ZMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 IF (NPIV.EQ.0) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) IF (COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_COL+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during ZMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL ZMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1) & ) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF CALL ZMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_PROCESS_BLOCFACTO SUBROUTINE ZMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE ZMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE ZMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_COMPLEX, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_COMPLEX, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_COMPLEX, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_MPI_UNPACK_LR MUMPS_5.4.1/src/sfac_mem_free_block_cb.F0000664000175000017500000000600014102210521020175 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE SMUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER IPOSSHIFT INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL SMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL SMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE SMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.4.1/src/clr_stats.F0000664000175000017500000006042514102210524015620 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_LR_STATS USE CMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: MRY_CB_FR, & MRY_CB_LRGAIN, & MRY_LU_FR, & MRY_LU_LRGAIN, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_LRGAIN, & FLOP_FACTO_FR, & FLOP_FACTO_LR, & FLOP_PANEL, & FLOP_TRSM, & FLOP_TRSM_FR, & FLOP_TRSM_LR, & FLOP_UPDATE_FR, & FLOP_UPDATE_LR, & FLOP_UPDATE_LRLR1, & FLOP_UPDATE_LRLR2, & FLOP_UPDATE_LRLR3, & FLOP_UPDATE_FRLR, & FLOP_UPDATE_FRFR DOUBLE PRECISION :: FLOP_COMPRESS, & FLOP_CB_COMPRESS, & FLOP_MIDBLK_COMPRESS, & FLOP_FRSWAP_COMPRESS, & FLOP_ACCUM_COMPRESS, & FLOP_DECOMPRESS, & FLOP_CB_DECOMPRESS, & FLOP_FRFRONTS, & FLOP_SOLFWD_FR, & FLOP_SOLFWD_LR DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: TIME_UPDATE DOUBLE PRECISION :: TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TIME_UPDATE_FRLR DOUBLE PRECISION :: TIME_UPDATE_FRFR DOUBLE PRECISION :: TIME_COMPRESS DOUBLE PRECISION :: TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TIME_CB_COMPRESS DOUBLE PRECISION :: TIME_LR_MODULE DOUBLE PRECISION :: TIME_UPD_NELIM DOUBLE PRECISION :: TIME_LRTRSM DOUBLE PRECISION :: TIME_FRTRSM DOUBLE PRECISION :: TIME_PANEL DOUBLE PRECISION :: TIME_FAC_I DOUBLE PRECISION :: TIME_FAC_MQ DOUBLE PRECISION :: TIME_FAC_SQ DOUBLE PRECISION :: TIME_FRFRONTS DOUBLE PRECISION :: TIME_DIAGCOPY DOUBLE PRECISION :: TIME_DECOMP DOUBLE PRECISION :: TIME_DECOMP_UCFS DOUBLE PRECISION :: TIME_DECOMP_ASM1 DOUBLE PRECISION :: TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TIME_DECOMP_ASMS2M DOUBLE PRECISION :: TIME_LRANA_LRGROUPING DOUBLE PRECISION :: TIME_LRANA_SEPGROUPING DOUBLE PRECISION :: TIME_LRANA_GETHALO DOUBLE PRECISION :: TIME_LRANA_KWAY DOUBLE PRECISION :: TIME_LRANA_GNEW DOUBLE PRECISION :: AVG_FLOP_FACTO_LR DOUBLE PRECISION :: MIN_FLOP_FACTO_LR DOUBLE PRECISION :: MAX_FLOP_FACTO_LR INTEGER :: TOTAL_NBLOCKS_ASS, TOTAL_NBLOCKS_CB INTEGER :: MIN_BLOCKSIZE_ASS, MAX_BLOCKSIZE_ASS INTEGER :: MIN_BLOCKSIZE_CB, MAX_BLOCKSIZE_CB DOUBLE PRECISION :: AVG_BLOCKSIZE_ASS, AVG_BLOCKSIZE_CB CONTAINS SUBROUTINE COLLECT_BLOCKSIZES(CUT,NPARTSASS,NPARTSCB) INTEGER, INTENT(IN) :: NPARTSASS, NPARTSCB INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: LOC_MIN_ASS, LOC_MIN_CB, LOC_MAX_ASS, LOC_MAX_CB, & LOC_TOT_ASS, LOC_TOT_CB DOUBLE PRECISION :: LOC_AVG_ASS, LOC_AVG_CB INTEGER :: I LOC_TOT_ASS = 0 LOC_TOT_CB = 0 LOC_AVG_ASS = 0.D0 LOC_AVG_CB = 0.D0 LOC_MIN_ASS = 100000 LOC_MIN_CB = 100000 LOC_MAX_ASS = 0 LOC_MAX_CB = 0 DO I = 1,NPARTSASS LOC_AVG_ASS = ( LOC_TOT_ASS * LOC_AVG_ASS & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_ASS + 1) LOC_TOT_ASS = LOC_TOT_ASS + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_ASS) THEN LOC_MIN_ASS = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_ASS) THEN LOC_MAX_ASS = CUT(I+1) - CUT(I) END IF END DO DO I = NPARTSASS+1,NPARTSASS+NPARTSCB LOC_AVG_CB = ( LOC_TOT_CB * LOC_AVG_CB & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_CB + 1) LOC_TOT_CB = LOC_TOT_CB + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_CB) THEN LOC_MIN_CB = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_CB) THEN LOC_MAX_CB = CUT(I+1) - CUT(I) END IF END DO AVG_BLOCKSIZE_ASS = (TOTAL_NBLOCKS_ASS*AVG_BLOCKSIZE_ASS & + LOC_TOT_ASS*LOC_AVG_ASS) / (TOTAL_NBLOCKS_ASS+LOC_TOT_ASS) AVG_BLOCKSIZE_CB = (TOTAL_NBLOCKS_CB*AVG_BLOCKSIZE_CB & + LOC_TOT_CB*LOC_AVG_CB) / (TOTAL_NBLOCKS_CB+LOC_TOT_CB) TOTAL_NBLOCKS_ASS = TOTAL_NBLOCKS_ASS + LOC_TOT_ASS TOTAL_NBLOCKS_CB = TOTAL_NBLOCKS_CB + LOC_TOT_CB MIN_BLOCKSIZE_ASS = min(MIN_BLOCKSIZE_ASS,LOC_MIN_ASS) MIN_BLOCKSIZE_CB = min(MIN_BLOCKSIZE_CB,LOC_MIN_CB) MAX_BLOCKSIZE_ASS = max(MAX_BLOCKSIZE_ASS,LOC_MAX_ASS) MAX_BLOCKSIZE_CB = max(MAX_BLOCKSIZE_CB,LOC_MAX_CB) END SUBROUTINE COLLECT_BLOCKSIZES SUBROUTINE UPD_FLOP_DECOMPRESS(F, CB) DOUBLE PRECISION, INTENT(IN) :: F LOGICAL, INTENT(IN) :: CB !$OMP ATOMIC UPDATE FLOP_DECOMPRESS = FLOP_DECOMPRESS + F !$OMP END ATOMIC IF (CB) THEN !$OMP ATOMIC UPDATE FLOP_CB_DECOMPRESS = FLOP_CB_DECOMPRESS + F !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE UPD_FLOP_DECOMPRESS SUBROUTINE UPD_FLOP_COMPRESS(LR_B, REC_ACC, & CB_COMPRESS, FRSWAP) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST,BUILDQ_COST, & HR_AND_BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC, CB_COMPRESS, FRSWAP M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(K*K*K/3_8 + 4_8*K*M*N - (2_8*M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(2_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF HR_AND_BUILDQ_COST = HR_COST + BUILDQ_COST !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + HR_AND_BUILDQ_COST !$OMP END ATOMIC IF (present(REC_ACC)) THEN IF (REC_ACC) THEN !$OMP ATOMIC UPDATE FLOP_ACCUM_COMPRESS = FLOP_ACCUM_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(CB_COMPRESS)) THEN IF (CB_COMPRESS) THEN !$OMP ATOMIC UPDATE FLOP_CB_COMPRESS = FLOP_CB_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(FRSWAP)) THEN IF (FRSWAP) THEN !$OMP ATOMIC UPDATE FLOP_FRSWAP_COMPRESS = FLOP_FRSWAP_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE UPD_FLOP_COMPRESS SUBROUTINE UPD_FLOP_TRSM(LRB, LorU) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: LorU DOUBLE PRECISION :: LR_COST, FR_COST, LR_GAIN IF (LorU.EQ.0) THEN FR_COST = dble(LRB%M*LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%K*LRB%N*LRB%N) ELSE LR_COST = FR_COST ENDIF ELSE FR_COST = dble(LRB%M-1)*dble(LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%N-1)*dble(LRB%N*LRB%K) ELSE LR_COST = FR_COST ENDIF ENDIF LR_GAIN = FR_COST - LR_COST !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_TRSM SUBROUTINE UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS, RANK_IN, BUILDQ, & IS_SYMDIAG, LUA_ACTIVATED, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 LOGICAL, INTENT(IN) :: BUILDQ, IS_SYMDIAG, LUA_ACTIVATED INTEGER, INTENT(IN) :: RANK_IN, MIDBLK_COMPRESS LOGICAL, INTENT(IN), OPTIONAL :: REC_ACC DOUBLE PRECISION :: COST_FR, COST_LR, COST_LRLR1, COST_LRLR2, & COST_LRLR3, COST_FRLR, COST_FRFR, & COST_COMPRESS, COST_LR_AND_COMPRESS, LR_GAIN DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK LOGICAL :: REC_ACC_LOC M1 = dble(LRB1%M) N1 = dble(LRB1%N) K1 = dble(LRB1%K) M2 = dble(LRB2%M) N2 = dble(LRB2%N) K2 = dble(LRB2%K) RANK = dble(RANK_IN) COST_LRLR1 = 0.0D0 COST_LRLR2 = 0.0D0 COST_LRLR3 = 0.0D0 COST_FRLR = 0.0D0 COST_FRFR = 0.0D0 COST_COMPRESS = 0.0D0 IF (present(REC_ACC)) THEN REC_ACC_LOC = REC_ACC ELSE REC_ACC_LOC = .FALSE. ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN COST_FRFR = 2.0D0*M1*M2*N1 COST_LR = 2.0D0*M1*M2*N1 COST_FR = 2.0D0*M1*M2*N1 ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN COST_FRLR = 2.0D0*K1*M2*N1 COST_LRLR3 = 2.0D0*M1*M2*K1 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN COST_FRLR = 2.0D0*M1*K2*N1 COST_LRLR3 = 2.0D0*M1*M2*K2 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSE IF (MIDBLK_COMPRESS.GE.1) THEN COST_COMPRESS = RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & (2.0D0*K1+K2)*RANK*RANK IF (BUILDQ) THEN COST_COMPRESS = COST_COMPRESS + 4.0D0*RANK*RANK*K1 & - RANK*RANK*RANK ENDIF ENDIF COST_LRLR1 = 2.0D0*K1*K2*N1 IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN COST_LRLR2 = 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK COST_LRLR3 = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN COST_LRLR2 = 2.0D0*K1*M1*K2 COST_LRLR3 = 2.0D0*M1*M2*K2 ELSE COST_LRLR2 = 2.0D0*K1*M2*K2 COST_LRLR3 = 2.0D0*M1*M2*K1 ENDIF ENDIF COST_LR = COST_LRLR1 + COST_LRLR2 + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ENDIF IF (IS_SYMDIAG) THEN COST_FR = COST_FR/2.0D0 COST_LRLR3 = COST_LRLR3/2.0D0 COST_FRFR = COST_FRFR/2.0D0 COST_LR = COST_LR - COST_LRLR3 - COST_FRFR ENDIF IF (LUA_ACTIVATED) THEN COST_LR = COST_LR - COST_LRLR3 COST_LRLR3 = 0.0D0 IF (REC_ACC_LOC) THEN COST_LR_AND_COMPRESS = COST_LR + COST_COMPRESS !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_LR_AND_COMPRESS !$OMP END ATOMIC ENDIF ENDIF IF (.NOT.REC_ACC_LOC) THEN !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_COMPRESS !$OMP END ATOMIC LR_GAIN = COST_FR - COST_LR !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC ENDIF END SUBROUTINE UPD_FLOP_UPDATE SUBROUTINE UPD_FLOP_UPDATE_LRLR3(LRB, NIV) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV DOUBLE PRECISION :: FLOP_COST FLOP_COST = 2.0D0*dble(LRB%M)*dble(LRB%N)*dble(LRB%K) !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN - FLOP_COST !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_UPDATE_LRLR3 SUBROUTINE UPD_FLOP_ROOT(KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + COST_PER_PROC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_ROOT SUBROUTINE INIT_STATS_GLOBAL(id) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id MRY_LU_FR = 0.D0 MRY_LU_LRGAIN = 0.D0 MRY_CB_FR = 0.D0 MRY_CB_LRGAIN = 0.D0 FLOP_FACTO_FR = 0.D0 FLOP_FACTO_LR = 0.D0 FLOP_LRGAIN = 0.D0 FLOP_CB_COMPRESS = 0.D0 FLOP_CB_DECOMPRESS = 0.D0 FLOP_DECOMPRESS = 0.D0 FLOP_UPDATE_FR = 0.D0 FLOP_UPDATE_LR = 0.D0 FLOP_UPDATE_LRLR1 = 0.D0 FLOP_UPDATE_LRLR2 = 0.D0 FLOP_UPDATE_LRLR3 = 0.D0 FLOP_UPDATE_FRLR = 0.D0 FLOP_UPDATE_FRFR = 0.D0 FLOP_MIDBLK_COMPRESS = 0.D0 FLOP_TRSM_FR = 0.D0 FLOP_TRSM_LR = 0.D0 FLOP_COMPRESS = 0.D0 FLOP_ACCUM_COMPRESS = 0.D0 FLOP_FRSWAP_COMPRESS = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 FLOP_FRFRONTS = 0.D0 FLOP_SOLFWD_FR = 0.D0 FLOP_SOLFWD_LR = 0.D0 TOTAL_NBLOCKS_ASS = 0 TOTAL_NBLOCKS_CB = 0 AVG_BLOCKSIZE_ASS = 0.D0 AVG_BLOCKSIZE_CB = 0.D0 MIN_BLOCKSIZE_ASS = huge(1) MAX_BLOCKSIZE_ASS = 0 MIN_BLOCKSIZE_CB = huge(1) MAX_BLOCKSIZE_CB = 0 CNT_NODES = 0 TIME_UPDATE = 0.D0 TIME_MIDBLK_COMPRESS = 0.D0 TIME_UPDATE_LRLR1 = 0.D0 TIME_UPDATE_LRLR2 = 0.D0 TIME_UPDATE_LRLR3 = 0.D0 TIME_UPDATE_FRLR = 0.D0 TIME_UPDATE_FRFR = 0.D0 TIME_COMPRESS = 0.D0 TIME_CB_COMPRESS = 0.D0 TIME_LR_MODULE = 0.D0 TIME_UPD_NELIM = 0.D0 TIME_LRTRSM = 0.D0 TIME_FRTRSM = 0.D0 TIME_PANEL = 0.D0 TIME_FAC_I = 0.D0 TIME_FAC_MQ = 0.D0 TIME_FAC_SQ = 0.D0 TIME_FRFRONTS = 0.D0 TIME_DIAGCOPY = 0.D0 TIME_FRSWAP_COMPRESS = 0.D0 TIME_DECOMP = 0.D0 TIME_DECOMP_UCFS = 0.D0 TIME_DECOMP_ASM1 = 0.D0 TIME_DECOMP_LOCASM2 = 0.D0 TIME_DECOMP_MAPLIG1 = 0.D0 TIME_DECOMP_ASMS2S = 0.D0 TIME_DECOMP_ASMS2M = 0.D0 END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE UPD_MRY_LU_FR(NASS, NCB, SYM, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, NELIM DOUBLE PRECISION :: MRY INTEGER :: NPIV NPIV = NASS - NELIM IF (SYM .GT. 0) THEN MRY = dble(NPIV)*(dble(NPIV)+1.D0)/2.D0 & + dble(NPIV)*dble(NCB+NELIM) ELSE MRY = dble(NPIV)*dble(NPIV) & + 2.0D0*dble(NPIV)*dble(NCB+NELIM) END IF !$OMP ATOMIC UPDATE MRY_LU_FR = MRY_LU_FR + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_FR SUBROUTINE UPD_MRY_CB(NROWS, NCOLS, & SYM, NIV, LRGAIN) INTEGER,INTENT(IN) :: NROWS, NCOLS, SYM, NIV, LRGAIN DOUBLE PRECISION :: MRY, LRGAIND IF (SYM.EQ.0) THEN MRY = dble(NCOLS)*dble(NROWS) ELSE MRY = dble(NCOLS-NROWS)*dble(NROWS) + & dble(NROWS)*dble(NROWS+1)/2.D0 ENDIF !$OMP ATOMIC UPDATE MRY_CB_FR = MRY_CB_FR + MRY !$OMP END ATOMIC LRGAIND=dble(LRGAIN) !$OMP ATOMIC UPDATE MRY_CB_LRGAIN = MRY_CB_LRGAIN + LRGAIND !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_CB SUBROUTINE UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_INASM, & NB_INCB, DIR) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR DOUBLE PRECISION :: FLOPFR, FLOPLR, MRY INTEGER :: I FLOPFR = 0.0D0 FLOPLR = 0.0D0 MRY = 0.0D0 IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN FLOPFR = FLOPFR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) FLOPLR = FLOPLR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) ENDIF DO I = 1, NB_INASM+NB_INCB IF (DIR .EQ. 'V') THEN FLOPFR = FLOPFR + & 2.0D0*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN FLOPLR = FLOPLR + & 2.0D0*dble((BLR_PANEL(I)%M+BLR_PANEL(I)%N) & *BLR_PANEL(I)%K) ELSE FLOPLR = FLOPLR + & 2.0D0*dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N) ENDIF ENDIF IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ENDIF ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE UPD_FLOP_FACTO_FR( NFRONT, NASS, NPIV, SYM, NIV) INTEGER,INTENT(IN) :: NFRONT, SYM, NASS, NPIV, NIV DOUBLE PRECISION :: FLOP CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP) !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC END SUBROUTINE UPD_FLOP_FACTO_FR SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2( NROW1, NCOL1, & NASS1, KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FAC CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FAC) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP_FAC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONTS SUBROUTINE UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NB_ENTRIES_FACTOR_withLR, & PROKG, MPG) INTEGER(8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: MPG LOGICAL, INTENT(IN) :: PROKG REAL, INTENT(IN) :: FLOP_NUMBER INTEGER(8), INTENT(OUT) :: & NB_ENTRIES_FACTOR_withLR IF (NB_ENTRIES_FACTOR < 0) THEN IF (PROKG.AND.MPG.GT.0) THEN WRITE(MPG,*) "NEGATIVE NUMBER OF ENTRIES IN FACTOR" WRITE(MPG,*) "===> OVERFLOW ?" END IF END IF IF (MRY_LU_FR .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & MRY_LU_LRGAIN/MRY_LU_FR ENDIF IF (MRY_CB_FR .EQ. 0) THEN MRY_CB_FR = 100.0D0 END IF NB_ENTRIES_FACTOR_withLR = NB_ENTRIES_FACTOR - & int(MRY_LU_LRGAIN,8) IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & MRY_LU_FR/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*MRY_LU_LRGAIN/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN + FLOP_COMPRESS & + FLOP_DECOMPRESS RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & ICNTL36, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, & K8110, K849, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,DEPTH, N, & ICNTL36, BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, & K472, K475, K478, K480, K481, K483, K484, & SYM, NPROCS INTEGER(8), INTENT(IN) :: K8110, K849 LOGICAL, INTENT(IN) :: PROKG REAL :: DKEEP(230) LOGICAL PROK PROK = (PROKG.AND.(MPG.GE.0)) IF (PROK) THEN WRITE(MPG,'(/A,A)') & '-------------- Beginning of BLR statistics -------------------', & '--------------' WRITE(MPG,'(A,I2)') & ' ICNTL(36) BLR variant = ', ICNTL36 WRITE(MPG,'(A,ES8.1)') & ' CNTL(7) Dropping parameter controlling accuracy = ', & DKEEP(8) WRITE(MPG,'(A)') & ' Statistics after BLR factorization :' WRITE(MPG,'(A,I8)') & ' Number of BLR fronts = ', & CNT_NODES ENDIF IF (PROK) WRITE(MPG,'(A,F8.1,A)') & ' Fraction of factors in BLR fronts =', & FACTOR_PROCESSED_FRACTION,'% ' IF (PROK) THEN WRITE(MPG,'(A)') & ' Statistics on the number of entries in factors :' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(29) Theoretical nb of entries in factors =' & ,real(K8110),' (100.0%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(35) Effective nb of entries (% of INFOG(29)) =' & ,real(K849),' (' & ,real(100)*(real(K849)/real(max(K8110,1_8))) & ,'%)' ENDIF IF (PROK) WRITE(MPG,'(A)') & ' Statistics on operation counts (OPC):' TOTAL_FLOP = MAX(TOTAL_FLOP,EPSILON(1.0D0)) DKEEP(55)=real(TOTAL_FLOP) DKEEP(60)=real(100) DKEEP(56)=real(FLOP_FACTO_LR+FLOP_FRFRONTS) DKEEP(61)=real(100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(3) Total theoretical operations counts =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(14) Total effective OPC (% of RINFOG(3)) =' & ,FLOP_FACTO_LR+FLOP_FRFRONTS,' (' &,100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP &,'%)' ENDIF IF (PROK) WRITE(MPG,'(A,A)') & '-------------- End of BLR statistics -------------------------', & '--------------' RETURN END SUBROUTINE SAVEandWRITE_GAINS END MODULE CMUMPS_LR_STATS MUMPS_5.4.1/src/dfac_lr.F0000664000175000017500000030130114102210523015202 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_LR USE DMUMPS_LR_CORE IMPLICIT NONE CONTAINS SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, CURRENT_BLR, BLR_L, & NELIM, IW2, BLOCK, & MAXI_CLUSTER, NPIV, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NELIM, MAXI_CLUSTER, NPIV, NIV, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(CURRENT_BLR)-1,8) & + int(BEGS_BLR(CURRENT_BLR) - 1,8) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC, CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, !$OMP& MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL*(NB_BLOCKS_PANEL+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT + int(NFRONT,8) * & int(BEGS_BLR(CURRENT_BLR+I)-1,8) & + int(BEGS_BLR(CURRENT_BLR+J) - 1, 8) CALL DMUMPS_LRGEMM4(MONE, & BLR_L(J), BLR_L(I), ONE, A, LA, & POSELTT, NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_L(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_LDLT SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA, LA_BLOCFACTO DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, DIMENSION(:) :: BEGS_BLR_LM, BEGS_BLR_LS TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_LM, NB_BLOCKS_PANEL_LS, J, MID_RANK LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELTT, POSELTD DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL_LM = NB_BLR_LM-CURRENT_BLR_LM NB_BLOCKS_PANEL_LS = NB_BLR_LS-CURRENT_BLR_LS POSELTD = 1_8 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, OMP_NUM, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*NB_BLOCKS_PANEL_LM) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_LM+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_LM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((BEGS_BLR_LM(CURRENT_BLR_LM+J)+ISHIFT_LM-1),8) CALL DMUMPS_LRGEMM4(MONE, & BLR_LM(J), BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LM(J), BLR_LS(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO IF (IFLAG.LT.0) RETURN !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELTT, MID_RANK, OMP_NUM, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_LS*(NB_BLOCKS_PANEL_LS+1)/2) IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif POSELTT = POSELT & + int(NCOL,8) * & int((BEGS_BLR_LS(CURRENT_BLR_LS+I)+ISHIFT_LS-1),8) & + int((NCOL-NROW+(BEGS_BLR_LS(CURRENT_BLR_LS+J)-1)),8) CALL DMUMPS_LRGEMM4(MONE, & BLR_LS(J),BLR_LS(I), ONE, A, LA, & POSELTT, NCOL, & 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT, & MID_RANK, BUILDQ, & .FALSE., MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A_BLOCFACTO, LD_DIAG=LD_BLOCFACTO, IW2=IW2, & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_LS(J), BLR_LS(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif RETURN END SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & IBEG_BLR, NPIV, NELIM, FIRST_BLOCK INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) INTEGER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: IP INTEGER :: allocok INTEGER(8) :: LPOS, UPOS DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (NELIM.NE.0) THEN LPOS = POSELT + int(NFRONT,8)*int(NPIV,8) + int(IBEG_BLR-1,8) #if defined(BLR_MT) !$OMP DO PRIVATE(LRB, UPOS) #endif DO IP = FIRST_BLOCK, NB_BLR IF (IFLAG.LT.0) CYCLE LRB => BLR_U(IP-CURRENT_BLR) UPOS = POSELT + int(NFRONT,8)*int(NPIV,8) & + int(BEGS_BLR(IP)-1,8) IF (LRB%ISLR) THEN IF (LRB%K.GT.0) THEN allocate(TEMP_BLOCK( LRB%K, NELIM ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * LRB%K GOTO 100 ENDIF CALL dgemm('N', 'N', LRB%K, NELIM, LRB%N, ONE, & LRB%R(1,1), LRB%K, A(LPOS), NFRONT, & ZERO, TEMP_BLOCK, LRB%K) CALL dgemm('N', 'N', LRB%M, NELIM, LRB%K, MONE, & LRB%Q(1,1), LRB%M, TEMP_BLOCK, LRB%K, & ONE, A(UPOS), NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE CALL dgemm('N', 'N', LRB%M, NELIM, LRB%N, MONE, & LRB%Q(1,1), LRB%M, A(LPOS), NFRONT, & ONE, A(UPOS), NFRONT) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_U SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:) INTEGER :: I, NB_BLOCKS_PANEL_L, KL, ML, NL INTEGER :: allocok INTEGER(8) :: IPOS DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR IF (NELIM.NE.0) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(KL, ML, NL, IPOS) #endif DO I = FIRST_BLOCK-CURRENT_BLR, NB_BLOCKS_PANEL_L IF (IFLAG.LT.0) CYCLE KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IPOS = LPOS + int(LDL,8) * & int(BEGS_BLR_L(CURRENT_BLR+I)-BEGS_BLR_L(CURRENT_BLR+1),8) IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL write(*,*) 'Allocation problem in BLR routine & DMUMPS_BLR_UPD_NELIM_VAR_L: ', & 'not enough memory? memory requested = ', IERROR GOTO 100 ENDIF CALL dgemm(UTRANS , 'T' , NELIM, KL, NL , ONE , & A_U(UPOS) , LDU , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL dgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) deallocate(TEMP_BLOCK) ENDIF ELSE CALL dgemm(UTRANS , 'T' , NELIM, ML, NL , MONE , & A_U(UPOS) , LDU , BLR_L(I)%Q(1,1) , ML , & ONE , A_L(IPOS) , LDL) ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP ENDDO #endif ENDIF END SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_U(:) TYPE(LRB_TYPE),TARGET,intent(in) :: BLR_L(:) INTEGER :: BEGS_BLR_L(:), BEGS_BLR_U(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: I, NB_BLOCKS_PANEL_L, NB_BLOCKS_PANEL_U, & KL, ML, NL, J, IS, MID_RANK INTEGER :: allocok LOGICAL :: BUILDQ INTEGER :: OMP_NUM INTEGER :: IBIS #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELT_TOP DOUBLE PRECISION, ALLOCATABLE,DIMENSION(:,:) :: TEMP_BLOCK DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL_L = NB_BLR_L-CURRENT_BLR NB_BLOCKS_PANEL_U = NB_BLR_U-CURRENT_BLR IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS = 0 ENDIF #if defined(BLR_MT) !$OMP SINGLE #endif IF (NELIM.NE.0) THEN DO I = 1, NB_BLOCKS_PANEL_L KL = BLR_L(I)%K ML = BLR_L(I)%M NL = BLR_L(I)%N IF (BLR_L(I)%ISLR) THEN IF (KL.GT.0) THEN allocate(TEMP_BLOCK( NELIM, KL ), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NELIM * KL GOTO 100 ENDIF POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_U(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) CALL dgemm('N' , 'T' , NELIM, KL, NL , ONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%R(1,1) , KL , & ZERO , TEMP_BLOCK , NELIM) CALL dgemm('N' , 'T' , NELIM , ML , KL , MONE , & TEMP_BLOCK , NELIM , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) deallocate(TEMP_BLOCK) ENDIF ELSE POSELT_TOP = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1)+IS-NELIM-1,8) POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+1) + IS - NELIM - 1, 8) CALL dgemm('N' , 'T' , NELIM, ML, NL , MONE , & A(POSELT_TOP) , NFRONT , BLR_L(I)%Q(1,1) , ML , & ONE , A(POSELT_INCB) , NFRONT) ENDIF ENDDO ENDIF 100 CONTINUE #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 200 OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_INCB, MID_RANK, BUILDQ) #endif DO IBIS = 1, (NB_BLOCKS_PANEL_L*NB_BLOCKS_PANEL_U) IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_BLOCKS_PANEL_U+1 J = IBIS - (I-1)*NB_BLOCKS_PANEL_U POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR_L(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR_U(CURRENT_BLR+J) +IS - 1,8) CALL DMUMPS_LRGEMM4(MONE, BLR_U(J), & BLR_L(I), ONE, A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT, MID_RANK, BUILDQ, .FALSE.) IF (IFLAG.LT.0) CYCLE CALL UPD_FLOP_UPDATE(BLR_U(J), BLR_L(I), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., .FALSE.) ENDDO #if defined(BLR_MT) !$OMP END DO #endif 200 CONTINUE END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT_LDLT( & A, LA, POSELT, NFRONT, IWHANDLER, & BEGS_BLR, CURRENT_BLR, NB_BLR, NPARTSASS, & NELIM, IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & KEEP8, & FIRST_BLOCK & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, TOL_OPT, & NELIM, NIV, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER, intent(in) :: IW2(*) DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK TYPE(LRB_TYPE), POINTER :: BLR_L(:), NEXT_BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & I, II, J, JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX, & MAXRANK, NB_DEC, FR_RANK INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB, POSELTD DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: KEEP(480)=",K480, & ">= 5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, K_MAX, !$OMP& BLR_L, OMP_NUM, J_ORDER, J_RANK, !$OMP& IND_U, IND_L, ACC_LRB, POSELTD, NB_DEC, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, COMPRESSED_FR, FR_RANK, II, OFFSET_IW) #endif DO I = 1, NB_BLOCKS_PANEL #if defined(BLR_MT) IF (IFLAG.LT.0) CYCLE OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 1, 0, I, 0, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR(J)-1,8) & + int(BEGS_BLR(J) - 1,8) OFFSET_IW = BEGS_BLR(J) IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=0, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), & BLR_L(IND_L), MIDBLK_COMPRESS, & MID_RANK, BUILDQ, (I.EQ.1), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = floor(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR_L(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR_L(I-1)%ISLR=.FALSE. CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, 0) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT_LDLT SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT( & A, LA, POSELT, NFRONT, IWHANDLER, LorU, & BEGS_BLR, BEGS_BLR_U, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, NIV, SYM, & LBANDSLAVE, IFLAG, IERROR, ISHIFT, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, KEEP8, & FIRST_BLOCK, BEG_I_IN, END_I_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, NPARTSASS, & CURRENT_BLR, IWHANDLER, LorU, & NELIM, NIV, SYM, K480, K479, K478, & MAXI_CLUSTER, MAXI_RANK, & KPERCENT_LUA, KPERCENT, ISHIFT, & K474, FSorCB LOGICAL, intent(in) :: LBANDSLAVE DOUBLE PRECISION, TARGET, intent(inout) :: A(LA) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER,intent(inout) :: IFLAG, IERROR INTEGER,OPTIONAL,intent(in) :: FIRST_BLOCK INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:), NEXT_BLR(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, FRFR_UPDATES, & NB_DEC, FR_RANK, MAXRANK, BEG_I, END_I INTEGER :: I,II,J,JJ, NB_BLOCKS_PANEL, IND_U, IND_L, K_MAX INTEGER :: MID_RANK, allocok INTEGER :: J_ORDER(CURRENT_BLR), J_RANK(CURRENT_BLR) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) LOGICAL :: BUILDQ, COMPRESSED_FR #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif INTEGER(8) :: POSELT_INCB DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) IF (NIV.EQ.2.AND.LorU.EQ.0) THEN IF (LBANDSLAVE) THEN NB_BLOCKS_PANEL = NB_BLR ELSE NB_BLOCKS_PANEL = NPARTSASS-CURRENT_BLR ENDIF ELSE NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR ENDIF ACC_LRB => ACC_LUA(1) IF (K480.GE.5) THEN IF (NB_BLOCKS_PANEL.GT.1) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & LorU, & CURRENT_BLR+1, NEXT_BLR) ENDIF IF (.not.(present(FIRST_BLOCK))) THEN write(*,*) "Internal error in & DMUMPS_BLR_UPD_PANEL_LEFT: KEEP(480)=",K480, & ">=5, but FIRST_BLOCK argument is missing" CALL MUMPS_ABORT() ENDIF ENDIF IF (LorU.EQ.0) THEN BEG_I = 1 ELSE BEG_I = 2 ENDIF END_I = NB_BLOCKS_PANEL IF (K474.EQ.3) THEN IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN - CURRENT_BLR ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN - CURRENT_BLR ENDIF ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, JJ, POSELT_INCB, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, J_ORDER, J_RANK, K_MAX, !$OMP& IND_U, IND_L, OMP_NUM, ACC_LRB, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, COMPRESSED_FR) #endif DO I = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(I+1)-1),8) & + int(BEGS_BLR_U(2)+ISHIFT-1,8) ACC_LRB%N = BEGS_BLR(I+2)-BEGS_BLR(I+1) ACC_LRB%M = BEGS_BLR_U(3)-BEGS_BLR_U(2) IF (K474.GE.2) THEN BLR_U => BLR_U_COL ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+I)-1),8) & + int(BEGS_BLR(CURRENT_BLR+1)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+I+1) & -BEGS_BLR(CURRENT_BLR+I) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ENDIF ELSE POSELT_INCB = POSELT & + int(NFRONT,8) * int((BEGS_BLR(CURRENT_BLR+1)-1),8) & + int(BEGS_BLR(CURRENT_BLR+I)-1,8) ACC_LRB%N = BEGS_BLR(CURRENT_BLR+2)-BEGS_BLR(CURRENT_BLR+1) ACC_LRB%M = BEGS_BLR(CURRENT_BLR+I+1)-BEGS_BLR(CURRENT_BLR+I) ENDIF MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 COMPRESSED_FR = .FALSE. IF (K480.EQ.2) THEN DO J = 1, CURRENT_BLR J_ORDER(J) = J ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(CURRENT_BLR, J_ORDER, J_RANK, & IWHANDLER, & 0, 0, I, LorU, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF ENDIF NB_DEC = FRFR_UPDATES DO JJ = 1, CURRENT_BLR J = J_ORDER(JJ) K_MAX = J_RANK(JJ) IF (LorU.EQ.0) THEN IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = CURRENT_BLR+1-J ELSE IND_U = J ENDIF ELSE IND_L = CURRENT_BLR+I-J IND_U = CURRENT_BLR+1-J ENDIF ELSE IND_L = CURRENT_BLR+1-J IND_U = CURRENT_BLR+I-J ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & J, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & J, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = JJ-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB, MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_INCB, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=LorU, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER & ) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN J_RANK(JJ) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.1)) THEN IF (I.GT.FIRST_BLOCK) THEN IF (JJ.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, LorU, .FALSE.) MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K IF (COMPRESSED_FR) THEN J_RANK(JJ) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF ENDIF ENDIF ENDIF ENDDO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) ELSE allocate(POS_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,CURRENT_BLR POS_LIST(II+1)=POS_LIST(II)+J_RANK(II-1) ENDDO allocate(RANK_LIST(CURRENT_BLR+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_PANEL_LEFT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,CURRENT_BLR+1 RANK_LIST(II) = J_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & CURRENT_BLR+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL ALLOC_LRB_FROM_ACC(ACC_LRB, NEXT_BLR(I-1), & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, LorU, & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE ACC_LRB%K = 0 ELSE IF (I.NE.1) NEXT_BLR(I-1)%ISLR=.FALSE. CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (CURRENT_BLR-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(CURRENT_BLR-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = CURRENT_BLR-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,CURRENT_BLR-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+J_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_INCB, KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & J_RANK(NB_DEC+1:CURRENT_BLR), POS_LIST, & CURRENT_BLR-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_INCB, NFRONT, NIV, LorU) ENDIF ENDIF 100 CONTINUE ENDDO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE DMUMPS_BLR_UPD_PANEL_LEFT SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT_LDLT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_DYN, NB_INCB, NB_INASM, NASS, & IWHANDLER, & IW2, BLOCK, ACC_LUA, & MAXI_CLUSTER, MAXI_RANK, NIV, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & K480, K479, K478, KPERCENT_LUA, KPERCENT, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, K480, K479, K478, NASS, & KPERCENT_LUA, KPERCENT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER(8) :: KEEP8(150) INTEGER, DIMENSION(:) :: BEGS_BLR INTEGER, DIMENSION(:) :: BEGS_BLR_DYN DOUBLE PRECISION, INTENT(INOUT) :: BLOCK(MAXI_CLUSTER,*) INTEGER, intent(in) :: IW2(*) TYPE(LRB_TYPE), POINTER :: ACC_LUA(:) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, K_MAX, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM), NB_DEC INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK, POSELTD INTEGER :: NCB, MID_RANK, FRFR_UPDATES, MAXRANK, FR_RANK LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK INTEGER :: OFFSET_IW INTEGER :: OMP_NUM #if defined(BLR_MT) INTEGER :: CHUNK #endif DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) NCB = NFRONT - NASS ACC_LRB => ACC_LUA(1) OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_L, IND_U, IND_L, M, N, K_ORDER, K_RANK, !$OMP& K_MAX, OMP_NUM, ACC_LRB, POSELTD, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, FR_RANK, NB_DEC, II) #endif DO IBIS = 1,NB_INCB*(NB_INCB+1)/2 IF (IFLAG.LT.0) CYCLE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 I = I+NB_INASM J = J+NB_INASM #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 M = BEGS_BLR(I+1)-BEGS_BLR(I) N = BEGS_BLR(J+1)-BEGS_BLR(J) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR(J)-1,8) ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 1, 1, I, J, & FRFR_UPDATES) ENDIF FR_RANK = 0 IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (FRFR_UPDATES.EQ.0) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) FR_RANK = ACC_LRB%K MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF NB_DEC = FRFR_UPDATES DO KK = 1, NB_INASM K = K_ORDER(KK) K_MAX = K_RANK(KK) POSELTD = POSELT + int(NFRONT,8) * int(BEGS_BLR_DYN(K)-1,8) & + int(BEGS_BLR_DYN(K) - 1,8) OFFSET_IW = BEGS_BLR_DYN(K) IND_L = I-K IND_U = J-K CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN NB_DEC = KK-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) COMPRESSED_FR = .FALSE. MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_L(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 1, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER, & DIAG=A(POSELTD), LD_DIAG=NFRONT, & IW2=IW2(OFFSET_IW), & BLOCK=BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1)) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_L(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & (I.EQ.J), (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN IF (ACC_LRB%K.GT.0) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF IF ((K480.GE.5).AND.(I.NE.J)) THEN IF (KK.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF ((K480.GE.5)) THEN IF (COMPRESSED_FR.OR.(K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 write(*,*) 'Allocation problem in BLR routine ', & 'DMUMPS_BLR_UPD_CB_LEFT_LDLT: ', & 'not enough memory? memory requested = ', & IERROR GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2, & COUNT_FLOPS=.FALSE.) ELSE CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8, NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT_LDLT SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_INCB, NB_INASM, NASS, & IWHANDLER, NIV, LBANDSLAVE, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT_RMB, & ACC_LUA, K480, K479, K478, KPERCENT_LUA, KPERCENT, & MAXI_CLUSTER, MAXI_RANK, & K474, FSorCB, BLR_U_COL, COMPRESS_CB, CB_LRB, KEEP8) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_ROWS, NB_INCB, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & MAXI_RANK, KPERCENT_LUA, KPERCENT INTEGER, INTENT(IN) :: K480, K479, K478, NASS, K474, & FSorCB INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U #if defined(MUMPS_F2003) TYPE(LRB_TYPE), POINTER, intent(inout) :: CB_LRB(:,:) #else TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) #endif TYPE(LRB_TYPE), POINTER :: ACC_LUA(:), BLR_U_COL(:) INTEGER(8) :: KEEP8(150) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT_RMB, TOL_OPT DOUBLE PRECISION,intent(in) :: TOLEPS LOGICAL, intent(in) :: LBANDSLAVE, COMPRESS_CB INTEGER :: M, N, allocok INTEGER :: I, II, J, K, KK, IND_L, IND_U, IBIS, & K_ORDER(NB_INASM), K_RANK(NB_INASM) INTEGER, ALLOCATABLE :: POS_LIST(:), RANK_LIST(:) INTEGER(8) :: POSELT_BLOCK INTEGER :: MID_RANK, K_MAX, FRFR_UPDATES, NB_DEC INTEGER :: FRONT_CB_BLR_SAVINGS LOGICAL :: BUILDQ, COMPRESSED_FR TYPE(LRB_TYPE), POINTER :: BLR_U(:), BLR_L(:) TYPE(LRB_TYPE), POINTER :: ACC_LRB, LRB INTEGER :: OLD_ACC_RANK, MAX_ACC_RANK, NEW_ACC_RANK, MAXRANK, & FR_RANK #if defined(BLR_MT) INTEGER :: OMP_NUM INTEGER :: CHUNK #endif DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) ACC_LRB => ACC_LUA(1) FRONT_CB_BLR_SAVINGS = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, K, KK, POSELT_BLOCK, MID_RANK, BUILDQ, !$OMP& BLR_U, BLR_L, IND_U, IND_L, M, N, !$OMP& ACC_LRB, OMP_NUM, K_MAX, K_ORDER, K_RANK, !$OMP& MAX_ACC_RANK, OLD_ACC_RANK, NEW_ACC_RANK, !$OMP& FRFR_UPDATES, LRB) #endif DO IBIS = 1,NB_ROWS*NB_INCB IF (IFLAG.LT.0) CYCLE I = (IBIS-1)/NB_INCB+1 J = IBIS - (I-1)*NB_INCB IF (.NOT.LBANDSLAVE) THEN I = I+NB_INASM ENDIF J = J+NB_INASM #if defined(BLR_MT) OMP_NUM=0 !$ OMP_NUM = OMP_GET_THREAD_NUM() ACC_LRB => ACC_LUA(OMP_NUM+1) #endif MAX_ACC_RANK = 0 NEW_ACC_RANK = 0 IF (LBANDSLAVE) THEN M = BEGS_BLR(I+2)-BEGS_BLR(I+1) IF (K474.EQ.1) THEN POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & +int(NASS,8) + int(BEGS_BLR_U(J-NB_INASM+1)-1,8) N = BEGS_BLR_U(J-NB_INASM+2)-BEGS_BLR_U(J-NB_INASM+1) ELSEIF (K474.GE.2) THEN BLR_U => BLR_U_COL POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I+1)-1,8) & + int(NASS-1,8) N = BEGS_BLR_U(3)-BEGS_BLR_U(2) ELSE write(*,*) 'Internal error in DMUMPS_BLR_UPD_CB_LEFT', & LBANDSLAVE,K474 CALL MUMPS_ABORT() ENDIF ELSE M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(NFRONT,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ENDIF ACC_LRB%M = N ACC_LRB%N = M IF (K480.EQ.2) THEN DO K = 1, NB_INASM K_ORDER(K) = K ENDDO ELSE CALL DMUMPS_GET_LUA_ORDER(NB_INASM, K_ORDER, K_RANK, & IWHANDLER, & 0, 1, I, J, & FRFR_UPDATES, & LBANDSLAVE, K474, BLR_U_COL) ENDIF COMPRESSED_FR = .FALSE. FR_RANK = 0 DO KK = 1, NB_INASM IF ((K480.GE.5.OR.COMPRESS_CB).AND.I.NE.J) THEN IF (KK-1.EQ.FRFR_UPDATES) THEN CALL DMUMPS_COMPRESS_FR_UPDATES(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, TOLEPS, TOL_OPT, KPERCENT, & COMPRESSED_FR, 0, .TRUE.) IF (COMPRESSED_FR) THEN K_RANK(KK) = ACC_LRB%K NB_DEC = FRFR_UPDATES-1 ENDIF MAX_ACC_RANK = ACC_LRB%K NEW_ACC_RANK = ACC_LRB%K FR_RANK = ACC_LRB%K ENDIF ENDIF K = K_ORDER(KK) K_MAX = K_RANK(KK) IF (LBANDSLAVE) THEN IND_L = I IF (K474.LT.2) THEN IND_U = J-K ELSE IND_U = K ENDIF ELSE IND_L = I-K IND_U = J-K ENDIF CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 0, & K, BLR_L) IF (BLR_L(IND_L)%M.EQ.0) THEN CYCLE ENDIF IF (.NOT.LBANDSLAVE.OR.K474.LT.2) THEN CALL DMUMPS_BLR_RETRIEVE_PANEL_LORU( & IWHANDLER, & 1, & K, BLR_U) ENDIF IF (K480.GE.3) THEN IF (ACC_LRB%K+K_MAX.GT.MAXI_RANK) THEN COMPRESSED_FR = .FALSE. NB_DEC = KK-1 CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, 2) MAX_ACC_RANK = 0 ENDIF OLD_ACC_RANK = ACC_LRB%K ENDIF CALL DMUMPS_LRGEMM4(MONE, & BLR_U(IND_U), BLR_L(IND_L), ONE, & A, LA, POSELT_BLOCK, & NFRONT, 0, IFLAG, IERROR, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, MID_RANK, BUILDQ, & (K480.GE.3), LorU=2, & LRB3=ACC_LRB, MAXI_RANK=MAXI_RANK, & MAXI_CLUSTER=MAXI_CLUSTER) IF (IFLAG.LT.0) GOTO 100 CALL UPD_FLOP_UPDATE(BLR_U(IND_U), BLR_L(IND_L), & MIDBLK_COMPRESS, MID_RANK, BUILDQ, & .FALSE., (K480.GE.3)) IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN K_RANK(KK) = MID_RANK ENDIF IF (K480.GE.3) THEN NEW_ACC_RANK = NEW_ACC_RANK + ACC_LRB%K - OLD_ACC_RANK MAX_ACC_RANK = MAX(MAX_ACC_RANK, ACC_LRB%K - OLD_ACC_RANK) IF (K480.EQ.4) THEN IF ((K478.GT.0).AND.((ACC_LRB%K-MAX_ACC_RANK).GE.K478)) & THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) MAX_ACC_RANK = ACC_LRB%K ENDIF ENDIF ENDIF END DO IF (K480.GE.3) THEN IF (K480.GE.5.OR.COMPRESS_CB) THEN IF (K480.GE.5.AND.(COMPRESSED_FR.OR.K480.GE.6)) THEN IF (ACC_LRB%K.GT.0) THEN IF (K478.EQ.-1) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF (K478.LE.-2) THEN IF (FRFR_UPDATES.GT.0) THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) ELSE allocate(POS_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF POS_LIST(1) = 1 POS_LIST(2) = 1 + FR_RANK DO II = 2,NB_INASM POS_LIST(II+1)=POS_LIST(II)+K_RANK(II-1) ENDDO allocate(RANK_LIST(NB_INASM+1),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM+1 GOTO 100 ENDIF RANK_LIST(1) = FR_RANK DO II = 2,NB_INASM+1 RANK_LIST(II) = K_RANK(II-1) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK,KEEP8, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, K478, & RANK_LIST, POS_LIST, & NB_INASM+1, 0) deallocate(RANK_LIST) ENDIF deallocate(POS_LIST) ENDIF ENDIF ENDIF MAXRANK = FLOOR(dble(ACC_LRB%M*ACC_LRB%N)/dble(ACC_LRB%M+ & ACC_LRB%N)) IF (COMPRESSED_FR.AND.(ACC_LRB%K.LE.MAXRANK)) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB_FROM_ACC(ACC_LRB, LRB, & ACC_LRB%K, ACC_LRB%M, ACC_LRB%N, 0, & IFLAG, IERROR, KEEP8) FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & LRB%M*LRB%N - LRB%M*LRB%K - LRB%N*LRB%K ACC_LRB%K = 0 IF (IFLAG.LT.0) GOTO 100 ELSE CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) LRB => CB_LRB(I-NB_INASM,J-NB_INASM) CALL ALLOC_LRB(LRB, ACC_LRB%K, ACC_LRB%N, ACC_LRB%M, & .FALSE., IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 100 DO II=1,ACC_LRB%N LRB%Q(II,1:ACC_LRB%M) = & A( POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((II-1),8)*int(NFRONT,8) & +int(ACC_LRB%M-1,8) ) END DO ENDIF ELSE IF ((K480.EQ.4).AND.(K478.EQ.-1).AND.(ACC_LRB%K.GT.0)) THEN IF (NB_INASM-FRFR_UPDATES.GT.1) THEN CALL DMUMPS_RECOMPRESS_ACC(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, TOL_OPT, & KPERCENT_RMB, KPERCENT_LUA, NEW_ACC_RANK) ENDIF ELSEIF ((K480.EQ.4).AND.(K478.LE.-2).AND.(ACC_LRB%K.GT.0)) & THEN allocate(POS_LIST(NB_INASM-NB_DEC),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NB_INASM-NB_DEC GOTO 100 ENDIF POS_LIST(1) = 1 DO II = 1,NB_INASM-NB_DEC-1 POS_LIST(II+1)=POS_LIST(II)+K_RANK(NB_DEC+II) ENDDO CALL DMUMPS_RECOMPRESS_ACC_NARYTREE(ACC_LRB, & MAXI_CLUSTER, MAXI_RANK, A, LA, POSELT_BLOCK, & KEEP8,NFRONT, NIV, MIDBLK_COMPRESS, TOLEPS, & TOL_OPT, KPERCENT_RMB, KPERCENT_LUA, K478, & K_RANK(NB_DEC+1:NB_INASM), POS_LIST, & NB_INASM-NB_DEC, 0) deallocate(POS_LIST) ENDIF CALL DMUMPS_DECOMPRESS_ACC(ACC_LRB,MAXI_CLUSTER, & MAXI_RANK, A, LA, POSELT_BLOCK, NFRONT, NIV, 2) ENDIF ENDIF 100 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO #endif IF (COMPRESS_CB) THEN #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NFRONT-NASS, NFRONT-NASS, 0, 1, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, 0, 1, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif ENDIF END SUBROUTINE DMUMPS_BLR_UPD_CB_LEFT SUBROUTINE DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, DECOMP_TIMER, & BEG_I_IN, END_I_IN, ONLY_NELIM_IN, CBASM_TOFIX_IN) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: LDA11, LDA21 INTEGER, intent(in) :: DECOMP_TIMER INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN, ONLY_NELIM_IN LOGICAL,OPTIONAL,intent(in) :: CBASM_TOFIX_IN INTEGER :: IP, M, N, BIP, BEG_I, END_I, ONLY_NELIM LOGICAL :: CBASM_TOFIX #if defined(BLR_MT) INTEGER :: LAST_IP, CHUNK #endif INTEGER :: K, I DOUBLE PRECISION :: PROMOTE_COST INTEGER(8) :: POSELT_BLOCK, LD_BLK_IN_FRONT DOUBLE PRECISION :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO = 0.0D0) IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = 0 ENDIF IF (present(CBASM_TOFIX_IN)) THEN CBASM_TOFIX = CBASM_TOFIX_IN ELSE CBASM_TOFIX = .FALSE. ENDIF LD_BLK_IN_FRONT = int(LDA11,8) BIP = BEGS_BLR_FIRST_OFFDIAG #if !defined(BLR_MT) IF (BEG_I .NE. CURRENT_BLR+1) THEN DO I = 1, BEG_I - CURRENT_BLR - 1 IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(I)%N ELSE BIP = BIP + BLR_PANEL(I)%M ENDIF ENDDO ENDIF #endif #if defined(BLR_MT) LAST_IP = CURRENT_BLR+1 CHUNK = 1 !$OMP DO PRIVATE(POSELT_BLOCK, M, N, K, I) SCHEDULE(DYNAMIC, CHUNK) #endif DO IP = BEG_I, END_I #if defined(BLR_MT) DO I = 1, IP - LAST_IP IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%N ELSE BIP = BIP + BLR_PANEL(LAST_IP-CURRENT_BLR+I-1)%M ENDIF ENDDO LAST_IP = IP #endif IF (DIR .eq. 'V') THEN IF (BIP .LE. LDA21) THEN IF (CBASM_TOFIX) THEN POSELT_BLOCK = POSELT & + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) + int(BIP-1,8) ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BIP-1,8) + & int(BEGS_BLR_DIAG - 1,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(LDA21,8)+ & int(BEGS_BLR_DIAG - 1,8) POSELT_BLOCK = POSELT_BLOCK + & int(LDA21,8)*int(BIP-1-LDA21,8) LD_BLK_IN_FRONT=int(LDA21,8) ENDIF ELSE POSELT_BLOCK = POSELT + int(LDA11,8)*int(BEGS_BLR_DIAG-1,8) & + int(BIP-1,8) ENDIF M = BLR_PANEL(IP-CURRENT_BLR)%M N = BLR_PANEL(IP-CURRENT_BLR)%N IF(present(ONLY_NELIM_IN)) THEN ONLY_NELIM = ONLY_NELIM_IN ELSE ONLY_NELIM = N ENDIF K = BLR_PANEL(IP-CURRENT_BLR)%K IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (K.EQ.0) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) = ZERO ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = ZERO ENDDO ENDIF GOTO 1800 ENDIF IF (DIR .eq. 'V') THEN IF (DIR .eq.'V' .AND. BIP .LE. LDA21 & .AND. BIP + M - 1 .GT. LDA21 & .AND..NOT.CBASM_TOFIX) THEN CALL dgemm('T', 'T', N, LDA21-BIP+1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) CALL dgemm('T', 'T', N, BIP+M-LDA21-1, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(LDA21-BIP+2,1) , M, & ZERO, A(POSELT_BLOCK+int(LDA21-BIP,8)*int(LDA11,8)), & LDA21) ELSE CALL dgemm('T', 'T', N, M, K, ONE , & BLR_PANEL(IP-CURRENT_BLR)%R(1,1) , K, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1) , M, & ZERO, A(POSELT_BLOCK), int(LD_BLK_IN_FRONT)) ENDIF ELSE CALL dgemm('N', 'N', M, ONLY_NELIM, K, ONE, & BLR_PANEL(IP-CURRENT_BLR)%Q(1,1), M, & BLR_PANEL(IP-CURRENT_BLR)%R(1,N-ONLY_NELIM+1), K, ZERO, & A(POSELT_BLOCK+int(N-ONLY_NELIM,8)*int(LDA11,8)), LDA11) ENDIF PROMOTE_COST = 2.0D0*M*K*ONLY_NELIM IF (CBASM_TOFIX) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .TRUE.) ELSEIF(present(ONLY_NELIM_IN)) THEN CALL UPD_FLOP_DECOMPRESS(PROMOTE_COST, .FALSE.) ENDIF ELSE IF (COPY_DENSE_BLOCKS) THEN IF (DIR .eq. 'V') THEN DO I = 1, M IF (BIP+I-1.GT.LDA21) THEN LD_BLK_IN_FRONT = int(LDA21,8) ENDIF A(POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT : & POSELT_BLOCK+int(I-1,8)*LD_BLK_IN_FRONT & + int(N-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) ENDDO ELSE DO I = N-ONLY_NELIM+1, N A(POSELT_BLOCK+int(I-1,8)*int(LDA11,8): & POSELT_BLOCK+int(I-1,8)*int(LDA11,8) + int(M-1,8)) & = BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) ENDDO ENDIF ENDIF 1800 CONTINUE #if !defined(BLR_MT) IF (CBASM_TOFIX) THEN BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%N ELSE BIP = BIP + BLR_PANEL(IP-CURRENT_BLR)%M ENDIF #endif ENDDO #if defined(BLR_MT) !$OMP END DO #endif END SUBROUTINE DMUMPS_DECOMPRESS_PANEL SUBROUTINE DMUMPS_COMPRESS_CB(A, LA, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), TARGET, intent(inout) :: CB_LRB(:,:) INTEGER, DIMENSION(:) :: BEGS_BLR, BEGS_BLR_U DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION, OPTIONAL :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in), OPTIONAL :: NELIM INTEGER, intent(in), OPTIONAL :: NBROWSinF INTEGER :: M, N, INFO, FRONT_CB_BLR_SAVINGS INTEGER :: I, J, IBIS, IBIS_END, RANK, MAXRANK, II, JJ INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR TYPE(LRB_TYPE), POINTER :: LRB INTEGER :: OMP_NUM INTEGER(8) :: POSA, ASIZE INTEGER :: NROWS_CM #if defined(BLR_MT) INTEGER :: CHUNK #endif DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & (NFS4FATHER.GT.0) ) THEN IF (NIV.EQ.1) THEN NROWS_CM = NROWS - (NFS4FATHER-NELIM) ELSE NROWS_CM = NROWS - NBROWSinF ENDIF IF (NROWS_CM-NVSCHUR_K253.GT.0) THEN IF (NIV.EQ.1) THEN POSA = POSELT & + int(LDA,8)*int(NPIV+NFS4FATHER,8) & + int(NPIV,8) ASIZE = int(LDA,8)*int(LDA,8) & - int(LDA,8)*int(NPIV+NFS4FATHER,8) & - int(NPIV,8) ELSE POSA = POSELT & + int(LDA,8)*int(NBROWSinF,8) & + int(NPIV,8) ASIZE = int(NROWS,8)*int(LDA,8) & - int(LDA,8)*int(NBROWSinF,8) & - int(NPIV,8) ENDIF CALL DMUMPS_COMPUTE_MAXPERCOL ( & A(POSA), ASIZE, LDA, & NROWS_CM-NVSCHUR_K253, & M_ARRAY(1), NFS4FATHER, .FALSE., & -9999) ELSE DO I=1, NFS4FATHER M_ARRAY(I) = ZERO ENDDO ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif FRONT_CB_BLR_SAVINGS = 0 OMP_NUM = 0 IF (SYM.EQ.0.OR.NIV.EQ.2) THEN IBIS_END = NB_ROWS*NB_COLS ELSE IBIS_END = NB_ROWS*(NB_COLS+1)/2 ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(I, J, POSELT_BLOCK, M, N, OMP_NUM, INFO, RANK, !$OMP& MAXRANK, ISLR, II, JJ, LRB) #endif DO IBIS = 1,IBIS_END IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) IF (SYM.EQ.0.OR.NIV.EQ.2) THEN I = (IBIS-1)/NB_COLS+1 J = IBIS - (I-1)*NB_COLS ELSE I = CEILING((1.0D0+SQRT(1.0D0+8.0D0*dble(IBIS)))/2.0D0)-1 J = IBIS - I*(I-1)/2 ENDIF IF (NIV.EQ.1) THEN I = I+NB_INASM J = J+NB_INASM ELSE J = J+NB_INASM IF (SYM.NE.0) THEN IF (BEGS_BLR_U(J).GE.BEGS_BLR(I+2)+NCOLS-NROWS-1+ & BEGS_BLR_U(NB_INASM+1)) THEN CYCLE ENDIF ENDIF ENDIF IF (NIV.EQ.1) THEN M = BEGS_BLR(I+1)-BEGS_BLR(I) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I)-1,8) + & int(BEGS_BLR_U(J)-1,8) IF (I .EQ. NB_INASM+1 .AND. present(NELIM)) THEN POSELT_BLOCK = POSELT_BLOCK + int(NELIM,8)*int(LDA,8) M = M - NELIM ENDIF N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE M = BEGS_BLR(I+2)-BEGS_BLR(I+1) POSELT_BLOCK = POSELT + int(LDA,8)*int(BEGS_BLR(I+1)-1,8) & + int(BEGS_BLR_U(J)-1,8) IF (SYM.EQ.0) THEN N = BEGS_BLR_U(J+1)-BEGS_BLR_U(J) ELSE N = min(BEGS_BLR_U(J+1), BEGS_BLR(I+2) + NCOLS - NROWS -1 & + BEGS_BLR_U(NB_INASM+1)) - BEGS_BLR_U(J) ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (NIV.EQ.1) THEN LRB => CB_LRB(I-NB_INASM,J-NB_INASM) ELSE LRB => CB_LRB(I,J-NB_INASM) ENDIF IF (K489.EQ.3) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF DO II=1,M BLOCK_THR(II,1:N)= & A( POSELT_BLOCK+int(II-1,8)*int(LDA,8) : & POSELT_BLOCK+int(II-1,8)*int(LDA,8)+int(N-1,8) ) ENDDO MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL DMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(LRB, RANK, M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF (ISLR) THEN IF (RANK .GT. 0) THEN DO JJ=1,N DO II=1,MIN(RANK,JJ) LRB%R(II,JPVT_THR(JJ)) = BLOCK_THR(II,JJ) ENDDO IF(JJ.LT.RANK) LRB%R(MIN(RANK,JJ)+1:RANK,JPVT_THR(JJ)) & = ZERO ENDDO CALL dorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO II=1,RANK DO JJ= 1, M LRB%Q(JJ,II) = BLOCK_THR(JJ,II) ENDDO END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A CB BLOCK" CALL MUMPS_ABORT() END IF IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF END IF FRONT_CB_BLR_SAVINGS = FRONT_CB_BLR_SAVINGS + & (M-RANK)*(N-RANK)-RANK*RANK ELSE DO II=1,M LRB%Q(II,1:N) = & A( POSELT_BLOCK+int((II-1),8)*int(LDA,8) : & POSELT_BLOCK+int((II-1),8)*int(LDA,8) & +int(N-1,8) ) END DO IF (K489.NE.3) THEN CALL UPD_FLOP_COMPRESS(LRB, CB_COMPRESS=.TRUE.) ENDIF LRB%K = -1 END IF END DO #if defined(BLR_MT) !$OMP END DO #endif #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_THREAD_NUM() !$ IF (OMP_NUM.EQ.0) THEN #endif CALL UPD_MRY_CB(NROWS, NCOLS, SYM, NIV, & FRONT_CB_BLR_SAVINGS) #if defined(BLR_MT) !$ ELSE !$ CALL UPD_MRY_CB(0, 0, SYM, NIV, !$ & FRONT_CB_BLR_SAVINGS) !$ ENDIF #endif END SUBROUTINE DMUMPS_COMPRESS_CB SUBROUTINE DMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, K480, & BEG_I_IN, END_I_IN, FRSWAP & ) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(:) DOUBLE PRECISION, TARGET, DIMENSION(:) :: RWORK DOUBLE PRECISION, TARGET, DIMENSION(:,:) :: BLOCK DOUBLE PRECISION, TARGET, DIMENSION(:) :: WORK, TAU INTEGER, TARGET, DIMENSION(:) :: JPVT INTEGER :: BEGS_BLR(:) INTEGER(8) :: KEEP8(150) INTEGER, OPTIONAL, intent(in) :: K480 INTEGER,OPTIONAL,intent(in) :: BEG_I_IN, END_I_IN LOGICAL, OPTIONAL, intent(in) :: FRSWAP INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: MAXI_CLUSTER, LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR INTRINSIC maxval INTEGER :: IP, NB_BLOCKS_PANEL, M, N, RANK, MAXRANK INTEGER :: INFO, I, J, IS, BEG_I, END_I INTEGER(8) :: POSELT_BLOCK LOGICAL :: ISLR DOUBLE PRECISION :: ONE, ALPHA, ZERO PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) PARAMETER (ZERO = 0.0D0) INTEGER :: OMP_NUM DOUBLE PRECISION, POINTER, DIMENSION(:) :: RWORK_THR DOUBLE PRECISION, POINTER, DIMENSION(:,:) :: BLOCK_THR DOUBLE PRECISION, POINTER, DIMENSION(:) :: WORK_THR, TAU_THR INTEGER, POINTER, DIMENSION(:) :: JPVT_THR #if defined(BLR_MT) INTEGER :: CHUNK #endif IF(present(BEG_I_IN)) THEN BEG_I = BEG_I_IN ELSE BEG_I = CURRENT_BLR+1 ENDIF IF(present(END_I_IN)) THEN END_I = END_I_IN ELSE END_I = NB_BLR ENDIF IF (LBANDSLAVE) THEN IS = ISHIFT ELSE IS=0 ENDIF IF (DIR .eq. 'V') THEN IF (LBANDSLAVE) THEN N = NPIV ELSE N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ENDIF ELSE IF (DIR .eq. 'H') THEN N = BEGS_BLR(CURRENT_BLR+1)-BEGS_BLR(CURRENT_BLR)-NELIM ELSE WRITE(*,*) " WRONG ARGUMENT IN DMUMPS_COMPRESS_PANEL " CALL MUMPS_ABORT() END IF NB_BLOCKS_PANEL = NB_BLR-CURRENT_BLR OMP_NUM = 0 #if defined(BLR_MT) CHUNK = 1 !$OMP DO PRIVATE(INFO, POSELT_BLOCK, RANK, MAXRANK, I, J, OMP_NUM) !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = BEG_I, END_I IF (IFLAG.LT.0) CYCLE #if defined(BLR_MT) OMP_NUM = 0 !$ OMP_NUM = OMP_GET_THREAD_NUM() #endif BLOCK_THR => BLOCK(1:MAXI_CLUSTER,OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) JPVT_THR => JPVT(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) TAU_THR => TAU(OMP_NUM*MAXI_CLUSTER+1: & (OMP_NUM+1)*MAXI_CLUSTER) WORK_THR => WORK(OMP_NUM*LWORK+1: & (OMP_NUM+1)*LWORK) RWORK_THR => RWORK(OMP_NUM*2*MAXI_CLUSTER+1: & (OMP_NUM+1)*2*MAXI_CLUSTER) RANK = 0 M = BEGS_BLR(IP+1)-BEGS_BLR(IP) IF (DIR .eq. 'V') THEN POSELT_BLOCK = POSELT + & int(NFRONT,8) * int(BEGS_BLR(IP)-1,8) + & int(BEGS_BLR(CURRENT_BLR) + IS - 1,8) ELSE POSELT_BLOCK = POSELT + & int(NFRONT,8)*int(BEGS_BLR(CURRENT_BLR)-1,8) + & int( BEGS_BLR(IP) - 1,8) ENDIF IF (present(K480)) then IF (K480.GE.5) THEN IF (BLR_PANEL(IP-CURRENT_BLR)%ISLR) THEN IF (M.NE.BLR_PANEL(IP-CURRENT_BLR)%M) THEN write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL', & ' M size inconsistency',M, & BLR_PANEL(IP-CURRENT_BLR)%M CALL MUMPS_ABORT() ENDIF IF (N.NE.BLR_PANEL(IP-CURRENT_BLR)%N) THEN write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL', & ' N size inconsistency',N, & BLR_PANEL(IP-CURRENT_BLR)%N CALL MUMPS_ABORT() ENDIF MAXRANK = floor(dble(M*N)/dble(M+N)) IF (BLR_PANEL(IP-CURRENT_BLR)%K.GT.MAXRANK) THEN write(*,*) 'Internal error in DMUMPS_COMPRESS_PANEL', & ' MAXRANK inconsistency',MAXRANK, & BLR_PANEL(IP-CURRENT_BLR)%K CALL MUMPS_ABORT() ENDIF GOTO 3000 ENDIF ENDIF ENDIF JPVT_THR(1:MAXI_CLUSTER) = 0 IF (K473.EQ.1) THEN MAXRANK = 1 RANK = MAXRANK+1 INFO = 0 GOTO 3800 ENDIF IF (DIR .eq. 'V') THEN DO I=1,M BLOCK_THR(I,1:N)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(N-1,8) ) END DO ELSE DO I=1,N BLOCK_THR(1:M,I)= & A( POSELT_BLOCK+int(I-1,8)*int(NFRONT,8) : & POSELT_BLOCK+int(I-1,8)*int(NFRONT,8)+int(M-1,8) ) END DO END IF MAXRANK = floor(dble(M*N)/dble(M+N)) MAXRANK = max (1, int((MAXRANK*KPERCENT/100))) CALL DMUMPS_TRUNCATED_RRQR( M, N, & BLOCK_THR(1,1), & MAXI_CLUSTER, JPVT_THR(1), & TAU_THR(1), & WORK_THR(1), N, & RWORK_THR(1), & TOLEPS, TOL_OPT, RANK, MAXRANK, INFO) 3800 CONTINUE IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF TRUNCATED_RRQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF ISLR = ((RANK.LE.MAXRANK).AND.(M.NE.0).AND.(N.NE.0)) CALL ALLOC_LRB(BLR_PANEL(IP-CURRENT_BLR), RANK, & M, N, ISLR, IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) CYCLE IF ((M.EQ.0).OR.(N.EQ.0)) GOTO 3000 IF (ISLR) THEN IF (RANK .EQ. 0) THEN ELSE DO J=1,N BLR_PANEL(IP-CURRENT_BLR)%R(1:MIN(RANK,J), & JPVT_THR(J)) = & BLOCK_THR(1:MIN(RANK,J),J) IF(J.LT.RANK) BLR_PANEL(IP-CURRENT_BLR)% & R(MIN(RANK,J)+1:RANK,JPVT_THR(J))= ZERO ENDDO CALL dorgqr & (M, RANK, RANK, & BLOCK_THR(1,1), & MAXI_CLUSTER, TAU_THR(1), & WORK_THR(1), LWORK, INFO ) DO I=1,RANK BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = BLOCK_THR(1:M,I) END DO IF (INFO < 0) THEN WRITE(*,*) " PROBLEM IN ARGUMENT NUMBER ",INFO, & " OF CUNGQR WHILE COMPRESSING A BLOCK " CALL MUMPS_ABORT() END IF IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS( & BLR_PANEL(IP-CURRENT_BLR), FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF END IF ELSE IF (DIR .eq. 'V') THEN DO I=1,M BLR_PANEL(IP-CURRENT_BLR)%Q(I,1:N) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(N-1,8) ) END DO ELSE DO I=1,N BLR_PANEL(IP-CURRENT_BLR)%Q(1:M,I) = & A( POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) : & POSELT_BLOCK+int((I-1),8)*int(NFRONT,8) & +int(M-1,8) ) END DO END IF IF (K473.EQ.0) THEN IF (present(FRSWAP)) THEN CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR), & FRSWAP=FRSWAP) ELSE CALL UPD_FLOP_COMPRESS(BLR_PANEL(IP-CURRENT_BLR)) ENDIF ENDIF BLR_PANEL(IP-CURRENT_BLR)%K = -1 END IF 3000 CONTINUE END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE DMUMPS_COMPRESS_PANEL SUBROUTINE DMUMPS_BLR_PANEL_LRTRSM( & A, & LA, POSELT, NFRONT, & IBEG_BLOCK, NB_BLR, & BLR_LorU, & CURRENT_BLR, FIRST_BLOCK, LAST_BLOCK, & NIV, SYM, LorU, LBANDSLAVE, & IW, OFFSET_IW, NASS) !$ USE OMP_LIB INTEGER(8), intent(in) :: LA INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, & NIV, SYM, LorU LOGICAL, intent(in) :: LBANDSLAVE INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: IBEG_BLOCK, FIRST_BLOCK, LAST_BLOCK INTEGER, OPTIONAL, intent(in) :: NASS DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE), intent(inout) :: BLR_LorU(:) INTEGER, OPTIONAL :: OFFSET_IW INTEGER, OPTIONAL :: IW(*) INTEGER(8) :: POSELT_LOCAL INTEGER :: IP, LDA #if defined(BLR_MT) INTEGER :: CHUNK #endif DOUBLE PRECISION :: ONE, MONE, ZERO PARAMETER (ONE = 1.0D0, MONE=-1.0D0) PARAMETER (ZERO=0.0D0) LDA = NFRONT IF (LorU.EQ.0.AND.SYM.NE.0.AND.NIV.EQ.2 & .AND.(.NOT.LBANDSLAVE)) THEN IF (present(NASS)) THEN LDA = NASS ELSE write(*,*) 'Internal error in DMUMPS_BLR_PANEL_LRTRSM' CALL MUMPS_ABORT() ENDIF ENDIF IF (LBANDSLAVE) THEN POSELT_LOCAL = POSELT ELSE POSELT_LOCAL = POSELT + & int(IBEG_BLOCK-1,8)*int(LDA,8) + int(IBEG_BLOCK - 1,8) ENDIF #if defined(BLR_MT) CHUNK = 1 !$OMP DO !$OMP& SCHEDULE(DYNAMIC,CHUNK) #endif DO IP = FIRST_BLOCK, LAST_BLOCK CALL DMUMPS_LRTRSM(A, LA, POSELT_LOCAL, NFRONT, LDA, & BLR_LorU(IP-CURRENT_BLR), NIV, SYM, LorU, & IW, OFFSET_IW) END DO #if defined(BLR_MT) !$OMP END DO NOWAIT #endif END SUBROUTINE DMUMPS_BLR_PANEL_LRTRSM END MODULE DMUMPS_FAC_LR MUMPS_5.4.1/src/dfac_sol_l0omp_m.F0000664000175000017500000003332614102210523017016 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: DMUMPS_INIT_L0_OMP_FACTORS & , DMUMPS_FREE_L0_OMP_FACTORS & , DMUMPS_SAVE_RESTORE_L0FACARRAY CONTAINS SUBROUTINE DMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE DMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE DMUMPS_FREE_L0_OMP_FACTORS SUBROUTINE DMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE DMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (DMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (trim(mode) .EQ. "memory_save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (trim(mode) .EQ. "save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (trim(mode) .EQ. "restore") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if !defined(MUMPS_F2003) IF (trim(mode).EQ."memory_save") THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."save") THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."restore") THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE DMUMPS_SAVE_RESTORE_L0FAC END MODULE DMUMPS_FACSOL_L0OMP_M MUMPS_5.4.1/src/zini_defaults.F0000664000175000017500000014067014102210526016465 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C********************************************************************** C SUBROUTINE ZMUMPS_SET_TYPE_SIZES( K34, K35, K16, K10 ) IMPLICIT NONE C C Purpose: C ======= C C Set the size in bytes of an "INTEGER" in K34 C Set the size of the default arithmetic (DOUBLE PRECISION, DOUBLE PRECISION, C COMPLEX(kind=8) or DOUBLE COMPLEX(kind=8)) in K35 C Set the size of floating-point types that are real or double C precision even for complex versions of MUMPS (DOUBLE PRECISION for S and C C versions, DOUBLE PRECISION for D and Z versions) C Assuming that the size of an INTEGER(8) is 8, store the ratio C nb_bytes(INTEGER(8)) / nb_bytes(INTEGER) = 8 / K34 into K10. C C In practice, we have: C C K35: Arithmetic Value Value for T3E C S 4 8 C D 8 16 C C 8 16 C Z 16 32 C C K16 = K35 for S and D arithmetics C K16 = K35 / 2 for C and Z arithmetics C C K34= 4 and K10 = 2, except on CRAY machines or when compilation C flag -i8 is used, in which case, K34 = 8 and K10 = 1 C C INTEGER, INTENT(OUT) :: K34, K35, K10, K16 INTEGER(8) :: SIZE_INT, SIZE_REAL_OR_DOUBLE ! matches MUMPS_INT8 INTEGER I(2) DOUBLE PRECISION R(2) ! Will be DOUBLE PRECISION if 1 CALL MUMPS_SIZE_C(I(1),I(2),SIZE_INT) CALL MUMPS_SIZE_C(R(1),R(2),SIZE_REAL_OR_DOUBLE) K34 = int(SIZE_INT) K10 = 8 / K34 K16 = int(SIZE_REAL_OR_DOUBLE) K35 = K16 K35 = K35 * 2 RETURN END SUBROUTINE ZMUMPS_SET_TYPE_SIZES C C********************************************************************** C SUBROUTINE ZMUMPSID( NSLAVES, LWK_USER, CNTL, ICNTL, & KEEP,KEEP8, & INFO, INFOG, RINFO, RINFOG, SYM, PAR, & DKEEP, MYID ) !$ USE OMP_LIB IMPLICIT NONE C C Purpose C ======= C C The elements of the arrays CNTL and ICNTL control the action of C ZMUMPS, ZMUMPS_ANA_DRIVER, ZMUMPS_FAC_DRIVER, ZMUMPS_SOLVE_DRIVER C Default values for the elements are set in this routine. C DOUBLE PRECISION DKEEP(230) DOUBLE PRECISION CNTL(15), RINFO(40), RINFOG(40) INTEGER ICNTL(60), KEEP(500), SYM, PAR, NSLAVES, MYID INTEGER INFO(80), INFOG(80) INTEGER(8) KEEP8(150) INTEGER LWK_USER C C Parameters C ========== C=========================================== C Arrays for control and information C=========================================== C C N Matrix order C C NELT Number of elements for matrix in ELt format C C C SYM = 0 ... initializes the defaults for unsymmetric code C = 1,2 ... initializes the defaults for symmetric code C C C C PAR = 0 ... instance where host is not working C = 1 ... instance where host is working as a normal node. C (host uses more memory than other processors in C the latter case) C C CNTL and the elements of the array ICNTL control the action of C ZMUMPS Default values C are set by ZMUMPSID. The elements of the arrays RINFO C and INFO provide information on the action of ZMUMPS. C C CNTL(1) threshold for partial pivoting C has default value 0.0 when SYM=1 and 0.01 otherwise C Values and less than zero as treated as zero. C Values greater than 1.0 are treated as 1.0 for C SYM=1 and as 0.5 for SYM=2 C In general, a larger value of CNTL(1) leads to C greater fill-in but a more accurate factorization. C If CNTL(1) is nonzero, numerical pivoting will be performed. C If CNTL(1) is zero, no pivoting will be performed and C the subroutine will fail if a zero pivot is encountered. C If the matrix A is diagonally dominant, then C setting CNTL(1) to zero will decrease the factorization C time while still providing a stable decomposition. C C CNTL(2) must be set to the tolerance for convergence of iterative C refinement. C Default value is sqrt(macheps). C Values less than zero are treated as sqrt(macheps). C C CNTL(3) is used with null pivot row detection (ICNTL(24) .eq. 1) C Default value is 0.0. C Let A_{preproc} be the preprocessed matrix to be factored (see C equation in the user's guide). C A pivot is considered to be null if the infinite norm of its C row/column is smaller than a threshold. Let MACHEPS be the C machine precision and ||.|| be the infinite norm. C The absolute value to detect a null pivot row (when ICNTL(24) .EQ.1) C is stored in DKEEP(1). C IF CNTL(3) > 0 THEN C DKEEP(1) = CNTL(3) ||A_{preproc}|| C ELSE IF CNTL(3) = 0.0 THEN C DKEEP(1) = MACHEPS 10^{-5} ||A_{preproc}|| C ELSE IF CNTL(3) < 0 THEN C DKEEP(1) = abs(CNTL(3))! this was added for EDF C ! in the context of SOLSTICE project C ENDIF C C CNTL(4) must be set to value for static pivoting. C Default value is -1.0 C Note that static pivoting is enabled only when C Rank-Revealing and null pivot detection C are off (KEEP(19).EQ.0).AND.(KEEP(110).EQ.0). C If negative, static pivoting will be set OFF (KEEP(97)=0) C If positive, static pivoting is ON (KEEP(97=1) with C threshold CNTL(4) C If = 0, static pivoting is ON with threshold MACHEPS^1/2 || A || C C CNTL(5) fixation for null pivots C Default value is 0.0 C Only active if ICNTL(24) = 1 C If > 0 after finding a null pivot, it is set to CNTL(5) x ||A|| C (This value is stored in DKEEP(2)) C If <= 0 then C SYM=2: C the row/column (except the pivot) is set to zero C and the pivot is set to 1 C SYM=0: C the fixation is automatically C set to a large potitive value and the pivot row of the C U factors is set to zero. C Default is 0. C C CNTL(6) not used yet C C CNTL(7) tolerance for Low Rank approximation of the Blocks (BLR). C Dropping parameter expressed with a double precision, C real value, controlling C compression and used to truncate the RRQR algorithm C default value is 0.0. (i.e. no approximation). C The truncated RRQR operation is implemented as C as variant of the LAPACK GEQP3 and LAQPS routines. C 0.0 : full precision approximation. C > 0.0 : the dropping parameter is DKEEP(8). C C Warning: using negative values is an experimental and C non recommended setting. C < 0.0 : the dropping parameter is |DKEEP(8)|*|Apre|, Apre C as defined in user's guide C C C ----------------------------------------- C C ICNTL(1) has default value 6. C It is the output stream for error messages. C If it is set to zero, these C messages will be suppressed. C C ICNTL(2) has default value 0. C It is the output stream for diagnostic printing and C for warning messages that are local to each MPI process. C If it is set to zero, these messages are suppressed. C C ICNTL(3) -- Host only C It is the output stream for diagnostic printing C and for warning messages. Default value is 6. C If it is set to zero, these messages are suppressed. C C ICNTL(4) is used by ZMUMPS to control printing of error, C warning, and diagnostic messages. It has default value 2. C Possible values are: C C <1 __No messages output. C 1 __Only error messages printed. C 2 __Errors and warnings printed. C 3 __Errors and warnings and terse diagnostics C (only first ten entries C of arrays printed). C 4 __Errors and warnings and all information C on input and output parameters printed. C C C ICNTL(5) is the format of the input matrix and rhs C 0: assembled matrix, assembled rhs C 1: elemental matrix, assembled rhs C Default value is 0. C C ICNTL(6) has default value 7 for unsymmetric and C general symmetric matrices, and 0 for SPD matrices. C It is only accessed and operational C on a call that includes an analysis phase C (JOB = 1, 4, or 6). C In these cases, if ICNTL(6)=1, 2, 3, 4, 5, 6 or 7, C a column permutation based on algorithms described in C Duff and Koster, 1997, *SIMAX <20>, 4, 889-901, C is applied to the original matrix. Column permutations are C then applied to the original matrix to get a zero-free diagonal. C Except for ICNTL(6)=1, the numerical values of the C original matrix, id%A(NE), need be provided by the user C during the analysis phase. C If ICNTL(6)=7, based on the structural symmetry of the C input matrix the value of ICNTL(6) is automatically chosen. C If the ordering is provided by the user C (ICNTL(7)=1) then the value of ICNTL(6) is ignored. C C ICNTL(7) has default value 7 and must be set by the user to C 1 if the pivot order in IS is to be used. C Effective value of ordering stored in KEEP(256). C Possible values are (depending on the softwares installed) C 0 AMD: Approximate minimum degree (included in ZMUMPS package) C 1 Ordering provided by the user C 2 Approximate minimum fill (included in ZMUMPS package) C 3 SCOTCH (see http://gforge.inria.fr/projects/scotch/) C should be downloaded/installed separately. C 4 PORD from Juergen Schulze (js@juergenschulze.de) C PORD package is extracted from the SPACE-1.0 package developed at the C University of Paderborn by Juergen Schulze C and is provided as a separate package. C 5 Metis ordering should be downloaded/installed separately. C 6 Approximate minimum degree with automatic quasi C dense row detection (included in ZMUMPS package). C (to be used when ordering time with AMD is abnormally large) C 7 Automatic choice done during analysis phase C For any other C value of ICNTL(7), a suitable pivot order will be C chosen automatically. C C ICNTL(8) is used to describe the scaling strategy. C Default value is 77. C Note that scaling is performed only when the numerical C factorization step is performed (JOB = 2, 4>, 5>, or 6>). C If ICNTL(8) is not equal to C any of the values listed below then ICNTL(8) is treated C as if it had its default value of 0 (no scaling). C If the matrix is known to be very badly scaled, C our experience has been that option 6 is the most robust but C the best scaling is very problem dependent. C If ICNTL(8)=0, COLSCA and ROWSCA are dummy arguments C of the subroutine that are not accessed. C Possible values of ICNTL(8) are: C C -2 scaling computed during analysis (and applied during the C factorization) C C -1 the user must provide the scaling in arrays C COLSCA and ROWSCA C C 0 no scaling C C 1 Diagonal scaling C C 2 not defined C C 3 Column scaling C C 4 Row and column scaling C C 5,6 not defined C 7, 8 Scaling based on Daniel Ruiz and Bora Ucar's work done C during the ANR-SOLSTICE project. C Reference for this work are: C The scaling algorithms are based on those discussed in C [1] D. Ruiz, "A scaling algorithm to equilibrate both rows and C columns norms in matrices", Tech. Rep. Rutherford C Appleton Laboratory, Oxon, UK and ENSEEIHT-IRIT, C Toulouse, France, RAL-TR-2001-034 and RT/APO/01/4, 2001. C [2] D. Ruiz and B. Ucar, "A symmetry preserving algorithm for C matrix scaling", in preparation as of Jan'08. C This scaling can work on both centralized and distributed C assembled input matrix format. (it works for both symmetric C and unsymmetric matrices) C Option 8 is similar to 7 but more rigourous and expensive to compute. C 77 Automatic choice of scaling value done. Proposed algo: C if (sym=1) then C option = 0 C else C if distributed matrix entry then C option = 7 C else C if (maximum transversal is called C and makes use of numerical values) then C option=-2 and ordering is computed during analysis C else C option = 7 C endif C endif C endif C C ICNTL(9) has default value 1. If ICNTL(9)=1 C the system of equations A * x = b is solved. For other C values the system A^T * x = b is solved. C When ICNTL(30) (compute selected entries in A-1) is activated C ICNTL(9) is ignored. C C ICNTL(10) has default value 0. C If ICNTL(10)=0 : iterative refinement is not performed. C Values of ICNTL(10) < 0 : a fix number of steps equal C to ICNTL(10) of IR is done. C Values of ICNTL(10) > 0 : mean a maximum of ICNTL(10) number C of steps of IR is done, and a test of C convergence is used C C ICNTL(11) has default value 0. C A value equal to 1 will return a backward error estimate in C RINFO(4-11). C A value equal to 2 will return a backward error estimate in C RINFO(4-8). No LCOND 1, 2 and forward error are computed. C If ICNTL(11) is negative, zero or greater than 2 no estimate C is returned. C C C ICNTL(12) has default value 0 and defines the strategy for C LDLT orderings C 0 : automatic choice C 1 : usual ordering (nothing done) C 2 : ordering on the compressed graph, available with all orderings C except with AMD C 3 : constraint ordering, only available with AMF, C -> reset to 2 with other orderings C Other values are treated as 1 (nothing done). C On output KEEP(95) holds the internal value used and INFOG(24) gives C access to KEEP(95) to the user. C in LU facto it is always reset to 1 C C - ICNTL(12) = 3 has a lower priority than ICNTL(7) C thus if ICNTL(12) = 3 and the ordering required is not AMF C then ICNTL(12) is set to 2 C C - ICNTL(12) = 2 has a higher priority than ICNTL(7) C thus if ICNTL(12) = 2 and the ordering required is AMD C then the ordering used is QAMD C C - ICNTL(12) has a higher priority than ICNTL(6) and ICNTL(8) C thus if ICNTL(12) = 2 then ICNTL(6) is automatically C considered as if it was set to a value between 1-6 C if ICNTL(12) = 3 then ICNTL(6) is considered as if C set to 5 and ICNTL(8) as if set to -2 (we need the scaling C factors to define free and constrained variables) C C ICNTL(13) has default value 0 and allows for selecting Type 3 node. C IF ICNTL(13).GT. 0 scalapack is forbidden. Otherwise, C scalapack will be activated if the root is large enough. C Furthermore C IF ((ICNTL(13).GT.0) .AND. (NSLAVES.GT.ICNTL(13), C or ICNTL(13)=-1 THEN C extra splitting of the root will be activated C and is controlled by abs(KEEP(82)). C The order of the root node is divided by KEEP(82) C ENDIF C If ICNTL(13) .EQ. -1 then splitting of the root C is done whatever the nb of procs is. C C To summarize: C -1 : root splitting and scalapack on C 0 or < -1 : root splitting off and sclalapack on C > 0 : scalapack off C C ICNTL(14) has default value 20 (5 if NSLAVES=1 and SYM=1) C and is the value for memory relaxation C so called "PERLU" in the following. C C C ICNTL(16) : number of OpenMP threads asked by the user. C C ICNTL(17) not used in this version C C ICNTL(18) has default value 0 and is only accessed by the host during C the analysis phase if the matrix is assembled (ICNTL(5))= 0). C ICNTL(18) defines the strategy for the distributed input matrix. C Possible values are: C 0: input matrix is centralized on the host. This is the default C 1: user provides the structure of the matrix on the host at analysis, C ZMUMPS returns C a mapping and user should provide the matrix distributed according C to the mapping C 2: user provides the structure of the matrix on the host at analysis, C and the C distributed matrix on all slave processors at factorization. C Any distribution is allowed C 3: user directly provides the distributed matrix input both C for analysis and factorization C C For flexibility and performance issues, option 3 is recommended. C C ICNTL(19) has default value 0 and is only accessed by the host C during the analysis phase. If ICNTL(19) \neq 0 then Schur matrix will C be returned to the user. C The user must set on entry on the host node (before analysis): C the integer variable SIZE\_SCHUR to the size fo the Schur matrix, C the integer array pointer LISTVAR\_SCHUR to the list of indices C of the schur matrix. C if = 0 : Schur is off and the root node gets factorized C if = 1 : Schur is on and the Schur complement is returned entirely C on a memory area provided by the user ONLY on the host node C if = 2 or 3 : Schur is on and the Schur complement is returned in a C distributed fashion according to a 2D block-cyclic C distribution. In the case where the matrix is symmetric C the lower part is returned if =2 or the complete C matrix if =3. C C ICNTL(20) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(20)=0, the right-hand side must given C in dense form in the structure component RHS. C If ICNTL(20)=1,2,3, then the right-hand side must be given in sparse form C using the structure components IRHS\_SPARSE, RHS\_SPARSE, IRHS\_PTR and C NZ\_RHS. C When the right-hand side is provided in sparse form then duplicate entries C are summed. C C 0 : dense RHS C 1,2,3 : Sparse RHS C 1 The decision of exploiting sparsity of the right-hand side to C accelerate the solution phase is done automatically. C 2 Sparsity of the right-hand sides is NOT exploited C to improve solution phase. C 3 Sparsity of the right-hand sides is exploited C to improve solution phase. C Values different from 0,1, 2,3 are treated as 0. C For sparse RHS recommended value is 1. C C ICNTL(21) has default value 0 and is only accessed by the host C during the solve phase. If ICNTL(21)=0, the solution vector will be assembled C and stored in the structure component RHS, that must have been allocated by C the user. If ICNTL(21)=1, the solution vector is kept distributed at the C end of the solve phase, and will be available on each slave processor C in the structure components ISOL_loc and SOL_loc. ISOL_loc and SOL_loc C must then have been allocated by the user and must be of size at least C INFO(23), where INFO(23) has been returned by ZMUMPS at the end of the C factorization phase. C Values of ICNTL(21) different from 0 and 1 are currently treated as 0. C C ICNTL(22) (saved in KEEP(201) controls the OOC setting (0=incore, 1 =OOC) C It has default value 0 (incore).Out-of-range values are treated as 1. C If set before analysis then special setting and massage of the tree C might be done (so far only extra splitting CUTNODES) is performed. C It is then accessed by the host C during the factorization phase. If ICNTL(22)=0, then no attempt C to use the disks is made. If ICNTL(22)=1, then ZMUMPS will store C the computed factors on disk for later use during the solution C phase. C C ICNTL(23) has default value 0 and is accessed by ALL processors C at the beginning of the factorization phase. If positive C it corresponds to the maximum size of the working memory C in MegaBytes that MUMPS can allocate per working processor. C If only the host C value is non zero, then other processors also use the value on C the host. Otherwise, each processor uses the local value C provided. C C ICNTL(24) default value is 0 C if = 0 no null pivot detection (CNTL(5) and CNTL(3) are inactive), C = 1 null pivot row detection; CNTL(3) and CNTL(5) are C then used to describe the action taken. C C C ICNTL(25) has default value 0 and is only accessed by the C host during the solution stage. It is only significant if C a null space basis was requested during the factorization C phase (INFOG(28) .GT. 0); otherwise a normal solution step C is performed. C If ICNTL(25)=0, then a normal solution step is performed, C on the internal problem (excluding the null space). C No special property on the solution (discussion with Serge) C If ICNTL(25)=i, 1 <= i <= INFOG(28), then the i-th vector C of the null space basis is computed. In that case, note C that NRHS should be set to 1. C If ICNTL(25)=-1, then all null space is computed. The C user should set NRHS=INFOG(28) in that case. C Note that centralized or distributed solutions are C applicable in that case, but that iterative refinement, C error analysis, etc... are excluded. Note also that the C option to solve the transpose system (ICNTL(9)) is ignored. C C C ICNTL(26) has default value 0 and is accessed on the host only C at the beginning of the solution step. C It is only effective if the Schur option is ON. C (copy in KEEP(221)) C C C During the solution step, a value of 0 will perform a normal C solution step on the reduced problem not involving the Schur C variables. C During the solution step, if ICNTL(26)=1 or 2, then REDRHS C should be allocated of size at least LREDRHS*(NRHS-1)+ C SIZE_SCHUR, where LREDRHS is the leading dimension of C LREDRHS (LREDRHS >= SIZE_SCHUR). C C If ICNTL(26)=1, then only a forward substitution is performed, C and a reduced RHS will be computed and made available in C REDRHS(i+(k-1)*LREDRHS), i=1, ..., SIZE_SCHUR, k=1, ..., NRHS. C If ICNTL(26)=2, then REDRHS(i+(k-1)*LREDRHS),i=1, SIZE_SCHUR, C k=1,NRHS is considered to be the solution corresponding to the C Schur variables. It is injected in ZMUMPS, that computes the C solution on the "internal" problem during the backward C substitution. C C ICNTL(27) controls the blocking factor for multiple right-hand-sides C during the solution phase. C It influences both the memory used (see INFOG(30-31)) and C the solution time C (Larger values of ICNTL(27) leads to larger memory requirements). C Its tuning can be critical when C the factors are written on disk (out-of core, ICNTL(22)=1). C A negative value indicates that automatic setting is C performed by the solver. C C C ICNTL(28) decides whether parallel or sequential analysis should be used. Three C values are possible at the moment: C 0: automatic. This defaults to sequential analysis C 1: sequential. In this case the ordering strategy is defined by ICNTL(7) C 2: parallel. In this case the ordering strategy is defined by ICNTL(29) C C ICNTL(29) defines the ordering too to be used during the parallel analysis. Three C values are possible at the moment: C 0: automatic. This defaults to PT-SCOTCH C 1: PT-SCOTCH. C 2: ParMetis. C C C ICNTL(30) controls the activation of functionality A-1. C It has default value 0 and is only accessed by the master C during the solution phase. It enables the solver to C compute entries in the inverse of the original matrix. C Possible values are: C 0 normal solution C other values: compute entries in A-1 C When ICNTL(30).NE.0 then the user C must describe on entry to the solution phase, C in the sparse right-hand-side C (NZ_RHS, NRHS, RHS_SPARSE, IRHS_SPARSE, IRHS_PTR) C the target entries of A-1 that need be computed. C Note that RHS_SPARSE must be allocated but need not be C initialized. C On output RHS_SPARSE then holds the requested C computed values of A-1. C Note that when ICNTL(30).NE.0 then C - sparse right hand side interface is implicitly used C functionality (ICNTL(20)= 1) but RHS need not be C allocated since computed A-1 entries will be stored C in place. C - ICNTL(9) option (solve Ax=b or Atx=b) is ignored C In case of duplicate entries in the sparse rhs then C on output duplicate entries in the solution are provided C in the same place. C This need not be mentioned in the spec since it is a C "natural" extension. C C ----------- C Fwd in facto C ----------- C ICNTL(31) Must be set before analysis to control storage C of LU factors. Default value is 0. Out of range C values considered as 0. C (copied in KEEP(251) and broadcast, C when setting of ICNTL(31) C results in not factors to be stored then C KEEP(201) = -1, OOC is "suppressed") C 0 Keep factors needed for solution phase C (when option forward during facto is used then C on unsymmetric matrices L factors are not stored) C 1 Solve not needed (solve phase will never be called). C When the user is only interested in the inertia or the C determinant then C all factor matrices need not be stored. C This can also be useful for testing : C to experiment facto OOC without C effective storage of factors on disk. C 2 L factors not stored: meaningful when both C - matrix is unsymmetric and fwd performed during facto C - the user is only interested in the null-space basis C and thus only need the U factors to be stored. C Currently, L factors are always stored in IC. C C ----------- C Fwd in facto C ----------- C ICNTL(32) Must be set before analysis to indicate whether C forward is performed during factorization. C Default value is 0 (normal factorization without fwd) C (copied in KEEP(252) and broadcast) C 0 Normal factorization (default value) C 1 Forward performed during factorization C C C ICNTL(33) Must be set before the factorization phase to compute C the determinant. See also KEEP(258), KEEP(259), C DKEEP(6), DKEEP(7), INFOG(34), RINFOG(12), INFOG(34) C C If ICNTL(33)=0 the determinant is not computed C For all other values, the determinant is computed. Note that C null pivots and static pivots are excluded from the C computation of the determinant. C C ICNTL(34) Must be set before a call to MUMPS with JOB=-2 in case C the save/restore feature was used and user wants to clean C save/restore files (and possibly OOC files). C ICTNL(34)=0 => user wants to be able to restore instance later C ICTNL(34)=1 => user will not restore the instance again (clean C to be done) C C ICNTL(35) : Block Low-Rank (BLR) functionality, C need be set before analysis C Default value is 0 C 0: FR factorization and FR solve C 1: Automatic BLR option setting (=> 2) C 2: BLR factorization + BLR Solve C => keep BLR factors only C 3: BLR factorization + FR Solve C Other values are treated as zero C Note that this functionality is currently incompatible C with elemental matrices (ICNTL(5) = 1) and with C forward elimination during factorization (ICNTL(32) = 1) C C ICNTL(36) : Block Low-Rank variant choice C Default value is 0 C 0: UFSC variant, no recompression: Compress step is C performed after the Solve; the low-rank updates are not C recompressed C 1: UCFS variant, no recompression: Compress step is C performed before the Solve; pivoting strategy is adapted C to pe performed on low-rank blocks; the low-rank updates are not C recompressed C C C ICNTL(38): Compression rate of LU factors, can be set before C analysis/factorization C Between 0 and 1000; other values ares treated as 0; C ICNTL(38)/10 is a percentage representing the typical C compressed factors compression of the factor matrices C in BLR fronts: C ICNTL(38)/10= compressed/uncompressed factors × 100. C Default value: 333 C (when factors of BLR fronts are compressed, C their size is 33.3% of their full- rank size). C========================= C ARRAYS FOR INFORMATION C======================== C C----- C INFO is an INTEGER array of length 80 that need not be C set by the user. C----- C C INFO(1) is zero if the routine is successful, is negative if an C error occurred, and is positive for a warning (see ZMUMPS for C a partial documentation and the userguide for a full documentation C of INFO(1)). C C INFO(2) holds additional information concerning the C error (see ZMUMPS). C C ------------------------------------------ C Statistics produced after analysis phase C ------------------------------------------ C C INFO(3) Estimated real space needed for factors. C C INFO(4) Estimated integer space needed for factors. C C INFO(5) Estimated maximum frontal size. C C INFO(6) Number of nodes in the tree. C C INFO(7) Minimum value of integer working array IS (old MAXIS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(8) Minimum value of real/complex array S (old MAXS) C estimated by the analysis phase C to run the numerical factorization. C C INFO(15) Estimated size in MBytes of all ZMUMPS internal data C structures to run factorization C C INFO(17) provides an estimation (minimum in Megabytes) C of the total memory required to run C the numerical phases out-of-core. C This memory estimation corresponds to C the least memory consuming out-of-core strategy and it can be C used as a lower bound if the user wishes to provide ICNTL(23). C --------------------------------------- C Statistics produced after factorization C --------------------------------------- C INFO(9) Size of the real space used to store the LU factors possibly C including BLR compressed factors C C INFO(10) Size of the integer space used to store the LU factors C C INFO(11) Order of largest frontal matrix. C C INFO(12) Number of off-diagonal pivots. C C INFO(13) Number of uneliminated variables sent to the father. C C INFO(14) Number of memory compresses. C C INFO(18) On exit to factorization: C Local number of null pivots (ICNTL(24)=1) C on the local processor even on master. C (local size of array PIVNUL_LIST). C C INFO(19) - after analysis: C Estimated size of the main internal integer workarray IS C (old MAXIS) to run the numerical factorization out-of-core. C C INFO(21) - after factorization: Effective space used in the main C real/complex workarray S -- or in the workarray WK_USER, C in the case where WK_USER is provided. C C INFO(22) - after factorization: C Size in millions of bytes of memory effectively used during C factorization. C This includes the memory effectively used in the workarray C WK_USER, in the case where WK_user is provided. C C INFO(23) - after factorization: total number of pivots eliminated C on the processor. In the case of a distributed solution (see C ICNTL(21)), this should be used by the user to allocate solution C vectors ISOL_loc and SOL_loc of appropriate dimensions C (ISOL_LOC of size INFO(23), SOL_LOC of size LSOL_LOC * NRHS C where LSOL_LOC >= INFO(23)) on that processor, between the C factorization and solve steps. C C INFO(24) - after analysis: estimated number of entries in factors on C the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(24)=INFO(3). C In the symmetric case, however, INFO(24) < INFO(3). C INFO(25) - after factorization: number of tiny pivots (number of C pivots modified by static pivoting) detected on the processor. C INFO(26) - after solution: C effective size in Megabytes of all working space C to run the solution phase. C (The maximum and sum over all processors are returned C respectively in INFOG(30) and INFOG(31)). C INFO(27) - after factorization: effective number of entries in factors C on the processor. If negative, then C the absolute value corresponds to {\it millions} of entries C in the factors. C Note that in the unsymmetric case, INFO(27)=INFO(9). C In the symmetric case, however, INFO(27) < INFO(9). C The total number of entries over all processors is C available in INFOG(29). C C C ------------------------------------------------------------- C ------------------------------------------------------------- C RINFO is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C local information on the execution of ZMUMPS. C C C RINFOG is a DOUBLE PRECISION/DOUBLE PRECISION array of length 40 that C need not be set by the user. This array supplies C global information on the execution of ZMUMPS. C RINFOG is only significant on processor 0 C C C RINFO(1) hold the estimated number of floating-point operations C for the elimination process on the local processor C C RINFOG(1) hold the estimated number of floating-point operations C for the elimination process on all processors C C RINFO(2) Number of floating-point operations C for the assembly process on local processor. C C RINFOG(2) Number of floating-point operations C for the assembly process. C C RINFO(3) Number of floating-point operations C for the elimination process on the local processor. C C RINFOG(3) Number of floating-point operations C for the elimination process on all processors. C C---------------------------------------------------- C Statistics produced after solve with error analysis C---------------------------------------------------- C C RINFOG(4) Infinite norm of the input matrix. C C RINFOG(5) Infinite norm of the computed solution, where C C RINFOG(6) Norm of scaled residuals C C RINFOG(7), `RINFOG(8) and `RINFOG(9) are used to hold information C on the backward error. C We calculate an estimate of the sparse backward error using the C theory and measure developed C by Arioli, Demmel, and Duff (1989). The scaled residual w1 C is calculated for all equations except those C for which numerator is nonzero and the denominator is small. C For the exceptional equations, w2, is used instead. C The largest scaled residual (w1) is returned in C RINFOG(7) and the largest scaled C residual (w2) is returned in `RINFOG(8)>. If all equations are C non exceptional then zero is returned in `RINFOG(8). C The upper bound error is returned in `RINFOG(9). C C RINFOG(14) Number of floating-point operations C for the elimination process (on all fronts, BLR or not) C performed when BLR option is activated on all processors. C (equal to zero if BLR option not used, ICNTL(35).EQ.1) C C RINFOG(15) - after analysis: if the user decides to perform an C out-of-core factorization (ICNTL(22)=1), then a rough C estimation of the total size of the disk space in MegaBytes of C the files written by all processors is provided in RINFOG(15). C C RINFOG(16) - after factorization: in the case of an out-of-core C execution (ICNTL(22)=1), the total C size in MegaBytes of the disk space used by the files written C by all processors is provided. C C RINFOG(17) - after each job: sum over all processors of the sizes C (in MegaBytes) of the files used to save the instance C C RINFOG(18) - after each job: sum over all processors of the sizes C (in MegaBytes) of the MUMPS structures. C C RINFOG(19) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and considering also C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(20) - after factorization: smallest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre and NOT considering C small pivots selected as null-pivots (see ICNTL(24)) C and pivots on which static pivoting was applied C C RINFOG(21) - after factorization: largest pivot in absolute C value selected during factorization of the preprocessed C matrix A_pre. C=========================== C DESCRIPTION OF KEEP8 ARRAY C=========================== C C KEEP8 is a 64-bit integer array of length 150 that need not C be set by the user C C=========================== C DESCRIPTION OF KEEP ARRAY C=========================== C C KEEP is an INTEGER array of length 500 that need not C be set by the user. C C C============================= C Description of DKEEP array C============================= C C DKEEP internal control array for DOUBLE PRECISION parameters C of size 30 C=================================== C Default values for control arrays C================================== C uninitialized values should be 0 LWK_USER = 0 KEEP(1:500) = 0 KEEP8(1:150)= 0_8 INFO(1:80) = 0 INFOG(1:80) = 0 ICNTL(1:60) = 0 RINFO(1:40) = 0.0D0 RINFOG(1:40)= 0.0D0 CNTL(1:15) = 0.0D0 DKEEP(1:230) = 0.0D0 C ---------------- C Symmetric code ? C ---------------- KEEP( 50 ) = SYM C Check value of SYM IF (SYM.EQ.1) THEN C C this option is not available with the complex C code on symmetric matrices. C We set KEEP(50) to 2 and will exploit symmetry C up to the root. KEEP(50) = 2 ENDIF C ------------------------------------- C Only options 0, 1, or 2 are available C ------------------------------------- IF ( KEEP(50).NE.1 .and. KEEP(50).NE.2 ) KEEP( 50 ) = 0 C threshold value for pivoting IF ( KEEP(50) .NE. 1 ) THEN CNTL(1) = 0.01D0 ELSE CNTL(1) = 0.0D0 END IF CNTL(2) = sqrt(epsilon(0.0D0)) CNTL(3) = 0.0D0 CNTL(4) = -1.0D0 CNTL(5) = 0.0D0 C Working host ? KEEP(46) = PAR IF ( KEEP(46) .NE. 0 .AND. & KEEP(46) .NE. 1 ) THEN C ---------------------- C If out-of-range value, C use a working host C ---------------------- KEEP(46) = 1 END IF C control printing ICNTL(1) = 6 ICNTL(2) = 0 ICNTL(3) = 6 ICNTL(4) = 2 C format of input matrix ICNTL(5) = 0 C maximum transversal (0=NO, 7=automatic) IF (SYM.NE.1) THEN ICNTL(6) = 7 ELSE ICNTL(6) = 0 ENDIF C Ordering option (icntl(7)) C Default is automatic choice done during analysis ICNTL(7) = 7 C ask for scaling (0=NO, 4=Row and Column) C Default value is 77: automatic choice for analysis ICNTL(8) = 77 C solve Ax=b (1) or Atx=b (other values) ICNTL(9) = 1 C Naximum number of IR (0=NO) ICNTL(10) = 0 C Error analysis (0=NO) ICNTL(11) = 0 C Control ordering strategy C automatic choice IF(SYM .EQ. 2) THEN ICNTL(12) = 0 ELSE ICNTL(12) = 1 ENDIF C Control of the use of ScaLAPACK for root node C If null space options asked, ScaLAPACK is always ignored C and ICNTL(13) is not significant C ICNTL(13) = 0 : Root parallelism on (if size large enough) C ICNTL(13) = 1 : Root parallelism off ICNTL(13) = 0 C Default value for the memory relaxation IF (SYM.eq.1.AND.NSLAVES.EQ.1) THEN ICNTL(14) = 5 ! it should work with 0 ELSE ICNTL(14) = 20 END IF IF (NSLAVES.GT.4) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.8) ICNTL(14) = ICNTL(14) + 5 IF (NSLAVES.GT.16) ICNTL(14)= ICNTL(14) + 5 C Distributed matrix entry ICNTL(18) = 0 C Schur (default is not active) ICNTL(19) = 0 C dense RHS by default ICNTL(20) = 0 C solution vector centralized on host ICNTL(21) = 0 C out-of-core flag ICNTL(22) = 0 C MEM_ALLOWED (0: not provided) ICNTL(23) = 0 C null pivots ICNTL(24) = 0 C blocking factor for multiple RHS during solution phase ICNTL(27) = -32 C analysis strategy: 0=auto, 1=sequential, 2=parallel ICNTL(28) = 1 C tool used for parallel ordering computation : C 0 = auto, 1 = PT-SCOTCH, 2 = ParMETIS ICNTL(29) = 0 C Default BLR compression rate of factors (33.3%) ICNTL(38) = 333 ICNTL(55) = 0 ICNTL(56) = 0 ICNTL(57) = 0 ICNTL(58) = 1 C=================================== C Default values for some components C of KEEP array C=================================== KEEP(12) = 0 KEEP(24) = 18 KEEP(68) = 0 KEEP(30) = 2000 KEEP(36) = 1 KEEP(1) = 5 KEEP(7) = 150 KEEP(8) = 120 KEEP(57) = 2000 KEEP(58) = 1000 IF ( SYM .eq. 0 ) THEN KEEP(4) = 32 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 700 KEEP(85) = 300 KEEP(62) = 50 ELSE KEEP(4) = 24 KEEP(3) = 96 KEEP(5) = 16 KEEP(6) = 32 KEEP(9) = 400 KEEP(85) = 100 KEEP(62) = 50 END IF KEEP(63) = 60 KEEP(48) = 5 CALL ZMUMPS_SET_TYPE_SIZES( KEEP(34), KEEP(35), & KEEP(16), KEEP(10) ) KEEP(51) = 70 KEEP(37) = max(800, int(sqrt(dble(NSLAVES+1))*dble(KEEP(51)))) IF ( NSLAVES > 256 ) THEN KEEP(39) = 10000 ELSEIF ( NSLAVES > 128 ) THEN KEEP(39) = 20000 ELSEIF ( NSLAVES > 64 ) THEN KEEP(39) = 40000 ELSEIF ( NSLAVES > 16 ) THEN KEEP(39) = 80000 ELSE KEEP(39) = 160000 END IF KEEP(40) = -1 - 456789 KEEP(45) = 0 KEEP(47) = 2 KEEP(64) = 20 KEEP(69) = 4 C To disable SMP management when using new mapping strategy C KEEP(69) = 1 C Forcing proportional is ok with strategy 5 KEEP(75) = 1 KEEP(76) = 2 KEEP(77) = 30 KEEP(79) = 0 ! old splitting IF (NSLAVES.GT.4) THEN KEEP(78)=max( & int(log(dble(NSLAVES))/log(dble(2))) - 2 & , 0 ) ENDIF KEEP(210) = 2 KEEP8(79) = -10_8 KEEP(80) = 1 KEEP(81) = 0 KEEP(82) = 30 KEEP(83) = min(8,NSLAVES/4) KEEP(83) = max(min(4,NSLAVES),max(KEEP(83),1)) KEEP(86)=1 KEEP(87)=0 KEEP(88)=0 KEEP(90)=1 KEEP(91)=min(8, NSLAVES) KEEP(91) = max(min(4,NSLAVES),min(KEEP(83),KEEP(91))) IF(NSLAVES.LT.48)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.128)THEN KEEP(102)=150 ELSEIF(NSLAVES.LT.256)THEN KEEP(102)=200 ELSEIF(NSLAVES.LT.512)THEN KEEP(102)=300 ELSEIF(NSLAVES.GE.512)THEN KEEP(102)=400 ENDIF #if defined(OLD_OOC_NOPANEL) KEEP(99)=0 ! no panel -> synchronous / no buffer #else KEEP(99)=4 ! new OOC -> asynchronous + buffer #endif KEEP(100)=0 KEEP(114) = 1 C strategy for MUMPS_BLOC2_GET_NSLAVESMIN KEEP(119)=0 C KEEP(199) for MUMPS_PROCNODE, MUMPS_TYPENODE, etc C KEEP(199)=NSLAVES + 7 KEEP(199)=-1 KEEP(200)=0 ! root pre-assembled in id%S KEEP(204)=0 KEEP(205)=0 KEEP(209)=-1 KEEP(104) = 16 KEEP(107)=0 KEEP(121)=-999999 KEEP(122)=150 KEEP(141)=1 ! min needed KEEP(206)=1 KEEP(211)=2 IF (NSLAVES .EQ. 2) THEN KEEP(213) = 101 ELSE KEEP(213) = 201 ENDIF KEEP(217)=0 KEEP(215)=0 KEEP(216)=1 KEEP(218)=250 KEEP(219)=1 IF (KEEP(50).EQ.2) THEN KEEP(227)= max(2,32) ELSE KEEP(227)= max(1,32) ENDIF KEEP(231) = 1 KEEP(232) = 3 KEEP(233) = 0 KEEP(239) = 1 KEEP(240) = 10 DKEEP(4) = -1.0D0 DKEEP(5) = -1.0D0 C#if defined(try_null_space) DKEEP(10) = -9D0 ! default value is 10D-1 set in fac_driver.F DKEEP(13) = -9D0 ! to define SEUIL for postponing with RR ! (default value is 10 set in fac_driver.F) DKEEP(24) = 1000.0D0 ! gap should be larger than dkeep(14) DKEEP(25) = 10.0D0 ! gap precision C#endif KEEP(238)=14 KEEP(234)= 1 KEEP(235)=-1 DKEEP(3) =-5.0D0 DKEEP(18)= 1.0D12 KEEP(242) = -9 KEEP(243) = -1 KEEP(249)=1 !$ KEEP(249) = OMP_GET_MAX_THREADS() KEEP(250) = 1 KEEP(261) = 1 KEEP(262) = 0 KEEP(263) = 1 KEEP(266) = 0 KEEP(267) = 0 KEEP(268)=77 KEEP(350) = 1 KEEP(351) = 0 KEEP(360) = 256 KEEP(361) = 2048 KEEP(362) = 4 KEEP(363) = 512 KEEP(364) = 32768 C OMP parallelization of arrowheads KEEP(399) = 1 KEEP(420) = 4*KEEP(6) ! if KEEP(6)=32 then 128 #if defined(GEMMT_AVAILABLE) KEEP(421) = -1 #endif C Default size of KEEP(424) is defined below. C It does not depend on arithmetic, C it is related to L1 cache size: 250 * 64 bytes C is about half of the cache size (32768 bytes). C This leaves space in cache for the destination, C of size 250*sizeof(arith). (4k bytes for z) C At each new block of size KEEP(424), there is C probably a cache miss on the pivot. KEEP(424) = 250 KEEP(461) = 10 KEEP(462) = 10 KEEP(464) = 333 KEEP(465) = 200 KEEP(466) = 1 KEEP(468) = 3 KEEP(469) = 3 KEEP(471) = -1 KEEP(479) = 1 KEEP(480) = 3 KEEP(472) = 1 KEEP(476) = 50 KEEP(477) = 100 KEEP(483) = 50 KEEP(484) = 50 KEEP(487) = 1 IF (KEEP(472).EQ.1) THEN KEEP(488) = 512 ELSE KEEP(488) = 8*KEEP(6) ! if KEEP(6)=32 then 256 ENDIF KEEP(490) = 128 KEEP(491) = 1000 KEEP(492) = 1 KEEP(82) = 30 KEEP(493) = 0 KEEP(496) = 1 KEEP(495) = -1 KEEP(497) = -1 C RETURN END SUBROUTINE ZMUMPSID SUBROUTINE ZMUMPS_SET_KEEP72(id, LP) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER LP IF (id%KEEP(72)==1) THEN id%KEEP(37) = 2*id%NSLAVES id%KEEP(3)=3 id%KEEP(4)=2 id%KEEP(5)=1 id%KEEP(6)=2 id%KEEP(9)=3 id%KEEP(39)=300 id%KEEP(7) = 3 id%KEEP(8) = 2 id%KEEP(57)= 3 id%KEEP(58)= 2 id%KEEP(63)=3 id%CNTL(1)=0.1D0 id%KEEP(213) = 101 id%KEEP(85)=2 id%KEEP(85)=-4 id%KEEP(62) = 2 id%KEEP(1) = 1 id%KEEP(51) = 2 !$ id%KEEP(360) = 2 !$ id%KEEP(361) = 2 !$ id%KEEP(362) = 1 !$ id%KEEP(363) = 2 id%KEEP(364) = 10 id%KEEP(420) = 4 id%KEEP(488) = 4 id%KEEP(490) = 5 id%KEEP(491) = 5 id%ICNTL(27)=-3 id%KEEP(227)=3 id%KEEP(30) = 1000 ELSE IF (id%KEEP(72)==2) THEN id%KEEP(85)=2 ! default is id%KEEP(85)=-10000 ! default is 160 id%KEEP(62) = 10 ! default is 50 id%KEEP(210) = 1 ! defaults is 0 (automatic) id%KEEP8(79) = 160000_8 id%KEEP(1) = 2 ! default is 8 id%KEEP(102) = 110 ! defaults is 150 up to 48 procs id%KEEP(213) = 121 ! default is 201 END IF RETURN END SUBROUTINE ZMUMPS_SET_KEEP72 MUMPS_5.4.1/src/sfac_par_m.F0000664000175000017500000010324414102210521015706 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_PAR_M CONTAINS SUBROUTINE SMUMPS_FAC_PAR(N, IW, LIW, A, LA, NSTK_STEPS, & ND, FILS, STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, & NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, & DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, PROCNODE_STEPS, & SLAVEF,MYID, COMM_NODES, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & INTARR, DBLARR, root, PERM, NELT, FRTPTR, FRTELT, LPTRAR, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS ) !$ USE OMP_LIB USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_CBSTATIC2DYNAMIC, & SMUMPS_DM_FREEALLDYNAMICCB USE SMUMPS_LOAD USE SMUMPS_OOC USE SMUMPS_FAC_ASM_MASTER_M USE SMUMPS_FAC_ASM_MASTER_ELT_M USE SMUMPS_FAC1_LDLT_M USE SMUMPS_FAC2_LDLT_M USE SMUMPS_FAC1_LU_M USE SMUMPS_FAC2_LU_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP REAL, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA REAL, TARGET :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) LOGICAL IS_ISOLATED_NODE INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER LRGROUPS(N) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0, DONE = 1.0D0 INTEGER INODE INTEGER IWPOSCB INTEGER FPERE, TYPEF INTEGER MP, LP, DUMMY(1) INTEGER NBFIN, NBROOT_TRAITEES INTEGER NFRONT, IOLDPS, NASS, HF, XSIZE INTEGER(8) NFRONT8 INTEGER(8) :: POSELT INTEGER IPOSROOT, IPOSROOTROWINDICES INTEGER GLOBK109 INTEGER(8) :: LBUFRX REAL, POINTER, DIMENSION(:) :: BUFRX LOGICAL :: IS_BUFRX_ALLOCATED DOUBLE PRECISION FLOP1 INTEGER TYPE LOGICAL SON_LEVEL2, SET_IRECV, BLOCKING, & MESSAGE_RECEIVED LOGICAL AVOID_DELAYED LOGICAL LAST_CALL INTEGER MASTER_ROOT INTEGER LOCAL_M, LOCAL_N INTEGER LRHS_CNTR_MASTER_ROOT, FWD_LOCAL_N_RHS LOGICAL ROOT_OWNER EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE LOGICAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR,MUMPS_ROOTSSARBR LOGICAL SMUMPS_POOL_EMPTY EXTERNAL SMUMPS_POOL_EMPTY, SMUMPS_EXTRACT_POOL LOGICAL STACK_RIGHT_AUTHORIZED INTEGER numroc EXTERNAL numroc INTEGER JOBASS, ETATASS INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, TYPEFile, NextPiv2beWritten, & IDUMMY INTEGER(8) :: ITMP8 TYPE(IO_BLOCK) :: MonBloc INCLUDE 'mumps_headers.h' INTEGER MPA DOUBLE PRECISION OPLAST_PRINTED ITLOC(1:N+KEEP(253)) =0 ASS_IRECV = MPI_REQUEST_NULL MP = ICNTL(2) LP = ICNTL(1) IWPOSCB = LIW OPLAST_PRINTED = DONE MPA = ICNTL(2) IF (ICNTL(4).LT.2) MPA=0 STACK_RIGHT_AUTHORIZED = .TRUE. CALL SMUMPS_ALLOC_CB( .FALSE., 0_8, & .FALSE., .FALSE., MYID_NODES, N, KEEP, KEEP8, DKEEP, & IW, LIW, A, LA, LRLU, IPTRLU, IWPOS, IWPOSCB, & SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, & PAMASTER, KEEP(IXSZ), 0_8, -444, -444, .true., & COMP, LRLUS, KEEP8(67), & INFO(1), INFO(2) & ) JOBASS = 0 ETATASS = 0 NBFIN = NBRTOT NBROOT_TRAITEES = 0 KEEP(121)=0 IF ( KEEP(38).NE.0 ) THEN IF (root%yes) THEN CALL SMUMPS_ROOT_ALLOC_STATIC( & root, KEEP(38), N, IW, LIW, & A, LA, & FILS, DAD, MYID_NODES, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, INFO(1), KEEP,KEEP8, DKEEP, INFO(2) ) ENDIF IF ( INFO(1) .LT. 0 ) GOTO 635 END IF KEEP(429)=0 20 CONTINUE NIV1_FLAG=0 SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, & COMP, INFO(1), INFO(2), COMM_NODES, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID_NODES, SLAVEF, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED & , LRGROUPS & ) CALL SMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (MESSAGE_RECEIVED) THEN IF ( INFO(1) .LT. 0 ) GO TO 640 IF ( NBFIN .eq. 0 ) GOTO 640 ELSE IF ( .NOT. SMUMPS_POOL_EMPTY( IPOOL, LPOOL) )THEN CALL SMUMPS_EXTRACT_POOL( N, IPOOL, LPOOL, & PROCNODE_STEPS, & SLAVEF, STEP, INODE, KEEP,KEEP8, MYID_NODES, ND, & (.NOT. STACK_RIGHT_AUTHORIZED) ) STACK_RIGHT_AUTHORIZED = .TRUE. IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF IF (KEEP(47).EQ.4) THEN IF(INODE.GT.0.AND.INODE.LE.N)THEN IF((NE(STEP(INODE)).EQ.0).AND. & (FRERE(STEP(INODE)).EQ.0))THEN IS_ISOLATED_NODE=.TRUE. ELSE IS_ISOLATED_NODE=.FALSE. ENDIF ENDIF CALL SMUMPS_LOAD_SBTR_UPD_NEW_POOL( & IS_ISOLATED_NODE,INODE,IPOOL,LPOOL, & MYID_NODES,SLAVEF,COMM_LOAD,KEEP,KEEP8) ENDIF IF ((( KEEP(80) == 2 .OR. KEEP(80)==3 ) .AND. & ( KEEP(47) == 4 )).OR. & (KEEP(80) == 1 .AND. KEEP(47) .GE. 1)) THEN CALL SMUMPS_UPPER_PREDICT(INODE,STEP,KEEP(28), & PROCNODE_STEPS,FRERE,ND,COMM_LOAD,SLAVEF, & MYID_NODES,KEEP,KEEP8,N) END IF GOTO 30 ENDIF ENDIF GO TO 20 30 CONTINUE IF ( INODE .LT. 0 ) THEN INODE = -INODE FPERE = DAD(STEP(INODE)) GOTO 130 ELSE IF (INODE.GT.N) THEN INODE = INODE - N IF (INODE.EQ.KEEP(38)) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN NBFIN = NBFIN - NBROOT IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL SMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID_NODES, & COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0) GOTO 640 GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) GOTO 100 FPERE = DAD(STEP(INODE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF ( KEEP(50) .eq. 0 ) THEN CALL SMUMPS_FAC2_LU( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) ELSE CALL SMUMPS_FAC2_LDLT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, IW, LIW, A, LA, UU, & NOFFNEGPV, NTOTPV, & NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & COMM_NODES, MYID_NODES, BUFR, LBUFR,LBUFR_BYTES, & NBFIN,LEAF, INFO(1), INFO(2), IPOOL,LPOOL, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, COMP, PTRIST, PTRAST, PTLUST, PTRFAC, & STEP, PIMASTER, PAMASTER, & NSTK_STEPS,PERM,PROCNODE_STEPS, & root, OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, SEUIL_LDLT_NIV2, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, AVOID_DELAYED, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( IW( PTLUST(STEP(INODE)) + KEEP(IXSZ) + 5 ) .GT. 1 ) THEN GOTO 20 END IF END IF GOTO 130 ENDIF IF (INODE.EQ.KEEP(38)) THEN CALL SMUMPS_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, & root, FRERE, & INODE, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_STEPS, COMP, & INFO(1), INFO(2), COMM_NODES, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID_NODES, SLAVEF, & & OPASS, OPELI, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP, ND, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 640 IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) GOTO 20 ENDIF TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (TYPE.EQ.1) THEN IF (KEEP(55).NE.0) THEN CALL SMUMPS_FAC_ASM_NIV1_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, & INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSE JOBASS = 0 CALL SMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP, PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP, INTARR,KEEP8(27), & DBLARR,KEEP8(26), & NSTK_STEPS,PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF ( INFO(1) .LT. 0 ) GOTO 640 IF ((IW(PTLUST(STEP(INODE))+XXNBPR).GT.0).OR.(SON_LEVEL2)) THEN GOTO 20 ENDIF ELSE IF ( KEEP(55) .eq. 0 ) THEN CALL SMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, & INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) ELSE CALL SMUMPS_FAC_ASM_NIV2_ELT( COMM_LOAD, ASS_IRECV, & NELT, FRTPTR, FRTELT, & N, INODE, IW, LIW, A, LA, INFO(1), & ND, FILS, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRT, & root, OPASS, OPELI, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_STEPS, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPSDONE, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & PROCNODE_STEPS, SLAVEF, COMM_NODES, & MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & NBFIN, LEAF, IPOOL, LPOOL, PERM, & MEM_DISTRIB(0) & , LRGROUPS & ) END IF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 GOTO 20 ENDIF 100 CONTINUE FPERE = DAD(STEP(INODE)) IF ( INODE .eq. KEEP(20) ) THEN POSELT = PTRAST(STEP(INODE)) IF (PTRFAC(STEP(INODE)).NE.POSELT) THEN WRITE(*,*) "ERROR 2 in SMUMPS_FAC_PAR", POSELT CALL MUMPS_ABORT() ENDIF CALL SMUMPS_CHANGE_HEADER & ( IW(PTLUST(STEP(INODE))+KEEP(IXSZ)), KEEP(253) ) GOTO 200 END IF POSELT = PTRAST(STEP(INODE)) IOLDPS = PTLUST(STEP(INODE)) XSIZE = KEEP(IXSZ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) AVOID_DELAYED = ( (FPERE .eq. KEEP(20) .OR. FPERE .eq. KEEP(38)) & .AND. KEEP(60).ne.0 ) IF (KEEP(50).EQ.0) THEN CALL SMUMPS_FAC1_LU ( & N, INODE, IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, & STEP, PROCNODE_STEPS, MYID_NODES, SLAVEF, & SEUIL, AVOID_DELAYED, ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 ELSE IW( IOLDPS+4+KEEP(IXSZ) ) = 1 CALL SMUMPS_FAC1_LDLT( N, INODE, & IW, LIW, A, LA, & IOLDPS, POSELT, & INFO(1), INFO(2), UU, NOFFNEGPV, NTOTPV, & NB22T1, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & KEEP,KEEP8, MYID_NODES, SEUIL, AVOID_DELAYED, & ETATASS, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, IWPOS & , LRGROUPS & , PERM & ) IF (INFO(1).LT.0) GOTO 635 IW( IOLDPS+4+KEEP(IXSZ) ) = STEP(INODE) ENDIF JOBASS = ETATASS IF (JOBASS.EQ.1) THEN CALL SMUMPS_FAC_ASM_NIV1(COMM_LOAD, ASS_IRECV, & N,INODE,IW,LIW,A,LA, & INFO(1),ND, & FILS,FRERE,DAD,MAXFRT,root,OPASS, OPELI, & PTRIST,PTLUST,PTRFAC,PTRAST,STEP,PIMASTER,PAMASTER, & PTRARW,PTRAIW, & ITLOC, RHS_MUMPS, NSTEPSDONE, SON_LEVEL2, & COMP, LRLU, IPTRLU, & IWPOS,IWPOSCB, POSFAC, LRLUS, KEEP8(67), & ICNTL, KEEP,KEEP8,DKEEP,INTARR,KEEP8(27),DBLARR,KEEP8(26), & NSTK_STEPS, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & JOBASS,ETATASS & , LRGROUPS & ) ENDIF IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 635 130 CONTINUE TYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( FPERE .NE. 0 ) THEN TYPEF = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) ELSE TYPEF = -9999 END IF CALL SMUMPS_FAC_STACK( COMM_LOAD, ASS_IRECV, & N,INODE,TYPE,TYPEF,LA,IW,LIW,A, & INFO(1),INFO(2),OPELI,NELVA,NMAXNPIV, & PTRIST,PTLUST,PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NE, POSFAC,LRLU, LRLUS,KEEP8(67), & IPTRLU,ICNTL,KEEP,KEEP8,DKEEP,COMP,IWPOS,IWPOSCB, & PROCNODE_STEPS,SLAVEF,FPERE,COMM_NODES,MYID_NODES, & IPOOL, LPOOL, LEAF, & NSTK_STEPS, PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, & root, OPASS, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (MPA.GT.0) & CALL MUMPS_PRINT_STILL_ACTIVE (MYID_NODES, KEEP, & dble(DKEEP(17)), & OPELI, & OPLAST_PRINTED, MPA) IF (INFO(1).LT.0) GOTO 640 200 CONTINUE IF ( INODE .eq. KEEP(38) ) THEN WRITE(*,*) 'Error .. in SMUMPS_FAC_PAR: ', & ' INODE == KEEP(38)' Stop END IF IF ( FPERE.EQ.0 ) THEN NBROOT_TRAITEES = NBROOT_TRAITEES + 1 IF ( NBROOT_TRAITEES .EQ. NBROOT ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF ( KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF NBFIN = NBFIN - NBROOT IF ( NBFIN .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in SMUMPS_FAC_PAR: ', & ' NBFIN=', NBFIN CALL MUMPS_ABORT() END IF IF ( NBROOT .LT. 0 ) THEN WRITE(*,*) ' ERROR 1 in SMUMPS_FAC_PAR: ', & ' NBROOT=', NBROOT CALL MUMPS_ABORT() END IF IF (SLAVEF.GT.1) THEN DUMMY(1) = NBROOT CALL SMUMPS_MCAST2( DUMMY(1), 1, MPI_INTEGER, & MYID_NODES, COMM_NODES, RACINE, SLAVEF, KEEP ) END IF ENDIF IF (NBFIN.EQ.0)THEN GOTO 640 ENDIF ELSEIF ( FPERE.NE.KEEP(38) .AND. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID_NODES ) THEN NSTK_STEPS(STEP(FPERE)) = NSTK_STEPS(STEP(FPERE))-1 IF ( NSTK_STEPS( STEP( FPERE )).EQ.0) THEN IF (KEEP(234).NE.0 .AND. & MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199))) & THEN STACK_RIGHT_AUTHORIZED = .FALSE. ENDIF CALL SMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID_NODES, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, KEEP(28), & KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL SMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ENDIF GO TO 20 635 CONTINUE CALL SMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) 640 CONTINUE CALL SMUMPS_CANCEL_IRECV( INFO(1), & KEEP, & ASS_IRECV, BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, & MYID_NODES, SLAVEF) CALL SMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR, & LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & .TRUE., & .TRUE.) CALL MPI_BARRIER( COMM_NODES, IERR ) IF (INFO(1) .LT. 0) THEN CALL SMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, PROCNODE_STEPS, DAD, & .FALSE. ) ENDIF IF ( INFO(1) .GE. 0 ) THEN IF( KEEP(38) .NE. 0 .OR. KEEP(20).NE.0) THEN MASTER_ROOT = MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(max(KEEP(38),KEEP(20)))), & KEEP(199)) ROOT_OWNER = (MASTER_ROOT .EQ. MYID_NODES) IF ( KEEP(38) .NE. 0 ) THEN IF (KEEP(60).EQ.0) THEN IOLDPS = PTLUST(STEP(KEEP(38))) LOCAL_M = IW(IOLDPS+2+KEEP(IXSZ)) LOCAL_N = IW(IOLDPS+1+KEEP(IXSZ)) ELSE IOLDPS = -999 LOCAL_M = root%SCHUR_MLOC LOCAL_N = root%SCHUR_NLOC ENDIF ITMP8 = int(LOCAL_M,8)*int(LOCAL_N,8) LBUFRX = min(int(root%MBLOCK,8)*int(root%NBLOCK,8), & int(root%TOT_ROOT_SIZE,8)*int(root%TOT_ROOT_SIZE,8) ) IF ( LRLU .GT. LBUFRX ) THEN BUFRX => A(POSFAC:POSFAC+LRLU-1_8) LBUFRX=LRLU IS_BUFRX_ALLOCATED = .FALSE. ELSE ALLOCATE( BUFRX( LBUFRX ), stat = IERR ) IF (IERR.gt.0) THEN INFO(1) = -9 CALL MUMPS_SET_IERROR(LBUFRX, INFO(2) ) IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before SMUMPS_FACTO_ROOT', LBUFRX CALL MUMPS_ABORT() ENDIF IS_BUFRX_ALLOCATED = .FALSE. ENDIF CALL SMUMPS_FACTO_ROOT( & MPA, MYID_NODES, MASTER_ROOT, & root, N, KEEP(38), & COMM_NODES, IW, LIW, IWPOS + 1, & A, LA, PTRAST, PTLUST, PTRFAC, STEP, & INFO(1), KEEP(50), KEEP(19), & BUFRX(1), LBUFRX, KEEP,KEEP8, DKEEP, & OPELI, DET_EXP, DET_MANT, DET_SIGN ) IF (IS_BUFRX_ALLOCATED) DEALLOCATE ( BUFRX ) NULLIFY(BUFRX) IF ( MYID_NODES .eq. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199)) & ) THEN IF ( INFO(1) .EQ. -10 .OR. INFO(1) .EQ. -40 ) THEN NTOTPV = NTOTPV + INFO(2) ELSE NTOTPV = NTOTPV + root%TOT_ROOT_SIZE NMAXNPIV = max(NMAXNPIV,root%TOT_ROOT_SIZE) END IF END IF IF (root%yes.AND.KEEP(60).EQ.0) THEN IF (KEEP(252).EQ.0) THEN IF (KEEP(201).EQ.1) THEN CALL MUMPS_GETI8(LAFAC, IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) TYPEFile = TYPEF_L NextPiv2beWritten = 1 MonBloc%INODE = KEEP(38) MonBloc%MASTER = .TRUE. MonBloc%Typenode = 3 MonBloc%NROW = LOCAL_M MonBloc%NCOL = LOCAL_N MonBloc%NFS = MonBloc%NCOL MonBloc%Last = .TRUE. MonBloc%LastPiv = MonBloc%NCOL MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. LAST_CALL = .TRUE. CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & A(PTRFAC(STEP(KEEP(38)))), & LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IERR,LAST_CALL) ELSE IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+ ITMP8 CALL SMUMPS_NEW_FACTOR(KEEP(38),PTRFAC, & KEEP,KEEP8,A,LA, ITMP8, IERR) IF(IERR.LT.0)THEN WRITE(*,*)MYID, & ': Internal error in SMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (KEEP(201).NE.0 .OR. KEEP(252).NE.0) THEN LRLUS = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 IF (KEEP(252).NE.0) THEN CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,0_8,-ITMP8, & KEEP,KEEP8,LRLUS) ELSE CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF IF (PTRFAC(STEP(KEEP(38))).EQ.POSFAC-ITMP8) THEN POSFAC = POSFAC - ITMP8 LRLU = LRLU + ITMP8 ENDIF ELSE CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS & ,ITMP8, & 0_8, & KEEP,KEEP8,LRLUS) ENDIF ENDIF IF (root%yes. AND. KEEP(252) .NE. 0 .AND. & (KEEP(60).EQ.0 .OR. KEEP(221).EQ.1)) THEN IF (MYID_NODES .EQ. MASTER_ROOT) THEN LRHS_CNTR_MASTER_ROOT = root%TOT_ROOT_SIZE*KEEP(253) ELSE LRHS_CNTR_MASTER_ROOT = 1 ENDIF ALLOCATE(root%RHS_CNTR_MASTER_ROOT( & LRHS_CNTR_MASTER_ROOT), stat=IERR ) IF (IERR.gt.0) THEN INFO(1) = -13 INFO(2) = LRHS_CNTR_MASTER_ROOT IF (LP > 0 ) & write(LP,*) ' Error allocating, real array ', & 'of size before SMUMPS_FACTO_ROOT', & LRHS_CNTR_MASTER_ROOT CALL MUMPS_ABORT() ENDIF FWD_LOCAL_N_RHS = numroc(KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL) FWD_LOCAL_N_RHS = max(1,FWD_LOCAL_N_RHS) CALL SMUMPS_GATHER_ROOT( MYID_NODES, & root%TOT_ROOT_SIZE, KEEP(253), & root%RHS_CNTR_MASTER_ROOT(1), LOCAL_M, & FWD_LOCAL_N_RHS, root%MBLOCK, root%NBLOCK, & root%RHS_ROOT(1,1), MASTER_ROOT, & root%NPROW, root%NPCOL, COMM_NODES ) & ENDIF ELSE IF (KEEP(19).NE.0) THEN CALL MPI_REDUCE(KEEP(109), GLOBK109, 1, & MPI_INTEGER, MPI_SUM, & MASTER_ROOT, & COMM_NODES, IERR) ENDIF IF (ROOT_OWNER) THEN IPOSROOT = PTLUST(STEP(KEEP(20))) NFRONT = IW(IPOSROOT+KEEP(IXSZ)+3) NFRONT8 = int(NFRONT,8) IPOSROOTROWINDICES=IPOSROOT+6+KEEP(IXSZ)+ & IW(IPOSROOT+5+KEEP(IXSZ)) NTOTPV = NTOTPV + NFRONT NMAXNPIV = max(NMAXNPIV,NFRONT) END IF IF (ROOT_OWNER.AND.KEEP(60).NE.0) THEN ITMP8 = NFRONT8*NFRONT8 IF ( PTRFAC(STEP(KEEP(20))) .EQ. POSFAC - & ITMP8 ) THEN POSFAC = POSFAC - ITMP8 LRLUS = LRLUS + ITMP8 LRLU = LRLUS + ITMP8 KEEP8(69) = KEEP8(69) - ITMP8 CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-ITMP8,KEEP,KEEP8,LRLUS) ENDIF ENDIF END IF END IF END IF IF ( KEEP(38) .NE. 0 ) THEN IF (MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(KEEP(38))),KEEP(199)) & ) THEN MAXFRT = max ( MAXFRT, root%TOT_ROOT_SIZE) END IF END IF RETURN END SUBROUTINE SMUMPS_FAC_PAR SUBROUTINE SMUMPS_CHANGE_HEADER( HEADER, KEEP253 ) INTEGER HEADER( 6 ), KEEP253 INTEGER NFRONT, NASS NFRONT = HEADER(1) IF ( HEADER(2) .ne. 0 ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 1 :',HEADER(2) CALL MUMPS_ABORT() END IF NASS = abs( HEADER( 3 ) ) IF ( NASS .NE. abs( HEADER( 4 ) ) ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 2 :',HEADER(3:4) CALL MUMPS_ABORT() END IF IF ( NASS+KEEP253 .NE. NFRONT ) THEN WRITE(*,*) ' *** CHG_HEADER ERROR 3 : not root', & NASS, KEEP253, NFRONT CALL MUMPS_ABORT() END IF HEADER( 1 ) = KEEP253 HEADER( 2 ) = 0 HEADER( 3 ) = NFRONT HEADER( 4 ) = NFRONT-KEEP253 RETURN END SUBROUTINE SMUMPS_CHANGE_HEADER END MODULE SMUMPS_FAC_PAR_M MUMPS_5.4.1/src/cfac_mem_dynamic.F0000664000175000017500000005241314102210524017056 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_DYNAMIC_MEMORY_M CONTAINS SUBROUTINE CMUMPS_DM_SET_DYNPTR( CB_STATE, A, LA, & PAMASTER_OR_PTRAST, IXXD, & IXXR, SON_A, IACHK, RECSIZE ) IMPLICIT NONE INTEGER, INTENT(IN) :: CB_STATE INTEGER, INTENT(IN) :: IXXR(2), IXXD(2) INTEGER(8), INTENT(IN) :: LA, PAMASTER_OR_PTRAST COMPLEX, INTENT(IN), TARGET :: A( LA ) #if defined(MUMPS_F2003) COMPLEX, POINTER, DIMENSION(:), INTENT(OUT) :: SON_A #else COMPLEX, POINTER, DIMENSION(:) :: SON_A #endif INTEGER(8), INTENT(OUT) :: IACHK, RECSIZE IF ( CMUMPS_DM_IS_DYNAMIC( IXXD ) ) THEN CALL MUMPS_GETI8(RECSIZE, IXXD) CALL CMUMPS_DM_SET_PTR( PAMASTER_OR_PTRAST, RECSIZE, SON_A ) IACHK = 1_8 ELSE CALL MUMPS_GETI8(RECSIZE, IXXR) IACHK = PAMASTER_OR_PTRAST SON_A => A ENDIF RETURN END SUBROUTINE CMUMPS_DM_SET_DYNPTR SUBROUTINE CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP28, & KEEP199, INODE, CB_STATE, IXXD, & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IMPLICIT NONE INTEGER, INTENT(in) :: KEEP28, N, SLAVEF, MYID, INODE, CB_STATE INTEGER, INTENT(in) :: KEEP199 INTEGER, INTENT(in) :: IXXD(2) INTEGER, INTENT(in) :: DAD(KEEP28) INTEGER, INTENT(in) :: STEP(N) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28) LOGICAL, INTENT(out) :: IS_PAMASTER, IS_PTRAST INTEGER(8), INTENT(in) :: PAMASTER(KEEP28), PTRAST(KEEP28) INTEGER(8), INTENT(in) :: RCURRENT LOGICAL :: DAD_TYPE2_NOT_ON_MYID INTEGER :: NODETYPE, DADTYPE INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE IS_PAMASTER = .FALSE. IS_PTRAST = .FALSE. IF (CB_STATE .EQ. S_FREE) THEN RETURN ENDIF NODETYPE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), KEEP199) DADTYPE=-99999 DAD_TYPE2_NOT_ON_MYID = .FALSE. IF (DAD(STEP(INODE)) .NE. 0) THEN DADTYPE= MUMPS_TYPENODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199) IF (DADTYPE .EQ. 2 .AND. & MUMPS_PROCNODE( & PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP199).NE.MYID & ) THEN DAD_TYPE2_NOT_ON_MYID = .TRUE. ENDIF ENDIF IF (CMUMPS_DM_ISBAND(CB_STATE)) THEN IS_PTRAST=.TRUE. ELSE IF (NODETYPE.EQ.1 & .AND. MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP199).EQ.MYID & .AND. DAD_TYPE2_NOT_ON_MYID) & THEN IS_PTRAST=.TRUE. ELSE IS_PAMASTER=.TRUE. ENDIF RETURN END SUBROUTINE CMUMPS_DM_PAMASTERORPTRAST LOGICAL FUNCTION CMUMPS_DM_ISBAND(XXSTATE) INTEGER, INTENT(IN) :: XXSTATE INCLUDE 'mumps_headers.h' SELECT CASE (XXSTATE) CASE(S_NOTFREE, S_CB1COMP); CMUMPS_DM_ISBAND = .FALSE. CASE(S_ACTIVE, S_ALL, & S_NOLCBCONTIG, S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED); CMUMPS_DM_ISBAND = .TRUE. CASE(S_FREE); CMUMPS_DM_ISBAND = .FALSE. CASE DEFAULT; WRITE(*,*) "Wrong state during CMUMPS_DM_ISBAND", XXSTATE CALL MUMPS_ABORT() END SELECT RETURN END FUNCTION CMUMPS_DM_ISBAND LOGICAL FUNCTION CMUMPS_DM_IS_DYNAMIC(IXXD) INTEGER :: IXXD(2) INTEGER(8) :: DYN_SIZE CALL MUMPS_GETI8( DYN_SIZE, IXXD ) CMUMPS_DM_IS_DYNAMIC = DYN_SIZE > 0_8 RETURN END FUNCTION CMUMPS_DM_IS_DYNAMIC SUBROUTINE CMUMPS_DM_FAC_UPD_DYN_MEMCNTS & ( MEM_COUNT_ALLOCATED, ATOMIC_UPDATES, KEEP8, & IFLAG, IERROR, K69UPD_ARG ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_ALLOCATED INTEGER(8), INTENT(INOUT) :: KEEP8(150) LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER, INTENT(INOUT) :: IFLAG, IERROR LOGICAL, INTENT(IN), OPTIONAL :: K69UPD_ARG LOGICAL K69UPD INTEGER(8) :: KEEP8TMPCOPY K69UPD = .TRUE. IF (present(K69UPD_ARG)) THEN IF ( .NOT. K69UPD_ARG ) THEN K69UPD = .FALSE. ENDIF ENDIF IF (MEM_COUNT_ALLOCATED.GT.0) THEN IF (ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP8(73)) ENDIF IF ( KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP8TMPCOPY-KEEP8(75)), IERROR) ENDIF IF ( K69UPD ) THEN IF ( ATOMIC_UPDATES ) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ELSE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED KEEP8(68) = max(KEEP8(69), KEEP8(68)) ENDIF ENDIF ELSE IF (ATOMIC_UPDATES) THEN !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC IF ( K69UPD ) THEN !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED !$OMP END ATOMIC ENDIF ELSE KEEP8(73) = KEEP8(73) + MEM_COUNT_ALLOCATED IF ( K69UPD ) THEN KEEP8(69) = KEEP8(69) + MEM_COUNT_ALLOCATED ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_DM_FAC_UPD_DYN_MEMCNTS SUBROUTINE CMUMPS_DM_FAC_ALLOC_ALLOWED & (MEM_COUNT_TO_ALLOCATE, KEEP8, & IFLAG, IERROR) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MEM_COUNT_TO_ALLOCATE INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR IF ( KEEP8(73) + MEM_COUNT_TO_ALLOCATE & .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & KEEP8(73) + MEM_COUNT_TO_ALLOCATE -KEEP8(75), & IERROR ) ENDIF RETURN END SUBROUTINE CMUMPS_DM_FAC_ALLOC_ALLOWED SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) !$ USE OMP_LIB USE CMUMPS_LOAD, ONLY : CMUMPS_LOAD_MEM_UPDATE IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE, TYPEINODE, CB_STATE INTEGER(8) :: RCURRENT, RCURRENT_SIZE, SIZEHOLE INTEGER(8) :: KEEP8TMPCOPY LOGICAL :: MOVE2DYNAMIC LOGICAL :: SSARBRDAD INTEGER(8) :: TMP_ADDRESS, ITMP8 INTEGER(8) :: I8 COMPLEX, DIMENSION(:), POINTER :: DYNAMIC_CB LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER :: allocok !$ INTEGER(8) :: CHUNK8 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP LOGICAL :: IFLAG_M13_OCCURED, IFLAG_M19_OCCURED INTEGER(8) :: MIN_SIZE_M13, MIN_SIZE_M19 INTEGER, EXTERNAL :: MUMPS_TYPENODE IF ( STRATEGY .EQ. 0 ) THEN IF (LRLUS.LT.SIZER_NEEDED) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF RETURN ENDIF IFLAG_M13_OCCURED = .FALSE. MIN_SIZE_M13 = huge(MIN_SIZE_M13) IFLAG_M19_OCCURED = .FALSE. MIN_SIZE_M19 = huge(MIN_SIZE_M19) !$ NOMP = OMP_GET_MAX_THREADS() ICURRENT = IWPOSCB + 1 RCURRENT = IPTRLU + 1 IF (STRATEGY.EQ.1 .AND. SIZER_NEEDED.LE.LRLUS) GOTO 500 IF (( KEEP8(73) + SIZER_NEEDED-LRLUS).GT. & KEEP8(75)) THEN IFLAG = -19 CALL MUMPS_SET_IERROR & (KEEP8(73) + SIZER_NEEDED-LRLUS-KEEP8(75), IERROR) GOTO 500 ENDIF DO WHILE (ICURRENT .NE. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT+XXR)) CALL CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, & IW(ICURRENT+XXD:ICURRENT+XXD+1), & STEP, DAD, PROCNODE_STEPS, & RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF ( CB_STATE .NE. S_FREE .AND. & .NOT. CMUMPS_DM_IS_DYNAMIC(IW(ICURRENT+XXD)) ) THEN TYPEINODE = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IF (STRATEGY .EQ. -1) THEN MOVE2DYNAMIC = .FALSE. MOVE2DYNAMIC = MOVE2DYNAMIC .OR. & CB_STATE .EQ. S_NOLCBCONTIG .OR. & CB_STATE .EQ. S_NOLCBNOCONTIG .OR. & CB_STATE .EQ. S_NOLCLEANED .OR. & CB_STATE .EQ. S_ALL .OR. & CB_STATE .EQ. S_ACTIVE ELSE IF (STRATEGY .EQ. 2 .OR. STRATEGY .EQ. 3) THEN MOVE2DYNAMIC = .TRUE. MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (TYPEINODE.NE.3) ELSE IF (STRATEGY .EQ. 1) THEN MOVE2DYNAMIC = .FALSE. IF (LRLUS.GT.SIZER_NEEDED) GOTO 500 IF (TYPEINODE.EQ.3) GOTO 100 MOVE2DYNAMIC = MOVE2DYNAMIC.OR..TRUE. ELSE WRITE(*,*) "Internal error in CMUMPS_DM_CBSTATIC2DYNAMIC", & MOVE2DYNAMIC CALL MUMPS_ABORT() ENDIF MOVE2DYNAMIC = MOVE2DYNAMIC .AND. (RCURRENT_SIZE .NE. 0_8) MOVE2DYNAMIC = MOVE2DYNAMIC .AND. & .NOT. ((ICURRENT.EQ.IWPOSCB + 1).AND.(SKIP_TOP_STACK)) IF (STRATEGY .NE. 3) THEN IF ( KEEP(405) .EQ. 1 ) THEN !$OMP ATOMIC READ KEEP8TMPCOPY = KEEP8(73) !$OMP END ATOMIC ELSE KEEP8TMPCOPY = KEEP8(73) ENDIF IF ( RCURRENT_SIZE + KEEP8TMPCOPY .GT. KEEP8(75) ) THEN IFLAG_M19_OCCURED= .TRUE. MIN_SIZE_M19 = min( MIN_SIZE_M19, & RCURRENT_SIZE+KEEP8(73)-KEEP8(75) ) MOVE2DYNAMIC = .FALSE. ENDIF ENDIF IF ( MOVE2DYNAMIC ) THEN ALLOCATE(DYNAMIC_CB(RCURRENT_SIZE), stat=allocok) IF (allocok .GT. 0) THEN IF ( (STRATEGY .NE. 1).OR. & (SIZER_NEEDED-LRLUS).GE.RCURRENT_SIZE) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 ENDIF IFLAG_M13_OCCURED = .TRUE. MIN_SIZE_M13 = min(MIN_SIZE_M13, RCURRENT_SIZE) GOTO 100 ENDIF SIZEHOLE=0_8 IF (KEEP(216).NE.3) THEN CALL CMUMPS_SIZEFREEINREC( IW(ICURRENT), & LIW-ICURRENT+1, SIZEHOLE, KEEP(IXSZ)) ENDIF CALL MUMPS_STOREI8(RCURRENT_SIZE,IW(ICURRENT+XXD)) CALL MUMPS_ADDR_C(DYNAMIC_CB(1), TMP_ADDRESS) IF (IS_PTRAST) THEN PTRAST(STEP(INODE)) = TMP_ADDRESS ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE)) = TMP_ADDRESS ELSE WRITE(*,*) & "Internal error 3 in CMUMPS_DM_CBSTATIC2DYNAMIC", & RCURRENT, PTRAST(STEP(INODE)), PAMASTER(STEP(INODE)) CALL MUMPS_ABORT() ENDIF ITMP8 = (RCURRENT_SIZE-SIZEHOLE) LRLUS = LRLUS + ITMP8 IF (KEEP(405).EQ.1) THEN IF (SIZEHOLE .NE. 0_8) THEN !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max( KEEP8(68), KEEP8TMPCOPY ) !$OMP END ATOMIC ENDIF ELSE KEEP8(69) = KEEP8(69) + SIZEHOLE KEEP8(68) = max( KEEP8(68), KEEP8(69) ) ENDIF CALL MUMPS_SET_SSARBR_DAD(SSARBRDAD, INODE, & DAD, N, KEEP(28), & STEP, PROCNODE_STEPS, KEEP(199)) CALL CMUMPS_LOAD_MEM_UPDATE( SSARBRDAD, .FALSE., & LA - LRLUS, 0_8, -(RCURRENT_SIZE-SIZEHOLE), & KEEP, KEEP8, LRLUS) IF (ICURRENT .EQ. IWPOSCB+1) THEN IPTRLU = IPTRLU + RCURRENT_SIZE LRLU = LRLU + RCURRENT_SIZE CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXR)) ENDIF IF (STRATEGY .NE. 3) THEN CALL CMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & RCURRENT_SIZE, KEEP(405).EQ.1, KEEP8, & IFLAG, IERROR, .FALSE.) IF (IFLAG.LT.0) GOTO 500 ENDIF !$ CHUNK8 = max( int(KEEP(361),8), !$ & (RCURRENT_SIZE+NOMP-1) / NOMP) !$ OMP_FLAG = ( (RCURRENT_SIZE > int(KEEP(361),8)) !$ & .AND.(NOMP.GT.1) !$ & ) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (OMP_FLAG) DO I8=1_8, RCURRENT_SIZE DYNAMIC_CB(I8) = A(RCURRENT+I8-1_8) ENDDO !$OMP END PARALLEL DO ENDIF ENDIF 100 CONTINUE RCURRENT = RCURRENT + RCURRENT_SIZE ICURRENT = ICURRENT + IW(ICURRENT+XXI) END DO IF (LRLUS.LT.SIZER_NEEDED) THEN IF (IFLAG_M19_OCCURED) THEN IFLAG = -19 CALL MUMPS_SET_IERROR(MIN_SIZE_M19, IERROR) ELSE IF (IFLAG_M13_OCCURED) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(MIN_SIZE_M13, IERROR) ELSE IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES INCLUDE 'mumps_headers.h' INTEGER :: ICURRENT, INODE INTEGER :: CB_STATE INTEGER(8) :: DYN_SIZE, TMP_ADDRESS INTEGER(8), PARAMETER :: RDUMMY = -987654 LOGICAL :: IS_PAMASTER, IS_PTRAST COMPLEX, DIMENSION(:), POINTER :: TMP_PTR ICURRENT = IWPOSCB + 1 IF (KEEP8(73) .NE. 0_8) THEN DO WHILE (ICURRENT .LT. LIW-KEEP(IXSZ)+1) INODE = IW(ICURRENT+XXN) CB_STATE = IW(ICURRENT+XXS) IF (CB_STATE.NE.S_FREE) THEN CALL MUMPS_GETI8( DYN_SIZE, IW(ICURRENT+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL CMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, KEEP(28), & KEEP(199), INODE, CB_STATE, IW(ICURRENT+XXD), & STEP, DAD, PROCNODE_STEPS, & RDUMMY, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PAMASTER) THEN TMP_ADDRESS = PAMASTER(STEP(INODE)) ELSE IF (IS_PTRAST) THEN TMP_ADDRESS = PTRAST(STEP(INODE)) ELSE WRITE(*,*) "Internal error 1 in CMUMPS_DM_FREEALLDYNAMICCB" & , IS_PTRAST, IS_PAMASTER ENDIF CALL CMUMPS_DM_SET_PTR(TMP_ADDRESS, DYN_SIZE, TMP_PTR) CALL CMUMPS_DM_FREE_BLOCK( TMP_PTR, DYN_SIZE, & ATOMIC_UPDATES, KEEP8) CALL MUMPS_STOREI8(0_8, IW(ICURRENT+XXD)) ENDIF ENDIF ICURRENT = ICURRENT + IW(ICURRENT+XXI) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB SUBROUTINE CMUMPS_DM_SET_PTR(ADDRESS, SIZFR8, CBPTR) USE CMUMPS_STATIC_PTR_M, ONLY : CMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER(8), INTENT(IN) :: ADDRESS, SIZFR8 #if defined(MUMPS_F2003) COMPLEX, DIMENSION(:), POINTER, INTENT(out) :: CBPTR #else COMPLEX, DIMENSION(:), POINTER :: CBPTR #endif !$OMP CRITICAL(STATIC_PTR_ACCESS) CALL CMUMPS_SET_TMP_PTR_C( ADDRESS, SIZFR8 ) CALL CMUMPS_GET_TMP_PTR( CBPTR ) !$OMP END CRITICAL(STATIC_PTR_ACCESS) RETURN END SUBROUTINE CMUMPS_DM_SET_PTR SUBROUTINE CMUMPS_DM_FREE_BLOCK( DYNPTR, SIZFR8, & ATOMIC_UPDATES, KEEP8 ) IMPLICIT NONE COMPLEX, POINTER, DIMENSION(:) :: DYNPTR INTEGER(8) :: SIZFR8 LOGICAL, INTENT(IN) :: ATOMIC_UPDATES INTEGER(8) :: KEEP8(150) INTEGER IDUMMY DEALLOCATE(DYNPTR) NULLIFY(DYNPTR) CALL CMUMPS_DM_FAC_UPD_DYN_MEMCNTS ( & -SIZFR8, ATOMIC_UPDATES, KEEP8, IDUMMY, IDUMMY) RETURN END SUBROUTINE CMUMPS_DM_FREE_BLOCK END MODULE CMUMPS_DYNAMIC_MEMORY_M SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB_I( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_FREEALLDYNAMICCB IMPLICIT NONE INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(in) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) LOGICAL, INTENT(in) :: ATOMIC_UPDATES CALL CMUMPS_DM_FREEALLDYNAMICCB( MYID, N, SLAVEF, & KEEP, KEEP8, IW, LIW, IWPOSCB, IWPOS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, ATOMIC_UPDATES ) RETURN END SUBROUTINE CMUMPS_DM_FREEALLDYNAMICCB_I SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC_I( & STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_CBSTATIC2DYNAMIC IMPLICIT NONE INTEGER, INTENT(in) :: STRATEGY INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: N, SLAVEF, KEEP(500) INTEGER, INTENT(in) :: MYID INTEGER(8), INTENT(inout) :: KEEP8(150) INTEGER :: IWPOS, IWPOSCB, LIW INTEGER, INTENT(inout) :: IW( LIW ) INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS COMPLEX, INTENT(in) :: A( LA ) INTEGER, INTENT(in) :: STEP(N) INTEGER(8), INTENT(inout) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER, INTENT(inout) :: IFLAG, IERROR CALL CMUMPS_DM_CBSTATIC2DYNAMIC( STRATEGY, & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) RETURN END SUBROUTINE CMUMPS_DM_CBSTATIC2DYNAMIC_I MUMPS_5.4.1/src/smumps_ooc_buffer.F0000664000175000017500000004327314102210521017336 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_OOC_BUFFER USE MUMPS_OOC_COMMON IMPLICIT NONE PUBLIC INTEGER FIRST_HBUF,SECOND_HBUF PARAMETER (FIRST_HBUF=0, SECOND_HBUF=1) INTEGER,SAVE :: OOC_FCT_TYPE_LOC REAL, DIMENSION(:),ALLOCATABLE :: BUF_IO LOGICAL,SAVE :: PANEL_FLAG INTEGER,SAVE :: EARLIEST_WRITE_MIN_SIZE INTEGER(8),SAVE,DIMENSION(:), ALLOCATABLE :: & I_SHIFT_FIRST_HBUF, I_SHIFT_SECOND_HBUF, & I_SHIFT_CUR_HBUF, I_REL_POS_CUR_HBUF INTEGER, SAVE, DIMENSION(:), ALLOCATABLE :: & LAST_IOREQUEST, CUR_HBUF INTEGER, DIMENSION(:),ALLOCATABLE :: I_CUR_HBUF_NEXTPOS INTEGER,SAVE :: I_CUR_HBUF_FSTPOS, & I_SUB_HBUF_FSTPOS INTEGER(8) :: BufferEmpty PARAMETER (BufferEmpty=-1_8) INTEGER(8), DIMENSION(:),ALLOCATABLE :: NextAddVirtBuffer INTEGER(8), DIMENSION(:),ALLOCATABLE :: FIRST_VADDR_IN_BUF CONTAINS SUBROUTINE SMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IMPLICIT NONE INTEGER TYPEF_ARG SELECT CASE(CUR_HBUF(TYPEF_ARG)) CASE (FIRST_HBUF) CUR_HBUF(TYPEF_ARG) = SECOND_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_SECOND_HBUF(TYPEF_ARG) CASE (SECOND_HBUF) CUR_HBUF(TYPEF_ARG) = FIRST_HBUF I_SHIFT_CUR_HBUF(TYPEF_ARG) = & I_SHIFT_FIRST_HBUF(TYPEF_ARG) END SELECT IF(.NOT.PANEL_FLAG)THEN I_SUB_HBUF_FSTPOS =I_CUR_HBUF_FSTPOS I_CUR_HBUF_FSTPOS =I_CUR_HBUF_NEXTPOS(TYPEF_ARG) ENDIF I_REL_POS_CUR_HBUF(TYPEF_ARG) = 1_8 RETURN END SUBROUTINE SMUMPS_OOC_NEXT_HBUF SUBROUTINE SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_ARG,IERR) IMPLICIT NONE INTEGER TYPEF_ARG INTEGER NEW_IOREQUEST INTEGER IERR IERR=0 CALL SMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL MUMPS_WAIT_REQUEST(LAST_IOREQUEST(TYPEF_ARG),IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*) MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF LAST_IOREQUEST(TYPEF_ARG) = NEW_IOREQUEST CALL SMUMPS_OOC_NEXT_HBUF(TYPEF_ARG) IF(PANEL_FLAG)THEN NextAddVirtBuffer(TYPEF_ARG)=BufferEmpty ENDIF RETURN END SUBROUTINE SMUMPS_OOC_DO_IO_AND_CHBUF SUBROUTINE SMUMPS_OOC_BUF_CLEAN_PENDING(IERR) IMPLICIT NONE INTEGER, intent(out) :: IERR INTEGER TYPEF_LAST INTEGER TYPEF_LOC IERR = 0 TYPEF_LAST = OOC_NB_FILE_TYPE DO TYPEF_LOC = 1, TYPEF_LAST IERR=0 CALL SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF IERR=0 CALL SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF ENDDO RETURN END SUBROUTINE SMUMPS_OOC_BUF_CLEAN_PENDING SUBROUTINE SMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF_ARG,IOREQUEST, & IERR) IMPLICIT NONE INTEGER IOREQUEST,IERR INTEGER TYPEF_ARG INTEGER FIRST_INODE INTEGER(8) :: FROM_BUFIO_POS, SIZE INTEGER TYPE INTEGER ADDR_INT1,ADDR_INT2 INTEGER(8) TMP_VADDR INTEGER SIZE_INT1,SIZE_INT2 IERR=0 IF (I_REL_POS_CUR_HBUF(TYPEF_ARG) == 1_8) THEN IOREQUEST=-1 RETURN END IF IF(PANEL_FLAG)THEN TYPE=TYPEF_ARG-1 FIRST_INODE=-9999 TMP_VADDR=FIRST_VADDR_IN_BUF(TYPEF_ARG) ELSE TYPE=FCT FIRST_INODE = & OOC_INODE_SEQUENCE(I_CUR_HBUF_FSTPOS,TYPEF_ARG) TMP_VADDR=OOC_VADDR(STEP_OOC(FIRST_INODE),TYPEF_ARG) ENDIF FROM_BUFIO_POS=I_SHIFT_CUR_HBUF(TYPEF_ARG)+1_8 SIZE = I_REL_POS_CUR_HBUF(TYPEF_ARG)-1_8 CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(ADDR_INT1,ADDR_INT2, & TMP_VADDR) CALL MUMPS_OOC_CONVERT_BIGINTTO2INT(SIZE_INT1,SIZE_INT2, & SIZE) CALL MUMPS_LOW_LEVEL_WRITE_OOC_C(LOW_LEVEL_STRAT_IO, & BUF_IO(FROM_BUFIO_POS),SIZE_INT1,SIZE_INT2, & FIRST_INODE,IOREQUEST, & TYPE,ADDR_INT1,ADDR_INT2,IERR) IF(IERR.LT.0)THEN IF (ICNTL1>0) & WRITE(ICNTL1,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ENDIF RETURN END SUBROUTINE SMUMPS_OOC_WRT_CUR_BUF2DISK SUBROUTINE SMUMPS_INIT_OOC_BUF(I1,I2,IERR) IMPLICIT NONE INTEGER I1,I2,IERR INTEGER allocok IERR=0 PANEL_FLAG=.FALSE. IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF DIM_BUF_IO = int(KEEP_OOC(100),8) ALLOCATE(I_SHIFT_FIRST_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_SECOND_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_SHIFT_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(I_REL_POS_CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(LAST_IOREQUEST(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF ALLOCATE(CUR_HBUF(OOC_NB_FILE_TYPE), & stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 I2 = OOC_NB_FILE_TYPE IERR=-1 RETURN ENDIF OOC_FCT_TYPE_LOC=OOC_NB_FILE_TYPE ALLOCATE(BUF_IO(DIM_BUF_IO), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in SMUMPS_INIT_OOC' ENDIF I1 = -13 CALL MUMPS_SET_IERROR(DIM_BUF_IO, I2) RETURN ENDIF PANEL_FLAG=(KEEP_OOC(201).EQ.1) IF (PANEL_FLAG) THEN IERR=0 KEEP_OOC(228)=0 IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF ALLOCATE(AddVirtLibre(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF AddVirtLibre(1:OOC_NB_FILE_TYPE)=0_8 IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF ALLOCATE(NextAddVirtBuffer(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF NextAddVirtBuffer (1:OOC_NB_FILE_TYPE) = BufferEmpty IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ALLOCATE(FIRST_VADDR_IN_BUF(OOC_NB_FILE_TYPE), stat=allocok) IF (allocok > 0) THEN IF (ICNTL1>0) THEN WRITE(ICNTL1,*) 'PB allocation in ', & 'SMUMPS_INIT_OOC_BUF_PANEL' ENDIF IERR=-1 I1=-13 I2=OOC_NB_FILE_TYPE RETURN ENDIF CALL SMUMPS_OOC_INIT_DB_BUFFER_PANEL() ELSE CALL SMUMPS_OOC_INIT_DB_BUFFER() ENDIF KEEP_OOC(223)=int(HBUF_SIZE) RETURN END SUBROUTINE SMUMPS_INIT_OOC_BUF SUBROUTINE SMUMPS_END_OOC_BUF() IMPLICIT NONE IF(allocated(BUF_IO))THEN DEALLOCATE(BUF_IO) ENDIF IF(allocated(I_SHIFT_FIRST_HBUF))THEN DEALLOCATE(I_SHIFT_FIRST_HBUF) ENDIF IF(allocated(I_SHIFT_SECOND_HBUF))THEN DEALLOCATE(I_SHIFT_SECOND_HBUF) ENDIF IF(allocated(I_SHIFT_CUR_HBUF))THEN DEALLOCATE(I_SHIFT_CUR_HBUF) ENDIF IF(allocated(I_REL_POS_CUR_HBUF))THEN DEALLOCATE(I_REL_POS_CUR_HBUF) ENDIF IF(allocated(LAST_IOREQUEST))THEN DEALLOCATE(LAST_IOREQUEST) ENDIF IF(allocated(CUR_HBUF))THEN DEALLOCATE(CUR_HBUF) ENDIF IF(PANEL_FLAG)THEN IF(allocated(NextAddVirtBuffer))THEN DEALLOCATE(NextAddVirtBuffer) ENDIF IF(allocated(AddVirtLibre))THEN DEALLOCATE(AddVirtLibre) ENDIF IF(allocated(FIRST_VADDR_IN_BUF))THEN DEALLOCATE(FIRST_VADDR_IN_BUF) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_END_OOC_BUF SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER() IMPLICIT NONE OOC_FCT_TYPE_LOC=1 HBUF_SIZE = DIM_BUF_IO / int(2,kind=kind(DIM_BUF_IO)) EARLIEST_WRITE_MIN_SIZE = 0 I_SHIFT_FIRST_HBUF(OOC_FCT_TYPE_LOC) = 0_8 I_SHIFT_SECOND_HBUF(OOC_FCT_TYPE_LOC) = HBUF_SIZE LAST_IOREQUEST(OOC_FCT_TYPE_LOC) = -1 I_CUR_HBUF_NEXTPOS = 1 I_CUR_HBUF_FSTPOS = 1 I_SUB_HBUF_FSTPOS = 1 CUR_HBUF(OOC_FCT_TYPE_LOC) = SECOND_HBUF CALL SMUMPS_OOC_NEXT_HBUF(OOC_FCT_TYPE_LOC) END SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER SUBROUTINE SMUMPS_OOC_COPY_DATA_TO_BUFFER(BLOCK,SIZE_OF_BLOCK, & IERR) IMPLICIT NONE INTEGER(8) :: SIZE_OF_BLOCK REAL BLOCK(SIZE_OF_BLOCK) INTEGER, intent(out) :: IERR INTEGER(8) :: I IERR=0 IF (I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + & SIZE_OF_BLOCK <= HBUF_SIZE + 1_8) THEN ELSE CALL SMUMPS_OOC_DO_IO_AND_CHBUF(OOC_FCT_TYPE_LOC,IERR) IF(IERR.LT.0)THEN RETURN ENDIF END IF DO I = 1_8, SIZE_OF_BLOCK BUF_IO(I_SHIFT_CUR_HBUF(OOC_FCT_TYPE_LOC) + & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + I - 1_8) = & BLOCK(I) END DO I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) = & I_REL_POS_CUR_HBUF(OOC_FCT_TYPE_LOC) + SIZE_OF_BLOCK RETURN END SUBROUTINE SMUMPS_OOC_COPY_DATA_TO_BUFFER SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER_PANEL() IMPLICIT NONE INTEGER(8) :: DIM_BUF_IO_L_OR_U INTEGER TYPEF, TYPEF_LAST INTEGER NB_DOUBLE_BUFFERS TYPEF_LAST = OOC_NB_FILE_TYPE NB_DOUBLE_BUFFERS = OOC_NB_FILE_TYPE DIM_BUF_IO_L_OR_U = DIM_BUF_IO / & int(NB_DOUBLE_BUFFERS,kind=kind(DIM_BUF_IO_L_OR_U)) IF(.NOT.STRAT_IO_ASYNC)THEN HBUF_SIZE = DIM_BUF_IO_L_OR_U ELSE HBUF_SIZE = DIM_BUF_IO_L_OR_U / 2_8 ENDIF DO TYPEF = 1, TYPEF_LAST LAST_IOREQUEST(TYPEF) = -1 IF (TYPEF == 1 ) THEN I_SHIFT_FIRST_HBUF(TYPEF) = 0_8 ELSE I_SHIFT_FIRST_HBUF(TYPEF) = DIM_BUF_IO_L_OR_U ENDIF IF(.NOT.STRAT_IO_ASYNC)THEN I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) ELSE I_SHIFT_SECOND_HBUF(TYPEF) = I_SHIFT_FIRST_HBUF(TYPEF) + & HBUF_SIZE ENDIF CUR_HBUF(TYPEF) = SECOND_HBUF CALL SMUMPS_OOC_NEXT_HBUF(TYPEF) ENDDO I_CUR_HBUF_NEXTPOS = 1 RETURN END SUBROUTINE SMUMPS_OOC_INIT_DB_BUFFER_PANEL SUBROUTINE SMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IMPLICIT NONE INTEGER, INTENT(in) :: TYPEF INTEGER, INTENT(out) :: IERR INTEGER IFLAG INTEGER NEW_IOREQUEST IERR=0 CALL MUMPS_TEST_REQUEST_C(LAST_IOREQUEST(TYPEF),IFLAG, & IERR) IF (IFLAG.EQ.1) THEN IERR = 0 CALL SMUMPS_OOC_WRT_CUR_BUF2DISK(TYPEF, & NEW_IOREQUEST, & IERR) IF(IERR.LT.0)THEN RETURN ENDIF LAST_IOREQUEST(TYPEF) = NEW_IOREQUEST CALL SMUMPS_OOC_NEXT_HBUF(TYPEF) NextAddVirtBuffer(TYPEF)=BufferEmpty RETURN ELSE IF(IFLAG.LT.0)THEN WRITE(*,*)MYID_OOC,': ',ERR_STR_OOC(1:DIM_ERR_STR_OOC) RETURN ELSE IERR = 1 RETURN ENDIF END SUBROUTINE SMUMPS_OOC_TRYIO_CHBUF_PANEL SUBROUTINE SMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,VADDR) IMPLICIT NONE INTEGER(8), INTENT(in) :: VADDR INTEGER, INTENT(in) :: TYPEF IF(I_REL_POS_CUR_HBUF(TYPEF).EQ.1_8)THEN FIRST_VADDR_IN_BUF(TYPEF)=VADDR ENDIF RETURN END SUBROUTINE SMUMPS_OOC_UPD_VADDR_CUR_BUF SUBROUTINE SMUMPS_COPY_LU_TO_BUFFER( STRAT, TYPEF, MonBloc, & AFAC, LAFAC, & AddVirtCour, IPIVBEG, IPIVEND, LPANELeff, & IERR) IMPLICIT NONE INTEGER, INTENT(IN) :: TYPEF, IPIVBEG, IPIVEND, STRAT INTEGER(8), INTENT(IN) :: LAFAC REAL, INTENT(IN) :: AFAC(LAFAC) INTEGER(8), INTENT(IN) :: AddVirtCour TYPE(IO_BLOCK), INTENT(IN) :: MonBloc INTEGER, INTENT(OUT):: LPANELeff INTEGER, INTENT(OUT):: IERR INTEGER :: II, NBPIVeff INTEGER(8) :: IPOS, IDIAG, IDEST INTEGER(8) :: DeltaIPOS INTEGER :: StrideIPOS IERR=0 IF (STRAT.NE.STRAT_WRITE_MAX.AND.STRAT.NE.STRAT_TRY_WRITE) THEN write(6,*) ' SMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented ' CALL MUMPS_ABORT() ENDIF NBPIVeff = IPIVEND - IPIVBEG + 1 IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IF (TYPEF.EQ.TYPEF_L) THEN LPANELeff = (MonBloc%NROW-IPIVBEG+1)*NBPIVeff ELSE LPANELeff = (MonBloc%NCOL-IPIVBEG+1)*NBPIVeff ENDIF ELSE LPANELeff = MonBloc%NROW*NBPIVeff ENDIF IF ( ( I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff - 1,8) & > & HBUF_SIZE ) & .OR. & ( (AddVirtCour.NE.NextAddVirtBuffer(TYPEF)) .AND. & (NextAddVirtBuffer(TYPEF).NE.BufferEmpty) ) & ) THEN IF (STRAT.EQ.STRAT_WRITE_MAX) THEN CALL SMUMPS_OOC_DO_IO_AND_CHBUF(TYPEF,IERR) ELSE IF (STRAT.EQ.STRAT_TRY_WRITE) THEN CALL SMUMPS_OOC_TRYIO_CHBUF_PANEL(TYPEF,IERR) IF (IERR.EQ.1) RETURN ELSE write(6,*) 'SMUMPS_COPY_LU_TO_BUFFER: STRAT Not implemented' ENDIF ENDIF IF (IERR < 0 ) THEN RETURN ENDIF IF (NextAddVirtBuffer(TYPEF).EQ. BufferEmpty) THEN CALL SMUMPS_OOC_UPD_VADDR_CUR_BUF (TYPEF,AddVirtCour) NextAddVirtBuffer(TYPEF) = AddVirtCour ENDIF IF (MonBloc%MASTER .AND. MonBloc%Typenode .NE. 3) THEN IDIAG = int(IPIVBEG-1,8)*int(MonBloc%NCOL,8) + int(IPIVBEG,8) IPOS = IDIAG IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (TYPEF.EQ.TYPEF_L) THEN DO II = IPIVBEG, IPIVEND CALL scopy(MonBloc%NROW-IPIVBEG+1, & AFAC(IPOS), MonBloc%NCOL, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NROW-IPIVBEG+1,8) IPOS = IPOS + 1_8 ENDDO ELSE DO II = IPIVBEG, IPIVEND CALL scopy(MonBloc%NCOL-IPIVBEG+1, & AFAC(IPOS), 1, & BUF_IO(IDEST), 1) IDEST = IDEST + int(MonBloc%NCOL-IPIVBEG+1,8) IPOS = IPOS + int(MonBloc%NCOL,8) ENDDO ENDIF ELSE IDEST = I_SHIFT_CUR_HBUF(TYPEF) + & I_REL_POS_CUR_HBUF(TYPEF) IF (MonBloc%Typenode.EQ.3) THEN DeltaIPOS = int(MonBloc%NROW,8) StrideIPOS = 1 ELSE DeltaIPOS = 1_8 StrideIPOS = MonBloc%NCOL ENDIF IPOS = 1_8 + int(IPIVBEG - 1,8) * DeltaIPOS DO II = IPIVBEG, IPIVEND CALL scopy(MonBloc%NROW, & AFAC(IPOS), StrideIPOS, & BUF_IO(IDEST), 1) IDEST = IDEST+int(MonBloc%NROW,8) IPOS = IPOS + DeltaIPOS ENDDO ENDIF I_REL_POS_CUR_HBUF(TYPEF) = & I_REL_POS_CUR_HBUF(TYPEF) + int(LPANELeff,8) NextAddVirtBuffer(TYPEF) = NextAddVirtBuffer(TYPEF) & + int(LPANELeff,8) RETURN END SUBROUTINE SMUMPS_COPY_LU_TO_BUFFER END MODULE SMUMPS_OOC_BUFFER MUMPS_5.4.1/src/zsol_lr.F0000664000175000017500000007074614102210525015316 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SOL_LR USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_LR_DATA_M, only: BLR_ARRAY IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_SOL_FWD_LR_SU & (INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES, & IW, IPOS_INIT, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_INIT, PCB_INIT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, N, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: LIW, IPOS_INIT, LRHSCOMP INTEGER, INTENT(IN) :: IW(LIW), POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, PPIV_INIT, PCB_INIT INTEGER, INTENT(IN) :: LD_WCBPIV, LD_WCBCB, NRHS, JBDEB, JBFIN COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX(kind=8), INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: I, NPARTSASS, NB_BLR , NELIM, LDADIAG, & DIAGSIZ_DYN, DIAGSIZ_STA, IBEG_BLR, IEND_BLR, & LD_CB, NELIM_GLOBAL, NRHS_B, IPOS, KCB INTEGER(8) :: PPIV, PCB INTEGER :: LAST_BLR COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NRHS_B = JBFIN-JBDEB+1 IF (MTYPE.EQ.1) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in ZMUMPS_SOL_FWD_SU_MASTER" ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ENDIF IF (NSLAVES.EQ.0 .OR. (KEEP(50).eq.0 .and. MTYPE .NE.1)) THEN LAST_BLR = NB_BLR ELSE LAST_BLR = NPARTSASS ENDIF IPOS = IPOS_INIT PPIV = PPIV_INIT NELIM_GLOBAL = & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(NPARTSASS+1) & - BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(NPARTSASS+1) DO I=1, NPARTSASS IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN PCB = PCB_INIT ELSE PCB = PPIV + int(DIAGSIZ_DYN,8) ENDIF IF ( DIAGSIZ_DYN.EQ.0) CYCLE NELIM = DIAGSIZ_STA - DIAGSIZ_DYN IF ( MTYPE .EQ. 1 ) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL END IF DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK CALL ZMUMPS_SOLVE_FWD_TRSOLVE (DIAG(1), int(size(DIAG),8), 1_8, & DIAGSIZ_DYN , LDADIAG, NRHS_B, WCB, LWCB, NPIV_GLOBAL, & PPIV, MTYPE, KEEP) IF (NELIM.GT.0) THEN KCB = int(PCB-PPIV_INIT+1) IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN LD_CB = LD_WCBCB ELSE LD_CB = LD_WCBPIV ENDIF IF (MTYPE.EQ.1) THEN IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL zgemm('T', 'N', NPIV_GLOBAL-KCB+1, NRHS_B, & DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL zgemm('T', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-KCB+1)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL zgemm('T', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ELSE IF (KCB.LE.NPIV_GLOBAL .AND. & KCB+NELIM-1.GT.NPIV_GLOBAL) THEN CALL zgemm('N', 'N', NPIV_GLOBAL-KCB+1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) CALL zgemm('N', 'N', KCB+NELIM-NPIV_GLOBAL-1, & NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-KCB+1), & DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB_INIT), LD_WCBCB) ELSE CALL zgemm('N', 'N', NELIM, NRHS_B, DIAGSIZ_DYN, MONE, & DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & WCB(PPIV), LD_WCBPIV, & ONE, WCB(PCB), LD_CB) ENDIF ENDIF ENDIF CALL ZMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LD_WCBPIV, PPIV_INIT, 1, & WCB, LWCB, LD_WCBCB, PCB_INIT, & PPIV, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, I, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., & IFLAG, IERROR) IF (IFLAG.LT.0) RETURN CALL ZMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, DIAGSIZ_DYN, LIELL, NELIM, NSLAVES, & PPIV, & IW, IPOS, LIW, & DIAG(1), int(size(DIAG),8), 1_8, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) PPIV = PPIV + int(DIAGSIZ_DYN,8) IPOS = IPOS + DIAGSIZ_DYN ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_FWD_LR_SU SUBROUTINE ZMUMPS_SOL_SLAVE_LR_U & (INODE, IWHDLR, NPIV_GLOBAL, & WCB, LWCB, & LDX, LDY, & PTRX_INIT, PTRY_INIT, & JBDEB, JBFIN, & MTYPE, KEEP, IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL INTEGER, INTENT(IN) :: MTYPE, KEEP(500) INTEGER(8), INTENT(IN) :: LWCB, PTRX_INIT, PTRY_INIT INTEGER, INTENT(IN) :: LDX, LDY, JBDEB, JBFIN COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, NPARTSASS, NB_BLR , NRHS_B INTEGER(8) :: PTRX, PTRY TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) NRHS_B = JBFIN-JBDEB+1 IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) NB_BLR = NB_BLR - 2 ELSE WRITE(6,*) " Internal error 1 in ZMUMPS_SOL_SLAVE_LR_U" CALL MUMPS_ABORT() ENDIF PTRX = PTRX_INIT PTRY = PTRY_INIT DO I = 1, NPARTSASS BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL IF (associated(BLR_PANEL)) THEN IF (MTYPE.EQ.1) THEN CALL ZMUMPS_SOL_FWD_BLR_UPDATE ( & WCB, LWCB, 1, LDX, -99999_8, 1, & WCB, LWCB, LDY, PTRY, & PTRX, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ELSE CALL ZMUMPS_SOL_BWD_BLR_UPDATE ( & WCB, LWCB, 1, LDY, -99999_8, 1, & WCB, LWCB, LDX, PTRX, & PTRY, & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, NB_BLR, 0, & BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(2:NB_BLR+2), & .TRUE., IFLAG, IERROR ) ENDIF IF (MTYPE .EQ. 1) THEN PTRX = PTRX + BLR_PANEL(1)%N ELSE PTRY = PTRY + BLR_PANEL(1)%N ENDIF IF (IFLAG.LT.0) RETURN ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_SLAVE_LR_U SUBROUTINE ZMUMPS_SOL_FWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, & CURRENT_BLR, BEGS_BLR_STATIC, & IS_T2_SLAVE, IFLAG, IERROR ) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER, INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX(kind=8), INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX(kind=8), INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) INTEGER :: BEGS_BLR_STATIC(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK INTEGER :: allocok TYPE(LRB_TYPE), POINTER :: LRB COMPLEX(kind=8), ALLOCATABLE,DIMENSION(:) :: TEMP_BLOCK COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK, allocok, CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & ZMUMPS_SOL_FWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, N, !$OMP& POSBLOCK) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 IF (IBEG_BLOCK .EQ. IEND_BLOCK + 1) CYCLE LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M N = LRB%N IF (LRB%ISLR) THEN IF (K.GT.0) THEN CALL zgemm('N', 'N', K, NRHS_B, N, ONE, & LRB%R(1,1), K, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, K, & MONE, LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL zgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, K, & MONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, TEMP_BLOCK(1), & K, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('N', 'N', M, NRHS_B, K, MONE, & LRB%Q(1,1), M, TEMP_BLOCK(1), K, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB + int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', NPIV-IBEG_BLOCK+1, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) CALL zgemm('N', 'N', IBEG_BLOCK+M-NPIV-1, NRHS_B, N, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYPIV(POSDIAG,POSPIVCOL), & LDPIV, ONE, ARRAYCB(POSCB), LDCB) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV) ELSE POSBLOCK = POSCB + int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('N', 'N', M, NRHS_B, N, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSDIAG,POSPIVCOL), LDPIV, & ONE, ARRAYCB(POSBLOCK), LDCB) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif RETURN END SUBROUTINE ZMUMPS_SOL_FWD_BLR_UPDATE SUBROUTINE ZMUMPS_SOL_BWD_LR_SU & ( INODE, IWHDLR, NPIV_GLOBAL, NSLAVES, & LIELL, WCB, LWCB, NRHS_B, PTWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPOSINRHSCOMP, JBDEB, & MTYPE, KEEP, & IFLAG, IERROR ) INTEGER, INTENT(IN) :: INODE, IWHDLR, NPIV_GLOBAL, NSLAVES INTEGER, INTENT(IN) :: MTYPE, LIELL, KEEP(500) INTEGER, INTENT(IN) :: IPOSINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWCB, PTWCB INTEGER, INTENT(IN) :: NRHS_B INTEGER, INTENT(INOUT) :: IFLAG, IERROR COMPLEX(kind=8), INTENT(INOUT) :: WCB(LWCB) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER :: I, NPARTSASS, NB_BLR, LAST_BLR, & NELIM_PANEL, LD_WCB, & DIAGSIZ_DYN, DIAGSIZ_STA, LDADIAG, & IEND_BLR, IBEG_BLR, PCBINRHSCOMP INTEGER(8) :: PCB_LAST, PWCB INTEGER :: IPIV_PANEL COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) IF ((MTYPE.EQ.1).AND.(KEEP(50).EQ.0)) THEN IF (associated(BLR_ARRAY(IWHDLR)%PANELS_U)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_U) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ENDIF ELSE IF (associated(BLR_ARRAY(IWHDLR)%PANELS_L)) & THEN NPARTSASS=size(BLR_ARRAY(IWHDLR)%PANELS_L) NB_BLR = size(BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC) -1 ELSE WRITE(6,*) " Internal error in ZMUMPS_SOL_FWD_SU_MASTER" ENDIF ENDIF PCBINRHSCOMP= IPOSINRHSCOMP + NPIV_GLOBAL PCB_LAST = PTWCB + int(LIELL ,8) PWCB = PTWCB + int(NPIV_GLOBAL,8) LD_WCB = LIELL DO I=NPARTSASS,1,-1 IBEG_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I) IEND_BLR = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) -1 DIAGSIZ_DYN = BLR_ARRAY(IWHDLR)%BEGS_BLR_DYNAMIC(I+1) - & IBEG_BLR DIAGSIZ_STA = BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC(I+1) - & IBEG_BLR IF (KEEP(50).NE.0) THEN LDADIAG = DIAGSIZ_DYN ELSE LDADIAG = DIAGSIZ_STA ENDIF IF (DIAGSIZ_DYN.EQ.0) CYCLE NELIM_PANEL = DIAGSIZ_STA - DIAGSIZ_DYN IPIV_PANEL = IPOSINRHSCOMP + IBEG_BLR -1 IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0) THEN BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_U(I)%LRB_PANEL ELSE BLR_PANEL => BLR_ARRAY(IWHDLR)%PANELS_L(I)%LRB_PANEL END IF IF (KEEP(50).EQ.0 .AND. NSLAVES.GT.0 .AND. MTYPE.NE.1) THEN LAST_BLR = NPARTSASS ELSE LAST_BLR = NB_BLR ENDIF CALL ZMUMPS_SOL_BWD_BLR_UPDATE ( & RHSCOMP, int(LRHSCOMP,8), NRHS, LRHSCOMP, & int(IPOSINRHSCOMP,8), JBDEB, & WCB, LWCB, LD_WCB, PWCB, & int(IPIV_PANEL,8), & NRHS_B, NPIV_GLOBAL, & BLR_PANEL, LAST_BLR, & I, BLR_ARRAY(IWHDLR)%BEGS_BLR_STATIC, & .FALSE., IFLAG, IERROR) IF (IFLAG.LT.0) RETURN DIAG => BLR_ARRAY(IWHDLR)%DIAG_BLOCKS(I)%DIAG_BLOCK IF (NELIM_PANEL.GT.0) THEN IF (MTYPE.EQ.1.AND.KEEP(50).EQ.0) THEN IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, WCB(PWCB), & LD_WCB, ONE , RHSCOMP(IPIV_PANEL,JBDEB),LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN+NPIV_GLOBAL-IEND_BLR), & DIAGSIZ_STA, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL zgemm('T', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN), DIAGSIZ_STA, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ELSE IF (IEND_BLR.EQ.NPIV_GLOBAL) THEN CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, ONE, & RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE IF (IEND_BLR+1.LE.NPIV_GLOBAL .AND. & IEND_BLR+NELIM_PANEL.GT.NPIV_GLOBAL) THEN CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & NPIV_GLOBAL-IEND_BLR, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, & IEND_BLR+NELIM_PANEL-NPIV_GLOBAL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG + & (NPIV_GLOBAL-IEND_BLR)*DIAGSIZ_DYN), & DIAGSIZ_DYN, & WCB(PWCB), LD_WCB, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ELSE CALL zgemm('N', 'N', DIAGSIZ_DYN, NRHS_B, NELIM_PANEL, & MONE, DIAG(1+DIAGSIZ_DYN*LDADIAG), DIAGSIZ_DYN, & RHSCOMP(IPIV_PANEL+DIAGSIZ_DYN,JBDEB), LRHSCOMP, & ONE, RHSCOMP(IPIV_PANEL,JBDEB), LRHSCOMP) ENDIF ENDIF ENDIF ENDIF IF (IFLAG.LT.0) RETURN CALL ZMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG(1), size(DIAG), DIAGSIZ_DYN, NELIM_PANEL, LIELL, & NRHS_B, WCB, LWCB, & RHSCOMP, LRHSCOMP, NRHS, & IPIV_PANEL, JBDEB, & MTYPE, KEEP ) ENDDO RETURN END SUBROUTINE ZMUMPS_SOL_BWD_LR_SU SUBROUTINE ZMUMPS_SOL_BWD_BLR_UPDATE ( & ARRAYPIV, LPIV, LPIVCOL, LDPIV, POSPIV, POSPIVCOL, & ARRAYCB, LCB, LDCB, POSCB, & POSDIAG, & NRHS_B, NPIV, & BLR_PANEL, LAST_BLR, CURRENT_BLR, & BEGS_BLR_STATIC, & IS_T2_SLAVE, & IFLAG, IERROR) !$ USE OMP_LIB INTEGER(8), INTENT(IN) :: LPIV, LCB, POSPIV, POSCB, POSDIAG INTEGER,INTENT(IN) :: LPIVCOL, POSPIVCOL COMPLEX(kind=8), INTENT(INOUT) :: ARRAYPIV(LPIV,LPIVCOL) COMPLEX(kind=8), INTENT(INOUT) :: ARRAYCB(LCB) INTEGER, INTENT(IN) :: LAST_BLR, NRHS_B, LDPIV, LDCB, & CURRENT_BLR, NPIV TYPE(LRB_TYPE), TARGET,INTENT(IN) :: & BLR_PANEL(:) LOGICAL, INTENT(IN) :: IS_T2_SLAVE INTEGER :: BEGS_BLR_STATIC(:) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER :: I, K, M, N, IBEG_BLOCK, IEND_BLOCK INTEGER :: KMAX INTEGER(8) :: POSBLOCK TYPE(LRB_TYPE), POINTER :: LRB COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: TEMP_BLOCK COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: DEST_ARRAY INTEGER :: allocok COMPLEX(kind=8) :: ONE, MONE, ZERO PARAMETER (ONE=(1.0D0,0.0D0), MONE=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) #if defined(BLR_MT) INTEGER :: CHUNK #endif KMAX = -1 DO I = CURRENT_BLR+1, LAST_BLR KMAX = max(KMAX, BLR_PANEL(I-CURRENT_BLR)%K) ENDDO IF (CURRENT_BLR.LT.LAST_BLR) THEN N = BLR_PANEL(1)%N ELSE RETURN ENDIF allocate(DEST_ARRAY(N*NRHS_B),stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = N * NRHS_B GOTO 100 ENDIF DEST_ARRAY = ZERO #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(TEMP_BLOCK,allocok,CHUNK) #endif IF (KMAX.GT.0) THEN allocate(TEMP_BLOCK(KMAX*NRHS_B), stat=allocok ) IF (allocok .GT. 0) THEN IFLAG = -13 IERROR = NRHS_B * KMAX write(*,*) 'Allocation problem in BLR routine & ZMUMPS_SOL_BWD_BLR_UPDATE: ', & 'not enough memory? memory requested = ', IERROR ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif #if defined(BLR_MT) CHUNK = 1 !$OMP DO SCHEDULE(DYNAMIC,CHUNK) !$OMP& PRIVATE(IBEG_BLOCK, IEND_BLOCK, LRB, K, M, !$OMP& POSBLOCK) !$OMP& REDUCTION(+:DEST_ARRAY) #endif DO I = CURRENT_BLR+1, LAST_BLR IF (IFLAG.LT.0) CYCLE IBEG_BLOCK = BEGS_BLR_STATIC(I) IEND_BLOCK = BEGS_BLR_STATIC(I+1)-1 LRB => BLR_PANEL(I-CURRENT_BLR) K = LRB%K M = LRB%M IF (LRB%ISLR) THEN IF (K.GT.0) THEN IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB +int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, NPIV-IBEG_BLOCK+1, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) CALL zgemm('T', 'N', K, NRHS_B, IBEG_BLOCK+M-NPIV-1, & ONE, LRB%Q(NPIV-IBEG_BLOCK+2,1), M, & ARRAYCB(POSCB), LDCB, & ONE, & TEMP_BLOCK(1), K) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ZERO, TEMP_BLOCK(1), K) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('T', 'N', K, NRHS_B, M, ONE, & LRB%Q(1,1), M, & ARRAYCB(POSBLOCK), LDCB, ZERO, & TEMP_BLOCK(1), K) ENDIF CALL zgemm('T', 'N', N, NRHS_B, K, MONE, & LRB%R(1,1), K, & TEMP_BLOCK(1), K, ONE, & DEST_ARRAY(1), N) ENDIF ELSE IF (IS_T2_SLAVE) THEN POSBLOCK = POSCB+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ELSE IF (IBEG_BLOCK.LE.NPIV.AND.IEND_BLOCK.GT.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', N, NRHS_B, NPIV-IBEG_BLOCK+1, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) CALL zgemm('T', 'N', N, NRHS_B, IBEG_BLOCK+M-NPIV-1, MONE, & LRB%Q(NPIV-IBEG_BLOCK+2,1), M, ARRAYCB(POSCB), & LDCB, ONE, DEST_ARRAY(1), N) ELSEIF (IBEG_BLOCK.LE.NPIV) THEN POSBLOCK = POSPIV+int(IBEG_BLOCK-1,8) CALL zgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYPIV(POSBLOCK,POSPIVCOL), LDPIV, & ONE, DEST_ARRAY(1), N) ELSE POSBLOCK = POSCB+int(IBEG_BLOCK-1-NPIV,8) CALL zgemm('T', 'N', N, NRHS_B, M, MONE, & LRB%Q(1,1), M, ARRAYCB(POSBLOCK), LDCB, & ONE, DEST_ARRAY(1), N) ENDIF ENDIF ENDDO #if defined(BLR_MT) !$OMP END DO #endif IF (KMAX.GT.0) THEN IF (allocated(TEMP_BLOCK)) deallocate(TEMP_BLOCK) ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IS_T2_SLAVE) THEN DO I=1,NRHS_B call zaxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG+(I-1)*LDPIV,POSPIVCOL), 1) ENDDO ELSE DO I=1,NRHS_B call zaxpy(N, ONE, DEST_ARRAY((I-1)*N+1), 1, & ARRAYPIV(POSDIAG,POSPIVCOL+I-1), 1) ENDDO ENDIF 100 CONTINUE IF (allocated(DEST_ARRAY)) DEALLOCATE(DEST_ARRAY) RETURN END SUBROUTINE ZMUMPS_SOL_BWD_BLR_UPDATE END MODULE ZMUMPS_SOL_LR SUBROUTINE ZMUMPS_SOLVE_BWD_LR_TRSOLVE ( & DIAG, LDIAG, NPIV, NELIM, LIELL, & NRHS_B, W, LWC, & RHSCOMP, LRHSCOMP, NRHS, & PPIVINRHSCOMP, JBDEB, & MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LIELL, NPIV, NELIM, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDIAG INTEGER, INTENT(IN) :: PPIVINRHSCOMP, JBDEB, LRHSCOMP, NRHS INTEGER(8), INTENT(IN) :: LWC COMPLEX(kind=8), INTENT(IN) :: DIAG(LDIAG) COMPLEX(kind=8), INTENT(INOUT) :: W(LWC) COMPLEX(kind=8) RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LDAJ COMPLEX(kind=8) ONE PARAMETER ( ONE=(1.0D0,0.0D0) ) IF ( MTYPE .eq. 1 ) THEN LDAJ = NPIV + NELIM CALL ztrsm('L','L','T','N', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), & LRHSCOMP) ELSE IF ( KEEP(50) .EQ. 0 ) THEN LDAJ=NPIV+NELIM ELSE LDAJ=NPIV ENDIF CALL ztrsm('L','U','N','U', NPIV, NRHS_B, ONE, DIAG(1), & LDAJ, RHSCOMP(PPIVINRHSCOMP,JBDEB), LRHSCOMP) END IF RETURN END SUBROUTINE ZMUMPS_SOLVE_BWD_LR_TRSOLVE MUMPS_5.4.1/src/dsol_distrhs.F0000664000175000017500000005422714102210522016324 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SCATTER_DIST_RHS( & NSLAVES, N, & MYID_NODES, COMM_NODES, & NRHS_COL, NRHS_loc, LRHS_loc, & MAP_RHS_loc, & IRHS_loc, RHS_loc, RHS_loc_size, & RHSCOMP, LD_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP, NB_BYTES_LOC, INFO ) USE DMUMPS_STRUC_DEF !$ USE OMP_LIB IMPLICIT NONE INTEGER, INTENT(IN) :: NSLAVES, N, MYID_NODES INTEGER, INTENT(IN) :: NRHS_loc, LRHS_loc INTEGER, INTENT(IN) :: NRHS_COL INTEGER, INTENT(IN) :: COMM_NODES INTEGER, INTENT(IN) :: MAP_RHS_loc(max(1,NRHS_loc)) INTEGER, INTENT(IN) :: IRHS_loc(NRHS_loc) INTEGER(8), INTENT(IN) :: RHS_loc_size DOUBLE PRECISION, INTENT(IN) :: RHS_loc(RHS_loc_size) INTEGER, INTENT(IN) :: NB_FS_IN_RHSCOMP, LD_RHSCOMP INTEGER, INTENT(IN) :: POSINRHSCOMP_FWD(N) DOUBLE PRECISION, INTENT(OUT) :: RHSCOMP(LD_RHSCOMP, NRHS_COL) INTEGER :: KEEP(500) LOGICAL, INTENT(IN) :: LSCAL type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type(scaling_data_t), INTENT(IN) :: scaling_data_dr LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: LP INTEGER, INTENT(INOUT) :: INFO(2) INTEGER(8), INTENT(OUT):: NB_BYTES_LOC INCLUDE 'mpif.h' INTEGER :: IERR_MPI !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP !$ INTEGER(8) :: CHUNK8 INTEGER :: allocok INTEGER :: MAXRECORDS INTEGER, ALLOCATABLE, DIMENSION(:) :: NBROWSTOSEND INTEGER, ALLOCATABLE, DIMENSION(:) :: NEXTROWTOSEND DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUFRECR LOGICAL, ALLOCATABLE, DIMENSION(:) :: IS_SEND_ACTIVE, TOUCHED INTEGER, ALLOCATABLE, DIMENSION(:) :: MPI_REQI, MPI_REQR INTEGER, ALLOCATABLE, DIMENSION(:) :: IRHS_loc_sorted INTEGER :: Iloc INTEGER :: Iloc_sorted INTEGER :: IREQ INTEGER :: IMAP, IPROC_MAX INTEGER :: IFS INTEGER :: MAX_ACTIVE_SENDS INTEGER :: NB_ACTIVE_SENDS INTEGER :: NB_FS_TOUCHED INTEGER :: NBROWSTORECV DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 !$ NOMP = OMP_GET_MAX_THREADS() NB_BYTES_LOC = 0_8 ALLOCATE( NBROWSTOSEND (NSLAVES), & NEXTROWTOSEND (NSLAVES), & IRHS_loc_sorted (NRHS_loc), & stat=allocok ) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = NSLAVES+NSLAVES+NRHS_loc ENDIF NB_BYTES_LOC = int(2*NSLAVES+NRHS_loc,8)*KEEP(34) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .GT. 0) RETURN NBROWSTOSEND(1:NSLAVES) = 0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) NBROWSTOSEND(IMAP+1) = NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO NEXTROWTOSEND(1)=1 DO IMAP=1, NSLAVES-1 NEXTROWTOSEND(IMAP+1)=NEXTROWTOSEND(IMAP)+NBROWSTOSEND(IMAP) ENDDO NBROWSTOSEND=0 DO Iloc = 1, NRHS_loc IF (IRHS_loc(Iloc) .GE. 1 .AND. & IRHS_loc(Iloc) .LE. N) THEN IMAP = MAP_RHS_loc(Iloc) Iloc_sorted = NEXTROWTOSEND(IMAP+1)+NBROWSTOSEND(IMAP+1) IRHS_loc_sorted(Iloc_sorted) = Iloc NBROWSTOSEND(IMAP+1)=NBROWSTOSEND(IMAP+1)+1 ENDIF ENDDO CALL DMUMPS_DR_BUILD_NBROWSTORECV() MAX_ACTIVE_SENDS = min(10, NSLAVES) IF (KEEP(72) .EQ.1 ) THEN MAXRECORDS = 15 ELSE MAXRECORDS = min(200000,2000000/NRHS_COL) MAXRECORDS = min(MAXRECORDS, & 50000000 / MAX_ACTIVE_SENDS / NRHS_COL) MAXRECORDS = max(MAXRECORDS, 50) ENDIF ALLOCATE(BUFR(MAXRECORDS*NRHS_COL, & MAX_ACTIVE_SENDS), & MPI_REQI(MAX_ACTIVE_SENDS), & MPI_REQR(MAX_ACTIVE_SENDS), & IS_SEND_ACTIVE(MAX_ACTIVE_SENDS), & BUFRECI(MAXRECORDS), & BUFRECR(MAXRECORDS*NRHS_COL), & TOUCHED(NB_FS_IN_RHSCOMP), & stat=allocok) IF (allocok .GT. 0) THEN IF (LP .GT. 0) WRITE(LP, '(A)') & 'Error: Allocation problem in DMUMPS_SCATTER_DIST_RHS' INFO(1)=-13 INFO(2)=NRHS_COL*MAXRECORDS*MAX_ACTIVE_SENDS+ & 3*MAX_ACTIVE_SENDS+MAXRECORDS*(1+NRHS_COL) & + NB_FS_IN_RHSCOMP ENDIF NB_BYTES_LOC=NB_BYTES_LOC + & KEEP(34) * ( int(2*MAX_ACTIVE_SENDS,8) + int(MAXRECORDS,8) ) + & KEEP(34) * (int(MAX_ACTIVE_SENDS,8) + int(NB_FS_IN_RHSCOMP,8)) + & KEEP(35) * ( & int( MAXRECORDS,8)*int(NRHS_COL,8)*int(MAX_ACTIVE_SENDS,8) & + int(MAXRECORDS,8) * int(NRHS_COL,8) ) CALL MPI_ALLREDUCE( MPI_IN_PLACE, allocok, 1, & MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR_MPI ) IF (allocok .NE. 0) RETURN NB_ACTIVE_SENDS = 0 DO IREQ = 1, MAX_ACTIVE_SENDS IS_SEND_ACTIVE(IREQ) = .FALSE. ENDDO NB_FS_TOUCHED = 0 DO IFS = 1, NB_FS_IN_RHSCOMP TOUCHED(IFS) = .FALSE. ENDDO IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 DO WHILE (NBROWSTOSEND(IPROC_MAX+1) .NE. 0) IF (IPROC_MAX .EQ. MYID_NODES) THEN CALL DMUMPS_DR_ASSEMBLE_LOCAL() ELSE CALL DMUMPS_DR_TRY_SEND(IPROC_MAX) ENDIF CALL DMUMPS_DR_TRY_RECV() CALL DMUMPS_DR_TRY_FREE_SEND() IPROC_MAX=maxloc(NBROWSTOSEND,DIM=1)-1 ENDDO DO WHILE ( NBROWSTORECV .NE. 0) CALL DMUMPS_DR_TRY_RECV() CALL DMUMPS_DR_TRY_FREE_SEND() ENDDO DO WHILE (NB_ACTIVE_SENDS .NE. 0) CALL DMUMPS_DR_TRY_FREE_SEND() ENDDO CALL DMUMPS_DR_EMPTY_ROWS() RETURN CONTAINS SUBROUTINE DMUMPS_DR_BUILD_NBROWSTORECV() INTEGER :: IPROC DO IPROC = 0, NSLAVES-1 CALL MPI_REDUCE( NBROWSTOSEND(IPROC+1), NBROWSTORECV, & 1, MPI_INTEGER, & MPI_SUM, IPROC, COMM_NODES, IERR_MPI ) ENDDO END SUBROUTINE DMUMPS_DR_BUILD_NBROWSTORECV SUBROUTINE DMUMPS_DR_TRY_RECV() IMPLICIT NONE INCLUDE 'mumps_tags.h' INTEGER :: MPI_STATUS(MPI_STATUS_SIZE), MSGSOU INTEGER :: NBRECORDS LOGICAL :: FLAG CALL MPI_IPROBE( MPI_ANY_SOURCE, DistRhsI, COMM_NODES, & FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN MSGSOU = MPI_STATUS( MPI_SOURCE ) CALL MPI_GET_COUNT(MPI_STATUS, MPI_INTEGER, & NBRECORDS, IERR_MPI) CALL MPI_RECV(BUFRECI(1), NBRECORDS, MPI_INTEGER, & MSGSOU, DistRhsI, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL MPI_RECV(BUFRECR(1), NBRECORDS*NRHS_COL, & MPI_DOUBLE_PRECISION, & MSGSOU, DistRhsR, & COMM_NODES, MPI_STATUS, IERR_MPI) CALL DMUMPS_DR_ASSEMBLE_FROM_BUFREC(NBRECORDS, & BUFRECI, BUFRECR) ENDIF RETURN END SUBROUTINE DMUMPS_DR_TRY_RECV SUBROUTINE DMUMPS_DR_ASSEMBLE_FROM_BUFREC & (NBRECORDS, BUFRECI_ARG, BUFRECR_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: NBRECORDS INTEGER, INTENT(INOUT) :: BUFRECI_ARG(NBRECORDS) DOUBLE PRECISION, INTENT(IN) :: BUFRECR_ARG(NBRECORDS, & NRHS_COL) INTEGER :: I, K, IRHSCOMP, IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IFIRSTNOTTOUCHED = NBRECORDS+1 ILASTNOTTOUCHED = 0 DO I = 1, NBRECORDS IF (BUFRECI(I) .LE. 0) THEN WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_RECV", & I, BUFRECI(I), BUFRECI(1) CALL MUMPS_ABORT() ENDIF IRHSCOMP=POSINRHSCOMP_FWD(BUFRECI(I)) BUFRECI_ARG(I)=IRHSCOMP IF ( .NOT. TOUCHED(IRHSCOMP) ) THEN IFIRSTNOTTOUCHED=min(IFIRSTNOTTOUCHED,I) ILASTNOTTOUCHED=max(ILASTNOTTOUCHED,I) ENDIF ENDDO !$ OMP_FLAG = ( NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(I,IRHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO I = IFIRSTNOTTOUCHED, ILASTNOTTOUCHED IRHSCOMP=BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS IRHSCOMP=BUFRECI_ARG(I) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K) + & BUFRECR_ARG(I,K) ENDDO ENDDO !$OMP END PARALLEL DO DO I = 1, NBRECORDS IRHSCOMP = BUFRECI_ARG(I) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE DMUMPS_DR_ASSEMBLE_FROM_BUFREC SUBROUTINE DMUMPS_DR_ASSEMBLE_LOCAL() INTEGER :: NBRECORDS, I, K, IFIRSTNOTTOUCHED INTEGER :: Iloc INTEGER :: Iglob INTEGER :: IRHSCOMP INTEGER(8) :: ISHIFT IF ( NBROWSTOSEND(MYID_NODES+1) .EQ. 0) THEN WRITE(*,*) "Internal error in DMUMPS_DR_ASSEMBLE_LOCAL" CALL MUMPS_ABORT() ENDIF NBRECORDS=min(MAXRECORDS, NBROWSTOSEND(MYID_NODES+1)) IFIRSTNOTTOUCHED=NBRECORDS+1 DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN IFIRSTNOTTOUCHED=I EXIT ENDIF ENDDO IF (LSCAL) THEN !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT)* & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = (NRHS_COL.GE.KEEP(362) .AND. !$ & NRHS_COL*NBRECORDS .GE. KEEP(363)/2) !$OMP PARALLEL DO PRIVATE(K, ISHIFT, I, IRHSCOMP, Iloc, Iglob) !$OMP& FIRSTPRIVATE(NBRECORDS) IF (OMP_FLAG) DO K = 1, NRHS_COL ISHIFT = (K-1) * LRHS_loc DO I = IFIRSTNOTTOUCHED, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN RHSCOMP(IRHSCOMP,K)=ZERO ENDIF ENDDO DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1) Iglob = IRHS_loc(Iloc) IRHSCOMP = POSINRHSCOMP_FWD(Iglob) RHSCOMP(IRHSCOMP,K) = RHSCOMP(IRHSCOMP,K)+ & RHS_loc(Iloc+ISHIFT) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS IRHSCOMP = POSINRHSCOMP_FWD(IRHS_loc( & IRHS_loc_sorted(NEXTROWTOSEND(MYID_NODES+1)+I-1))) IF (.NOT. TOUCHED(IRHSCOMP)) THEN NB_FS_TOUCHED = NB_FS_TOUCHED + 1 TOUCHED(IRHSCOMP) = .TRUE. ENDIF ENDDO NEXTROWTOSEND(MYID_NODES+1)=NEXTROWTOSEND(MYID_NODES+1)+ & NBRECORDS NBROWSTOSEND(MYID_NODES+1)=NBROWSTOSEND(MYID_NODES+1)- & NBRECORDS NBROWSTORECV = NBROWSTORECV - NBRECORDS RETURN END SUBROUTINE DMUMPS_DR_ASSEMBLE_LOCAL SUBROUTINE DMUMPS_DR_GET_NEW_BUF( IBUF ) INTEGER, INTENT(OUT) :: IBUF INTEGER :: I IBUF = -1 IF (NB_ACTIVE_SENDS .NE. MAX_ACTIVE_SENDS) THEN DO I=1, MAX_ACTIVE_SENDS IF (.NOT. IS_SEND_ACTIVE(I)) THEN IBUF = I EXIT ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DR_GET_NEW_BUF SUBROUTINE DMUMPS_DR_TRY_FREE_SEND() INTEGER :: MPI_STATUS(MPI_STATUS_SIZE) INTEGER :: I LOGICAL :: FLAG IF (NB_ACTIVE_SENDS .GT. 0) THEN DO I=1, MAX_ACTIVE_SENDS IF (IS_SEND_ACTIVE(I)) THEN CALL MPI_TEST( MPI_REQR(I), FLAG, MPI_STATUS, IERR_MPI ) IF (FLAG) THEN CALL MPI_WAIT(MPI_REQI(I), MPI_STATUS, IERR_MPI) NB_ACTIVE_SENDS = NB_ACTIVE_SENDS - 1 IS_SEND_ACTIVE(I)=.FALSE. IF (NB_ACTIVE_SENDS .EQ. 0) THEN RETURN ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_DR_TRY_FREE_SEND SUBROUTINE DMUMPS_DR_TRY_SEND(IPROC_ARG) IMPLICIT NONE INTEGER, INTENT(IN) :: IPROC_ARG INCLUDE 'mumps_tags.h' INTEGER :: NBRECORDS, IBUF, I, K INTEGER(8) :: IPOSRHS INTEGER :: IPOSBUF IF (IPROC_ARG .EQ. MYID_NODES) THEN WRITE(*,*) "Internal error 1 in DMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF IF (NBROWSTOSEND(IPROC_ARG+1) .EQ. 0) THEN WRITE(*,*) "Internal error 2 in DMUMPS_DR_TRY_SEND" CALL MUMPS_ABORT() ENDIF CALL DMUMPS_DR_GET_NEW_BUF(IBUF) IF (IBUF .GT. 0) THEN NBRECORDS = min(MAXRECORDS,NBROWSTOSEND(IPROC_ARG+1)) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS_COL*NBRECORDS !$ IF (CHUNK .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((CHUNK+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF IF (LSCAL) THEN !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) * & scaling_data_dr%SCALING_LOC(Iloc) ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) !$OMP& PRIVATE(K, I, IPOSBUF, IPOSRHS, Iloc) IF (OMP_FLAG) DO K=1, NRHS_COL DO I = 1, NBRECORDS IPOSBUF = (K-1)*NBRECORDS IPOSRHS = int(K-1,8)*int(LRHS_loc,8) Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) BUFR( IPOSBUF + I, IBUF ) & = RHS_loc( IPOSRHS + Iloc ) ENDDO ENDDO !$OMP END PARALLEL DO ENDIF DO I = 1, NBRECORDS Iloc = IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)+I-1) & = IRHS_loc(Iloc) ENDDO CALL MPI_ISEND( IRHS_loc_sorted(NEXTROWTOSEND(IPROC_ARG+1)), & NBRECORDS, MPI_INTEGER, IPROC_ARG, DistRhsI, & COMM_NODES, MPI_REQI(IBUF), IERR_MPI ) CALL MPI_ISEND( BUFR(1,IBUF), NBRECORDS*NRHS_COL, & MPI_DOUBLE_PRECISION, & IPROC_ARG, DistRhsR, & COMM_NODES, MPI_REQR(IBUF), IERR_MPI ) NEXTROWTOSEND(IPROC_ARG+1)=NEXTROWTOSEND(IPROC_ARG+1)+ & NBRECORDS NBROWSTOSEND(IPROC_ARG+1)=NBROWSTOSEND(IPROC_ARG+1)-NBRECORDS NB_ACTIVE_SENDS = NB_ACTIVE_SENDS + 1 IS_SEND_ACTIVE(IBUF)=.TRUE. ENDIF RETURN END SUBROUTINE DMUMPS_DR_TRY_SEND SUBROUTINE DMUMPS_DR_EMPTY_ROWS() INTEGER :: K, IFS IF ( NB_FS_TOUCHED .NE. NB_FS_IN_RHSCOMP ) THEN !$ OMP_FLAG = (NRHS_COL .GE. KEEP(362)) .AND. !$ & (NRHS_COL*NB_FS_IN_RHSCOMP > KEEP(363)/2) !$OMP PARALLEL DO FIRSTPRIVATE(NB_FS_IN_RHSCOMP) IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = 1, NB_FS_IN_RHSCOMP IF ( .NOT. TOUCHED(IFS) ) THEN RHSCOMP( IFS, K) = ZERO ENDIF ENDDO DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ELSE !$ OMP_FLAG = .FALSE. !$ CHUNK8 = int(NRHS_COL,8)*int(LD_RHSCOMP-NB_FS_IN_RHSCOMP,8) !$ CHUNK8 = max(CHUNK8,1_8) !$ IF (CHUNK8 .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK8 = max((CHUNK8+NOMP-1)/NOMP,int(KEEP(363)/2,8)) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK8) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS_COL DO IFS = NB_FS_IN_RHSCOMP +1, LD_RHSCOMP RHSCOMP (IFS, K) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE DMUMPS_DR_EMPTY_ROWS END SUBROUTINE DMUMPS_SCATTER_DIST_RHS SUBROUTINE DMUMPS_SOL_INIT_IRHS_loc(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE (DMUMPS_STRUC) :: id INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ROW_OR_COL_INDICES INTEGER :: IERR_MPI LOGICAL :: I_AM_SLAVE INTEGER, POINTER :: idIRHS_loc(:) INTEGER, POINTER :: UNS_PERM(:) INTEGER :: UNS_PERM_TO_BE_DONE, I, allocok INTEGER, TARGET :: IDUMMY(1) INCLUDE 'mpif.h' NULLIFY(UNS_PERM) IF (id%JOB .NE. 9) THEN WRITE(*,*) "Internal error 1 in DMUMPS_SOL_INIT_IRHS_loc" CALL MUMPS_ABORT() ENDIF I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & id%KEEP(46) .eq. 1 ) ) IF (id%MYID .EQ. MASTER) THEN IF (id%ICNTL(20).EQ.10) THEN ROW_OR_COL_INDICES = 0 ELSE IF (id%ICNTL(20).EQ.11) THEN ROW_OR_COL_INDICES = 1 ELSE ROW_OR_COL_INDICES = 0 ENDIF IF (id%ICNTL(9) .NE. 1) THEN ROW_OR_COL_INDICES = 1 - ROW_OR_COL_INDICES ENDIF IF (id%KEEP(23).NE.0 .AND. id%ICNTL(9) .NE.1) THEN UNS_PERM_TO_BE_DONE = 1 ELSE UNS_PERM_TO_BE_DONE = 0 ENDIF ENDIF CALL MPI_BCAST(ROW_OR_COL_INDICES,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) CALL MPI_BCAST(UNS_PERM_TO_BE_DONE,1,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF ( I_AM_SLAVE ) THEN IF (id%KEEP(89) .GT. 0) THEN IF (.NOT. associated(id%IRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 ELSE IF (size(id%IRHS_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=17 ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) goto 500 IF (I_AM_SLAVE) THEN IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .GT. 0) THEN idIRHS_loc => id%IRHS_loc ELSE idIRHS_loc => IDUMMY ENDIF ELSE idIRHS_loc => IDUMMY ENDIF CALL MUMPS_BUILD_IRHS_loc(id%MYID_NODES, id%NSLAVES, id%N, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), id%IS(1), & max(1, id%KEEP(32)), & id%STEP(1), id%PROCNODE_STEPS(1), idIRHS_loc(1), & ROW_OR_COL_INDICES) ENDIF IF (UNS_PERM_TO_BE_DONE .EQ. 1) THEN IF (id%MYID.NE.MASTER) THEN ALLOCATE(UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%N GOTO 100 ENDIF ENDIF 100 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) GOTO 500 IF ( id%MYID .EQ. MASTER ) THEN UNS_PERM => id%UNS_PERM ENDIF CALL MPI_BCAST(UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR_MPI) IF (I_AM_SLAVE .AND. id%KEEP(89) .NE.0) THEN DO I=1, id%KEEP(89) id%IRHS_loc(I)=UNS_PERM(id%IRHS_loc(I)) ENDDO ENDIF ENDIF 500 CONTINUE IF (id%MYID.NE.MASTER) THEN IF (associated(UNS_PERM)) DEALLOCATE(UNS_PERM) ENDIF NULLIFY(UNS_PERM) RETURN END SUBROUTINE DMUMPS_SOL_INIT_IRHS_loc MUMPS_5.4.1/src/zana_lr.F0000664000175000017500000020104414102210525015243 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_ANA_LR USE ZMUMPS_LR_CORE USE ZMUMPS_LR_STATS USE MUMPS_LR_COMMON USE MUMPS_ANA_ORD_WRAPPERS USE MUMPS_ANA_BLK_M, ONLY: LMATRIX_T IMPLICIT NONE CONTAINS SUBROUTINE GET_CUT(IWR, NASS, NCB, LRGROUPS, NPARTSCB, & NPARTSASS, CUT) INTEGER, INTENT(IN) :: NASS, NCB INTEGER, INTENT(IN) :: IWR(*) INTEGER, INTENT(IN), DIMENSION(:) :: LRGROUPS INTEGER, INTENT(OUT) :: NPARTSCB, NPARTSASS INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: I, CURRENT_PART, CUTBUILDER,allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: BIG_CUT ALLOCATE(BIG_CUT(max(NASS,1)+NCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of BIG_CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF CURRENT_PART = LRGROUPS(IWR(1)) BIG_CUT(1) = 1 BIG_CUT(2) = 2 CUTBUILDER = 2 NPARTSASS = 0 NPARTSCB = 0 DO I = 2,NASS + NCB IF (LRGROUPS(IWR(I)) == CURRENT_PART) THEN BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER) + 1 ELSE CUTBUILDER = CUTBUILDER + 1 BIG_CUT(CUTBUILDER) = BIG_CUT(CUTBUILDER-1) + 1 CURRENT_PART = LRGROUPS(IWR(I)) END IF IF (I == NASS) NPARTSASS = CUTBUILDER - 1 END DO IF (NASS.EQ.1) NPARTSASS= 1 NPARTSCB = CUTBUILDER - 1 - NPARTSASS ALLOCATE(CUT(max(NPARTSASS,1)+NPARTSCB+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error of CUT in GET_CUT" CALL MUMPS_ABORT() ENDIF IF (NPARTSASS.EQ.0) THEN CUT(1) = 1 CUT(2:2+NPARTSCB) = BIG_CUT(1:1+NPARTSCB) ELSE CUT = BIG_CUT(1:NPARTSASS+NPARTSCB+1) ENDIF if(allocated(BIG_CUT)) DEALLOCATE(BIG_CUT) END SUBROUTINE GET_CUT SUBROUTINE SEP_GROUPING(NV, VLIST, N, NZ, LRGROUPS, NBGROUPS, IW, & LW, IPE, LEN, GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) INTEGER(8), INTENT(IN) :: NZ, LW INTEGER, INTENT(IN) :: NV, N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: IW(LW), LEN(N), NODE, K482 INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) NBGROUPS_KWAY = MAX(NINT(dble(NV)/dble(GROUP_SIZE2)),1) IF (NV .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES(N, IW, LW, IPE, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, LEN, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF CALL GETHALOGRAPH(WORKH, NHALO, N, IW, LW, IPE, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF RETURN END SUBROUTINE SEP_GROUPING SUBROUTINE SEP_GROUPING_AB (NV, NVEXPANDED, & VLIST, N, LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, NODE, & GEN2HALO, K482, K472, K469, SEP_SIZE, & KEEP10, LP, LPOK, IFLAG, IERROR) TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: NV, NVEXPANDED, & N, GROUP_SIZE, HALO_DEPTH INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: NODE, K482 INTEGER, INTENT(IN) :: K472, K469, SEP_SIZE, KEEP10, LP LOGICAL :: LPOK INTEGER, INTENT(INOUT) :: NBGROUPS, WORKH(N) INTEGER, INTENT(INOUT) :: VLIST(NV), TRACE(N) INTEGER :: LRGROUPS(:) INTEGER, INTENT(INOUT) :: GEN2HALO(N) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8), ALLOCATABLE, DIMENSION(:) :: IPTRHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: PARTS, JCNHALO INTEGER, ALLOCATABLE, DIMENSION(:) :: VWGT INTEGER(8) :: HALOEDGENBR INTEGER :: NHALO, & NBGROUPS_KWAY, I, GROUP_SIZE2, LRGROUPS_SIGN, IERR DOUBLE PRECISION :: COMPRESS_RATIO #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) INTEGER :: METIS_IDX_SIZE #endif #if defined (scotch) || defined (ptscotch) INTEGER :: SCOTCH_IDX_SIZE #endif CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) COMPRESS_RATIO= dble(NVEXPANDED)/dble(NV) NBGROUPS_KWAY = MAX(NINT(dble(NVEXPANDED)/dble(GROUP_SIZE2)),1) NBGROUPS_KWAY = min(NBGROUPS_KWAY, NV) IF (NVEXPANDED .GE. SEP_SIZE) THEN LRGROUPS_SIGN = 1 ELSE LRGROUPS_SIGN = -1 ENDIF IF (NBGROUPS_KWAY > 1) THEN IF (K469.EQ.3) THEN !$OMP CRITICAL(gethalo_cri) CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) !$OMP END CRITICAL(gethalo_cri) IF (IFLAG.LT.0) RETURN ELSE CALL GETHALONODES_AB(N, LUMAT, VLIST, NV, HALO_DEPTH, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) ALLOCATE(PARTS(NHALO), IPTRHALO(NHALO+1), & JCNHALO(HALOEDGENBR), VWGT(NHALO), STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of size: ", & int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR IFLAG = -7 CALL MUMPS_SET_IERROR & (int(2*NHALO+(KEEP10*(NHALO+1)),8) + HALOEDGENBR, & IERROR) RETURN ENDIF DO I=1, NHALO VWGT(I) = SIZEOFBLOCKS(WORKH(I)) ENDDO CALL GETHALOGRAPH_AB(WORKH, NV, & NHALO, N, LUMAT, IPTRHALO, & JCNHALO, HALOEDGENBR,TRACE,NODE, GEN2HALO, PARTS) ENDIF IF (K482.EQ.1) THEN #if defined (metis) || defined (parmetis) || defined (metis4) || defined (parmetis3) CALL MUMPS_METIS_IDXSIZE(METIS_IDX_SIZE) IF (METIS_IDX_SIZE .EQ. 64) THEN CALL MUMPS_METIS_KWAY_AB_MIXEDto64(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ELSE IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 1 ELSE CALL MUMPS_METIS_KWAY_AB_MIXEDto32(NHALO, HALOEDGENBR, & IPTRHALO, & JCNHALO, & NBGROUPS_KWAY, PARTS, VWGT, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ENDIF #endif ELSE IF (K482.EQ.2) THEN #if defined (scotch) || defined (ptscotch) CALL MUMPS_SCOTCH_INTSIZE(SCOTCH_IDX_SIZE) IF (SCOTCH_IDX_SIZE .EQ. 32) THEN IF (KEEP10.EQ.1) THEN IFLAG = -52 IERROR = 2 ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto32( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) ENDIF ELSE CALL MUMPS_SCOTCH_KWAY_MIXEDto64( & NHALO, HALOEDGENBR, IPTRHALO, JCNHALO, & NBGROUPS_KWAY, PARTS, LP, LPOK, KEEP10, & IFLAG, IERROR) END IF #endif ELSE WRITE(6,*) " Internal ERROR K482=", K482 CALL MUMPS_ABORT() END IF IF (IFLAG.LT.0) GOTO 500 CALL GET_GLOBAL_GROUPS(PARTS,VLIST,NV, & NBGROUPS_KWAY, LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) ELSE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(VLIST(I)) = LRGROUPS_SIGN*(NBGROUPS + 1) END DO NBGROUPS = NBGROUPS + 1 !$OMP END CRITICAL(lrgrouping_cri) END IF 500 IF (allocated(IPTRHALO)) then DEALLOCATE(IPTRHALO) ENDIF IF (allocated(PARTS)) then DEALLOCATE(PARTS) ENDIF IF (allocated(JCNHALO)) then DEALLOCATE(JCNHALO ) ENDIF IF (allocated(VWGT)) then DEALLOCATE(VWGT) ENDIF RETURN END SUBROUTINE SEP_GROUPING_AB SUBROUTINE GETHALONODES_AB(N, LUMAT, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, HALOEDGENBR, & GEN2HALO) TYPE(LMATRIX_T) :: LUMAT INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: HALOEDGENBR INTEGER :: I, J, II INTEGER :: HALOI, NB, NEWNHALO INTEGER(8) :: SEPEDGES_TOTAL, & SEPEDGES_INTERNAL WORKH(1:NIND) = IND NHALO = NIND NEWNHALO = 0 HALOEDGENBR = 0_8 SEPEDGES_TOTAL = 0_8 SEPEDGES_INTERNAL = 0_8 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF ENDDO DO I=1,NIND HALOI = WORKH(I) NB = LUMAT%COL(HALOI)%NBINCOL SEPEDGES_TOTAL = SEPEDGES_TOTAL + int(NB,8) DO J=1, NB II = LUMAT%COL(HALOI)%IRN(J) IF (TRACE(II).NE.NODE) THEN NEWNHALO = NEWNHALO + 1 WORKH(NHALO+NEWNHALO) = II GEN2HALO(II) = NHALO+NEWNHALO TRACE(II) = NODE ELSE IF (GEN2HALO(II).LE.NHALO) THEN SEPEDGES_INTERNAL = SEPEDGES_INTERNAL + 1_8 ENDIF ENDIF ENDDO END DO HALOEDGENBR = SEPEDGES_TOTAL + & (SEPEDGES_TOTAL - SEPEDGES_INTERNAL) NHALO = NHALO + NEWNHALO END SUBROUTINE GETHALONODES_AB SUBROUTINE GETHALOGRAPH_AB(HALO,NSEP,NHALO, & N,LUMAT,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO, IQ) INTEGER, INTENT(IN) :: N TYPE(LMATRIX_T) :: LUMAT INTEGER,INTENT(IN):: NSEP, NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER, INTENT(IN) :: TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER :: IQ(NHALO) INTEGER::I,J,NB,II,JJ,HALOI,HALOJ DO I=NSEP+1, NHALO IQ(I) = 0 ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL IQ(I) = NB DO JJ=1, NB II = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(II) IF (J.GT.NSEP) THEN IQ(J) = IQ(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO DO I=1,NSEP HALOI = HALO(I) NB = LUMAT%COL(HALOI)%NBINCOL DO JJ=1, NB HALOJ = LUMAT%COL(HALOI)%IRN(JJ) J = GEN2HALO(HALOJ) JCNHALO(IPTRHALO(I)) = J IPTRHALO(I) = IPTRHALO(I) + 1 IF (J.GT.NSEP) THEN JCNHALO(IPTRHALO(J)) = I IPTRHALO(J) = IPTRHALO(J) + 1 ENDIF ENDDO ENDDO IPTRHALO(1) = 1_8 DO I=1,NHALO IPTRHALO(I+1) = IPTRHALO(I)+int(IQ(I),8) ENDDO END SUBROUTINE GETHALOGRAPH_AB SUBROUTINE GET_GLOBAL_GROUPS(PARTS, SEP, NSEP, NPARTS, & LRGROUPS, N, NBGROUPS, LRGROUPS_SIGN) INTEGER,INTENT(IN) :: NSEP, N, LRGROUPS_SIGN INTEGER :: PARTS(:) INTEGER,DIMENSION(:),INTENT(INOUT) :: SEP INTEGER, INTENT(INOUT) :: NPARTS INTEGER, INTENT(INOUT) :: NBGROUPS INTEGER :: LRGROUPS(:) INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES, RIGHTPART INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR INTEGER,DIMENSION(:),ALLOCATABLE :: NEWSEP ALLOCATE( NEWSEP(NSEP), & SIZES(NPARTS), & RIGHTPART(NPARTS), & PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GLOBAL_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 RIGHTPART = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = SIZES(PARTS(I)) + 1 END DO CNT = 0 PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 ELSE CNT = CNT + 1 RIGHTPART(I-1) = CNT END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE !$OMP CRITICAL(lrgrouping_cri) DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) LRGROUPS(SEP(I)) = LRGROUPS_SIGN*(RIGHTPART(PARTS(I)) & + NBGROUPS) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO NBGROUPS = NBGROUPS + NPARTS !$OMP END CRITICAL(lrgrouping_cri) SEP = NEWSEP DEALLOCATE(NEWSEP,SIZES,RIGHTPART,PARTPTR) END SUBROUTINE GET_GLOBAL_GROUPS SUBROUTINE GETHALONODES(N, IW, LW, IPE, IND, NIND, PMAX, & NHALO, TRACE, WORKH, NODE, LEN, CNT, & GEN2HALO) INTEGER,DIMENSION(:),INTENT(IN) :: IND INTEGER(8), INTENT(IN) :: LW INTEGER, INTENT(IN) :: N, NODE INTEGER, INTENT(IN) :: IW(LW), LEN(N) INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: PMAX,NIND INTEGER, INTENT(OUT) :: NHALO INTEGER, INTENT(INOUT) :: TRACE(N), WORKH(N) INTEGER :: GEN2HALO(N) INTEGER(8), INTENT(OUT) :: CNT INTEGER :: DEPTH, I, LAST_LVL_START INTEGER :: HALOI INTEGER(8) :: J WORKH(1:NIND) = IND LAST_LVL_START = 1 NHALO = NIND CNT = 0 DO I=1,NIND HALOI = WORKH(I) GEN2HALO(HALOI) = I IF (TRACE(HALOI) .NE. NODE) THEN TRACE(HALOI) = NODE END IF DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END DO DO DEPTH=1,PMAX CALL NEIGHBORHOOD(WORKH, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) END DO END SUBROUTINE GETHALONODES SUBROUTINE NEIGHBORHOOD(HALO, NHALO, N, IW, LW, IPE, & TRACE, NODE, LEN, CNT, LAST_LVL_START, & DEPTH, PMAX, GEN2HALO) INTEGER, INTENT(IN) :: N, NODE, DEPTH, PMAX INTEGER,INTENT(INOUT) :: NHALO, GEN2HALO(N) INTEGER, INTENT(INOUT) :: LAST_LVL_START INTEGER(8), INTENT(INOUT) :: CNT INTEGER,DIMENSION(:),INTENT(INOUT) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, TARGET, INTENT(IN) :: IW(LW) INTEGER, INTENT(IN) :: LEN(N) INTEGER,DIMENSION(:) :: TRACE INTEGER :: AvgDens, THRESH INTEGER :: I,INEI,NADJI,NEWNHALO, NEIGH INTEGER, DIMENSION(:), POINTER :: ADJI INTEGER(8) :: J NEWNHALO = 0 AvgDens = nint(dble(IPE(N+1)-1_8)/dble(N)) THRESH = AvgDens*10 DO I=LAST_LVL_START,NHALO NADJI = LEN(HALO(I)) IF (NADJI.GT.THRESH) CYCLE ADJI => IW(IPE(HALO(I)):IPE(HALO(I)+1)-1) DO INEI=1,NADJI IF (TRACE(ADJI(INEI)) .NE. NODE) THEN NEIGH = ADJI(INEI) IF (LEN(NEIGH).GT.THRESH) CYCLE TRACE(NEIGH) = NODE NEWNHALO = NEWNHALO + 1 HALO(NHALO+NEWNHALO) = NEIGH GEN2HALO(NEIGH) = NHALO + NEWNHALO DO J=IPE(NEIGH),IPE(NEIGH+1)-1 IF (TRACE(IW(J)).EQ.NODE) THEN CNT = CNT + 2 END IF END DO END IF END DO END DO LAST_LVL_START = NHALO + 1 NHALO = NHALO + NEWNHALO END SUBROUTINE NEIGHBORHOOD SUBROUTINE GETHALOGRAPH(HALO,NHALO,N,IW,LW,IPE,IPTRHALO,JCNHALO, & HALOEDGENBR,TRACE,NODE, GEN2HALO) INTEGER, INTENT(IN) :: N INTEGER,INTENT(IN):: NHALO, NODE INTEGER,INTENT(IN):: GEN2HALO(N) INTEGER,DIMENSION(NHALO),INTENT(IN) :: HALO INTEGER(8), INTENT(IN) :: LW INTEGER(8), INTENT(IN) :: IPE(N+1) INTEGER, INTENT(IN) :: IW(LW), TRACE(N) INTEGER(8),INTENT(IN) :: HALOEDGENBR INTEGER(8), INTENT(OUT) :: IPTRHALO(NHALO+1) INTEGER, INTENT(OUT) :: JCNHALO(HALOEDGENBR) INTEGER::I,IPTR_CNT,JCN_CNT,HALOI INTEGER(8) :: J, CNT CNT = 0 IPTR_CNT = 2 JCN_CNT = 1 IPTRHALO(1) = 1 DO I=1,NHALO HALOI = HALO(I) DO J=IPE(HALOI),IPE(HALOI+1)-1 IF (TRACE(IW(J))==NODE) THEN CNT = CNT + 1 JCNHALO(JCN_CNT) = GEN2HALO(IW(J)) JCN_CNT = JCN_CNT + 1 END IF END DO IPTRHALO(IPTR_CNT) = CNT + 1 IPTR_CNT = IPTR_CNT + 1 END DO END SUBROUTINE GETHALOGRAPH SUBROUTINE GET_GROUPS(NHALO,PARTS,SEP,NSEP,NPARTS, & CUT,NEWSEP,PERM,IPERM) INTEGER,INTENT(IN) :: NHALO,NSEP INTEGER,DIMENSION(:),INTENT(IN) :: SEP INTEGER,POINTER,DIMENSION(:)::PARTS INTEGER,POINTER,DIMENSION(:)::CUT,NEWSEP,PERM, & IPERM INTEGER,INTENT(INOUT) :: NPARTS INTEGER::I,CNT,NB_PARTS_WITHOUT_SEP_NODE,allocok INTEGER,DIMENSION(:),ALLOCATABLE::SIZES INTEGER,DIMENSION(:),ALLOCATABLE::PARTPTR ALLOCATE(NEWSEP(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(IPERM(NSEP),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(SIZES(NPARTS),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF ALLOCATE(PARTPTR(NPARTS+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF NB_PARTS_WITHOUT_SEP_NODE = 0 SIZES = 0 DO I=1,NSEP SIZES(PARTS(I)) = & SIZES(PARTS(I))+1 END DO PARTPTR(1)=1 DO I=2,NPARTS+1 PARTPTR(I) = PARTPTR(I-1) + SIZES(I-1) IF (SIZES(I-1)==0) THEN NB_PARTS_WITHOUT_SEP_NODE = NB_PARTS_WITHOUT_SEP_NODE + 1 END IF END DO ALLOCATE(CUT(NPARTS-NB_PARTS_WITHOUT_SEP_NODE+1),stat=allocok) IF(allocok.GT.0) THEN write(*,*) "Allocation error in GET_GROUPS" CALL MUMPS_ABORT() ENDIF CUT(1) = 1 CNT = 2 DO I=2,NPARTS+1 IF (SIZES(I-1).NE.0) THEN CUT(CNT) = PARTPTR(I) CNT = CNT + 1 END IF END DO NPARTS = NPARTS - NB_PARTS_WITHOUT_SEP_NODE CUT(NPARTS+1) = NSEP+1 DO I=1,NSEP NEWSEP(PARTPTR(PARTS(I))) = SEP(I) PERM(PARTPTR(PARTS(I))) = I IPERM(I) = PARTPTR(PARTS(I)) PARTPTR(PARTS(I)) = & PARTPTR(PARTS(I)) + 1 END DO DEALLOCATE(SIZES,PARTPTR) END SUBROUTINE GET_GROUPS SUBROUTINE ZMUMPS_LR_GROUPING(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, NE_STEPS, STEP, NA, LNA, & LRGROUPS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, & K38, K20, K60, & IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K10, & K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: NE_STEPS(:), ICNTL(60) INTEGER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, MAXFRONT INTEGER :: K482_LOC, K38ou20 INTEGER :: I, F, PV, NV, NLEAVES, NROOTS, PP, C, NF, NODE, & SYMTRY, NBQD, AD INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: LPTR, RPTR, NBGROUPS LOGICAL :: FIRST INTEGER, ALLOCATABLE, DIMENSION (:) :: POOL, PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, GEN2HALO INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF NBGROUPS = 0 IF (K265.EQ.-1) THEN LW = NZ8 ELSE LW = 2_8 * NZ8 ENDIF ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & POOL(NA(1)), PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 500 ENDIF CALL ZMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 NLEAVES = NA(1) NROOTS = NA(2) LPTR = 2+NLEAVES RPTR = 2+NLEAVES+NROOTS DO I = 1, NROOTS POOL(I) = NA(2+NLEAVES+I) END DO PP = NROOTS ALLOCATE(WORK(MAXFRONT), TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * 3*N+MAXFRONT IFLAG = -7 IERROR = 3*N+MAXFRONT RETURN ENDIF TRACE = 0 DO WHILE(PP .GT. 0) PV = ABS(POOL(PP)) NODE = STEP(PV) FIRST = POOL(PP) .LT. 0 NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE(1), WORKH(1), NODE, & GEN2HALO(1), K482_LOC, K472, 0, SEP_SIZE, & K10, LP, LPOK, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 END IF ELSE IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = (NBGROUPS + 1) ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -(NBGROUPS + 1) ENDDO ENDIF NBGROUPS = NBGROUPS + 1 ENDIF CALL MUMPS_UPD_TREE(NV, NSTEPS, N, FIRST, LPTR, RPTR, F, & WORK(1), & FILS, FRERE_STEPS, STEP, DAD_STEPS, & NE_STEPS, NA, LNA, PVS(1), K38ou20, & STEP_SCALAPACK_ROOT) IF (STEP_SCALAPACK_ROOT.GT.0) THEN IF (K38.GT.0) THEN K38 = K38ou20 ELSE K20 = K38ou20 ENDIF ENDIF PP = PP-1 NF = NE_STEPS(NODE) IF(NF .GT. 0) THEN PP = PP+1 POOL(PP) = F C = STEP(-F) F = FRERE_STEPS(C) DO WHILE(F .GT. 0) PP = PP+1 POOL(PP) = F C = STEP(F) F = FRERE_STEPS(C) END DO END IF END DO 500 IF (allocated(POOL)) DEALLOCATE(POOL) IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) RETURN END SUBROUTINE ZMUMPS_LR_GROUPING SUBROUTINE ZMUMPS_LR_GROUPING_NEW(N, NZ8, NSTEPS, IRN, JCN, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP) IMPLICIT NONE INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, POINTER, DIMENSION(:) :: IRN, JCN INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NODE, & SYMTRY, NBQD, AD LOGICAL :: PVSCHANGED INTEGER(8) :: LW, IWFR, NRORM, NIORM INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: LEN, IW INTEGER(8), ALLOCATABLE, DIMENSION (:) :: IPE, IQ INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: INPLACE64_GRAPH_COPY K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 LW = 2_8 * NZ8 ALLOCATE(IW(LW), IPE(N+1), LEN(N), IQ(N), & PVS(NSTEPS), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of size: ", * LW+int(N,8)+int(K10*(2*N+1),8) IFLAG = -7 CALL MUMPS_SET_IERROR(LW+int(N,8)+int(K10*(2*N+1),8),IERROR) GOTO 501 ENDIF CALL ZMUMPS_ANA_GNEW(N, NZ8, IRN(1), JCN(1), IW(1), LW, IPE(1), & LEN(1), IQ(1), LRGROUPS(1), IWFR, NRORM, NIORM, & IFLAG, IERROR, & ICNTL(1) , SYMTRY, SYM, NBQD, AD, K264, K265,.FALSE., & INPLACE64_GRAPH_COPY) IF (K54.EQ.3) THEN deallocate(IRN) deallocate(JCN) NULLIFY(IRN) NULLIFY(JCN) ENDIF IF (allocated(IQ)) DEALLOCATE(IQ) LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE PV = PVS(NODE) NV = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 WORK(NV) = F F = FILS(F) END DO CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NV) IF (NV .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING(NV, WORK(1), N, NZ8, & LRGROUPS, NBGROUPS, IW(1), LW, IPE(1), LEN(1), & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NV .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) IF (allocated(IPE)) DEALLOCATE(IPE) IF (allocated(LEN)) DEALLOCATE(LEN) RETURN END SUBROUTINE ZMUMPS_LR_GROUPING_NEW SUBROUTINE ZMUMPS_AB_LR_GROUPING(N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, MYID, COMM) IMPLICIT NONE INTEGER, INTENT(IN) :: MYID, COMM TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 501 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 501 ENDIF ENDIF PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(MAXFRONT), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", MAXFRONT !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = MAXFRONT !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP ATOMIC WRITE IERROR = 3*N ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 500 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IF (MAPCOL(NODE).NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = dble(NVEXPANDED)/dble(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(dble(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO IF (IFLAG.LT.0) GOTO 500 IF (.NOT.PVSCHANGED) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE ZMUMPS_AB_LR_GROUPING SUBROUTINE ZMUMPS_AB_LR_MPI_GROUPING( & N, MAPCOL, SIZEMAPCOL, & NSTEPS, LUMAT, FILS, & FRERE_STEPS, DAD_STEPS, STEP, NA, LNA, LRGROUPS, & SIZEOFBLOCKS, SYM, ICNTL, HALO_DEPTH, GROUP_SIZE, & SEP_SIZE, K38, K20, & K60, IFLAG, IERROR, K264, K265, K482, K472, MAXFRONT, K469, & K10, K54, LPOK, LP, & COMM, MYID, NPROCS & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI, MASTER PARAMETER( MASTER = 0 ) INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER, INTENT(IN) :: MYID, COMM, NPROCS TYPE(LMATRIX_T) :: LUMAT INTEGER, INTENT(IN) :: N, NSTEPS, LNA, SYM, & HALO_DEPTH, SEP_SIZE, GROUP_SIZE INTEGER, INTENT(IN) :: SIZEMAPCOL INTEGER, INTENT(IN) :: MAPCOL(SIZEMAPCOL) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(INOUT) :: K38, K20, K264, K265 INTEGER, INTENT(IN) :: K482, K10, MAXFRONT, K60, K54 INTEGER, INTENT(IN) :: LP LOGICAL, INTENT(IN) :: LPOK INTEGER, INTENT(IN) :: ICNTL(60) INTEGER, POINTER :: FILS(:), FRERE_STEPS(:), STEP(:), & NA(:), DAD_STEPS(:), LRGROUPS(:) INTEGER, INTENT(IN) :: SIZEOFBLOCKS(N) INTEGER, INTENT(IN) :: K472, K469 INTEGER :: K482_LOC, K469_LOC, K38ou20 INTEGER :: I, F, PV, NV, NVEXPANDED, NODE DOUBLE PRECISION :: COMPRESS_RATIO LOGICAL :: PVSCHANGED INTEGER :: PVSCHANGED_INT, PVSCHANGED_INT_GLOB, IPROC INTEGER :: NBGROUPS, NBGROUPS_local INTEGER, ALLOCATABLE, DIMENSION (:) :: PVS, WORK INTEGER :: NBGROUPS_sent INTEGER :: NBNODES_LOC, SIZE_SENT, ISHIFT, & MSGSOU, ILOOP INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE, WORKH, & GEN2HALO INTEGER, ALLOCATABLE, DIMENSION (:) :: TRACE_PRV, WORKH_PRV, & GEN2HALO_PRV INTEGER :: STEP_SCALAPACK_ROOT INTEGER :: GROUP_SIZE2, IERR, OMP_NUM INTEGER :: IERR_PRIV LOGICAL :: MAPCOL_PROVIDED MAPCOL_PROVIDED = (MAPCOL(1).GE.0) K38ou20=max(K38,K20) IF (K38ou20.GT.0) THEN STEP_SCALAPACK_ROOT = STEP(K38ou20) ELSE STEP_SCALAPACK_ROOT = 0 ENDIF IF (MAPCOL_PROVIDED) THEN CALL MPI_BCAST( FILS(1), N, MPI_INTEGER, & MASTER, COMM, IERR ) ENDIF IF((K482.LE.0) .OR. (K482.GT.3)) THEN #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #elif defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif ELSE IF (K482.EQ.1) THEN #if !defined(parmetis) && !defined(metis) && !defined(parmetis3) && !defined(metis4) #if defined(ptscotch) || defined(scotch) K482_LOC = 2 #else K482_LOC = 3 #endif #else K482_LOC = 1 #endif ELSE IF (K482.EQ.2) THEN #if !defined(ptscotch) && !defined(scotch) #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) K482_LOC = 1 #else K482_LOC = 3 #endif #else K482_LOC = 2 #endif ELSE IF (K482.EQ.3) THEN K482_LOC = 3 END IF IF (K482_LOC.EQ.2) THEN K469_LOC = 1 ELSE K469_LOC = K469 ENDIF NBGROUPS = 0 ALLOCATE( PVS(NSTEPS), STAT=IERR) IF (IERR.GT.0) THEN IFLAG = -7 IERROR = NSTEPS IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", IERROR GOTO 491 ENDIF LRGROUPS = -1 IF (K469_LOC.NE.2) THEN ALLOCATE(TRACE(N), WORKH(N), GEN2HALO(N), & STAT=IERR) IF (IERR.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N IFLAG = -7 IERROR = 3*N GOTO 491 ENDIF ENDIF 491 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 501 PVSCHANGED = .FALSE. OMP_NUM = 1 !$ OMP_NUM = OMP_GET_MAX_THREADS() OMP_NUM = min(OMP_NUM,8) !$OMP PARALLEL PRIVATE(I, NODE, PV, NV, F, GROUP_SIZE2, WORK, IERR_PRIV, !$OMP& WORKH_PRV, TRACE_PRV, GEN2HALO_PRV, NBGROUPS_local, !$OMP& NVEXPANDED, COMPRESS_RATIO, IPROC !$OMP& ) !$OMP& IF (K469_LOC.GT.1) NUM_THREADS(OMP_NUM) ALLOCATE(WORK(2*MAXFRONT+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 2*MAXFRONT+1 !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 2*MAXFRONT+1 !$OMP END ATOMIC ENDIF IF (IERR_PRIV .EQ. 0 .AND. K469_LOC.EQ.2) THEN ALLOCATE(TRACE_PRV(N), WORKH_PRV(N), GEN2HALO_PRV(N), & STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) " Error allocate integer array of ", * "size: ", 3*N !$OMP ATOMIC WRITE IFLAG = -7 !$OMP END ATOMIC !$OMP ATOMIC WRITE IERROR = 3*N !$OMP END ATOMIC ENDIF ENDIF !$OMP BARRIER IF (IFLAG .LT. 0 ) THEN GOTO 498 ENDIF IF (K469_LOC.EQ.2) THEN TRACE_PRV = 0 ELSE !$OMP SINGLE TRACE = 0 !$OMP END SINGLE ENDIF !$OMP DO DO I = 1,N IF (STEP(I).GT.0) PVS(STEP(I)) = I END DO !$OMP END DO !$OMP DO SCHEDULE(DYNAMIC,1) DO NODE=NSTEPS,1,-1 IF (IFLAG.LT.0) CYCLE IF (MAPCOL_PROVIDED) THEN IPROC = MAPCOL(NODE) IF (IPROC.NE.MYID) THEN PVS(NODE) = -999 CYCLE ENDIF ENDIF PV = PVS(NODE) NV = 0 NVEXPANDED = 0 F = PV DO WHILE(F .GT. 0) NV = NV+1 NVEXPANDED = NVEXPANDED+SIZEOFBLOCKS(F) WORK(NV) = F F = FILS(F) END DO COMPRESS_RATIO = dble(NVEXPANDED)/dble(NV) CALL COMPUTE_BLR_VCS(K472, GROUP_SIZE2, GROUP_SIZE, NVEXPANDED) IF (NVEXPANDED .GE. GROUP_SIZE2) THEN IF ( (K482_LOC.EQ.3) & .OR. & ( (K60.NE.0).AND.(WORK(1).EQ.K38ou20) ) & ) & THEN GROUP_SIZE2 = max(int(dble(GROUP_SIZE2)/COMPRESS_RATIO), 1) !$OMP CRITICAL(lrgrouping_cri) DO I=1,NV LRGROUPS(WORK(I))=NBGROUPS+1+(I-1)/GROUP_SIZE2 END DO NBGROUPS = NBGROUPS + (NV-1)/GROUP_SIZE2 + 1 !$OMP END CRITICAL(lrgrouping_cri) ELSE IF (K469_LOC .EQ. 2) THEN CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE_PRV, WORKH_PRV, & NODE, GEN2HALO_PRV, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ELSE CALL SEP_GROUPING_AB(NV, NVEXPANDED, WORK(1), N, & LRGROUPS, NBGROUPS, LUMAT, SIZEOFBLOCKS, & GROUP_SIZE, HALO_DEPTH, TRACE, WORKH, & NODE, GEN2HALO, K482_LOC, K472, K469_LOC, & SEP_SIZE, K10, LP, LPOK, IFLAG, IERROR) ENDIF IF (IFLAG.LT.0) CYCLE PVS(NODE) = WORK(1) !$OMP ATOMIC WRITE PVSCHANGED = .TRUE. !$OMP END ATOMIC STEP(WORK(1)) = ABS(STEP(WORK(1))) IF (STEP(WORK(1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORK(1) ELSE K20 = WORK(1) ENDIF ENDIF DO I=1, NV-1 STEP(WORK(I+1)) = -STEP(WORK(1)) IF (FILS(WORK(I)).LE.0) THEN FILS(WORK(NV)) = FILS(WORK(I)) ENDIF FILS(WORK(I)) = WORK(I+1) ENDDO ENDIF ELSE !$OMP ATOMIC CAPTURE NBGROUPS = NBGROUPS + 1 NBGROUPS_local = NBGROUPS !$OMP END ATOMIC IF (NVEXPANDED .GE. SEP_SIZE) THEN DO I = 1, NV LRGROUPS( WORK(I) ) = NBGROUPS_local ENDDO ELSE DO I = 1, NV LRGROUPS( WORK(I) ) = -NBGROUPS_local ENDDO ENDIF ENDIF ENDDO !$OMP END DO 498 CONTINUE !$OMP MASTER CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) !$OMP END MASTER !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP MASTER IF (K469_LOC.NE.2) THEN IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF !$OMP END MASTER IF (.NOT.MAPCOL_PROVIDED) THEN !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT_GLOB = 1 ELSE PVSCHANGED_INT_GLOB = 0 ENDIF !$OMP END MASTER ELSE !$OMP MASTER IF (PVSCHANGED) THEN PVSCHANGED_INT = 1 ELSE PVSCHANGED_INT = 0 ENDIF CALL MPI_ALLREDUCE( PVSCHANGED_INT, PVSCHANGED_INT_GLOB, 1, & MPI_INTEGER, & MPI_MAX, COMM, IERR_MPI ) PVSCHANGED_INT_GLOB = 1 IF (PVSCHANGED_INT_GLOB.NE.0) THEN IF (NPROCS.GT.1) THEN ALLOCATE(WORKH(2*N+3*NSTEPS+1), STAT=IERR_PRIV) IF (IERR_PRIV.GT.0) THEN IF (LPOK) WRITE(LP,*) & " Error allocate integer array of ", & "size: ", 2*MAXFRONT+1 IFLAG = -7 IERROR = 2*N+3*NSTEPS+1 ENDIF CALL MUMPS_PROPINFO( ICNTL(1), IFLAG, & COMM, MYID ) IF (IFLAG.LT.0) GOTO 499 IF (MYID.EQ.MASTER) THEN IPROC = 0 DO WHILE (IPROC.NE.NPROCS-1) IPROC = IPROC + 1 CALL MPI_RECV( NBNODES_LOC, 1, MPI_INTEGER, & MPI_ANY_SOURCE, & GROUPING, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) IF (NBNODES_LOC.EQ.0) THEN CYCLE ENDIF CALL MPI_RECV( NBGROUPS_sent, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( SIZE_SENT, 1, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) CALL MPI_RECV( WORKH, SIZE_SENT, MPI_INTEGER, & MSGSOU, GROUPING, COMM, STATUS, IERR ) ISHIFT = 0 DO ILOOP=1, NBNODES_LOC ISHIFT = ISHIFT+1 NODE = WORKH (ISHIFT) ISHIFT = ISHIFT+1 NV = WORKH(ISHIFT) PVS(NODE) = WORKH(ISHIFT+1) STEP(WORKH(ISHIFT+1)) = NODE IF (STEP(WORKH(ISHIFT+1)).EQ.STEP_SCALAPACK_ROOT) THEN IF (K38.GT.0) THEN K38 = WORKH(ISHIFT+1) ELSE K20 = WORKH(ISHIFT+1) END IF END IF DO I=2, NV STEP(WORKH(I+ISHIFT)) = -NODE END DO DO I=1, NV FILS(WORKH(I+ISHIFT)) = WORKH(I+1+ISHIFT) IF (WORKH(NV+1+I+ISHIFT).LT.0) THEN LRGROUPS(WORKH(I+ISHIFT)) = & - NBGROUPS + WORKH(NV+1+I+ISHIFT) ELSE LRGROUPS(WORKH(I+ISHIFT)) = & NBGROUPS + WORKH(NV+1+I+ISHIFT) END IF END DO ISHIFT = ISHIFT + 2*NV +1 END DO NBGROUPS = NBGROUPS + NBGROUPS_sent ENDDO ELSE NBNODES_LOC = 0 SIZE_SENT = 0 ISHIFT = 0 DO NODE = 1,NSTEPS IPROC = MAPCOL(NODE) IF (IPROC.EQ.MYID) THEN NBNODES_LOC = NBNODES_LOC + 1 ISHIFT = ISHIFT +1 WORKH(ISHIFT) = NODE ISHIFT = ISHIFT +1 NV = 0 F = PVS(NODE) DO WHILE (F.GT.0) NV = NV + 1 WORKH(NV+ISHIFT) = F F = FILS(F) ENDDO WORKH(ISHIFT) = NV WORKH(NV+1+ISHIFT) = F DO I=1, NV WORKH(NV+1+I+ISHIFT) = LRGROUPS(WORKH(I+ISHIFT)) ENDDO ISHIFT = ISHIFT + 2*NV+1 ENDIF ENDDO SIZE_SENT = ISHIFT CALL MPI_SEND( NBNODES_LOC, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) IF (NBNODES_LOC.GT.0) THEN CALL MPI_SEND( NBGROUPS, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( SIZE_SENT, 1, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) CALL MPI_SEND( WORKH, SIZE_SENT, MPI_INTEGER, MASTER, & GROUPING, COMM, IERR ) ENDIF ENDIF ENDIF ENDIF 499 CONTINUE !$OMP END MASTER ENDIF !$OMP BARRIER IF (IFLAG.LT.0) GOTO 500 IF (MYID.EQ.MASTER) THEN IF (PVSCHANGED_INT_GLOB.EQ.0) GOTO 500 !$OMP DO DO NODE = 1,NSTEPS IF(FRERE_STEPS(NODE) .GT. 0) THEN FRERE_STEPS(NODE) = PVS(ABS(STEP(FRERE_STEPS(NODE)))) ELSE IF(FRERE_STEPS(NODE) .LT. 0) THEN FRERE_STEPS(NODE) = -PVS(ABS(STEP(DAD_STEPS(NODE)))) ENDIF IF(DAD_STEPS(NODE) .NE. 0) THEN DAD_STEPS(NODE) = PVS(ABS(STEP(DAD_STEPS(NODE)))) END IF ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=3,LNA NA(I) = PVS(ABS(STEP(NA(I)))) ENDDO !$OMP END DO NOWAIT !$OMP DO DO I=1,N IF (FILS(I).LT.0) THEN FILS(I) = -PVS(ABS(STEP(-FILS(I)))) ENDIF ENDDO !$OMP END DO ENDIF 500 CONTINUE IF (allocated(WORK)) DEALLOCATE(WORK) IF (K469_LOC.EQ.2) THEN IF (allocated(TRACE_PRV)) DEALLOCATE(TRACE_PRV) IF (allocated(WORKH_PRV)) DEALLOCATE(WORKH_PRV) IF (allocated(GEN2HALO_PRV)) DEALLOCATE(GEN2HALO_PRV) ENDIF !$OMP END PARALLEL 501 CONTINUE IF (K469_LOC.NE.2) THEN IF (allocated(TRACE)) DEALLOCATE(TRACE) IF (allocated(WORKH)) DEALLOCATE(WORKH) IF (allocated(GEN2HALO)) DEALLOCATE(GEN2HALO) ENDIF IF (allocated(PVS)) DEALLOCATE(PVS) RETURN END SUBROUTINE ZMUMPS_AB_LR_MPI_GROUPING END MODULE ZMUMPS_ANA_LR MUMPS_5.4.1/src/tools_common.F0000664000175000017500000011605714102210475016342 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_MAKE1ROOT( N, FRERE, FILS, NFSIZ, THEROOT ) IMPLICIT NONE INTEGER, intent( in ) :: N INTEGER, intent( in ) :: NFSIZ( N ) INTEGER, intent( inout ) :: FRERE( N ), FILS( N ) INTEGER, intent( out ) :: THEROOT INTEGER INODE, IROOT, IFILS, IN, IROOTLAST, SIZE IROOT = -9999 SIZE = 0 DO INODE = 1, N IF ( FRERE( INODE ) .EQ. 0 ) THEN IF ( NFSIZ( INODE ) .GT. SIZE ) THEN SIZE = NFSIZ( INODE ) IROOT = INODE END IF ENDIF END DO IN = IROOT DO WHILE ( FILS( IN ) .GT. 0 ) IN = FILS( IN ) END DO IROOTLAST = IN IFILS = - FILS ( IN ) DO INODE = 1, N IF ( FRERE( INODE ) .eq. 0 .and. INODE .ne. IROOT ) THEN IF ( IFILS .eq. 0 ) THEN FILS( IROOTLAST ) = - INODE FRERE( INODE ) = -IROOT IFILS = INODE ELSE FRERE( INODE ) = -FILS( IROOTLAST ) FILS( IROOTLAST ) = - INODE END IF END IF END DO THEROOT = IROOT RETURN END SUBROUTINE MUMPS_MAKE1ROOT INTEGER FUNCTION MUMPS_ENCODE_TPN_IPROC(TPN,IPROC,K199) INTEGER, INTENT(IN) :: TPN, IPROC, K199 IF (K199 < 0) THEN MUMPS_ENCODE_TPN_IPROC = IPROC + ISHFT(TPN+1, 24) ELSE MUMPS_ENCODE_TPN_IPROC = (TPN-1)*K199+IPROC+1 ENDIF RETURN END FUNCTION MUMPS_ENCODE_TPN_IPROC INTEGER FUNCTION MUMPS_TYPENODE_ROUGH(PROCINFO_INODE, K199) IMPLICIT NONE INTEGER K199 INTEGER PROCINFO_INODE IF (K199 < 0) THEN MUMPS_TYPENODE_ROUGH = ISHFT(PROCINFO_INODE,-24) - 1 ELSE MUMPS_TYPENODE_ROUGH = (PROCINFO_INODE-1+2*K199)/K199 - 1 ENDIF RETURN END FUNCTION MUMPS_TYPENODE_ROUGH INTEGER FUNCTION MUMPS_TYPENODE(PROCINFO_INODE, K199) IMPLICIT NONE INTEGER K199 INTEGER PROCINFO_INODE, TPN IF (K199 < 0) THEN TPN = ISHFT(PROCINFO_INODE,-24) - 1 IF (TPN < 1 ) THEN TPN = 1 ELSE IF (TPN.GE.4) THEN TPN = 2 ENDIF ELSE IF (PROCINFO_INODE <= K199 ) THEN TPN = 1 ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199 - 1 IF ( TPN .LT. 1 ) TPN = 1 IF (TPN.EQ.4.OR.TPN.EQ.5.OR.TPN.EQ.6) TPN = 2 END IF END IF MUMPS_TYPENODE = TPN RETURN END FUNCTION MUMPS_TYPENODE SUBROUTINE MUMPS_TYPEANDPROCNODE( TPN, & MUMPS_PROCNODE, PROCINFO_INODE, K199 ) INTEGER, INTENT(IN) :: K199, PROCINFO_INODE INTEGER, intent(out) :: TPN, MUMPS_PROCNODE IF (K199 < 0 ) THEN MUMPS_PROCNODE=iand(PROCINFO_INODE, #if defined(MUMPS_F2003) & int(B"111111111111111111111111")) #else & 16777215) #endif TPN = ISHFT(PROCINFO_INODE,-24) - 1 IF (TPN < 1 ) THEN TPN = 1 ELSE IF (TPN.GE.4) THEN TPN = 2 ENDIF ELSE IF (K199 == 1) THEN MUMPS_PROCNODE = 0 IF (PROCINFO_INODE <= K199) THEN TPN = 1 ELSE TPN = 3 ENDIF ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199-1 MUMPS_PROCNODE = (PROCINFO_INODE-1+2*K199)- & (TPN+1)*K199 IF (TPN .LT. 1) THEN TPN = 1 ELSE IF (TPN .ge. 4) THEN TPN = 2 ENDIF ENDIF ENDIF RETURN END SUBROUTINE MUMPS_TYPEANDPROCNODE INTEGER FUNCTION MUMPS_PROCNODE(PROCINFO_INODE, K199) IMPLICIT NONE INTEGER K199 INTEGER PROCINFO_INODE IF ( K199 < 0 ) THEN MUMPS_PROCNODE=iand(PROCINFO_INODE, #if defined(MUMPS_F2003) & int(B"111111111111111111111111")) #else & 16777215 ) #endif ELSE IF (K199 == 1) THEN MUMPS_PROCNODE = 0 ELSE MUMPS_PROCNODE=mod(2*K199+PROCINFO_INODE-1,K199) END IF ENDIF RETURN END FUNCTION MUMPS_PROCNODE INTEGER FUNCTION MUMPS_TYPESPLIT (PROCINFO_INODE, K199) IMPLICIT NONE INTEGER, intent(in) :: K199 INTEGER PROCINFO_INODE, TPN IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 IF (TPN < 1 ) TPN = 1 ELSE IF (PROCINFO_INODE <= K199 ) THEN TPN = 1 ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199 - 1 IF ( TPN .LT. 1 ) TPN = 1 ENDIF ENDIF MUMPS_TYPESPLIT = TPN RETURN END FUNCTION MUMPS_TYPESPLIT LOGICAL FUNCTION MUMPS_ROOTSSARBR( PROCINFO_INODE, K199 ) IMPLICIT NONE INTEGER K199 INTEGER TPN, PROCINFO_INODE IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 ELSE TPN = (PROCINFO_INODE-1+2*K199)/K199 - 1 ENDIF MUMPS_ROOTSSARBR = ( TPN .eq. 0 ) RETURN END FUNCTION MUMPS_ROOTSSARBR LOGICAL FUNCTION MUMPS_INSSARBR( PROCINFO_INODE, K199 ) IMPLICIT NONE INTEGER K199 INTEGER TPN, PROCINFO_INODE IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 ELSE TPN = (PROCINFO_INODE-1+K199+K199)/K199 - 1 ENDIF MUMPS_INSSARBR = ( TPN .eq. -1 ) RETURN END FUNCTION MUMPS_INSSARBR LOGICAL FUNCTION MUMPS_IN_OR_ROOT_SSARBR & ( PROCINFO_INODE, K199 ) IMPLICIT NONE INTEGER K199 INTEGER TPN, PROCINFO_INODE IF (K199 < 0) THEN TPN = ishft(PROCINFO_INODE,-24) - 1 ELSE TPN = (PROCINFO_INODE-1+K199+K199)/K199 - 1 ENDIF MUMPS_IN_OR_ROOT_SSARBR = & ( TPN .eq. -1 .OR. TPN .eq. 0 ) RETURN END FUNCTION MUMPS_IN_OR_ROOT_SSARBR SUBROUTINE MUMPS_SET_SSARBR_DAD( & SSARBR, INODE, DAD, N, & KEEP28, & STEP, PROCNODE_STEPS, K199) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP28, K199, INODE INTEGER, INTENT(IN) :: DAD(KEEP28), PROCNODE_STEPS(KEEP28) INTEGER, INTENT(IN) :: STEP(N) LOGICAL, INTENT(OUT) :: SSARBR INTEGER :: DADINODE, TYPEDAD LOGICAL, EXTERNAL :: MUMPS_INSSARBR INTEGER, EXTERNAL :: MUMPS_TYPENODE SSARBR = .FALSE. DADINODE = DAD(STEP(INODE)) IF (DADINODE .NE. 0) THEN TYPEDAD = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DADINODE)), & K199) IF (TYPEDAD.EQ.1) THEN SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(DADINODE)), & K199) ENDIF ENDIF RETURN END SUBROUTINE MUMPS_SET_SSARBR_DAD LOGICAL FUNCTION MUMPS_I_AM_CANDIDATE( MYID, SLAVEF, INODE, & NMB_PAR2, ISTEP_TO_INIV2 , K71, STEP, N, & CANDIDATES, KEEP24 ) IMPLICIT NONE INTEGER MYID, SLAVEF, INODE, NMB_PAR2, KEEP24, I INTEGER K71, N INTEGER ISTEP_TO_INIV2 ( K71 ), STEP ( N ) INTEGER CANDIDATES(SLAVEF+1, max(NMB_PAR2,1)) INTEGER NCAND, POSINODE MUMPS_I_AM_CANDIDATE = .FALSE. IF (KEEP24 .eq. 0) RETURN POSINODE = ISTEP_TO_INIV2 ( STEP (INODE) ) NCAND = CANDIDATES( SLAVEF+1, POSINODE ) DO I = 1, NCAND IF (MYID .EQ. CANDIDATES( I, POSINODE )) & MUMPS_I_AM_CANDIDATE = .TRUE. END DO RETURN END FUNCTION MUMPS_I_AM_CANDIDATE SUBROUTINE MUMPS_SECDEB(T) DOUBLE PRECISION T DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME T=MPI_WTIME() RETURN END SUBROUTINE MUMPS_SECDEB SUBROUTINE MUMPS_SECFIN(T) DOUBLE PRECISION T DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME T=MPI_WTIME()-T RETURN END SUBROUTINE MUMPS_SECFIN SUBROUTINE MUMPS_SORT_DOUBLES( N, VAL, ID ) INTEGER N INTEGER ID( N ) DOUBLE PRECISION VAL( N ) INTEGER I, ISWAP DOUBLE PRECISION SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_DOUBLES SUBROUTINE MUMPS_SORT_DOUBLES_DEC( N, VAL, ID ) INTEGER N INTEGER ID( N ) DOUBLE PRECISION VAL( N ) INTEGER I, ISWAP DOUBLE PRECISION SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_DOUBLES_DEC #if defined (PESSL) SUBROUTINE DESCINIT( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, & LLD, INFO ) INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB INTEGER DESC( * ) INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, & LLD_, MB_, M_, NB_, N_, RSRC_ # if defined(DESC8) PARAMETER ( DLEN_ = 8, DTYPE_ = 1, & CTXT_ = 7, M_ = 1, N_ = 2, MB_ = 3, NB_ = 4, & RSRC_ = 5, CSRC_ = 6, LLD_ = 8 ) # else PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, & CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, & RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) # endif INTEGER MYCOL, MYROW, NPCOL, NPROW EXTERNAL blacs_gridinfo, PXERBLA INTEGER NUMROC EXTERNAL NUMROC INTRINSIC max, min CALL blacs_gridinfo( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) INFO = 0 IF( M.LT.0 ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -3 ELSE IF( MB.LT.1 ) THEN INFO = -4 ELSE IF( NB.LT.1 ) THEN INFO = -5 ELSE IF( IRSRC.LT.0 .OR. IRSRC.GE.NPROW ) THEN INFO = -6 ELSE IF( ICSRC.LT.0 .OR. ICSRC.GE.NPCOL ) THEN INFO = -7 ELSE IF( NPROW.EQ.-1 ) THEN INFO = -8 ELSE IF( LLD.LT.max( 1, numroc( M, MB, MYROW, IRSRC, & NPROW ) ) ) THEN INFO = -9 END IF IF( INFO.NE.0 ) & CALL PXERBLA( ICTXT, 'DESCINIT', -INFO ) # ifndef DESC8 DESC( DTYPE_ ) = BLOCK_CYCLIC_2D # endif DESC( M_ ) = max( 0, M ) DESC( N_ ) = max( 0, N ) DESC( MB_ ) = max( 1, MB ) DESC( NB_ ) = max( 1, NB ) DESC( RSRC_ ) = max( 0, min( IRSRC, NPROW-1 ) ) DESC( CSRC_ ) = max( 0, min( ICSRC, NPCOL-1 ) ) DESC( CTXT_ ) = ICTXT DESC( LLD_ ) = max( LLD, max( 1, numroc( DESC( M_ ), DESC( MB_ ), & MYROW, DESC( RSRC_ ), NPROW ) ) ) RETURN END SUBROUTINE DESCINIT SUBROUTINE PXERBLA( ICTXT, SRNAME, INFO ) INTEGER ICTXT, INFO CHARACTER*(*) SRNAME INTEGER MYCOL, MYROW, NPCOL, NPROW EXTERNAL blacs_gridinfo CALL blacs_gridinfo( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) WRITE( *, FMT = 9999 ) MYROW, MYCOL, SRNAME, INFO 9999 FORMAT( '{', I5, ',', I5, '}: On entry to ', A, & ' parameter number', I4, ' had an illegal value' ) END SUBROUTINE PXERBLA #endif SUBROUTINE MUMPS_MEM_CENTRALIZE(MYID, COMM, INFO, INFOG, IRANK) IMPLICIT NONE INTEGER MYID, COMM, IRANK, INFO, INFOG(2) INCLUDE 'mpif.h' INTEGER IERR_MPI, MASTER #if defined(WORKAROUNDINTELILP64MPI2INTEGER) INTEGER(4) :: TEMP1(2),TEMP2(2) #else INTEGER :: TEMP1(2),TEMP2(2) #endif PARAMETER( MASTER = 0 ) CALL MPI_REDUCE( INFO, INFOG(1), 1, MPI_INTEGER, & MPI_MAX, MASTER, COMM, IERR_MPI ) CALL MPI_REDUCE( INFO, INFOG(2), 1, MPI_INTEGER, & MPI_SUM, MASTER, COMM, IERR_MPI ) TEMP1(1) = INFO TEMP1(2) = MYID CALL MPI_REDUCE( TEMP1, TEMP2, 1, MPI_2INTEGER, & MPI_MAXLOC, MASTER, COMM, IERR_MPI ) IF ( MYID.eq. MASTER ) THEN IF ( INFOG(1) .ne. TEMP2(1) ) THEN write(*,*) 'Error in MUMPS_MEM_CENTRALIZE' CALL MUMPS_ABORT() END IF IRANK = TEMP2(2) ELSE IRANK = -1 END IF RETURN END SUBROUTINE MUMPS_MEM_CENTRALIZE INTEGER FUNCTION MUMPS_GET_POOL_LENGTH & (MAX_ACTIVE_NODES,KEEP,KEEP8) IMPLICIT NONE INTEGER MAX_ACTIVE_NODES INTEGER KEEP(500) INTEGER(8) KEEP8(150) MUMPS_GET_POOL_LENGTH = MAX_ACTIVE_NODES + 1 + 3 RETURN END FUNCTION MUMPS_GET_POOL_LENGTH SUBROUTINE MUMPS_INIT_POOL_DIST_BWD(N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, & KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, nb_prun_roots INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT(IN) :: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(OUT) :: MYROOT INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: I, INODE MYROOT = 0 DO I = nb_prun_roots, 1, -1 INODE = Pruned_Roots(I) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_BWD SUBROUTINE MUMPS_INIT_POOL_DIST_BWD_L0(N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, & KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL, TO_PROCESS ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, nb_prun_roots INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) LOGICAL, INTENT(IN) :: TO_PROCESS(KEEP(28)) INTEGER, INTENT(IN) :: Pruned_Roots(nb_prun_roots) INTEGER, INTENT(OUT) :: MYROOT INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: I, INODE MYROOT = 0 DO I = nb_prun_roots, 1, -1 INODE = Pruned_Roots(I) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN IF ( TO_PROCESS(STEP(INODE)) ) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_BWD_L0 SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWD(N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IPOOL, LPOOL ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, MYID_NODES, LPOOL, LNA INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, INTENT(IN) :: STEP(N) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), NA(LNA) INTEGER, INTENT(OUT) :: IPOOL(LPOOL) INTEGER, INTENT(OUT) :: MYROOT INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: NBLEAF, NBROOT, I, INODE NBLEAF = NA(1) NBROOT = NA(2) MYROOT = 0 DO I = NBROOT, 1, -1 INODE = NA(NBLEAF+I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) .EQ. MYID_NODES) THEN MYROOT = MYROOT + 1 IPOOL(MYROOT) = INODE ENDIF END DO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_NA_BWD SUBROUTINE MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & K199, NA, LNA, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) IMPLICIT NONE INTEGER N, LEAF, MYID_NODES, & K199, LPOOL, LNA INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)), NA(LNA), & IPOOL(LPOOL) INTEGER NBLEAF, INODE, I INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE NBLEAF = NA(1) LEAF = 1 DO I = 1, NBLEAF INODE = NA(I+2) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ.MYID_NODES) THEN IPOOL(LEAF) = INODE LEAF = LEAF + 1 ENDIF ENDDO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST SUBROUTINE MUMPS_INIT_POOL_DIST_NONA & (N, LEAF, MYID_NODES, & LLEAVES, LEAVES, KEEP,KEEP8, STEP, & PROCNODE_STEPS, IPOOL, LPOOL) IMPLICIT NONE INTEGER N, LEAF, MYID_NODES, & LPOOL, LLEAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)), LEAVES(LLEAVES), & IPOOL(LPOOL) INTEGER I, INODE INTEGER, EXTERNAL :: MUMPS_PROCNODE LEAF = 1 DO I = 1, LLEAVES INODE = LEAVES(I) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) & .EQ.MYID_NODES ) THEN IPOOL( LEAF ) = INODE LEAF = LEAF + 1 ENDIF ENDDO RETURN END SUBROUTINE MUMPS_INIT_POOL_DIST_NONA SUBROUTINE MUMPS_INIT_NROOT_DIST(N, NBROOT, & NROOT_LOC, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, & PROCNODE_STEPS) IMPLICIT NONE INTEGER, INTENT( OUT ) :: NROOT_LOC INTEGER, INTENT( OUT ) :: NBROOT INTEGER, INTENT( IN ) :: KEEP( 500 ) INTEGER, INTENT( IN ) :: SLAVEF INTEGER, INTENT( IN ) :: N INTEGER, INTENT( IN ) :: STEP(N) INTEGER, INTENT( IN ) :: LNA INTEGER, INTENT( IN ) :: NA(LNA) INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: MYID_NODES INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER :: INODE, I, NBLEAF NBLEAF = NA(1) NBROOT = NA(2) NROOT_LOC = 0 DO I = 1, NBROOT INODE = NA(I+2+NBLEAF) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)).EQ.MYID_NODES) THEN NROOT_LOC = NROOT_LOC + 1 END IF ENDDO RETURN END SUBROUTINE MUMPS_INIT_NROOT_DIST SUBROUTINE MUMPS_NBLOCAL_ROOTS_OR_LEAVES & (N, NBRORL, RORL_LIST, & NRORL_LOC, MYID_NODES, & SLAVEF, KEEP, STEP, & PROCNODE_STEPS) IMPLICIT NONE INTEGER, INTENT( OUT ) :: NRORL_LOC INTEGER, INTENT( IN ) :: NBRORL INTEGER, INTENT( IN ) :: RORL_LIST(NBRORL) INTEGER, INTENT( IN ) :: KEEP( 500 ) INTEGER, INTENT( IN ) :: SLAVEF INTEGER, INTENT( IN ) :: N INTEGER, INTENT( IN ) :: STEP(N) INTEGER, INTENT( IN ) :: PROCNODE_STEPS(KEEP(28)) INTEGER, INTENT( IN ) :: MYID_NODES INTEGER I, INODE INTEGER, EXTERNAL :: MUMPS_PROCNODE NRORL_LOC = 0 DO I = 1, NBRORL INODE = RORL_LIST(I) IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)).EQ.MYID_NODES) THEN NRORL_LOC = NRORL_LOC + 1 END IF ENDDO RETURN END SUBROUTINE MUMPS_NBLOCAL_ROOTS_OR_LEAVES LOGICAL FUNCTION MUMPS_COMPARE_TAB(TAB1,TAB2,LEN1,LEN2) IMPLICIT NONE INTEGER LEN1 , LEN2 ,I INTEGER TAB1(LEN1) INTEGER TAB2(LEN2) MUMPS_COMPARE_TAB=.FALSE. IF(LEN1 .NE. LEN2) THEN RETURN ENDIF DO I=1 , LEN1 IF(TAB1(I) .NE. TAB2(I)) THEN RETURN ENDIF ENDDO MUMPS_COMPARE_TAB=.TRUE. RETURN END FUNCTION MUMPS_COMPARE_TAB SUBROUTINE MUMPS_SORT_INT( N, VAL, ID ) INTEGER N INTEGER ID( N ) INTEGER VAL( N ) INTEGER I, ISWAP INTEGER SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_INT SUBROUTINE MUMPS_SORT_INT_DEC( N, VAL, ID ) INTEGER N INTEGER ID( N ) INTEGER VAL( N ) INTEGER I, ISWAP INTEGER SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .LT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_INT_DEC SUBROUTINE MUMPS_SORT_INT8( N, VAL, ID ) INTEGER N INTEGER ID( N ) INTEGER(8) :: VAL( N ) INTEGER I, ISWAP INTEGER(8) SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, N - 1 IF ( VAL( I ) .GT. VAL( I + 1 ) ) THEN DONE = .FALSE. ISWAP = ID( I ) ID ( I ) = ID ( I + 1 ) ID ( I + 1 ) = ISWAP SWAP = VAL( I ) VAL( I ) = VAL( I + 1 ) VAL( I + 1 ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT_INT8 SUBROUTINE MUMPS_ABORT() IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR, IERRCODE IERRCODE = -99 CALL MPI_ABORT(MPI_COMM_WORLD, IERRCODE, IERR) RETURN END SUBROUTINE MUMPS_ABORT SUBROUTINE MUMPS_GET_PERLU(KEEP12,ICNTL14, & KEEP50,KEEP54,ICNTL6,ICNTL8) IMPLICIT NONE INTEGER, intent(out)::KEEP12 INTEGER, intent(in)::ICNTL14,KEEP50,KEEP54,ICNTL6,ICNTL8 KEEP12 = ICNTL14 RETURN END SUBROUTINE MUMPS_GET_PERLU #if defined(NOTUSED) SUBROUTINE MUMPS_BCAST_I8( I8_VALUE, ROOT, MYID, COMM, IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ROOT, MYID, COMM, IERR INTEGER(8) :: I8_VALUE DOUBLE PRECISION :: DBLE_VALUE IF (MYID .EQ. ROOT) THEN DBLE_VALUE = dble(I8_VALUE) ENDIF CALL MPI_BCAST( DBLE_VALUE, 1, MPI_DOUBLE_PRECISION, & ROOT, COMM, IERR ) I8_VALUE = int( DBLE_VALUE,8) RETURN END SUBROUTINE MUMPS_BCAST_I8 #endif SUBROUTINE MUMPS_REDUCEI8( IN, OUT, MPI_OP, ROOT, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER ROOT, COMM, MPI_OP INTEGER(8) IN, OUT INTEGER IERR DOUBLE PRECISION DIN, DOUT DIN =dble(IN) DOUT=0.0D0 CALL MPI_REDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, & MPI_OP, ROOT, COMM, IERR) OUT=int(DOUT,kind=8) RETURN END SUBROUTINE MUMPS_REDUCEI8 SUBROUTINE MUMPS_ALLREDUCEI8( IN, OUT, MPI_OP, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, MPI_OP INTEGER(8) IN, OUT INTEGER IERR DOUBLE PRECISION DIN, DOUT DIN =dble(IN) DOUT=0.0D0 CALL MPI_ALLREDUCE(DIN, DOUT, 1, MPI_DOUBLE_PRECISION, & MPI_OP, COMM, IERR) OUT=int(DOUT,kind=8) RETURN END SUBROUTINE MUMPS_ALLREDUCEI8 SUBROUTINE MUMPS_SETI8TOI4(I8, I4) IMPLICIT NONE INTEGER , INTENT(OUT) :: I4 INTEGER(8), INTENT(IN) :: I8 IF ( I8 .GT. int(huge(I4),8) ) THEN I4 = -int(I8/1000000_8,kind(I4)) ELSE I4 = int(I8,kind(I4)) ENDIF RETURN END SUBROUTINE MUMPS_SETI8TOI4 SUBROUTINE MUMPS_ABORT_ON_OVERFLOW(I8, STRING) IMPLICIT NONE INTEGER(8), INTENT(IN) :: I8 CHARACTER(*), INTENT(IN) :: STRING INTEGER I4 IF ( I8 .GT. int(huge(I4),8)) THEN WRITE(*,*) STRING CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE MUMPS_ABORT_ON_OVERFLOW SUBROUTINE MUMPS_SET_IERROR( SIZE8, IERROR ) INTEGER(8), INTENT(IN) :: SIZE8 INTEGER, INTENT(OUT) :: IERROR CALL MUMPS_SETI8TOI4(SIZE8, IERROR) RETURN END SUBROUTINE MUMPS_SET_IERROR SUBROUTINE MUMPS_STOREI8(I8, INT_ARRAY) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(out) :: INT_ARRAY(2) INTEGER(kind(0_4)) :: I32 INTEGER(8) :: IDIV, IPAR PARAMETER (IPAR=int(huge(I32),8)) PARAMETER (IDIV=IPAR+1_8) IF ( I8 .LT. IDIV ) THEN INT_ARRAY(1) = 0 INT_ARRAY(2) = int(I8) ELSE INT_ARRAY(1) = int(I8 / IDIV) INT_ARRAY(2) = int(mod(I8,IDIV)) ENDIF RETURN END SUBROUTINE MUMPS_STOREI8 SUBROUTINE MUMPS_GETI8(I8, INT_ARRAY) IMPLICIT NONE INTEGER(8), intent(out) :: I8 INTEGER, intent(in) :: INT_ARRAY(2) INTEGER(kind(0_4)) :: I32 INTEGER(8) :: IDIV, IPAR PARAMETER (IPAR=int(huge(I32),8)) PARAMETER (IDIV=IPAR+1_8) IF ( INT_ARRAY(1) .EQ. 0 ) THEN I8=int(INT_ARRAY(2),8) ELSE I8=int(INT_ARRAY(1),8)*IDIV+int(INT_ARRAY(2),8) ENDIF RETURN END SUBROUTINE MUMPS_GETI8 SUBROUTINE MUMPS_ADDI8TOARRAY( INT_ARRAY, I8 ) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(inout) :: INT_ARRAY(2) INTEGER(8) :: I8TMP CALL MUMPS_GETI8(I8TMP, INT_ARRAY) I8TMP = I8TMP + I8 CALL MUMPS_STOREI8(I8TMP, INT_ARRAY) RETURN END SUBROUTINE MUMPS_ADDI8TOARRAY SUBROUTINE MUMPS_SUBTRI8TOARRAY( INT_ARRAY, I8 ) IMPLICIT NONE INTEGER(8), intent(in) :: I8 INTEGER, intent(inout) :: INT_ARRAY(2) INTEGER(8) :: I8TMP CALL MUMPS_GETI8(I8TMP, INT_ARRAY) I8TMP = I8TMP - I8 CALL MUMPS_STOREI8(I8TMP, INT_ARRAY) RETURN END SUBROUTINE MUMPS_SUBTRI8TOARRAY FUNCTION MUMPS_SEQANA_AVAIL(ICNTL7) LOGICAL :: MUMPS_SEQANA_AVAIL INTEGER, INTENT(IN) :: ICNTL7 LOGICAL :: SCOTCH=.FALSE. LOGICAL :: METIS =.FALSE. #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) METIS = .TRUE. #endif #if defined(scotch) || defined(ptscotch) SCOTCH = .TRUE. #endif IF ( ICNTL7 .LT. 0 .OR. ICNTL7 .GT. 7 ) THEN MUMPS_SEQANA_AVAIL = .FALSE. ELSE MUMPS_SEQANA_AVAIL = .TRUE. ENDIF IF ( ICNTL7 .EQ. 5 ) MUMPS_SEQANA_AVAIL = METIS IF ( ICNTL7 .EQ. 3 ) MUMPS_SEQANA_AVAIL = SCOTCH RETURN END FUNCTION MUMPS_SEQANA_AVAIL FUNCTION MUMPS_PARANA_AVAIL(WHICH) LOGICAL :: MUMPS_PARANA_AVAIL CHARACTER :: WHICH*(*) LOGICAL :: PTSCOTCH=.FALSE., PARMETIS=.FALSE. #if defined(ptscotch) PTSCOTCH = .TRUE. #endif #if defined(parmetis) || defined(parmetis3) PARMETIS = .TRUE. #endif SELECT CASE(WHICH) CASE('ptscotch','PTSCOTCH') MUMPS_PARANA_AVAIL = PTSCOTCH CASE('parmetis','PARMETIS') MUMPS_PARANA_AVAIL = PARMETIS CASE('both','BOTH') MUMPS_PARANA_AVAIL = PTSCOTCH .AND. PARMETIS CASE('any','ANY') MUMPS_PARANA_AVAIL = PTSCOTCH .OR. PARMETIS CASE default write(*,'("Invalid input in MUMPS_PARANA_AVAIL")') END SELECT RETURN END FUNCTION MUMPS_PARANA_AVAIL SUBROUTINE MUMPS_SORT_STEP(N,FRERE,STEP,FILS, & NA,LNA,NE,ND,DAD,LDAD,USE_DAD, & NSTEPS,INFO,LP, & PROCNODE,SLAVEF & ) IMPLICIT NONE INTEGER N, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER POSTORDER,TMP_SWAP INTEGER, DIMENSION (:), ALLOCATABLE :: STEP_TO_NODE INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER I,II,allocok INTEGER NBLEAF,NBROOT,LEAF,IN,INODE,IFATH EXTERNAL MUMPS_TYPENODE INTEGER MUMPS_TYPENODE POSTORDER=1 NBLEAF = NA(1) NBROOT = NA(2) ALLOCATE( IPOOL(NBLEAF), TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in MUMPS_SORT_STEP' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO ALLOCATE(STEP_TO_NODE(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &MUMPS_SORT_STEP' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DO I=1,N IF(STEP(I).GT.0)THEN STEP_TO_NODE(STEP(I))=I ENDIF ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF TMP_SWAP=FRERE(STEP(INODE)) FRERE(STEP(INODE))=FRERE(POSTORDER) FRERE(POSTORDER)=TMP_SWAP TMP_SWAP=ND(STEP(INODE)) ND(STEP(INODE))=ND(POSTORDER) ND(POSTORDER)=TMP_SWAP TMP_SWAP=NE(STEP(INODE)) NE(STEP(INODE))=NE(POSTORDER) NE(POSTORDER)=TMP_SWAP TMP_SWAP=PROCNODE(STEP(INODE)) PROCNODE(STEP(INODE))=PROCNODE(POSTORDER) PROCNODE(POSTORDER)=TMP_SWAP IF(USE_DAD)THEN TMP_SWAP=DAD(STEP(INODE)) DAD(STEP(INODE))=DAD(POSTORDER) DAD(POSTORDER)=TMP_SWAP ENDIF TMP_SWAP=TNSTK(STEP(INODE)) TNSTK(STEP(INODE))=TNSTK(POSTORDER) TNSTK(POSTORDER)=TMP_SWAP II=STEP_TO_NODE(POSTORDER) TMP_SWAP=STEP(INODE) STEP(STEP_TO_NODE(POSTORDER))=TMP_SWAP STEP(INODE)=POSTORDER STEP_TO_NODE(POSTORDER)=INODE STEP_TO_NODE(TMP_SWAP)=II IN=II 101 IN = FILS(IN) IF (IN .GT. 0 ) THEN STEP(IN)=-STEP(II) GOTO 101 ENDIF IN=INODE 102 IN = FILS(IN) IF (IN .GT. 0 ) THEN STEP(IN)=-STEP(INODE) GOTO 102 ENDIF POSTORDER = POSTORDER + 1 IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE DEALLOCATE(STEP_TO_NODE) DEALLOCATE(IPOOL,TNSTK) RETURN END SUBROUTINE MUMPS_SORT_STEP SUBROUTINE MUMPS_CHECK_COMM_NODES(COMM_NODES, EXIT_FLAG) IMPLICIT NONE INTEGER, INTENT(IN) :: COMM_NODES LOGICAL, INTENT(OUT) :: EXIT_FLAG INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: STATUS(MPI_STATUS_SIZE), IERR CALL MPI_IPROBE( MPI_ANY_SOURCE, TERREUR, COMM_NODES, & EXIT_FLAG, STATUS, IERR) RETURN END SUBROUTINE MUMPS_CHECK_COMM_NODES SUBROUTINE MUMPS_GET_PROC_PER_NODE(K414, MyID, NbProcs, COMM) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER :: K414, MyID, NbProcs, COMM, ALLOCOK INTEGER :: ierr,MyNAME_length,MyNAME_length_RCV,i,j CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: MyNAME CHARACTER, dimension(:), allocatable :: MyNAME_TAB,MyNAME_TAB_RCV logical :: SAME_NAME call MPI_GET_PROCESSOR_NAME(MyNAME, MyNAME_length, ierr) allocate(MyNAME_TAB(MyNAME_length), STAT=ALLOCOK) IF(ALLOCOK.LT.0) THEN write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE" call MUMPS_ABORT() ENDIF DO i=1, MyNAME_length MyNAME_TAB(i) = MyNAME(i:i) ENDDO K414=0 do i=0, NbProcs-1 if(MyID .eq. i) then MyNAME_length_RCV = MyNAME_length else MyNAME_length_RCV = 0 endif call MPI_BCAST(MyNAME_length_RCV,1,MPI_INTEGER, & i,COMM,ierr) allocate(MyNAME_TAB_RCV(MyNAME_length_RCV), STAT=ALLOCOK) IF(ALLOCOK.LT.0) THEN write(*,*) "Allocation error in MUMPS_GET_PROC_PER_NODE" call MUMPS_ABORT() ENDIF if(MyID .eq. i) then MyNAME_TAB_RCV = MyNAME_TAB endif call MPI_BCAST(MyNAME_TAB_RCV,MyNAME_length_RCV,MPI_CHARACTER, & i,COMM,ierr) SAME_NAME=.FALSE. IF(MyNAME_length .EQ. MyNAME_length_RCV) THEN DO j=1, MyNAME_length IF(MyNAME_TAB(j) .NE. MyNAME_TAB_RCV(j)) THEN goto 100 ENDIF ENDDO SAME_NAME=.TRUE. ENDIF 100 continue IF(SAME_NAME) K414=K414+1 deallocate(MyNAME_TAB_RCV) enddo deallocate(MyNAME_TAB) END SUBROUTINE MUMPS_GET_PROC_PER_NODE SUBROUTINE MUMPS_ICOPY_32TO64 (INTAB, SIZETAB, OUTTAB8) INTEGER, intent(in) :: SIZETAB INTEGER, intent(in) :: INTAB(SIZETAB) INTEGER(8), intent(out) :: OUTTAB8(SIZETAB) INTEGER :: I DO I=1,SIZETAB OUTTAB8(I) = int(INTAB(I),8) ENDDO RETURN END SUBROUTINE MUMPS_ICOPY_32TO64 SUBROUTINE MUMPS_ICOPY_32TO64_64C(INTAB, SIZETAB8, OUTTAB8) INTEGER(8), intent(in) :: SIZETAB8 INTEGER, intent(in) :: INTAB(SIZETAB8) INTEGER(8), intent(out) :: OUTTAB8(SIZETAB8) INTEGER(8) :: I8 LOGICAL :: OMP_FLAG OMP_FLAG = (SIZETAB8 .GE.500000_8 ) !$OMP PARALLEL DO PRIVATE(I8) !$OMP& IF(OMP_FLAG) DO I8=1_8, SIZETAB8 OUTTAB8(I8) = int(INTAB(I8),8) ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE MUMPS_ICOPY_32TO64_64C SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP(IN_OUT_TAB48, SIZETAB) INTEGER(8), intent(in) :: SIZETAB INTEGER, intent(inout) :: IN_OUT_TAB48(2*SIZETAB) CALL MUMPS_ICOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, SIZETAB) RETURN END SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP RECURSIVE SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP_REC( & IN_OUT_TAB48, SIZETAB) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB INTEGER :: IN_OUT_TAB48(2*SIZETAB) INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2 IF (SIZETAB.LE. 1000_8) THEN CALL MUMPS_ICOPY_32TO64_64C_IP_C(IN_OUT_TAB48(1), & SIZETAB) ELSE SIZE2 = SIZETAB / 2 SIZE1 = SIZETAB - SIZE2 IBEG24 = SIZE1+1 IBEG28 = 2*SIZE1+1_8 CALL MUMPS_ICOPY_32TO64_64C(IN_OUT_TAB48(IBEG24), & SIZE2, IN_OUT_TAB48(IBEG28)) CALL MUMPS_ICOPY_32TO64_64C_IP_REC(IN_OUT_TAB48, & SIZE1) ENDIF RETURN END SUBROUTINE MUMPS_ICOPY_32TO64_64C_IP_REC SUBROUTINE MUMPS_ICOPY_64TO32(INTAB8, SIZETAB, OUTTAB) INTEGER, intent(in) :: SIZETAB INTEGER(8), intent(in) :: INTAB8(SIZETAB) INTEGER, intent(out) :: OUTTAB(SIZETAB) INTEGER :: I DO I=1,SIZETAB OUTTAB(I) = int(INTAB8(I)) ENDDO RETURN END SUBROUTINE MUMPS_ICOPY_64TO32 SUBROUTINE MUMPS_ICOPY_64TO32_64C (INTAB8, SIZETAB, OUTTAB) INTEGER(8), intent(in) :: SIZETAB INTEGER(8), intent(in) :: INTAB8(SIZETAB) INTEGER, intent(out) :: OUTTAB(SIZETAB) INTEGER(8) :: I8 DO I8=1_8,SIZETAB OUTTAB(I8) = int(INTAB8(I8)) ENDDO RETURN END SUBROUTINE MUMPS_ICOPY_64TO32_64C SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP(IN_OUT_TAB48, SIZETAB) INTEGER(8), intent(in) :: SIZETAB INTEGER, intent(inout) :: IN_OUT_TAB48(2*SIZETAB) CALL MUMPS_ICOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, SIZETAB) RETURN END SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP RECURSIVE SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP_REC( & IN_OUT_TAB48, SIZETAB) IMPLICIT NONE INTEGER(8), intent(in) :: SIZETAB INTEGER :: IN_OUT_TAB48(2*SIZETAB) INTEGER(8) :: IBEG24, IBEG28, SIZE1, SIZE2 IF (SIZETAB.LE. 1000_8) THEN CALL MUMPS_ICOPY_64TO32_64C_IP_C(IN_OUT_TAB48(1), & SIZETAB) ELSE SIZE2 = SIZETAB / 2 SIZE1 = SIZETAB - SIZE2 IBEG24 = SIZE1 + 1 IBEG28 = SIZE1 + SIZE1 + 1_8 CALL MUMPS_ICOPY_64TO32_64C_IP_REC(IN_OUT_TAB48, & SIZE1) CALL MUMPS_ICOPY_64TO32_64C(IN_OUT_TAB48(IBEG28), & SIZE2, IN_OUT_TAB48(IBEG24)) ENDIF RETURN END SUBROUTINE MUMPS_ICOPY_64TO32_64C_IP_REC SUBROUTINE MUMPS_GET_NNZ_INTERNAL( NNZ, NZ, NNZ_i ) INTEGER , INTENT(IN) :: NZ INTEGER(8), INTENT(IN) :: NNZ INTEGER(8), INTENT(OUT) :: NNZ_i IF (NNZ > 0_8) THEN NNZ_i = NNZ ELSE NNZ_i = int(NZ, 8) ENDIF END SUBROUTINE MUMPS_GET_NNZ_INTERNAL SUBROUTINE MUMPS_NPIV_CRITICAL_PATH( & N, NSTEPS, STEP, FRERE, FILS, & NA, LNA, NE, MAXNPIVTREE ) IMPLICIT NONE INTEGER, intent(in) :: N, NSTEPS, LNA INTEGER, intent(in) :: FRERE(NSTEPS), FILS(N), STEP(N) INTEGER, intent(in) :: NA(LNA), NE(NSTEPS) INTEGER, intent(out) :: MAXNPIVTREE INTEGER :: IFATH,INODE,ISON INTEGER :: NPIV,ILEAF,NBLEAF,NBROOT INTEGER, DIMENSION(:) , ALLOCATABLE :: MAXNPIV INTEGER :: I, allocok MAXNPIVTREE = -9999 ALLOCATE ( MAXNPIV(NSTEPS), stat=allocok) IF (allocok .gt.0) THEN WRITE(*, *) 'Allocation error in MUMPS_NPIV_CRITICAL_PATH' & ,NSTEPS CALL MUMPS_ABORT() ENDIF NBLEAF = NA(1) NBROOT = NA(2) MAXNPIV = 0 NBLEAF = NA(1) NBROOT = NA(2) DO ILEAF = 1, NBLEAF INODE = NA(2+ILEAF) 95 CONTINUE NPIV = 0 ISON = INODE 100 NPIV = NPIV + 1 ISON = FILS(ISON) IF (ISON .GT. 0 ) GOTO 100 ISON = -ISON MAXNPIV( STEP(INODE) ) = NPIV DO I = 1, NE(STEP(INODE)) MAXNPIV(STEP(INODE)) = max( MAXNPIV(STEP(INODE)), & NPIV + MAXNPIV(STEP(ISON)) ) ISON = FRERE(STEP(ISON)) ENDDO IFATH = INODE DO WHILE (IFATH .GT. 0) IFATH = FRERE(STEP(IFATH)) ENDDO IFATH = -IFATH IF (IFATH.EQ.0) THEN MAXNPIVTREE = max(MAXNPIVTREE, MAXNPIV(STEP(INODE))) ELSE IF (FRERE(STEP(INODE)) .LT. 0) THEN INODE = IFATH GOTO 95 ENDIF ENDIF ENDDO DEALLOCATE( MAXNPIV ) RETURN END SUBROUTINE MUMPS_NPIV_CRITICAL_PATH MUMPS_5.4.1/src/sfac_front_aux.F0000664000175000017500000024726614102210521016632 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE SMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE SMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: DKEEP(230) REAL UU, SEUIL REAL A(LA) INTEGER IW(LIW) REAL, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR REAL AMROW REAL RMAX REAL SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER SMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max REAL, PARAMETER :: RZERO = 0.0E0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK, K360 K360 = KEEP(360) NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX)) ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = SMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 IF (KEEP(351).EQ.1) THEN J1_ini = J1 !$ CHUNK = max(K360/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO ENDIF END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE SMUMPS_FAC_H SUBROUTINE SMUMPS_FAC_M(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,XSIZE) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB,IBEG_BLOCK INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) REAL VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER LKJIT, XSIZE REAL ONE, ALPHA INTEGER NPIV,JROW2 INTEGER NEL2,NPIVP1,KROW,NEL INCLUDE 'mumps_headers.h' PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IF (NASS.LT.LKJIT) THEN IW(IOLDPS+3+XSIZE) = NASS ELSE IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NEL2 = JROW2 - NPIVP1 IF (NEL2.EQ.0) THEN IF (JROW2.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 IW(IOLDPS+3+XSIZE) = min0(JROW2+LKJIB,NASS) IBEG_BLOCK = NPIVP1+1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 CALL sger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) ENDIF RETURN END SUBROUTINE SMUMPS_FAC_M SUBROUTINE SMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) REAL ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) REAL, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 REAL, PARAMETER :: ONE = 1.0E0 #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, K360, CHUNK NOMP = OMP_GET_MAX_THREADS() K360 = KEEP(360) #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.K360) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(K360/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.2) THEN MAXFROMN = 0.0E0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE SMUMPS_FAC_N SUBROUTINE SMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K405 .EQ. 1 ) THEN IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 ENDIF IF ( K427_OUT .GT. 99 ) K427_OUT = 0 IF ( K427_OUT .LT. -100 ) K427_OUT = -1 RETURN END SUBROUTINE SMUMPS_FAC_PT_SETLOCK427 SUBROUTINE SMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE SMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & SMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC REAL A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL strsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL strsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL SMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL sgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL sgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_P SUBROUTINE SMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA REAL A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL strsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL sgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE SMUMPS_FAC_T SUBROUTINE SMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE SMUMPS_BUF #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS REAL ALPHA, ONE PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in SMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL strsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL sgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL sgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL strsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL strsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL sgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL sgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL SMUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL strsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL sgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_SQ SUBROUTINE SMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT REAL, intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED REAL :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 REAL :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL sger(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL sgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ SUBROUTINE SMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE SMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) REAL, intent(inout) :: A(LA) REAL, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv REAL :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL SMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IS_MAXFROMN_AVAIL = .FALSE. 120 CALL SMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL SMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL SMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE SMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST,LPN_LIST, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW REAL, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, intent(in) :: LPN_LIST INTEGER, intent(inout) :: PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' REAL SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC REAL ZERO PARAMETER( ZERO = 0.0E0 ) REAL RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV INTEGER(8) :: APOSMAX, APOSROW REAL :: RMAX_NORELAX REAL PIVNUL REAL FIXA, CSEUIL INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER SMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0E0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK,K361 #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() K361 = KEEP(361) #endif PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) IDIAG = APOS CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF (real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = SMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) IF ((J2-J1).GE.K361) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(IDIAG)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(real(FIXA).GT.RZERO) THEN IF(real(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_I SUBROUTINE SMUMPS_FAC_I_LDLT & ( NFRONT,NASS,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW REAL, intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE REAL A(LA) REAL UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled REAL, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP REAL RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV REAL RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW REAL MAXPIV REAL PIVNUL REAL FIXA, CSEUIL REAL PIVOT,DETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max REAL ZERO, ONE PARAMETER( ZERO = 0.0E0 ) PARAMETER( ONE = 1.0E0 ) REAL RZERO,RONE PARAMETER(RZERO=0.0E0, RONE=1.0E0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = DKEEP(2) CSEUIL = SEUIL LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(real(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL NNEGW = NNEGW+1 ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 IF (A(APOS).LT.RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN IF (PIVOT .LT. RZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = real(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & real(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(real(FIXA).GT.RZERO) THEN IF(real(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN IF (PIVOT .LT. ZERO) NNEGW = NNEGW+1 CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(real(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 IF (SEUIL.GT.RZERO) THEN IF (sqrt(abs(DETPIV)) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF CALL SMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL SMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 IF(DETPIV .LT. RZERO) THEN NNEGW = NNEGW+1 ELSE IF(A(POSPV2) .LT. RZERO) THEN NNEGW = NNEGW+2 ENDIF 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL SMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE SMUMPS_FAC_I_LDLT SUBROUTINE SMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT REAL, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED REAL VALPIV REAL :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL REAL ONE, ZERO REAL A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, IBEG, IEND INTEGER(8) :: JJ, K1, K2, IROW INTEGER(8) :: ROW_SHIFT, JJ_LOC, IBEG_LOC, IEND_LOC REAL SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX INCLUDE 'mumps_headers.h' PARAMETER(ONE = 1.0E0, & ZERO = 0.0E0) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0E0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 IF (NEL2 > 0) THEN IF (.NOT. IS_MAX_USEFUL) THEN DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ELSE IS_MAXFROMM_AVAIL = .TRUE. DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMM=max( MAXFROMM,abs(A(K1POS+1_8)) ) DO JJ = 2_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ENDIF ENDIF NCB1 = LAST_ROW - IEND_BLOCK IF (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0E0 !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (NCB1-NVSCHUR_K253>300) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL scopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL scopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & real(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_FAC_MQ_LDLT SUBROUTINE SMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA REAL, intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE REAL ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=1.0E0, ALPHA=-1.0E0) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL strsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL SMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL sgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IEND_BLOCK,8) CALL sgemm( 'N','N', IROW + Block - IEND_BLOCK - 1, & Block, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL sgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL sgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE SMUMPS_FAC_SQ_LDLT SUBROUTINE SMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP REAL A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 REAL SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL sswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL sswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL sswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL sswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_SWAP_LDLT SUBROUTINE SMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA REAL, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J REAL :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY REAL :: ONE PARAMETER (ONE = 1.0E0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL scopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL scopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE SMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE SMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA REAL, INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J REAL :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY REAL :: ONE PARAMETER (ONE = 1.0E0) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE SMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE SMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE SMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA REAL A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2 REAL ONE, ALPHA, BETA, ZERO PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) PARAMETER (ZERO=0.0E0) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL strsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL SMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL sgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL SMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL sgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL SMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG,LAST_CALL ) IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL sgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL SMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL sgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE SMUMPS_FAC_T_LDLT SUBROUTINE SMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN SMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE SMUMPS_STORE_PERMINFO SUBROUTINE SMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE REAL, INTENT(IN) :: DIAG REAL, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT END MODULE SMUMPS_FAC_FRONT_AUX_M MUMPS_5.4.1/src/cini_driver.F0000664000175000017500000002222214102210526016112 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_INI_DRIVER( id ) USE CMUMPS_STRUC_DEF C C Purpose: C ======= C C Initialize an instance of the CMUMPS package. C USE CMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL CMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) id%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is CMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in CMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in CMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C C Module needs to know the size of an INTEGER CALL CMUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) C This number, 18, corresponds to METIS_OPTIONS_NUMBERING which C tells METIS to use fortran numbering and is found in metis.h C In Metis 5.0.3 and Parmetis 4.0.2, METIS_OPTIONS_NUMBERING C was METIS_OPTIONS(17). MUMPS doesnot support those versions anymore. C To use them, just change METIS_OPTIONS(18) into METIS_OPTIONS(17) C like that: METIS_OPTIONS(17) = 1 id%METIS_OPTIONS(18) = 1 #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%INTARR) NULLIFY(id%DBLARR) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSCOMP) NULLIFY(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MPITOOMP_PROCS_MAP) C Must be nullified because of routine C CMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the root C NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_ROOT) NULLIFY(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_COL) NULLIFY(id%root%IPIV) NULLIFY(id%root%SCHUR_POINTER) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) CALL CMUMPS_RR_INIT_POINTERS(id) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C CMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF RETURN END SUBROUTINE CMUMPS_INI_DRIVER MUMPS_5.4.1/src/dfac_mem_compress_cb.F0000664000175000017500000005057214102210522017734 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE DMUMPS_SIZEFREEINREC SUBROUTINE DMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE DMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE DMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE DMUMPS_MOVETONEXTRECORD SUBROUTINE DMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_ISHIFT SUBROUTINE DMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT DOUBLE PRECISION A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_RSHIFT SUBROUTINE DMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP199, PROCNODE_STEPS, DAD) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF, KEEP199 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) DOUBLE PRECISION, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: DMUMPS_ISBAND EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_REF, TIME_COMP TIME_REF = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL DMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP216) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL DMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL DMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP28, KEEP199, & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL DMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL DMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL DMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP216) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL DMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL DMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL DMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL DMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in DMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in DMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in DMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = MPI_WTIME() - TIME_REF ACC_TIME = ACC_TIME + TIME_COMP RETURN END SUBROUTINE DMUMPS_COMPRE_NEW SUBROUTINE DMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE DMUMPS_GET_SIZEHOLE SUBROUTINE DMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT DOUBLE PRECISION A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN DMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in DMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in DMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE DMUMPS_MAKECBCONTIG SUBROUTINE DMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY: DMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) DOUBLE PRECISION, INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL DMUMPS_COMPRE_NEW_CALLED DMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF DMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.DMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) DMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. DMUMPS_COMPRE_NEW_CALLED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL DMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL DMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in DMUMPS_GET_SIZE_NEEDED ', & 'PB compress... DMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_GET_SIZE_NEEDED MUMPS_5.4.1/src/csol_driver.F0000664000175000017500000070374414102210526016147 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SOLVE_DRIVER(id) USE CMUMPS_STRUC_DEF USE CMUMPS_SOL_ES C C Purpose C ======= C C Performs solution phase (solve), Iterative Refinements C and Error analysis. C C C C USE CMUMPS_BUF USE CMUMPS_OOC USE MUMPS_MEMORY_MOD USE CMUMPS_LR_DATA_M, only : CMUMPS_BLR_STRUC_TO_MOD & , CMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_MOD_TO_STRUC USE CMUMPS_SAVE_RESTORE IMPLICIT NONE C ------------------- C Explicit interfaces C ------------------- INTERFACE SUBROUTINE CMUMPS_SIZE_IN_STRUCT( id, NB_INT,NB_CMPLX,NB_CHAR ) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC) :: id INTEGER(8) :: NB_INT,NB_CMPLX,NB_CHAR END SUBROUTINE CMUMPS_SIZE_IN_STRUCT SUBROUTINE CMUMPS_CHECK_DENSE_RHS &(idRHS, idINFO, idN, idNRHS, idLRHS) COMPLEX, DIMENSION(:), POINTER :: idRHS INTEGER, intent(in) :: idN, idNRHS, idLRHS INTEGER, intent(inout) :: idINFO(:) END SUBROUTINE CMUMPS_CHECK_DENSE_RHS END INTERFACE C INCLUDE 'mpif.h' INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' #if defined(V_T) INCLUDE 'VT.inc' #endif INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Parameters C ========== C TYPE (CMUMPS_STRUC), TARGET :: id C C Local variables C =============== C INTEGER MP,LP, MPG LOGICAL PROK, PROKG, LPOK INTEGER MTYPE, ICNTL21 LOGICAL LSCAL, POSTPros, GIVSOL INTEGER ICNTL10, ICNTL11 INTEGER I,IPERM,K,JPERM, J, II, IZ2 INTEGER IZ, NZ_THIS_BLOCK, PJ C pointers in IS INTEGER LIW C pointers in id%S INTEGER(8) :: LA, LA_PASSED INTEGER LIW_PASSED INTEGER(8) :: LWCB8_MIN, LWCB8, LWCB8_SOL_C C buffer sizes INTEGER CMUMPS_LBUF, CMUMPS_LBUF_INT INTEGER(8) :: CMUMPS_LBUF_8 INTEGER :: LBUFR, LBUFR_BYTES INTEGER :: MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL INTEGER(8) :: MSG_MAX_BYTES_SOLVE8 C reception buffer INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C null space INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, & IBEG_GLOB_DEF, IEND_GLOB_DEF, & IROOT_DEF_RHS_COL1 C INTEGER NITREF, NOITER, SOLVET, KASE C Meaningful only with tree pruning and sparse RHS LOGICAL INTERLEAVE_PAR, DO_PERMUTE_RHS C true if CMUMPS_SOL_C called during postprocessing LOGICAL FROM_PP C C TIMINGS DOUBLE PRECISION TIMEIT, TIMEEA, TIMEEA1, TIMELCOND DOUBLE PRECISION TIME3 DOUBLE PRECISION TIMEC1,TIMEC2 DOUBLE PRECISION TIMEGATHER1,TIMEGATHER2 DOUBLE PRECISION TIMESCATTER1,TIMESCATTER2 DOUBLE PRECISION TIMECOPYSCALE1,TIMECOPYSCALE2 C ------------------------------------------ C Declarations related to exploit sparsity C ------------------------------------------ INTEGER :: NRHS_NONEMPTY INTEGER :: STRAT_PERMAM1 LOGICAL :: DO_NULL_PIV INTEGER, DIMENSION(:), POINTER :: IRHS_PTR_COPY INTEGER, DIMENSION(:), POINTER :: IRHS_SPARSE_COPY COMPLEX, DIMENSION(:), POINTER :: RHS_SPARSE_COPY LOGICAL IRHS_SPARSE_COPY_ALLOCATED, IRHS_PTR_COPY_ALLOCATED, & RHS_SPARSE_COPY_ALLOCATED C INTEGER, DIMENSION(:), ALLOCATABLE :: MAP_RHS_loc INTEGER, DIMENSION(:), POINTER :: IRHS_loc_PTR LOGICAL :: IRHS_loc_PTR_allocated COMPLEX, DIMENSION(:), POINTER :: idRHS_loc INTEGER(8) :: DIFF_SOL_loc_RHS_loc INTEGER(8) :: RHS_loc_size, RHS_loc_shift INTEGER(8) :: NBT INTEGER :: NBCOL, COLSIZE, JBEG_RHS, JEND_RHS, JBEG_NEW, & NBCOL_INBLOC, IPOS, IPOSRHSCOMP INTEGER, DIMENSION(:), ALLOCATABLE :: PERM_RHS INTEGER, DIMENSION(:), POINTER :: PTR_POSINRHSCOMP_FWD, & PTR_POSINRHSCOMP_BWD COMPLEX, DIMENSION(:), POINTER :: PTR_RHS INTEGER :: SIZE_IPTR_WORKING, SIZE_WORKING C NRHS_NONEMPTY: holds C either the original number of RHS (id%NRHS defined on host) C or, when the RHS is sparse, it holds the C number of non empty columns. C it is computed on master and is C then broadcasted on all processes. C IRHS_PTR_COPY holds a compressed local copy of IRHS_PTR (or points C on the master to id%IRHS_PTR if no permutation requested) C IRHS_SPARSE_COPY might be allocated or might also point to C id%IRHS_SPARSE. To test if we can deallocate it we trace C with IRHS_SPARSE_COPY_ALLOCATED when it was effectively C allocated. C NBCOL_INBLOC total nb columns to process in this block C JBEG_RHS global ptr for starting column requested for this block C JEND_RHS global ptr for end column_number requested for this block C PERM_RHS -- Permutation of RHS computed on master and broadcasted C on all procs (of size id%NRHS orginal) C PERM_RHS(k) = i means that i is the kth column to be processed C Note that PERM_RHS will be used also in case of interleaving C ------------------------------------ COMPLEX ONE COMPLEX ZERO PARAMETER( ONE = (1.0E0,0.0E0) ) PARAMETER( ZERO = (0.0E0,0.0E0) ) REAL RZERO, RONE PARAMETER( RZERO = 0.0E0, RONE = 1.0E0 ) C C RHS_IR is internal to CMUMPS and used for iterative refinement C or the error analysis section. It either points to the user's C RHS (on the host when the solution is centralized or the RHS C is dense), or is a workarray allocated inside this routine C of size N. COMPLEX, DIMENSION(:), POINTER :: RHS_IR COMPLEX, DIMENSION(:), POINTER :: WORK_WCB COMPLEX, DIMENSION(:), POINTER :: PTR_RHS_ROOT INTEGER(8) :: LPTR_RHS_ROOT C C Local workarrays that will be dynamically allocated C COMPLEX, ALLOCATABLE :: SAVERHS(:), C_RW1(:), & C_RW2(:), & SRW3(:), C_Y(:), & C_W(:) INTEGER :: LCWORK COMPLEX, ALLOCATABLE :: CWORK(:) INTEGER, ALLOCATABLE :: MAP_RHS(:) REAL, ALLOCATABLE :: R_Y(:), D(:) REAL, ALLOCATABLE :: R_W(:) C The 2 following workarrays are temporary local C arrays only used for distributed matrix input C (KEEP(54) .NE. 0). REAL, ALLOCATABLE, DIMENSION(:) :: R_LOCWK54 COMPLEX, ALLOCATABLE, DIMENSION(:) :: C_LOCWK54 INTEGER :: NBENT_RHSCOMP, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT INTEGER, DIMENSION(:), ALLOCATABLE :: UNS_PERM_INV LOGICAL :: UNS_PERM_INV_NEEDED_INMAINLOOP, & UNS_PERM_INV_NEEDED_BEFMAINLOOP INTEGER LIWK_SOLVE, LIWCB INTEGER, ALLOCATABLE :: IW1(:), IWK_SOLVE(:), IWCB(:) INTEGER :: LIWK_PTRACB INTEGER(8), ALLOCATABLE :: PTRACB(:) C C Parameters arising from the structure C INTEGER(8) :: MAXS REAL, DIMENSION(:), POINTER :: CNTL INTEGER, DIMENSION (:), POINTER :: KEEP,ICNTL,INFO INTEGER(8), DIMENSION (:), POINTER :: KEEP8 INTEGER, DIMENSION (:), POINTER :: IS REAL, DIMENSION(:),POINTER:: RINFOG C =============================================================== C SCALING issues: C When scaling was performed C RHS holds the solution of the scaled system C The unscaled second member (b0) was given C then we have to scale both rhs adn solution: C A(sca) = LU = D1*A*D2 , with D2 = COLSCA C D1 = ROWSCA C -------------- C CASE OF A X =B C -------------- C (ICNTL(9)=1 or MTYPE=1) C A*x0 = b0 C b(sca) = D1 * b0 = ROWSCA*S(ISTW3) C A(sca) [(D2) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D2) **(-1)] x0 and so x0= D2*y0 is modified C -------------- C CASE OF AT X =B C -------------- C (ICNTL(9).NE.1 or MTYPE=0) C A(sca) = LU = D1*A*D2 C AT*x0 = b0 => D2ATD1 D1-1 x0 = D2b0 C b(sca) = D2 * b0 = COLSCA*S(ISTW3) C A(sca)T [(D1) **(-1)] x0 = b(sca) C so the computed solution by Check y0 of LU *y0 = b(sca) C is : y0 =[(D1) **(-1)] x0 and so x0= D1*y0 is modified C C In case of distributed RHS we need C scaling information on each processor C type scaling_data_t SEQUENCE REAL, dimension(:), pointer :: SCALING REAL, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data_sol, scaling_data_dr C To scale on the fly during GATHER SOLUTION REAL, DIMENSION(:), POINTER :: PT_SCALING REAL, TARGET :: Dummy_SCAL(1) C C ==================== END OF SCALING related data ================ C C Local variables C C Interval associated to the subblocks of RHS a node has to process INTEGER, DIMENSION(:), ALLOCATABLE, TARGET :: RHS_BOUNDS INTEGER :: LPTR_RHS_BOUNDS INTEGER, DIMENSION(:), POINTER :: PTR_RHS_BOUNDS LOGICAL :: DO_NBSPARSE, NBSPARSE_LOC LOGICAL :: PRINT_MAXAVG REAL ARRET COMPLEX C_DUMMY(1) REAL R_DUMMY(1) INTEGER IDUMMY(1), JDUMMY(1), KDUMMY(1), LDUMMY(1), MDUMMY(1) INTEGER, TARGET :: IDUMMY_TARGET(1) COMPLEX, TARGET :: CDUMMY_TARGET(1) INTEGER JJ INTEGER allocok INTEGER NBRHS, NBRHS_EFF, BEG_RHS, NB_RHSSKIPPED, & LD_RHS, & MASTER_ROOT, MASTER_ROOT_IN_COMM INTEGER SIZE_ROOT, LD_REDRHS INTEGER(8) :: IPT_RHS_ROOT INTEGER(8) :: IBEG, IBEG_RHSCOMP, KDEC, IBEG_loc, IBEG_REDRHS INTEGER LD_RHSCOMP, NCOL_RHS_loc INTEGER LD_RHS_loc, JBEG_RHS_loc INTEGER NB_K133, IRANK, TSIZE INTEGER KMAX_246_247 INTEGER IFLAG_IR, IRStep LOGICAL TESTConv LOGICAL WORKSPACE_MINIMAL_PREFERRED, WK_USER_PROVIDED INTEGER(8) NB_BYTES !size of data allocated during solve INTEGER(8) NB_BYTES_MAX !MAX size of data allocated during solve INTEGER(8) NB_BYTES_EXTRA !For Step2Node, which may be freed later INTEGER(8) NB_BYTES_LOC !For temp. computations INTEGER(8) NB_INT, NB_CMPLX, NB_CHAR, K34_8, K35_8 INTEGER(8) K16_8, ITMP8, NB_BYTES_ON_ENTRY #if defined(V_T) C Vampir INTEGER soln_drive_class, glob_comm_ini, perm_scal_ini, soln_dist, & soln_assem, perm_scal_post #endif LOGICAL I_AM_SLAVE, BUILD_POSINRHSCOMP LOGICAL :: BUILD_RHSMAPINFO LOGICAL WORK_WCB_ALLOCATED, IS_INIT_OOC_DONE LOGICAL :: IS_LR_MOD_TO_STRUC_DONE INTEGER :: KEEP350_SAVE LOGICAL STOP_AT_NEXT_EMPTY_COL INTEGER MTYPE_LOC INTEGER MAT_ALLOC_LOC, MAT_ALLOC INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER(8) :: FILE_SIZE,STRUC_SIZE C C First executable statement C #if defined(V_T) CALL VTCLASSDEF( 'Soln driver',soln_drive_class,IERR) CALL VTFUNCDEF( 'glob_comm_ini',soln_drive_class, & glob_comm_ini,IERR) CALL VTFUNCDEF( 'perm_scal_ini',soln_drive_class, & perm_scal_ini,IERR) CALL VTFUNCDEF( 'soln_dist',soln_drive_class,soln_dist,IERR) CALL VTFUNCDEF( 'soln_assem',soln_drive_class,soln_assem,IERR) CALL VTFUNCDEF( 'perm_scal_post',soln_drive_class, & perm_scal_post,IERR) #endif C -- The following pointers xxCOPY might be allocated but then C -- the associated xxCOPY_ALLOCATED will be set to C -- enable deallocation IRHS_PTR_COPY => IDUMMY_TARGET IRHS_PTR_COPY_ALLOCATED = .FALSE. IRHS_SPARSE_COPY => IDUMMY_TARGET IRHS_SPARSE_COPY_ALLOCATED=.FALSE. RHS_SPARSE_COPY => CDUMMY_TARGET RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_IR) NULLIFY(WORK_WCB) NULLIFY(scaling_data_dr%SCALING) NULLIFY(scaling_data_dr%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING) NULLIFY(scaling_data_sol%SCALING_LOC) IRHS_loc_PTR_allocated = .FALSE. IS_INIT_OOC_DONE = .FALSE. IS_LR_MOD_TO_STRUC_DONE = .FALSE. WK_USER_PROVIDED = .FALSE. WORK_WCB_ALLOCATED = .FALSE. CNTL =>id%CNTL KEEP =>id%KEEP KEEP8=>id%KEEP8 IS =>id%IS ICNTL=>id%ICNTL INFO =>id%INFO C ASPK =>id%A C COLSCA =>id%COLSCA C ROWSCA =>id%ROWSCA RINFOG =>id%RINFOG LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF (.not.PROK) MP =0 IF (.not.PROKG) MPG=0 IF ( PROK ) WRITE(MP,100) IF ( PROKG ) WRITE(MPG,100) NB_BYTES = 0_8 NB_BYTES_MAX = 0_8 NB_BYTES_EXTRA = 0_8 K34_8 = int(KEEP(34), 8) K35_8 = int(KEEP(35), 8) K16_8 = int(KEEP(16), 8) NBENT_RHSCOMP = 0 C Used by DISTRIBUTED_SOLUTION to skip empty columns C that are skipped (case of sparse RHS) NB_RHSSKIPPED = 0 C next 4 initialisations needed in case of error C to free space allocated LSCAL = .FALSE. WORK_WCB_ALLOCATED = .FALSE. ICNTL21 = -99998 ! will be bcasted later to slaves IBEG_RHSCOMP =-152525_8 ! Should not be used BUILD_POSINRHSCOMP = .TRUE. IBEG_GLOB_DEF = -9888 ! unitialized state IEND_GLOB_DEF = -9888 ! unitialized state IBEG_ROOT_DEF = -9777 ! unitialized state IEND_ROOT_DEF = -9777 ! unitialized state IROOT_DEF_RHS_COL1 = -9666 ! unitialized state C Not needed anymore (since new version of gather) C LD_RHSCOMP = max(KEEP(89),1) ! at the nb of pivots eliminated on ! that proc LD_RHSCOMP = 1 NB_FS_RHSCOMP_TOT = KEEP(89) ! number of FS var of the pruned tree ! mapped on this proc NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT C Save value of KEEP(350), in case of LR solve C KEEP(350) may be overwritten and restored C Old unoptimized version before 5.0.2 not available anymore IF (KEEP(350).LE.0) KEEP(350)=1 IF (KEEP(350).GT.2) KEEP(350)=1 KEEP350_SAVE = KEEP(350) C C Depending on the type of parallelism, C the master can have the role of a slave I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Compute the number of integers and nb of reals in the structure CALL CMUMPS_SIZE_IN_STRUCT (id, NB_INT, NB_CMPLX, NB_CHAR) NB_BYTES = NB_BYTES + NB_INT * K34_8 + NB_CMPLX * K35_8 + NB_CHAR NB_BYTES_ON_ENTRY = NB_BYTES !used to check alloc/dealloc count ok CALL CMUMPS_COMPUTE_MEMORY_SAVE(id,FILE_SIZE,STRUC_SIZE) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ====================================== C BEGIN CHECK KEEP ENTRIES AND INTERFACE C ====================================== C The checks below used to be in CMUMPS_DRIVER. It is much better C to have them here in CMUMPS_SOL_DRIVER because this enables C more flexibility in the management of priorities between various C checks. IF (id%MYID .EQ. MASTER) THEN c subroutine only because called at facto and solve CALL CMUMPS_SET_K221(id) id%KEEP(111) = id%ICNTL(25) C For the case of ICNTL(20)=1 one could C switch off exploit sparsity when RHS is too dense. IF (id%ICNTL(20) .EQ. 1) id%KEEP(235) = -1 !automatic IF (id%ICNTL(20) .EQ. 2) id%KEEP(235) = 0 !off IF (id%ICNTL(20) .EQ. 3) id%KEEP(235) = 1 !on IF (id%ICNTL(20).EQ.1 .or. id%ICNTL(20).EQ.2 .or. & id%ICNTL(20).EQ.3) THEN id%KEEP(248) = 1 !sparse RHS ELSE IF (id%ICNTL(20).EQ.10 .OR. id%ICNTL(20).EQ.11) THEN id%KEEP(248) = -1 ! dist. RHS ELSE id%KEEP(248) = 0 !dense RHS ENDIF ICNTL21 = id%ICNTL(21) IF (ICNTL21 .ne.0.and.ICNTL21.ne.1) ICNTL21=0 IF ( id%ICNTL(30) .NE.0 ) THEN C A-1 is on id%KEEP(237) = 1 ELSE C A-1 is off id%KEEP(237) = 0 ENDIF IF (id%KEEP(248) .eq.0.and. id%KEEP(237).ne.0) THEN C For A-1 we have a sparse RHS in the API. C Force KEEP(248) accordingly. id%KEEP(248)=1 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(248).NE.0) ) THEN C -- input RHS is indeed stored in REDRHS and RHSCOMP id%KEEP(248) = 0 ENDIF IF ((id%KEEP(221).EQ.2 ).AND.(id%KEEP(235).NE.0) ) THEN C -- input RHS is in fact effectively C -- stored in REDRHS and RHSCOMP id%KEEP(235) = 0 ENDIF IF ( (id%KEEP(248).EQ.0).AND.(id%KEEP(111).EQ.0) ) THEN C RHS is not sparse and thus exploit sparsity is reset to 0 id%KEEP(235) = 0 ENDIF IF (KEEP(248) .EQ. -1) THEN C V0 distributed RHS: no ES id%KEEP(235) = 0 ENDIF C Case of Automatic setting of exploit sparsity (KEEP(235)=-1) C (in MUMPS_DRIVER original value of KEEP(235) is reset) IF(id%KEEP(111).NE.0) id%KEEP(235)=0 C IF (id%KEEP(235).EQ.-1) THEN IF (id%KEEP(237).NE.0) THEN C for A-1 id%KEEP(235)=1 ELSE id%KEEP(235)=1 ENDIF ELSE IF (id%KEEP(235).NE.0) THEN id%KEEP(235)=1 ENDIF C Setting of KEEP(242) (permute RHS) IF ((KEEP(111).NE.0)) THEN C In the context of null space, the null pivots C are by default permuted to post-order C However for null space there is in this case no need to C permute null pivots since they are already in correct order. C Setting KEEP(242)=1 would just force to go through C part of the code permuting to identity. C Apart for validation purposes this is not interesting C costly (and more risky). KEEP(242) = 0 ENDIF IF (KEEP(248).EQ.0.AND.KEEP(111).EQ.0) THEN C Permutation possible if sparse RHS C (KEEP(248).NE.0: A-1 or General Sparse) C or null space (even if in current version C it is deactived) KEEP(242) = 0 ENDIF IF ((KEEP(242).NE.0).AND.KEEP(237).EQ.0) THEN IF ((KEEP(242).NE.-9).AND.KEEP(242).NE.1.AND. & KEEP(242).NE.-1) THEN C Reset it to 0 KEEP(242) = 0 ENDIF ENDIF IF (KEEP(242).EQ.-9) THEN C { C Automatic setting of permute RHS IF (id%KEEP(237).NE.0) THEN KEEP(242) = 1 ! postorder for A-1 ELSE ! dense or general sparse or distributed RHS KEEP(242) = 0 ! no permutation in most general case IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (KEEP(497).EQ.-1 .OR. KEEP(497).GE.1) THEN KEEP(242)=1 ENDIF ENDIF ENDIF ENDIF ENDIF C } ENDIF IF ( (id%KEEP(221).EQ.1 ).AND.(id%KEEP(235).NE.0) ) THEN C -- Do not permute RHS with REDRHS for the time being id%KEEP(242) = 0 ENDIF IF (KEEP(242).EQ.0) KEEP(243)=0 ! interleave off IF ((KEEP(237).EQ.0).OR.(KEEP(242).EQ.0)) THEN C Interleave (243) possible only C when permute RHS (242) is on and with A-1 KEEP(243) = 0 ENDIF IF (id%KEEP(237).EQ.1) THEN ! A-1 entries C Case of automatic setting of KEEP(243), KEEP(493-498) C (exploit sparsity parameters) IF (id%NSLAVES.EQ.1) THEN IF (id%KEEP(243).EQ.-1) id%KEEP(243)=0 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ELSE IF (id%KEEP(243).EQ.-1) id%KEEP(243)=1 IF (id%KEEP(495).EQ.-1) id%KEEP(495)=1 IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ELSE ! dense or general sparse or distributed RHS id%KEEP(243)=0 id%KEEP(495)=0 IF (KEEP(248) .EQ. 1) THEN ! sparse RHS IF (id%KEEP(235) .EQ. 1) THEN ! Tree pruning IF (id%NRHS .GT. 1) THEN IF (id%KEEP(497).EQ.-1) id%KEEP(497)=1 ENDIF ENDIF ELSE C nbsparse meaningless for distributed or dense RHS C Force it to 0 whatever was the initial value id%KEEP(497)=0 ENDIF ENDIF MTYPE = id%ICNTL( 9 ) IF (MTYPE.NE.1) MTYPE=0 ! see interface IF ((MTYPE.EQ.0).AND.KEEP(50).NE.0) MTYPE =1 ! suppress option Atx=b for A-1 IF (id%KEEP(237).NE.0) MTYPE = 1 C C ICNTL(35) was defined at analysis and C consistently reset at factorization C It was stored in KEEP(486) after factorization C Set KEEP(485) accordingly. C IF (KEEP(486) .EQ. 2) THEN KEEP(485) = 1 ! BLR solve ELSE KEEP(485) = 0 ! FR solve ENDIF ENDIF CALL MPI_BCAST(MTYPE,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST( id%KEEP(111), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(221), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(235), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(237), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(242), 2, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(248), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(350), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(485), 1, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( id%KEEP(495), 3, MPI_INTEGER, MASTER, id%COMM, & IERR ) CALL MPI_BCAST( ICNTL21, 1, MPI_INTEGER, MASTER, id%COMM, IERR ) C Broadcast original id%NRHS (used at least for checks on SOL_loc C and to allocate PERM_RHS in case of exploit sparsity) CALL MPI_BCAST( id%NRHS,1, MPI_INTEGER, MASTER, id%COMM,IERR) C C TIMINGS: reset to 0 TIMEC2=0.0D0 TIMECOPYSCALE2=0.0D0 TIMEGATHER2=0.0D0 TIMESCATTER2=0.0D0 id%DKEEP(112)=0.0E0 id%DKEEP(113)=0.0E0 C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C id%DKEEP(122) time for matrix redistribution (copy+scale solution) id%DKEEP(114)=0.0E0 id%DKEEP(120)=0.0E0 id%DKEEP(121)=0.0E0 id%DKEEP(115)=0.0E0 id%DKEEP(116)=0.0E0 id%DKEEP(122)=0.0E0 C Time for fwd, bwd and scalapack is C accumulated in DKEEP(117-119) within SOL_C C If requested time for each call to FWD/BWD C might be print but on output to solve C phase DKEEP will hold on each proc the accumulated time id%DKEEP(117)=0.0E0 id%DKEEP(118)=0.0E0 id%DKEEP(119)=0.0E0 id%DKEEP(123)=0.0E0 id%DKEEP(124)=0.0E0 id%DKEEP(125)=0.0E0 id%DKEEP(126)=0.0E0 id%DKEEP(127)=0.0E0 id%DKEEP(128:134)=0.0E0 id%DKEEP(140:153)=0.0E0 C CALL MUMPS_SECDEB(TIME3) C ------------------------------ C Check parameters on the master C ------------------------------ IF ( id%MYID .EQ. MASTER ) THEN IF ((KEEP(23).NE.0).AND.KEEP(50).NE.0) THEN C Maximum transversal permutation C has not been saved (KEEP(23)>0 and UNS_PERM allocated) C when matrix is symmetric. IF (PROKG) WRITE(MPG,'(A)') & ' Internal Error 1 in solution driver ' id%INFO(1)=-444 id%INFO(2)=KEEP(23) ENDIF C ------------------------------------ C Check that factors are available C either in-core or on disk, case C where factors were discarded during C factorization (e.g. useful to simulate C an OOC factorization or just get nb of C negative pivots or determinant) C ------------------------------------ IF (KEEP(201) .EQ. -1) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ELSE IF (KEEP(221).EQ.0 .AND. KEEP(251) .EQ. 2 & .AND. KEEP(252).EQ.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Solve impossible because factors not kept' ENDIF id%INFO(1)=-44 id%INFO(2)=KEEP(251) GOTO 333 ENDIF C ------------------ IF (KEEP(252).NE.0 .AND. id%NRHS .NE. id%KEEP(253)) THEN C Fwd in facto C KEEP(252-253) available on all procs since analysis phase C Error: id%NRHS is not allowed to change since analysis C because fwd has been performed during facto with C KEEP(253) RHS IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: id%NRHS not allowed to change when', & ' ICNTL(32)=1' ENDIF id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) GOTO 333 ENDIF C Testing MTYPE instead of ICNTL(9) IF (KEEP(252).NE.0 .AND. MTYPE.NE.1) THEN C Fwd in facto is not compatible with transpose system INFO(1) = -43 INFO(2) = 9 IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF GOTO 333 ENDIF IF (KEEP(248) .NE. 0.AND.KEEP(252).NE.0) THEN C Fwd during facto incompatible with sparse RHS C Forbid sparse RHS when Fwd performed during facto C Sparse RHS may be due to A-1 (ICNTL(30) INFO(1) = -43 IF (KEEP(237).NE.0) THEN INFO(2) = 30 ! ICNTL(30) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality incompatible with', & ' forward performed during factorization', & ' (ICNTL(32)=1)' ENDIF ELSE INFO(2) = 20 ! ICNTL(20) IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: sparse or dist. RHS incompatible with forward', & ' elimination during factorization (ICNTL(32)=1)' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. ICNTL21.NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with distributed solution.' ENDIF INFO(1)=-48 INFO(2)=21 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(60) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with Schur.' ENDIF INFO(1)=-48 INFO(2)=19 GOTO 333 ENDIF IF (KEEP(237) .NE. 0 .AND. KEEP(111) .NE.0) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & ' ERROR: A-1 functionality is incompatible', & ' with null space.' ENDIF INFO(1)=-48 INFO(2)=25 GOTO 333 ENDIF IF (id%NRHS .LE. 0) THEN id%INFO(1)=-45 id%INFO(2)=id%NRHS IF ((id%KEEP(111).NE.0).AND.(id%INFOG(28).EQ.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A)') & 'ICNTL(25) NE 0 but INFOG(28)=0', & ' the matrix is not deficient' ENDIF ENDIF GOTO 333 ENDIF C Entries of A-1 are stored in place of the input sparse RHS C thus no need for RHS to be allocated. IF ( (id%KEEP(237).EQ.0) ) THEN IF ((id%KEEP(248) == 0 .AND.KEEP(221).NE.2) & .OR. ICNTL21==0) THEN C RHS must be of size N on the master either to C store the dense centralized RHS, either to store C the dense centralized solution. CALL CMUMPS_CHECK_DENSE_RHS & (id%RHS,id%INFO,id%N,id%NRHS,id%LRHS) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF ELSE C Check that the constraint NRHS=N is respected C Check for valid sparse RHS structure done IF (id%NRHS .NE. id%N) THEN id%INFO(1)=-47 id%INFO(2)=id%NRHS GOTO 333 ENDIF ENDIF IF (id%KEEP(248) == 1) THEN C ------------------------------------ C RHS_SPARSE, IRHS_SPARSE and IRHS_PTR C must be allocated of adequate size C ------------------------------------ IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(237).NE.0)) THEN C At least one entry of A-1 must be requested id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF (( id%NZ_RHS .LE.0 ).AND.(KEEP(221).EQ.1)) THEN C At least one entry of RHS must be nonzero with c Schur reduced RHS option id%INFO(1)=-46 id%INFO(2)=id%NZ_RHS GOTO 333 ENDIF IF ( id%NZ_RHS .GT. 0 ) THEN IF ( .not. associated(id%RHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 ENDIF ENDIF IF (id%NZ_RHS .GT. 0) THEN IF ( .not. associated(id%IRHS_SPARSE) )THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 ENDIF ENDIF IF ( .not. associated(id%IRHS_PTR) )THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 ENDIF C IF (size(id%IRHS_PTR) < id%NRHS + 1) THEN id%INFO(1)=-22 id%INFO(2)=12 GOTO 333 END IF IF (id%IRHS_PTR(id%NRHS + 1).ne.id%NZ_RHS+1) THEN id%INFO(1)=-27 id%INFO(2)=id%IRHS_PTR(id%NRHS+1) GOTO 333 END IF C compare with dble to prevent overflow IF (dble(id%N)*dble(id%NRHS).LT.dble(id%NZ_RHS)) THEN C Possible in case of dupplicate entries in Sparse RHS IF (PROKG) THEN write(MPG,*) & " WARNING: many dupplicate entries in ", & " sparse RHS provided by the user ", & " id%NZ_RHS,id%N,id%NRHS =", & id%NZ_RHS,id%N,id%NRHS ENDIF END IF IF (id%IRHS_PTR(1).ne.1) THEN id%INFO(1)=-28 id%INFO(2)=id%IRHS_PTR(1) GOTO 333 END IF IF (size(id%IRHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=11 GOTO 333 END IF IF (size(id%RHS_SPARSE) < id%NZ_RHS) THEN id%INFO(1)=-22 id%INFO(2)=10 GOTO 333 END IF ENDIF C -------------------------------- C Set null space options for solve C -------------------------------- CALL CMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL(1),KEEP(1), & id%NRHS, & MPG,INFO(1)) IF (INFO(1) .LT. 0) GOTO 333 C END IF ! MASTER C -------------------------------------- C Check distributed solution vectors C -------------------------------------- IF (ICNTL21==1) THEN IF ( I_AM_SLAVE ) THEN C (I)SOL_loc should be allocated to hold the C distributed solution on exit IF ( id%LSOL_loc < id%KEEP(89) ) THEN id%INFO(1)= -29 id%INFO(2)= id%LSOL_loc GOTO 333 ENDIF IF (id%KEEP(89) .NE. 0) THEN IF ( .not. associated(id%ISOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 ENDIF IF ( .not. associated(id%SOL_loc) )THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 ENDIF IF (size(id%ISOL_loc) < id%KEEP(89) ) THEN id%INFO(1)=-22 id%INFO(2)=13 GOTO 333 END IF # if defined(MUMPS_F2003) IF (size(id%SOL_loc,kind=8) < & int(id%NRHS-1,8)*int(id%LSOL_loc,8)+ & int(id%KEEP(89),8)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # else C Warning: size returns a standard INTEGER and could C overflow if id%SOL_loc was allocated of size > 2^31-1; C still we prefer to perform this test since only (1) very C large problems with large NRHS and small numbers of MPI C can result in such a situation; (2) the test could be C suppressed if needed but might be still be ok in case C the right-hand side overflows too. IF (size(id%SOL_loc) < & (id%NRHS-1)*id%LSOL_loc+id%KEEP(89)) THEN id%INFO(1)=-22 id%INFO(2)=14 GOTO 333 END IF # endif ENDIF ENDIF ENDIF IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(248) == 1) THEN C RHS should NOT be associated C if I am not master since it is C not even used to store the solution IF ( associated( id%RHS ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 7 GOTO 333 END IF IF ( associated( id%RHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 10 GOTO 333 END IF IF ( associated( id%IRHS_SPARSE ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 11 GOTO 333 END IF IF ( associated( id%IRHS_PTR ) ) THEN id%INFO( 1 ) = -22 id%INFO( 2 ) = 12 GOTO 333 END IF END IF ENDIF IF (I_AM_SLAVE .AND. id%KEEP(248).EQ.-1) THEN CALL CMUMPS_CHECK_DISTRHS( & id%Nloc_RHS, & id%LRHS_loc, & id%NRHS, & id%IRHS_loc, & id%RHS_loc, & id%INFO) IF (id%INFO(1) .LT. 0) GOTO 333 ENDIF C Prepare pointers to pass POINTERS(1) to C routines with implicit interfaces which C will then assume contiguous information C without needing to copy pointer arrays C in and out. Do this even if KEEP(248) C is different from -1 because of the C call to CMUMPS_DISTSOL_INDICES IF (associated(id%IRHS_loc)) THEN IF (size(id%IRHS_loc) .NE. 0) THEN IRHS_loc_PTR=>id%IRHS_loc ELSE C so that IRHS_loc_PTR(1) is ok IRHS_loc_PTR=>IDUMMY_TARGET ENDIF ELSE IRHS_loc_PTR=>IDUMMY_TARGET ENDIF IF (associated(id%RHS_loc)) THEN IF (size(id%RHS_loc) .NE. 0) THEN idRHS_loc=>id%RHS_loc ELSE idRHS_loc=>CDUMMY_TARGET ENDIF ELSE idRHS_loc=>CDUMMY_TARGET ENDIF IF (I_AM_SLAVE .AND. ICNTL21.EQ.1 .AND. & KEEP(248) .EQ. -1) THEN ! Dist RHS and dist solution IF (associated(id%RHS_loc) .AND. & associated(id%SOL_loc)) THEN IF (id%KEEP(89).GT.0) THEN C ---------------------------------------------------- C Check if RHS_loc and SOL_loc point to same object... C id%SOL_loc(1) ok otherwise an error -22/14 C would have been raised earlier. C idRHS_loc(1) may point to CDUMMY but is ok C ---------------------------------------------------- CALL MUMPS_SIZE_C(idRHS_loc(1),id%SOL_loc(1), & DIFF_SOL_loc_RHS_loc) C ---------------------------------------- C Check for compatible dimensions in case C SOL_loc and RHS_loc point to same memory C ---------------------------------------- IF (DIFF_SOL_loc_RHS_loc .EQ. 0_8 .AND. & id%LSOL_loc .GT. id%LRHS_loc) THEN C Note that, depending on the block size, C if all columns are processed in one C shot, this could still work. However, C and since this was forbidden in the UG, C we raise the error systematically id%INFO(1)=-56 id%INFO(2)=id%LRHS_loc IF (LPOK) THEN WRITE(LP,'(A,I9,A,I9)') &" ** Error RHS_loc and SOL_loc pointers match but LRHS_loc=" &,id%LRHS_loc, " and LSOL_loc=", id%LSOL_loc ENDIF ENDIF ENDIF ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN C Do some checks (REDRHS), depending on KEEP(221) CALL CMUMPS_CHECK_REDRHS(id) END IF ! MYID.EQ.MASTER IF (id%INFO(1) .LT. 0) GOTO 333 C ------------------------- C Propagate possible errors C ------------------------- 333 CONTINUE CALL MUMPS_PROPINFO( id%ICNTL(1), & id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GO TO 90 C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== C ==================================== C Process case of NZ_RHS = 0 with C sparse RHS and General Sparse (NOT A-1) C ----------------------------------- IF ((id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0)) THEN C CALL MPI_BCAST(id%NZ_RHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (id%NZ_RHS.EQ.0) THEN C We reset solution to zero and we return C (first freeing working space at label 90) IF ((ICNTL21.EQ.1).AND.(I_AM_SLAVE)) THEN C ---------------------- C SOL_loc reset to zero C ---------------------- C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,KEEP(32)) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL CMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , .FALSE., IDUMMY(1), 1 & ) DO J=1, id%NRHS DO I=1, KEEP(89) id%SOL_loc((J-1)*id%LSOL_loc + I) =ZERO ENDDO ENDDO ENDIF ENDIF IF (ICNTL21.NE.1) THEN ! centralized solution C ---------------------------- C RHS reset to zero on master C ---------------------------- IF (id%MYID.EQ.MASTER) THEN DO J=1, id%NRHS DO I=1, id%N id%RHS(int(J-1,8)*int(id%LRHS,8) + int(I,8)) =ZERO ENDDO ENDDO ENDIF ENDIF C C print solve phase stats if requested IF ( PROKG ) THEN C write(6,*) " NZ_RHS is zero " WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, ICNTL(27), ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C -------- GOTO 90 ! end of solve deallocate what is needed C ==================================== C END CHECK INTERFACE AND KEEP ENTRIES C ==================================== ENDIF ! test NZ_RHS.EQ.0 C -------- ENDIF ! (id%KEEP(248).EQ.1).AND.(id%KEEP(237).EQ.0) INTERLEAVE_PAR =.FALSE. DO_PERMUTE_RHS =.FALSE. C IF ((id%KEEP(235).NE.0).or.(id%KEEP(237).NE.0)) THEN C Case of pruned elimination tree or selected entries in A-1 IF (id%KEEP(237).NE.0.AND. & id%KEEP(248).EQ.0) THEN C When A-1 is requested (keep(237).ne.0) C sparse RHS has been forced to be on. IF (LPOK) THEN WRITE(LP,'(A,I4,I4)') & ' Internal Error 2 in solution driver (A-1) ', & id%KEEP(237), id%KEEP(248) ENDIF CALL MUMPS_ABORT() ENDIF C NBT is inout in MUMPS_REALLOC and should be initialized. NBT = 0 C -- Allocate Step2node on each proc CALL MUMPS_REALLOC(id%Step2node, id%KEEP(28), id%INFO, LP, & FORCE=.TRUE., & STRING='id%Step2node (Solve)', MEMCNT=NBT, ERRCODE=-13) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM, id%MYID ) IF ( INFO(1).LT.0 ) RETURN C -- build Step2node on each proc; C -- this is usefull to have at each step a unique C -- representative node (associated with principal variable of C -- that node. IF (NBT.NE.0) THEN ! Step2node was reallocated and needs be recomputed DO I=1, id%N IF (id%STEP(I).LE.0) CYCLE ! nonprincipal variables id%Step2node(id%STEP(I)) = I ENDDO C ELSE C we reuse Step2node computed in a previous solve phase C Step2node is deallocated each time a new analysis is C performed or when job=-2 is called ENDIF NB_BYTES = NB_BYTES + NBT*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) NB_BYTES_EXTRA = NB_BYTES_EXTRA + NBT * K34_8 C Mapping information used during solve. In case of several C facto+solve it has to be recomputed. C In case of several solves with the same C facto, it is not recomputed. C It used to compute the interleaving C for A-1, and, in dev_version, passed to sol_c to compute C some stats IF((KEEP(235).NE.0).OR.(KEEP(237).NE.0)) THEN IF(.NOT.associated(id%IPTR_WORKING)) THEN CALL CMUMPS_BUILD_MAPPING_INFO(id) END IF END IF ENDIF C C Initialize SIZE_OF_BLOCK from MUMPS_SOL_ES module IF ( I_AM_SLAVE ) & CALL CMUMPS_SOL_ES_INIT(id%OOC_SIZE_OF_BLOCK, id%KEEP(201)) DO_NULL_PIV = .TRUE. NBCOL_INBLOC = -9998 NZ_THIS_BLOCK= -9998 JBEG_RHS = -9998 c IF (id%MYID.EQ.MASTER) THEN ! Compute NRHS_NONEMPTY C C -- Sparse RHS does IF ( KEEP(111)==0 .AND. KEEP(248)==1 & ) THEN C -- Note that KEEP(111).NE.0 (null space on) C -- and KEEP(248).NE.0 will be made incompatible C -- When computing entries of A-1 (or SparseRHS only) NRHS_NONEMPTY = 0 DO I=1, id%NRHS IF (id%IRHS_PTR(I).LT.id%IRHS_PTR(I+1)) & NRHS_NONEMPTY = NRHS_NONEMPTY+1 !ith col in non empty ENDDO IF (NRHS_NONEMPTY.LE.0) THEN C Internal error: tested before in mumps_driver IF (LPOK) & WRITE(LP,*) " Internal Error 3 in solution driver ", & " NRHS_NONEMPTY= ", & NRHS_NONEMPTY CALL MUMPS_ABORT() ENDIF ELSE NRHS_NONEMPTY = id%NRHS ENDIF ENDIF C ------------------------------------ C If there is a special root node, C precompute mapping of root's master C ------------------------------------ SIZE_ROOT = -33333 IF ( KEEP( 38 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP( KEEP(38))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%root%TOT_ROOT_SIZE ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE IF (KEEP( 20 ) .ne. 0 ) THEN MASTER_ROOT = MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(KEEP(20))), & KEEP(199) ) IF (id%MYID_NODES .eq. MASTER_ROOT) THEN SIZE_ROOT = id%IS( & id%PTLUST_S(id%STEP(KEEP(20)))+KEEP(IXSZ) + 3) ELSE IF ((id%MYID.EQ.MASTER).AND.KEEP(60).NE.0) THEN C SIZE_ROOT also used for KEEP(221).NE.0 SIZE_ROOT=id%KEEP(116) ENDIF ELSE MASTER_ROOT = -44444 END IF C -------------- C Get block size C -------------- C We work on a maximum of NBRHS at a time. C The leading dimension of RHS is id%LRHS on the host process C and it is set to N on slave processes. IF (id%MYID .eq. MASTER) THEN KEEP(84) = ICNTL(27) C Treating ICNTL(27)=0 as if ICNTL(27)=1 IF(ICNTL(27).EQ.0) KEEP(84)=1 IF (KEEP(252).NE.0) THEN ! Fwd in facto: all rhs (KEEP(253) need be processed in one pass NBRHS = KEEP(253) ELSE IF (KEEP(201) .EQ. 0 .OR. KEEP(84) .GT. 0) THEN NBRHS = abs(KEEP(84)) ELSE NBRHS = -2*KEEP(84) END IF IF (NBRHS .GT. NRHS_NONEMPTY ) NBRHS = NRHS_NONEMPTY C ENDIF ENDIF #if defined(V_T) CALL VTBEGIN(glob_comm_ini,IERR) #endif C NRHS_NONEMPTY needed on all procs to allocate RHSCOMP on slaves CALL MPI_BCAST(NRHS_NONEMPTY,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(NBRHS,1,MPI_INTEGER,MASTER, & id%COMM,IERR) C IF (KEEP(201).GT.0) THEN C --- id%KEEP(201) indicates if OOC is on (=1) of not (=0) C -- 107: number of buffers C Define number of types of files (L, possibly U) WORKSPACE_MINIMAL_PREFERRED = .FALSE. IF (id%MYID .eq. MASTER) THEN KEEP(107) = max(0,KEEP(107)) IF ((KEEP(107).EQ.0).AND. & (KEEP(204).EQ.0).AND.(KEEP(211).NE.1) ) THEN C -- default setting for release 4.8 ! Case of ! -Emmergency buffer only and ! -Synchronous mode ! -NO_O_DIRECT (because of synchronous choice) ! THEN ! "Basic system-based version" ! We can force to allocate S to a minimal ! value. WORKSPACE_MINIMAL_PREFERRED=.TRUE. ENDIF ENDIF CALL MPI_BCAST( KEEP(107), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(204), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(208), 2, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( WORKSPACE_MINIMAL_PREFERRED, 1, & MPI_LOGICAL, & MASTER, id%COMM, IERR ) C --- end of OOC case ENDIF IF ( I_AM_SLAVE ) THEN C C NB_K133: Max number of simultaneously processed C active fronts. C Why more than one active node ? C 1/ In parallel when we start a level 2 node C then we do not know exactly when we will C have received all contributions from the C slaves. C This is very critical in OOC since the C size provided to the solve phase is C much smaller and since we need C to determine the size fo the buffers for IO. C We pospone the allocation of the block NFRONT*NB_NRHS C and solve the problem. C C C 2/ While processing a node and sending information C if we have not enough memory in send buffer C then we must receive. C We feel that this is not so critical. C NB_K133 = 3 C C To this we must add one time KEEP(133) to store C the RHS of the root node if the root is local. C Furthermore this quantity has to be multiplied by the C blocking size in case of multiple RHS. C IF ( KEEP( 38 ) .NE. 0 .OR. KEEP( 20 ) .NE. 0 ) THEN IF ( MASTER_ROOT .eq. id%MYID_NODES ) THEN IF ( & .NOT. associated(id%root%RHS_CNTR_MASTER_ROOT) & ) THEN NB_K133 = NB_K133 + 1 ENDIF END IF ENDIF LWCB8_MIN = int(NB_K133,8)*int(KEEP(133),8)*int(NBRHS,8) C C --------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided C by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor. Note that we are C inside a block "IF (I_AM_SLAVE)" WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (id%LWK_USER.EQ.0) THEN ITMP8 = 0_8 ELSE IF (id%LWK_USER.GT.0) THEN ITMP8= int(id%LWK_USER,8) ELSE ITMP8 = -int(id%LWK_USER,8)* 1000000_8 ENDIF C Incore: Check if the provided size is equal to that used during C facto (case of ITMP8/=0 and KEEP8(24)/=ITMP8) C But also check case of space not provided during solve C but was provided during facto C (case of ITMP8=0 and KEEP8(24)/=0) IF (KEEP(201).EQ.0) THEN ! incore C Compare provided size with previous size IF (ITMP8.NE.KEEP8(24)) THEN C -- error when reusing space allocated INFO(1) = -41 INFO(2) = id%LWK_USER GOTO 99 ! jump to propinfo ! (S is used in between and not allocated) ! NO COMM must occur then before next propinfo ! it happens in Mila's code but only with ! KEEP(209) > 0 ENDIF ELSE KEEP8(24)=ITMP8 ENDIF C KEEP8(24) holds the size of WK_USER provided by user. C MAXS = 0_8 IF (WK_USER_PROVIDED) THEN MAXS = KEEP8(24) IF (MAXS.LT. KEEP8(20)) THEN INFO(1)= -11 ! MAXS should be increased by at least ITMP8 ITMP8 = KEEP8(20)+1_8-MAXS CALL MUMPS_SET_IERROR(ITMP8, INFO(2)) ENDIF IF (INFO(1) .GE. 0 ) id%S => id%WK_USER(1:KEEP8(24)) ELSE IF (associated(id%S)) THEN C Avoid the use of "size(id%S)" because it returns C a default integer that may overflow. Also "size(id%S,kind=8)" C will only be available with Fortran 2003 compilers. MAXS = KEEP8(23) ELSE ! S not allocated and WK_USER not provided ==> must be in OOC IF (KEEP(201).EQ.0) THEN ! incore WRITE(*,*) ' Working array S not allocated ', & ' on entry to solve phase (in core) ' CALL MUMPS_ABORT() ELSE C -- OOC and WK_USER not provided: C define size (S) and allocate it C ---- modify size of MAXS: in a simple C ---- system-based version, we want to C ---- use a small size for MAXS, to C ---- avoid the system pagecache to be C ---- polluted by 'our memory' C IF ( KEEP(209).EQ.-1 .AND. WORKSPACE_MINIMAL_PREFERRED) & THEN C We need space to load at least the largest factor MAXS = KEEP8(20) + 1_8 ELSE IF ( KEEP(209) .GE.0 ) THEN C Use suggested value of MAXS provided in KEEP(209) MAXS = max(int(KEEP(209),8), KEEP8(20) + 1_8) ELSE MAXS = id%KEEP8(14) ! initial value: do not use more than ! minimum (non relaxed) size of OOC facto ENDIF C MAXS = max(MAXS, id%KEEP8(20)+1_8) ALLOCATE (id%S(MAXS), stat = allocok) KEEP8(23)=MAXS IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID,': problem allocation of S ', & 'at solve' ENDIF INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, INFO(2)) NULLIFY(id%S) KEEP8(23)=0_8 ENDIF NB_BYTES = NB_BYTES + KEEP8(23) * K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C --- end of OOC case ENDIF C -- end of id%S already associated ENDIF C C On the slaves, S is divided as follows: C S(1..LA) holds the factors, C S(LA+1..MAXS) is free workspace IF(KEEP(201).EQ.0)THEN LA = KEEP8(31) ELSE C MAXS has normally be dimensionned to store only factors. LA = MAXS IF(MAXS.GT.KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8))THEN C If we have a very large MAXS, the size reserved for C loading the factors into memory does not need to exceed the C total size of factors. The (KEEP8(20)*(KEEP(107)+1)) term C is here in order to ensure that even with round-off C problems (linked to the number of solve zones) factors can C all be stored in-core LA=KEEP8(31)+KEEP8(20)*int(KEEP(107)+1,8) ENDIF ENDIF C C We need to allocate a workspace of size LWCB8 for the solve phase. C Either it is available at the end of MAXS, or we perform a C dynamic allocation. IF ( MAXS-LA .GT. LWCB8_MIN ) THEN LWCB8 = MAXS - LA WORK_WCB => id%S(LA+1_8:LA+LWCB8) WORK_WCB_ALLOCATED=.FALSE. ELSE LWCB8 = LWCB8_MIN ALLOCATE(WORK_WCB(LWCB8), stat = allocok) IF (allocok < 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(LWCB8,INFO(2)) ENDIF WORK_WCB_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + LWCB8*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF ! I_AM_SLAVE C ----------------------------------- 99 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C ----------------------------------- IF ( I_AM_SLAVE ) THEN IF (KEEP(201).GT.0) THEN CALL CMUMPS_INIT_FACT_AREA_SIZE_S(LA) C -- This includes thread creation C -- for asynchronous strategies CALL CMUMPS_OOC_INIT_SOLVE(id) IS_INIT_OOC_DONE = .TRUE. ENDIF ! KEEP(201).GT.0 ENDIF C CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) < 0) GOTO 90 C IF (I_AM_SLAVE) THEN IF (KEEP(485).EQ.1) THEN IF (.NOT. (associated(id%FDM_F_ENCODING))) THEN WRITE(*,*) "Internal error 18 in CMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF IF (.NOT. (associated(id%BLRARRAY_ENCODING))) THEN WRITE(*,*) "Internal error 19 in CMUMPS_SOL_DRIVER" CALL MUMPS_ABORT() ENDIF C Access to OOC data in module during solve CALL MUMPS_FDM_STRUC_TO_MOD('F',id%FDM_F_ENCODING) CALL CMUMPS_BLR_STRUC_TO_MOD(id%BLRARRAY_ENCODING) IS_LR_MOD_TO_STRUC_DONE = .TRUE. ENDIF ENDIF IF (id%MYID.EQ.MASTER) THEN IF ( PROKG ) THEN WRITE( MPG, 150 ) C ICNTL(35) should not been accessed during SOLVE thus C print KEEP(486) value set during factorization & id%NRHS, NBRHS, ICNTL(9), ICNTL(10), ICNTL(11), & ICNTL(20), ICNTL(21), ICNTL(30), KEEP(486) IF (KEEP(111).NE.0) THEN WRITE (MPG, 151) KEEP(111) ENDIF IF (KEEP(221).NE.0) THEN WRITE (MPG, 152) KEEP(221) ENDIF IF (KEEP(252).GT.0) THEN ! Fwd during facto WRITE (MPG, 153) KEEP(252) ENDIF ENDIF C C ==================================== C Define LSCAL, ICNTL10 and ICNTL11 C ==================================== C LSCAL = (((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) .OR. ( & KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) ICNTL10 = ICNTL(10) ICNTL11 = ICNTL(11) C Values of ICNTL(11) out of range IF ((ICNTL11 .LT. 0).OR.(ICNTL11 .GE. 3)) THEN ICNTL11 = 0 IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) out of range' ENDIF POSTPros = .FALSE. IF (ICNTL11.NE.0 .OR. ICNTL10.NE.0) THEN POSTPros = .TRUE. C FORBID ERROR ANALYSIS AND ITERATIVE REFINEMENT C if there are options that are not compatible IF (KEEP(111).NE.0) THEN C IF WE RETURN A NULL SPACE BASIS or compute entries in A-1 C of Fwd in facto C -When only one columns of A-1 is requested then C we could try to reactivate IR even if C -code need be updated C -accuracy could be # when one or more columns are requested IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: null space basis ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(237) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: AM1', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(252) .NE.0 ) THEN IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: Fwd in facto ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (KEEP(221).NE.0) THEN C Forbid error analysis and iterative refinement C in case of reduced rhs/solution IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: reduced RHS ', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF (NBRHS.GT. 1 .OR. ICNTL(21) .GT. 0) THEN C Forbid error analysis and iterative refinement if C the solution is distributed or C in the case where nrhs > 1 IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: nrhs>1 or distrib sol', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ELSE IF ( KEEP(248) .EQ. -1 ) THEN C Forbid error analysis and iterative refinement C in case of distributed RHS IF (PROKG) WRITE(MPG,'(A,A)') & ' WARNING: Incompatible features: distrib rhs', & ' and Iter. Ref and/or Err. Anal.' POSTPros = .FALSE. ENDIF IF (.NOT.POSTPros) THEN ICNTL11 = 0 ICNTL10 = 0 ENDIF ENDIF C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .NE. 0) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF C -- end of test master END IF CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) C We need the original matrix only in the case of C we want to perform IR or Error Analysis, i.e. if C POSTPros = TRUE MAT_ALLOC_LOC = 0 IF ( POSTPros ) THEN MAT_ALLOC_LOC = 1 C Check if the original matrix has been allocated. IF ( KEEP(54) .EQ. 0 ) THEN C The original matrix is centralized IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).eq.0) THEN C Case of matrix assembled centralized IF (.NOT.associated(id%A) .OR. & (.NOT.associated(id%IRN)) .OR. & ( .NOT.associated(id%JCN))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original centralized assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ELSE C Case of matrix in elemental format IF (.NOT.associated(id%A_ELT).OR. & .NOT.associated(id%ELTPTR).OR. & .NOT.associated(id%ELTVAR)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original elemental matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF !end master, centralized matrix ELSE C The original matrix is assembled distributed IF ( I_AM_SLAVE .AND. (id%KEEP8(29) .GT. 0_8) ) THEN C If MAT_ALLOC_LOC = 1 the local distributed matrix is C allocated, otherwise MAT_ALLOC_LOC = 0 IF ((.NOT.associated(id%A_loc)) .OR. & (.NOT.associated(id%IRN_loc)) .OR. & (.NOT.associated(id%JCN_loc))) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: original distributed assembled', & ' matrix is not allocated ' MAT_ALLOC_LOC = 0 ENDIF ENDIF ENDIF ! end test allocation matrix (keep(54)) ENDIF ! POSTPros CALL MPI_REDUCE( MAT_ALLOC_LOC, MAT_ALLOC, 1, & MPI_INTEGER, & MPI_MIN, MASTER, id%COMM, IERR) IF ( id%MYID .eq. MASTER ) THEN IF (MAT_ALLOC.EQ.0) THEN POSTPros = .FALSE. ICNTL11 = 0 ICNTL10 = 0 C Write a warning. IF ((ICNTL(10) .NE. 0) .AND. (ICNTL10 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(10) treated as if set to 0 ' ENDIF IF ((ICNTL(11) .EQ. 1).OR.(ICNTL(11) .EQ. 2) & .AND.(ICNTL11 .EQ. 0)) THEN IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: ICNTL(11) treated as if set to 0 ' ENDIF ENDIF IF (POSTPros) THEN ALLOCATE(SAVERHS(id%N*NBRHS),stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Problem in solve: error allocating SAVERHS' ENDIF INFO(1) = -13 INFO(2) = id%N*NBRHS END IF NB_BYTES = NB_BYTES + int(size(SAVERHS),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C Forbid entries in a-1, in case of null space computations c IF (KEEP(237).NE.0 .AND.KEEP(111).NE.0) THEN C Ignore ENTRIES IN A-1 in case we compute C vectors of the null space (KEEP(111)).NE.0.) C We should still allocate IRHS_SPARSE IF (PROKG) WRITE(MPG,'(A)') & ' WARNING: KEEP(237) treated as if set to 0 (null space)' KEEP(237)=0 ENDIF C -- end of test master END IF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C -------------------------------------------------- C Broadcast information to have all processes do the C same thing (error analysis/iterative refinements/ C scaling/distribution of solution) C -------------------------------------------------- CALL MPI_BCAST(ICNTL10,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL11,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(ICNTL21,1,MPI_INTEGER,MASTER, & id%COMM,IERR) CALL MPI_BCAST(POSTPros,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(LSCAL,1,MPI_LOGICAL,MASTER, & id%COMM,IERR) CALL MPI_BCAST(KEEP(237),1,MPI_INTEGER,MASTER, & id%COMM,IERR) C KEEP(248)==1 if not_NullSpace (KEEP(111)=0) C and sparse RHS on input (id%ICNTL(20)/KEEP(248)==1) C (KEEP(248)==1 implies KEEP(111) = 0, otherwise error was raised) C We cant thus isolate the case of C sparse RHS associated to Null space computation because C in this case preparation is different since C -we skip the forward step and C -the pattern of the RHS C of the bwd is related to null pivot indices found and not C to information contained in the sparse rhs input format. DO_PERMUTE_RHS = (KEEP(242).NE.0) C apply interleaving in parallel (FOR A-1 or Null space only) IF ( (id%NSLAVES.GT.1) .AND. (KEEP(243).NE.0) & ) THEN C -- Option to interleave RHS only makes sense when C -- A-1 option is on or Null space compution are on C (note also that KEEP(243).NE.0 only when PERMUTE_RHS is on) IF ((KEEP(237).NE.0).or.(KEEP(111).GT.0)) THEN INTERLEAVE_PAR= .TRUE. ELSE IF (PROKG) THEN write(MPG,*) ' Warning incompatible options ', & ' interleave RHS reset to false ' ENDIF ENDIF ENDIF C -------------------------------------- C Compute an upperbound of message size C for forward and backward solutions: C -------------------------------------- MSG_MAX_BYTES_SOLVE8 = int(( 4 + KEEP(133) ) * KEEP(34),8) + & int(KEEP(133)*KEEP(35),8) * int(NBRHS,8) & + int(16*KEEP(34),8) ! for request id, pointer to next + safety C Note that IF ( MSG_MAX_BYTES_SOLVE8 .GT. & int(huge(MSG_MAX_BYTES_SOLVE),8)) THEN INFO(1) = -18 INFO(2) = ( huge(MSG_MAX_BYTES_SOLVE) - & ( 16 + 4 + KEEP(133) ) ) / & ( KEEP(133) * KEEP(35) ) ENDIF IF (INFO(1) .LT.0 ) GOTO 111 MSG_MAX_BYTES_SOLVE = int(MSG_MAX_BYTES_SOLVE8) C ------------------------------------------ C Compute an upperbound of message size C for CMUMPS_GATHER_SOLUTION. Except C possibly on the non working host, it C should be smaller than MSG_MAX_BYTES_SOLVE #if defined(MPI_TO_K_OMPP) #endif C ------------------------------------------ IF (KEEP(237).EQ.0) THEN C Note that for CMUMPS_GATHER_SOLUTION LBUFR buffer should C be larger that MAX_inode(NPIV))*NBRHS + NPIV C which is covered by next formula since KMAX_246_247 is larger C than MAX_inode(NPIV)) C 2 integers packed (npiv and termination) C Note that MSG_MAX_BYTES_GTHRSOL < MSG_MAX_BYTES_SOLVE C so that it should not overflow KMAX_246_247 = max(KEEP(246),KEEP(247)) MSG_MAX_BYTES_GTHRSOL = ( 2 + KMAX_246_247 ) * KEEP(34) + & KMAX_246_247 * NBRHS * KEEP(35) ELSE IF (ICNTL21.EQ.0) THEN C Each message from a slave is of size max 4: C 2 integers : I,J C 1 complex : (Aij)-1 C 1 terminaison MSG_MAX_BYTES_GTHRSOL = ( 3 * KEEP(34) + KEEP(35) ) ELSE C Not needed in case of distributed solution and A-1 C because the entries of A −1 are C returned in RHS SPARSE on the host. MSG_MAX_BYTES_GTHRSOL = 0 ENDIF C The buffer is used both for solve and for CMUMPS_GATHER_SOLUTION LBUFR_BYTES = max(MSG_MAX_BYTES_SOLVE, MSG_MAX_BYTES_GTHRSOL) TSIZE = int(min(100_8*int(MSG_MAX_BYTES_GTHRSOL,8), & 10000000_8)) LBUFR_BYTES = max(LBUFR_BYTES,TSIZE) LBUFR = ( LBUFR_BYTES + KEEP(34) - 1 ) / KEEP(34) ALLOCATE (BUFR(LBUFR),stat=allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ' Problem in solve: error allocating BUFR' ENDIF INFO(1) = -13 INFO(2) = LBUFR GOTO 111 ENDIF NB_BYTES = NB_BYTES + int(size(BUFR),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( I_AM_SLAVE .AND. id%NSLAVES .GT. 1 ) THEN C ------------------------------------------------------ C Dimension send buffer for small integers, e.g. TRACINE C ------------------------------------------------------ CMUMPS_LBUF_INT = ( 20 + id%NSLAVES * id%NSLAVES * 4 ) & * KEEP(34) CALL CMUMPS_BUF_ALLOC_SMALL_BUF( CMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = CMUMPS_LBUF_INT IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating small Send buffer:IERR=',IERR END IF GOTO 111 END IF C C --------------------------------------- C Dimension cyclic send buffer for normal C messages, based on largest message C size during forward and backward solves C --------------------------------------- C Compute buffer size in BYTES (CMUMPS_LBUF) C using integer8 in CMUMPS_LBUF_8 C then convert it in integer4 and bound it to largest integer value C CMUMPS_LBUF_8 = & (int(MSG_MAX_BYTES_SOLVE,8)+2_8*int(KEEP(34),8))* & int(id%NSLAVES,8) C Avoid buffers larger than 100 Mbytes ... CMUMPS_LBUF_8 = min(CMUMPS_LBUF_8, 100000000_8) C ... as long as we can send messages to at least 3 C destinations simultaneously CMUMPS_LBUF_8 = max(CMUMPS_LBUF_8, & int((MSG_MAX_BYTES_SOLVE+2*KEEP(34)),8) * & int(min(id%NSLAVES,3),8) ) CMUMPS_LBUF_8 = CMUMPS_LBUF_8 + 2_8*int(KEEP(34),8) C Convert to integer and bound it to largest integer C and suppress 10 integers (one should be enough!) C to enable computation of integer size. CMUMPS_LBUF_8 = min(CMUMPS_LBUF_8, & int(huge(CMUMPS_LBUF),8) & - 10_8*int(KEEP(34),8) & ) CMUMPS_LBUF = int(CMUMPS_LBUF_8, kind(CMUMPS_LBUF)) CALL CMUMPS_BUF_ALLOC_CB( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1) = -13 INFO(2) = CMUMPS_LBUF/KEEP(34) + 1 IF ( LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating Send buffer:IERR=', IERR END IF GOTO 111 END IF C C C -- end of I am slave ENDIF C IF ( POSTPros ) THEN C When Iterative refinement of error analysis requested C Allocate RHS_IR on slave processors C (note that on MASTER RHS_IR points to RHS) IF ( id%MYID .NE. MASTER ) THEN C ALLOCATE(RHS_IR(id%N),stat=IERR) NB_BYTES = NB_BYTES + int(size(RHS_IR),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF ( IERR .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS on a slave' ENDIF GOTO 111 END IF ELSE RHS_IR=>id%RHS ENDIF ENDIF C C Parallel A-1 or General sparse and C exploit sparsity between columns DO_NBSPARSE = ( ( (KEEP(237).NE.0).OR.(KEEP(235).NE.0) ) & .AND. & ( KEEP(497).NE.0 ) & ) IF ( I_AM_SLAVE ) THEN IF(DO_NBSPARSE) THEN c --- ALLOCATE outside loop RHS_BOUNDS is needed LPTR_RHS_BOUNDS = 2*KEEP(28) ALLOCATE(RHS_BOUNDS(LPTR_RHS_BOUNDS), STAT=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=LPTR_RHS_BOUNDS IF (LPOK) THEN WRITE(LP,*) 'ERROR while allocating RHS_BOUNDS on', & ' a slave' ENDIF GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(RHS_BOUNDS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) PTR_RHS_BOUNDS => RHS_BOUNDS ELSE LPTR_RHS_BOUNDS = 1 PTR_RHS_BOUNDS => IDUMMY_TARGET ENDIF ENDIF C -------------------------------------------------- IF ( I_AM_SLAVE ) THEN IF ((KEEP(221).EQ.2 .AND. KEEP(252).EQ.0)) THEN C -- RHSCOMP must have been allocated in C -- previous solve step (with option KEEP(221)=1) IF (.NOT.associated(id%RHSCOMP)) THEN INFO(1) = -35 INFO(2) = 1 GOTO 111 ENDIF C IF ((KEEP(248).EQ.0) .OR. (id%NRHS.EQ.1)) THEN C POSINRHSCOMP_ROW/COL are meaningful and could even be reused IF (.NOT.associated(id%POSINRHSCOMP_ROW) ) ! .OR. ! & .NOT.(id%POSINRHSCOMP_COL_ALLOC)) & THEN INFO(1) = -35 INFO(2) = 2 GOTO 111 ENDIF IF (.not.id%POSINRHSCOMP_COL_ALLOC) THEN C POSINRHSCOMP_COL that is kept from C previous call to solve must then (already) C point to id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW ENDIF ELSE C ---------------------- C Allocate POSINRHSCOMP_ROW/COL C ---------------------- C The size of POSINRHSCOMP arrays C does not depend on the block of RHS C POSINRHSCOMP_ROW/COL are initialized in the loop of RHS IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) ENDIF ALLOCATE (id%POSINRHSCOMP_ROW(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C IF ((KEEP(50).EQ.0).OR.KEEP(237).NE.0) THEN ALLOCATE (id%POSINRHSCOMP_COL(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 END IF id%POSINRHSCOMP_COL_ALLOC = .TRUE. NB_BYTES = NB_BYTES + & int(size(id%POSINRHSCOMP_COL),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE C Do no allocate POSINRHSCOMP_COL id%POSINRHSCOMP_COL => id%POSINRHSCOMP_ROW id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF IF (KEEP(221).NE.2) THEN C -- only in the case of bwd after reduced RHS C -- we have to keep "old" RHSCOMP IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF ENDIF C --------------------------- C Allocate local workspace C for the solve (CMUMPS_SOL_C) C --------------------------- LIWK_SOLVE = 2 * KEEP(28) + id%NA(1)+1 LIWK_PTRACB= KEEP(28) C KEEP(228)+1 temporary integer positions C will be needed in CMUMPS_SOL_S IF (KEEP(201).EQ.1) THEN LIWK_SOLVE = LIWK_SOLVE + KEEP(228) + 1 ELSE C Reserve 1 position to pass array of size 1 in routines LIWK_SOLVE = LIWK_SOLVE + 1 ENDIF ALLOCATE ( IWK_SOLVE(LIWK_SOLVE), & PTRACB(LIWK_PTRACB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWK_SOLVE + LIWK_PTRACB*KEEP(10) GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWK_SOLVE,8)*K34_8 + & int(LIWK_PTRACB,8)*K34_8 *int(KEEP(10),8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C array IWCB used temporarily to hold C indices of a front unpacked from a message C and to stack (potentially in a recursive call) C headers of size 2 positions of CB blocks. LIWCB = 20*NB_K133*2 + KEEP(133) ALLOCATE ( IWCB( LIWCB), stat = allocok ) IF (allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=LIWCB GOTO 111 END IF NB_BYTES = NB_BYTES + int(LIWCB,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C C -- Code for a slave C ----------- C Subdivision C of array IS C ----------- LIW = KEEP(32) C Define a work array of size maximum global frontal C size (KEEP(133)) for the call to CMUMPS_SOL_C C This used to be of size id%N. ALLOCATE(SRW3(KEEP(133)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=KEEP(133) GOTO 111 END IF NB_BYTES = NB_BYTES + int(size(SRW3),8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ----------------- C End of slave code C ----------------- ELSE C I am the master with host not working C C LIW is used on master when calling C the routine CMUMPS_GATHER_SOLUTION. LIW=0 END IF C C Precompute inverse of UNS_PERM outside loop IF (allocated(UNS_PERM_INV)) DEALLOCATE(UNS_PERM_INV) UNS_PERM_INV_NEEDED_INMAINLOOP = .FALSE. IF ( ( id%MYID .eq. MASTER.AND.(KEEP(23).GT.0) .AND. & (MTYPE .NE. 1).AND.(KEEP(248).NE.0) & ) C Permute UNS_PERM on master only with C sparse RHS (KEEP(248).NE.0 ) when AT x = b is solved & .OR. ( KEEP(237).NE.0 .AND. KEEP(23).NE.0 ) C When A-1 is active and when the matrix is unsymmetric C and a column permutation has been applied (Max transversal) C then we have performed a C factorization of a column permuted matrix AQ = LU. C In this case, C the permuted entry must be used to select the target C entries for the BWD (note that a diagonal entry of A-1 C is not anymore a diagonal of AQ. Thus a diagonal C of A-1 does not correspond to the same path C in the tree during FWD and BWD steps when MAXTRANS is on C and permutation is not identity.) C Note that the inverse permutation C UNS_PERM_INV needs to be allocated on each proc C since it is used in CMUMPS_SOL_C routine for pruning. C It is allocated only once and its allocation has been C migrated outside the blocking on the right hand sides. & ) THEN UNS_PERM_INV_NEEDED_INMAINLOOP = .TRUE. ENDIF UNS_PERM_INV_NEEDED_BEFMAINLOOP = .FALSE. IF ( KEEP(23) .GT.0 .AND. & MTYPE .NE. 1 .AND. KEEP(248).EQ.-1 ) THEN C Similar to sparse RHS case, we need to modify IRHS_loc C indices in the distributed RHS case. However, we need C UNS_PERM_INV on all processors. But only before theC C main loop on the RHS blocks. UNS_PERM_INV_NEEDED_BEFMAINLOOP = .TRUE. ENDIF IF ( UNS_PERM_INV_NEEDED_INMAINLOOP .OR. & UNS_PERM_INV_NEEDED_BEFMAINLOOP ) THEN ALLOCATE(UNS_PERM_INV(id%N),stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 111 endif NB_BYTES = NB_BYTES + int(id%N,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C Build inverse permutation DO I = 1, id%N UNS_PERM_INV(id%UNS_PERM(I))=I ENDDO ENDIF C ELSE ALLOCATE(UNS_PERM_INV(1), stat=allocok) if (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=1 GOTO 111 endif NB_BYTES = NB_BYTES + 1_8*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C 111 CONTINUE #if defined(V_T) CALL VTEND(glob_comm_ini,IERR) #endif C C Synchro point + Broadcast of errors C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C C UNS_PERM_INV needed on slaves: IF ( KEEP(23).NE.0 .AND. & ( KEEP(237).NE.0 .OR. & ( MTYPE.NE.1 .AND. KEEP(248).EQ.-1 ) ) ) THEN C Broadcast UNS_PERM_INV CALL MPI_BCAST( UNS_PERM_INV,id%N,MPI_INTEGER,MASTER, & id%COMM,IERR ) ENDIF C ------------------------------- C BEGIN C Preparation for distributed RHS C ------------------------------- IF (I_AM_SLAVE .AND. KEEP(248).EQ.-1) THEN C Distributed RHS case ALLOCATE(MAP_RHS_loc(max(id%Nloc_RHS,1)), stat=allocok) IF (allocok .GT. 0) THEN id%INFO(1)=-13 id%INFO(2)=max(id%Nloc_RHS,1) GOTO 20 ENDIF NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 ENDIF C MAP_RHS_loc will be built in the main C loop, when processing the first block. C It requires POSINRHSCOMP to be built. BUILD_RHSMAPINFO = .TRUE. 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C In case of Unsymmetric column permutation and C transpose system, use MUMPS internal indices C for IRHS_loc_PTR. Done before scaling since C scaling is on permuted matrix IF ( I_AM_SLAVE .AND. KEEP(23).GT.0 .AND. KEEP(248).EQ.-1 & .AND. MTYPE.NE.1 ) THEN IF (id%Nloc_RHS .GT. 0) THEN ALLOCATE(IRHS_loc_PTR(id%Nloc_RHS),stat=allocok) IF (allocok.GT.0) THEN INFO(1)=-13 INFO(2)=id%Nloc_RHS GOTO 25 ENDIF IRHS_loc_PTR_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + max(int(id%Nloc_RHS,8),1_8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) DO I=1, id%Nloc_RHS IF (id%IRHS_loc(I).GE.1 .AND. id%IRHS_loc(I).LE.id%N) & THEN IRHS_loc_PTR(I)=UNS_PERM_INV(id%IRHS_loc(I)) ELSE C Keep track of out-of range entries IRHS_loc_PTR(I)=id%IRHS_loc(I) ENDIF ENDDO ENDIF ENDIF C Check if UNS_PERM_INV still needed C to free memory IF (UNS_PERM_INV_NEEDED_BEFMAINLOOP .AND. & .NOT. UNS_PERM_INV_NEEDED_INMAINLOOP) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ALLOCATE(UNS_PERM_INV(1)) ! to posibly pass it as an argument NB_BYTES = NB_BYTES + K34_8 ENDIF IF (LSCAL .AND. id%KEEP(248).EQ.-1) THEN C Scaling done based on original indices C provided by user IF (MTYPE == 1) THEN C No transpose scaling_data_dr%SCALING=>id%ROWSCA ELSE C Transpose scaling_data_dr%SCALING=>id%COLSCA ENDIF CALL CMUMPS_SET_SCALING_LOC( scaling_data_dr, id%N, & IRHS_loc_PTR(1), id%Nloc_RHS, & id%COMM, id%MYID, I_AM_SLAVE, MASTER, & NB_BYTES, NB_BYTES_MAX, K16_8, LP, LPOK, & ICNTL(1), INFO(1) ) ENDIF C ------------------------------- C END C Preparation for distributed RHS C ------------------------------- 25 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT.0 ) GOTO 90 C ------------------------------------- C BEGIN C Preparation for distributed solution C ------------------------------------- IF ( ICNTL21==1 ) THEN IF (LSCAL) THEN C In case of scaling we will need to scale C back the sol. Put the values of the scaling C arrays needed to do that on each processor. IF (id%MYID.NE.MASTER) THEN IF (MTYPE == 1) THEN ALLOCATE(id%COLSCA(id%N),stat=allocok) ELSE ALLOCATE(id%ROWSCA(id%N),stat=allocok) ENDIF IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=id%N GOTO 37 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! MYID .NE. MASTER 37 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data_sol%SCALING_LOC(id%KEEP(89)), & stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating local scaling array' ENDIF INFO(1)=-13 INFO(2)=id%KEEP(89) GOTO 38 ENDIF NB_BYTES = NB_BYTES + int(id%KEEP(89),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ! I_AM_SLAVE 38 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) THEN GOTO 90 ENDIF IF (MTYPE == 1) THEN CALL MPI_BCAST(id%COLSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%COLSCA ELSE CALL MPI_BCAST(id%ROWSCA(1),id%N, & MPI_REAL,MASTER, & id%COMM,IERR) scaling_data_sol%SCALING=>id%ROWSCA ENDIF ENDIF ! LSCAL IF ( I_AM_SLAVE ) THEN C ---------------------- C Prepare ISOL_loc array C ---------------------- LIW_PASSED=max(1,LIW) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF (KEEP(89) .GT. 0) THEN CALL CMUMPS_DISTSOL_INDICES( MTYPE, id%ISOL_loc(1), & id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%IS(1), LIW_PASSED,id%MYID_NODES, & id%N, id%STEP(1), id%PROCNODE_STEPS(1), & id%NSLAVES, scaling_data_sol, LSCAL C For checking only & , (KEEP(248).EQ.-1), IRHS_loc_PTR(1), id%Nloc_RHS & ) ENDIF IF (id%MYID.NE.MASTER .AND. LSCAL) THEN C --------------------------------- C Local (small) scaling arrays have C been built, free temporary copies C --------------------------------- IF (MTYPE == 1) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ELSE DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF NB_BYTES = NB_BYTES - int(id%N,8)*K16_8 ENDIF ENDIF ! I_AM_SLAVE IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN C Broadcast the unsymmetric permutation and C permute the indices in ISOL_loc IF (id%MYID.NE.MASTER) THEN ALLOCATE(id%UNS_PERM(id%N),stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=id%N GOTO 40 ENDIF ENDIF ENDIF C C ===================== ERROR handling and propagation ================ 40 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C IF (KEEP(23) .NE. 0 .AND. MTYPE==1) THEN CALL MPI_BCAST(id%UNS_PERM(1),id%N,MPI_INTEGER,MASTER, & id%COMM,IERR) IF (I_AM_SLAVE) THEN DO I=1, KEEP(89) id%ISOL_loc(I) = id%UNS_PERM(id%ISOL_loc(I)) ENDDO ENDIF IF (id%MYID.NE.MASTER) THEN DEALLOCATE(id%UNS_PERM) NULLIFY(id%UNS_PERM) ENDIF ENDIF ENDIF ! ICNTL(21)=1 C -------------------------------------- C Preparation for distributed solution C END C -------------------------------------- C ---------------------------- C Preparation for reduced RHS C ---------------------------- IF ( ( KEEP(221) .EQ. 1 ) .OR. & ( KEEP(221) .EQ. 2 ) & ) THEN C -- First compute MASTER_ROOT_IN_COMM proc number in C COMM_NODES on which is mapped the master of the root. IF (KEEP(46).EQ.1) THEN MASTER_ROOT_IN_COMM=MASTER_ROOT ELSE MASTER_ROOT_IN_COMM =MASTER_ROOT+1 ENDIF IF ( id%MYID .EQ. MASTER ) THEN C -------------------------------- C Avoid using LREDRHS when id%NRHS is C equal to 1, as was done for RHS C -------------------------------- IF (id%NRHS.EQ.1) THEN LD_REDRHS = id%KEEP(116) ELSE LD_REDRHS = id%LREDRHS ENDIF ENDIF IF (MASTER.NE.MASTER_ROOT_IN_COMM) THEN C -- Make available LD_REDRHS on MASTER_ROOT_IN_COMM C This will then be used to test if a single C message can be sent C (this is possible if LD_REDRHS=SIZE_SCHUR) IF ( id%MYID .EQ. MASTER ) THEN C -- send LD_REDRHS to MASTER_ROOT_IN_COMM C using COMM communicator CALL MPI_SEND(LD_REDRHS,1,MPI_INTEGER, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSEIF ( id%MYID.EQ.MASTER_ROOT_IN_COMM) THEN C -- recv LD_REDRHS CALL MPI_RECV(LD_REDRHS,1,MPI_INTEGER, & MASTER, 0, id%COMM,STATUS,IERR) ENDIF C -- other procs not concerned ENDIF ENDIF C IF ( KEEP(248)==1 ) THEN ! Sparse RHS (A-1 or general sparse) ! JBEG_RHS - current starting column within A-1 or sparse rhs ! set in the loop below and used to obtain the ! global index of the column of the sparse RHS ! Also used to get index in global permutation. ! It also allows to skip empty columns; JEND_RHS = 0 ! last column in current blockin A-1 C C Compute and apply permutations IF (DO_PERMUTE_RHS) THEN C Allocate PERM_RHS ALLOCATE(PERM_RHS(id%NRHS),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = id%NRHS GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(id%NRHS,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.EQ.MASTER) THEN C PERM_RHS is computed on MASTER, it might be modified C in case of interleaving and will thus be distributed C (BCAST) to all slaves only later. C Compute PERM_RHS C on output: PERM_RHS(k) = i means that i is the kth column C to be processed IF (KEEP(237).EQ.0) THEN C Permute RHS : case of GS (General Sparse) RHS C IRHS_SPARSE is of size at least NZ_RHS > 0 C since all this is skipped when NZ_RHS=0. So C accessing IRHS_SPARSE(1) is ok. CALL CMUMPS_PERMUTE_RHS_GS( & LP, LPOK, PROKG, MPG, KEEP(242), & id%SYM_PERM(1), id%N, id%NRHS, & id%IRHS_PTR(1), id%NRHS+1, & id%IRHS_SPARSE(1), id%NZ_RHS, & PERM_RHS, IERR) IF (IERR.LT.0) THEN INFO(1) = -9999 INFO(2) = IERR GOTO 109 ! propagate error ENDIF ELSE C Case of A-1 : C We compute the permutation of the RHS (sparse matrix) C (to compute all inverse entries) C We apply permutation to IRHS_SPARSE ONLY. C Note NRHS_NONEMPTY holds the nb of non empty columns C in A-1. STRAT_PERMAM1 = KEEP(242) CALL CMUMPS_PERMUTE_RHS_AM1 & (STRAT_PERMAM1, id%SYM_PERM(1), & id%IRHS_PTR(1), id%NRHS+1, & PERM_RHS, id%NRHS, & IERR & ) ENDIF ENDIF ENDIF ENDIF C C Note that within CMUMPS_SOL_C, PERM_RHS could be used C for A-1 case (with DO_PERMUTE_RHS OR INTERLEAVE_RHS C being tested) to get the column index for the C original matrix of RHS (column index in A-1) C of the permuted columns that have been selected. C PERM_RHS is also used in CMUMPS_GATHER_SOLUTION C in case of sparse RHS awith DO_PERMUTE_RHS. C C Allocate PERM_RHS of size 1 if not allocated IF (.NOT. allocated(PERM_RHS)) THEN ALLOCATE(PERM_RHS(1),stat=allocok) IF (allocok > 0) THEN INFO(1) = -13 INFO(2) = 1 GOTO 109 ENDIF NB_BYTES = NB_BYTES + int(size(PERM_RHS),8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C Propagate errors 109 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 c -------------------------- c -------------------------- IF (id%NSLAVES .EQ. 1) THEN c - In case of NS/A-1 we may want to permute RHS c - for NS thus is to apply permutation to PIVNUL_LIST * - before starting loop of NBRHS IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN C NOTE: C when host not working both master and slaves have C in this case the complete list WRITE(*,*) id%MYID, ':INTERNAL ERROR 1 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF ! End Permute_RHS ELSE IF (DO_PERMUTE_RHS .AND. KEEP(111).NE.0 ) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 2 : ', & ' PERMUTE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() C C ENDIF ! End DO_PERMUTE_RHS IF (INTERLEAVE_PAR.AND. (KEEP(111).NE.0)) THEN WRITE(*,*) id%MYID, ':INTERNAL ERROR 3 : ', & ' INTERLEAVE RHS during null space computation ', & ' not available yet ' CALL MUMPS_ABORT() ENDIF IF (INTERLEAVE_PAR.AND.KEEP(111).EQ.0) THEN C - A-1 + Interleave: C permute RHS on master IF (id%MYID.EQ.MASTER) THEN C -- PERM_RHS must have been already set or initialized C -- it is then modified in next routine SIZE_WORKING = id%IPTR_WORKING(id%NPROCS+1)-1 SIZE_IPTR_WORKING = id%NPROCS+1 CALL CMUMPS_INTERLEAVE_RHS_AM1( & PERM_RHS, id%NRHS, & id%IPTR_WORKING(1), SIZE_IPTR_WORKING, & id%WORKING(1), SIZE_WORKING, & id%IRHS_PTR(1), & id%STEP(1), id%SYM_PERM(1), id%N, NBRHS, & id%PROCNODE_STEPS(1), KEEP(28), id%NSLAVES, & KEEP(199), & KEEP(493).NE.0, & KEEP(495).NE.0, KEEP(496), PROKG, MPG & ) ENDIF ! End Master ENDIF ! End A-1 and INTERLEAVE_PAR C ------------- ENDIF ! End Parallel Case c -------------------------- c IF (DO_PERMUTE_RHS.AND.(KEEP(111).EQ.0)) THEN C --- Distribute PERM_RHS before loop of RHS C --- (with null space option PERM_RHS is not allocated / needed C to permute the null column pivot list) CALL MPI_BCAST(PERM_RHS(1), & id%NRHS, & MPI_INTEGER, & MASTER, id%COMM,IERR) ENDIF C ============================== C BLOCKING ON the number of RHS C We work on a maximum of NBRHS at a time. C the leading dimension of RHS is id%LRHS on master C and is set to N on slaves C ============================== C We may want to allow to have NBRHS that varies C this is typically the case when a partitionning of C the right hand side is performed and leads to C irregular partitions. C We only have to be sure that the size of each partition C is smaller than NBRHS. BEG_RHS=1 DO WHILE (BEG_RHS.LE.NRHS_NONEMPTY) C ========================== C -- NBRHS : Original block size C -- BEG_RHS : Column index of the first RHS in the list of C non empty RHS (RHS_LOC) to C be processed during this iteration C -- NBRHS_EFF : Effective block size at current iteration C In case of sparse RHS (KEEP(248)==1) NBRHS_EFF only refers to C non-empty columns and is used to compute NBCOL_INBLOC C -- NBCOL_INBLOC : the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns columns of C sparse RHS processed at each step C NBRHS_EFF = min(NRHS_NONEMPTY-BEG_RHS+1, NBRHS) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF C C =========================================================== C Set LD_RHS and IBEG for the accesses to id%RHS (in cases C id%RHS is accessed). Remark that IBEG might still be C overwritten later, in case of general sparse right-hand side C and centralized solution to skip empty columns C =========================================================== IF ( C slave procs & ( id%MYID .NE. MASTER ) C even on master when RHS not allocated & .or. C Case of Master working but with distributed sol and C ( sparse RHS or null space ) C -- Allocate not needed on host not working & ( I_AM_SLAVE .AND. id%MYID .EQ. MASTER .AND. & ICNTL21 .NE.0 .AND. & ( KEEP(248).ne.0 .OR. KEEP(221).EQ.2 & .OR. KEEP(111).NE.0 ) & ) & .or. C Case of Master and C (compute entries of INV(A)) C Even when I am a master with host not working I C am in charge of gathering solution to scale it C and to copy it back in the sparse RHS format & ( id%MYID .EQ. MASTER .AND. (KEEP(237).NE.0) ) C & ) THEN LD_RHS = id%N IBEG = 1 ELSE ! (id%MYID .eq. MASTER) IF ( associated(id%RHS) ) THEN C Leading dimension of RHS on master is id%LRHS LD_RHS = max(id%LRHS, id%N) ELSE C --- LRHS might not be defined (dont use it) LD_RHS = id%N ENDIF IBEG = int(BEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF C JBEG_RHS might also be used in DISTRIBUTED_SOLUTION C even when RHS is not sparse on input. In this case, C there are no empty columns. (If RHS is sparse JBEG_RHS C is overwritten). JBEG_RHS = BEG_RHS C ========================================== C Shift empty columns in case of sparse RHS C ========================================== IF ( (id%MYID.EQ.MASTER) .AND. & KEEP(248)==1 ) THEN C update position of JBEG_RHS on first non-empty C column of this block JBEG_RHS = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( id%IRHS_PTR(PERM_RHS(JBEG_RHS)) .EQ. & id%IRHS_PTR(PERM_RHS(JBEG_RHS)+1) ) C Empty column IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C General sparse RHS (NOT A-1) and centralized solution C Set to zero part of the C solution corresponding to empty columns DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_RHS) -1,8)*int(LD_RHS,8)+ & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ELSE DO WHILE( id%IRHS_PTR(JBEG_RHS) .EQ. & id%IRHS_PTR(JBEG_RHS+1) ) IF ((KEEP(237).EQ.0).AND.(ICNTL21.EQ.0).AND. & (KEEP(221).NE.1) ) THEN C Case of general sparse RHS (NOT A-1) and C centralized solution: set to zero part of C the solution corresponding to empty columns DO I=1, id%N id%RHS(int(JBEG_RHS -1,8)*int(LD_RHS,8) + & int(I,8)) = ZERO ENDDO ENDIF IF (KEEP(221).EQ.1) THEN C Reduced RHS set to ZERO DO I = 1, id%SIZE_SCHUR id%REDRHS(int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO ENDIF JBEG_RHS = JBEG_RHS +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR C Count nb of RHS columns skipped: useful for C * CMUMPS_DISTRIBUTED_SOLUTION to reset those C columns to zero. C * in case of reduced right-hand side, to set C corresponding entries of RHSCOMP to 0 after C forward phase. NB_RHSSKIPPED = JBEG_RHS - (JEND_RHS + 1) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0) & .AND. (ICNTL21.EQ.0)) & THEN ! case of general sparse rhs with centralized solution, !set IBEG to shifted columns ! (after empty columns have been skipped) IBEG = int(JBEG_RHS-1,8) * int(LD_RHS,8) + 1_8 ENDIF ENDIF ! of if (id%MYID.EQ.MASTER) .AND. KEEP(248)==1 CALL MPI_BCAST( JBEG_RHS, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Shift on REDRHS in reduced RHS functionality C IF (id%MYID.EQ.MASTER .AND. KEEP(221).NE.0) THEN C Initialize IBEG_REDRHS C Note that REDRHS always has id%NRHS Colmuns IBEG_REDRHS= int(JBEG_RHS-1,8)*int(LD_REDRHS,8) + 1_8 ELSE IBEG_REDRHS=-142424_8 ! Should not be used ENDIF C C ===================== C BEGIN C Prepare RHS on master C #if defined(V_T) CALL VTBEGIN(perm_scal_ini,IERR) #endif IF (id%MYID .eq. MASTER) THEN C ====================== IF (KEEP(248)==1) THEN C ====================== C C Sparse RHS format ( A-1 or sparse input format) C is provided as input by the user (IRHS_SPARSE ...) C -------------------------------------------------- C Compute NZ_THIS_BLOCK and NBCOL_INBLOC C where C NZ_THIS_BLOCK is defined C as the number of entries in the next NBRHS_EFF C non empty columns (note that since they might be permuted C then the following formula is not always valid: C NZ_THIS_BLOCK=id%IRHS_PTR(BEG_RHS+NBRHS_EFF)- C & id%IRHS_PTR(BEG_RHS) C anyway NBCOL_INBLOC also need be computed so going through C columns one at a time is needed. C NBCOL = 0 NBCOL_INBLOC = 0 NZ_THIS_BLOCK = 0 C With exploit sparsity we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). STOP_AT_NEXT_EMPTY_COL = .FALSE. DO I=JBEG_RHS, id%NRHS NBCOL_INBLOC = NBCOL_INBLOC +1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C PERM_RHS(k) = i means that i is the kth C column to be processed C PERM_RHS should also be defined for C empty columns i in A-1 (PERM_RHS(K) = i) COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) ELSE COLSIZE = id%IRHS_PTR(I+1) - id%IRHS_PTR(I) ENDIF IF ((.NOT.STOP_AT_NEXT_EMPTY_COL).AND.(COLSIZE.GT.0).AND. & (KEEP(237).EQ.0)) THEN C -- set STOP_NEXT_EMPTY_COL only for general C -- sparse case (not AM-1) STOP_AT_NEXT_EMPTY_COL =.TRUE. ENDIF IF (COLSIZE.GT.0 & ) THEN NBCOL = NBCOL+1 NZ_THIS_BLOCK = NZ_THIS_BLOCK + COLSIZE ELSE IF (STOP_AT_NEXT_EMPTY_COL) THEN C We have reached an empty column with already selected non empty C columns: reduce block size to non empty columns reached so far. NBCOL_INBLOC = NBCOL_INBLOC -1 NBRHS_EFF = NBCOL EXIT ENDIF IF (NBCOL.EQ.NBRHS_EFF) EXIT ENDDO IF (NZ_THIS_BLOCK.EQ.0) THEN WRITE(*,*) " Internal Error 16 in sol driver NZ_THIS_BLOCK=", & NZ_THIS_BLOCK CALL MUMPS_ABORT() ENDIF C IF (NBCOL.NE.NBRHS_EFF.AND. (KEEP(237).NE.0) & .AND.KEEP(221).NE.1) THEN C With exploit sparsity for general sparse RHS (Not A-1) C we skip empty rows up to reaching C the first non empty column; then we process a block of C maximum size NBRHS_EFF except if we reach another empty C column. (We are not sure to have a copy allocated C and thus cannot compress on the fly, as done naturally C for A-1). Thus NBCOL might be smaller than NBRHS_EFF WRITE(6,*) ' Internal Error 8 in solution driver ', & NBCOL, NBRHS_EFF call MUMPS_ABORT() ENDIF C ------------------------------------------------------------- C IF (NZ_THIS_BLOCK .NE. 0) THEN C ----------------------------------------------------------- C We recall that C NBCOL_INBLOC is the number of columns of sparse RHS needed C to get NBRHS_EFF non empty columns: ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 30 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 C ----------------------------------------------------------- C Initialize IRHS_PTR_COPY C compute local copy (compressed) of id%IRHS_PTR on Master IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IPOS = IPOS + COLSIZE ENDDO ELSE IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 J = J+1 IRHS_PTR_COPY(J) = IPOS COLSIZE = id%IRHS_PTR(I+1) & - id%IRHS_PTR(I) IPOS = IPOS + COLSIZE ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR IRHS_PTR_COPY(NBCOL_INBLOC+1)= IPOS IF ( IPOS-1 .NE. NZ_THIS_BLOCK ) THEN WRITE(*,*) "Error in compressed copy of IRHS_PTR" IERR = 99 call MUMPS_ABORT() ENDIF C ----------------------------------------------------------- C IRHS_SPARSE : do a copy or point to the original indices C C Check whether IRHS_SPARSE_COPY need be allocated IF (KEEP(23) .NE. 0 .and. MTYPE .NE. 1) THEN C AP = LU and At x = b ==> b need be permuted ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK) & ,stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C Columns are not contiguous and need be copied one by one C IRHS_SPARSE_COPY will hold a copy of contiguous permuted C columns so an explicit copy is needed. C IRHS_SPARSE_COPY is also allways allocated with A-1, C to enable receiving during mumps_gather_solution C . on the master in any order. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN IERR = 99 GOTO 30 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ENDIF C C Initialize IRHS_SPARSE_COPY IF (IRHS_SPARSE_COPY_ALLOCATED) THEN IF ( DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ) THEN IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IRHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ELSE IRHS_SPARSE_COPY = id%IRHS_SPARSE( & id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ELSE IRHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => & id%IRHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ENDIF IF (LSCAL.OR.DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (KEEP(237).NE.0)) THEN C if scaling is on or if columns of the RHS are C permuted then a copy of RHS_SPARSE is needed. C Also always allocated with A-1, c to enable receiving during mumps_gather_solution C on the master in any order. C ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 30 ENDIF RHS_SPARSE_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE IF ( KEEP(248)==1 ) THEN RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(JBEG_RHS): & id%IRHS_PTR(JBEG_RHS)+NZ_THIS_BLOCK-1) ELSE RHS_SPARSE_COPY c * (1:NZ_THIS_BLOCK) & => id%RHS_SPARSE(id%IRHS_PTR(BEG_RHS): & id%IRHS_PTR(BEG_RHS)+NZ_THIS_BLOCK-1) ENDIF ENDIF IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) THEN IF (id%KEEP(237).NE.0) THEN C --initialized to one; it might be C modified if scaling is on (one first entry in each col is scaled) RHS_SPARSE_COPY = ONE ELSE IF (.NOT. LSCAL) THEN C -- Columns are not contiguous and need be copied one by one C -- This need not be done if scaling is on because it C -- will done and scaled later. IPOS = 1 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 COLSIZE = id%IRHS_PTR(PERM_RHS(I)+1) & - id%IRHS_PTR(PERM_RHS(I)) IF (COLSIZE .EQ. 0) CYCLE RHS_SPARSE_COPY(IPOS:IPOS+COLSIZE-1) = & id%RHS_SPARSE(id%IRHS_PTR(PERM_RHS(I)): & id%IRHS_PTR(PERM_RHS(I)+1) -1) IPOS = IPOS + COLSIZE ENDDO ENDIF ENDIF C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * C ========== C SPARSE RHS : permute indices rather than values C ========== C Solve with At X = B should never occur for A-1 IPOS = 1 DO I=1, NBCOL_INBLOC C Note that: (i) IRHS_PTR_COPY is compressed; C (ii) columns might have been permuted COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) DO K = 1, COLSIZE JPERM = UNS_PERM_INV(IRHS_SPARSE_COPY(IPOS+K-1)) IRHS_SPARSE_COPY(IPOS+K-1) = JPERM ENDDO IPOS = IPOS + COLSIZE ENDDO ENDIF ! MTYPE.NE.1 ENDIF ! KEEP(23).NE.0 ENDIF ! NZ_THIS_BLOCK .NE. 0 C ----- ENDIF ! ============ KEEP(248)==1 C ----- ENDIF ! (id%MYID .eq. MASTER) C C ===================== ERROR handling and propagation ================ 30 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C NBCOL_INBLOC depends on loop IF (KEEP(248)==1) THEN CALL MPI_BCAST( NBCOL_INBLOC,1, MPI_INTEGER, & MASTER, id%COMM,IERR) ELSE NBCOL_INBLOC = NBRHS_EFF ENDIF JEND_RHS =JBEG_RHS + NBCOL_INBLOC - 1 IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 ).AND.(KEEP(248).EQ.1) ) THEN C ---------------------------- C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- CALL MPI_BCAST( NZ_THIS_BLOCK,1, MPI_INTEGER, & MASTER, id%COMM,IERR) IF (id%MYID.NE.MASTER .and. NZ_THIS_BLOCK.NE.0) THEN ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif IRHS_SPARSE_COPY_ALLOCATED=.TRUE. C RHS_SPARSE_COPY is broadcasted C for A-1 even if on the slaves the initialisation of the RHS C could be only based on the pattern. Doing so we C broadcast the scaled version of the RHS (scaling arrays C that are not available on slaves). ALLOCATE(RHS_SPARSE_COPY(NZ_THIS_BLOCK), & stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 45 endif RHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + int(NZ_THIS_BLOCK,8)*(K34_8+K35_8) NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) C ALLOCATE(IRHS_PTR_COPY(NBCOL_INBLOC+1),stat=allocok) if (allocok .GT.0 ) then INFO(1)=-13 INFO(2)=NBCOL_INBLOC+1 GOTO 45 endif IRHS_PTR_COPY_ALLOCATED = .TRUE. NB_BYTES = NB_BYTES + int(NBCOL_INBLOC+1,8)*K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF C C ===================== ERROR handling and propagation ================ 45 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NBCOL_INBLOC+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) IF (IERR.GT.0) THEN WRITE (*,*)'NOT OK FOR ALLOC PTR ON SLAVES' call MUMPS_ABORT() ENDIF ENDIF ENDIF C C ========================================================= C INITIALIZE POSINRHSCOMP_ROW/COL, RHSCOMP and related data C For distributed RHS, initialize RHSMAPINFO (at 1st block) C ========================================================= IF ( I_AM_SLAVE ) THEN C -------------------------------------------------- C If I am involved in the solve and if C either C no null space comput (keep(111)=0) and sparse rhs C or C null space computation C then C compute POSINRHSCOMP C endif C C Fwd in facto: in this case only POSINRHSCOMP need be computed C C (POSINRHSCOMP_ROW/COL indirection arrays should C have been allocated once outside loop) C Compute size of RHSCOMP since it might depend C on the process index and of the sparsity of the RHS C if it is exploited. C Initialize POSINRHSCOMP_ROW/COL C C Note that LD_RHSCOMP and id%KEEP8(25) C are not set on the host in this routine in C the case of a non-working host. C Note that POSINRHSCOMP is now always computed in SOL_DRIVER C at least during the first block of RHS when sparsity of RHS C is not exploited. C ------------------------------- C INITTIALZE POSINRHSCOMP_ROW/COL C ------------------------------- C IF ( KEEP(221).EQ.2 .AND. KEEP(252).EQ.0 & .AND. (KEEP(248).NE.1 .OR. (id%NRHS.EQ.1)) & ) THEN C Reduced RHS was already computed during C a previous forward step AND is valid. C By valid we mean: C -no forward in facto (KEEP(252)==0) during which C POSINRHSCOMP was not computed C AND C -no exploit sparsity with multiple RHS C because in this case POSINRHSCOMP would C be valid only for the last block processed during fwd. C In those cases since we only perform the backward step, we do not C need to compute POSINRHSCOMP BUILD_POSINRHSCOMP = .FALSE. ENDIF C ------------------------ C INITIALIZE POSINRHSCOMP C ------------------------ IF (BUILD_POSINRHSCOMP) THEN C -- we first set MTYPE_LOC and C -- reset BUILD_POSINRHSCOMP for next iteration in loop C C general case only POSINRHSCOMP is computed BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks MTYPE_LOC = MTYPE C IF ( (KEEP(111).NE.0) .OR. (KEEP(237).NE.0) .OR. & (KEEP(252).NE.0) ) THEN C IF (KEEP(111).NE.0) THEN C -- in the context of null space, we need to C -- build RHSCOMP to skip SOL_R. Therefore C -- we need to know for each concerned C -- row index its position in C -- RHSCOMP C We use row indices, as these are the ones that C were used to detect zero pivots during factorization. C POSINRHSCOMP_ROW will allow to find the (row) index of a C zero in RHSCOMP before calling CMUMPS_SOL_S. Then C CMUMPS_SOL_S uses column indices to build the solution C (corresponding to null space vectors) MTYPE_LOC = 1 ELSE IF (KEEP(252).NE.0) THEN C -- Fwd in facto: since fwd is skipped we need to build POSINRHSCOMP MTYPE_LOC = 1 ! (no transpose) C BUILD_POSINRHSCOMP = .FALSE. ! POSINRHSCOMP does not change between blocks ELSE C -- A-1 only MTYPE_LOC = MTYPE BUILD_POSINRHSCOMP = .TRUE. ENDIF ENDIF C -- compute POSINRHSCOMP LIW_PASSED=max(1,LIW) IF (KEEP(237).EQ.0) THEN CALL CMUMPS_BUILD_POSINRHSCOMP( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW_PASSED, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & NBENT_RHSCOMP, NB_FS_RHSCOMP_TOT ) NB_FS_RHSCOMP_F = NB_FS_RHSCOMP_TOT ELSE CALL CMUMPS_BUILD_POSINRHSCOMP_AM1( & id%NSLAVES,id%N, & id%MYID_NODES, id%PTLUST_S(1), id%DAD_STEPS(1), & id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), id%IS(1), LIW, & id%STEP(1), & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & id%POSINRHSCOMP_COL_ALLOC, & MTYPE_LOC, & IRHS_PTR_COPY(1), NBCOL_INBLOC, IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK,PERM_RHS, size(PERM_RHS) , JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_RHSCOMP_F, NB_FS_RHSCOMP_TOT, & UNS_PERM_INV, size(UNS_PERM_INV) ! size 1 if not used & ) ENDIF ENDIF ! BUILD_POSINRHSCOMP=.TRUE. IF (BUILD_RHSMAPINFO .AND. KEEP(248).EQ.-1) THEN C C Prepare symbolic data for sends. C For the moment: MAP_RHS_loc C CALL MUMPS_SOL_RHSMAPINFO( id%N, id%Nloc_RHS, id%KEEP(89), & IRHS_loc_PTR(1), MAP_RHS_loc, id%POSINRHSCOMP_ROW(1), & id%NSLAVES, id%MYID_NODES, & id%COMM_NODES, id%ICNTL(1), id%INFO(1) ) BUILD_RHSMAPINFO = .FALSE. C MUMPS_SOL_RHSMAPINFO does not propagate errors ENDIF ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 IF (I_AM_SLAVE) THEN IF (KEEP(221).EQ.1) THEN C we need to save the reduced RHS for all RHS to perform C later the backward phase with an updated reduced RHS C thus we allocate NRHS_NONEMPTY columns in one shot. C Note that RHSCOMP might have been allocated in previous block C and RHSCOMP has been deallocated previous to entering loop on RHS IF (.not. associated(id%RHSCOMP)) THEN C So far we cannot combine this to exploit sparsity C so that NBENT_RHSCOMP will not change in the loop C and can be used to dimension RHSCOMP C Furthermore, during bwd phase the REDRHS provided C by the user might also have a different non empty C column pattern than the sparse RHS provided on input to C this phase: thus we need to allocate id%NRHS columns too. LD_RHSCOMP = max(NBENT_RHSCOMP,1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(id%NRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) id%KEEP8(25)=0_8 GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF ((KEEP(221).NE.1).AND. & ((KEEP(221).NE.2).OR.(KEEP(252).NE.0)) & ) THEN C ------------------ C Allocate RHSCOMP (case of RHSCOMP allocated at each block of RHS) C ------------------ C RHSCOMP allocated per block of maximum size NBRHS LD_RHSCOMP = max(NBENT_RHSCOMP, LD_RHSCOMP) C NBRHS_EFF could be used instead on NBRHS IF (associated(id%RHSCOMP)) THEN IF ( (id%KEEP8(25).LT.int(LD_RHSCOMP,8)*int(NBRHS,8)) & .OR. (KEEP(235).NE.0).OR.(KEEP(237).NE.0) ) THEN ! deallocate and reallocate if: ! _larger array needed ! OR ! _exploit sparsity/A-1: since size of RHSCOMP ! is expected to vary much in these cases ! this should improve locality NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF ENDIF IF (.not. associated(id%RHSCOMP)) THEN LD_RHSCOMP = max(NBENT_RHSCOMP, 1) id%KEEP8(25) = int(LD_RHSCOMP,8)*int(NBRHS,8) ALLOCATE (id%RHSCOMP(id%KEEP8(25)), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(25),INFO(2)) GOTO 41 END IF NB_BYTES = NB_BYTES + id%KEEP8(25)*K35_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF IF (KEEP(221).EQ.2) THEN C RHSCOMP has been allocated (call with KEEP(221).EQ.1) C even in the case fwd in facto ! Not correct: LD_RHSCOMP = LENRHSCOMP/id%NRHS_NONEMPTY LD_RHSCOMP = int(id%KEEP8(25)/int(id%NRHS,8)) ENDIF C C Shift on RHSCOMP C IF ( KEEP(221).EQ.0 ) THEN C -- RHSCOMP reused in the loop IBEG_RHSCOMP= 1_8 ELSE C Initialize IBEG_RHSCOMP C IBEG_RHSCOMP= int(JBEG_RHS-1,8)*int(LD_RHSCOMP,8) + 1_8 ENDIF ENDIF ! I_AM_SLAVE C ===================== ERROR handling and propagation ================ 41 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== C C --------------------------- C Prepare RHS on master (case C of dense and sparse RHS) C --------------------------- IF (id%MYID .eq. MASTER) THEN C ========================= IF (KEEP(23) .NE. 0) THEN C ========================= * maximum transversal was performed IF (MTYPE .NE. 1) THEN * At x = b is asked while * we have AP = LU where P is the column permutation * due to max trans. * Therefore we need to modify rhs: * b' = P-1 b (P-1=Pt) * Apply column permutation to the right hand side RHS * Column J of the permuted matrix corresponds to * column PERMW(J) of the original matrix. * IF (KEEP(248)==0) THEN C ========= C DENSE RHS : permute values in RHS C ========= ALLOCATE( C_RW2( id%N ),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Error allocating C_RW2 in CMUMPS_SOLVE_DRIVE' END IF GOTO 30 END IF C We directly permute in id%RHS. DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N C_RW2(I)=id%RHS(I-1+KDEC) END DO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS(I-1+KDEC) = C_RW2(JPERM) END DO END DO DEALLOCATE(C_RW2) ENDIF ENDIF ENDIF C IF (POSTPros) THEN IF ( KEEP(248) == 0 ) THEN DO K = 1, NBRHS_EFF KDEC = IBEG+int(K-1,8)*int(LD_RHS,8) DO I = 1, id%N SAVERHS(I+(K-1)*id%N) = id%RHS(KDEC+I-1) END DO ENDDO ELSE IF (KEEP(248)==1) THEN SAVERHS(:) = ZERO DO K = 1, NBRHS DO J = id%IRHS_PTR(K), id%IRHS_PTR(K+1)-1 I = id%IRHS_SPARSE(J) SAVERHS(I+(K-1)*id%N) = id%RHS_SPARSE(J) ENDDO ENDDO ENDIF ENDIF C C RHS is set to scaled right hand side C IF (LSCAL) THEN C scaling was performed IF (KEEP(248)==0) THEN C dense RHS IF (MTYPE .EQ. 1) THEN C we solve Ax=b, use ROWSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%ROWSCA(I) ENDDO ENDDO ELSE C we solve Atx=b, use COLSCA to scale the RHS DO K =1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHS,8) + int(IBEG-1,8) DO I = 1, id%N id%RHS(KDEC+I) = id%RHS(KDEC+I) * & id%COLSCA(I) ENDDO ENDDO ENDIF ELSE IF (KEEP(248)==1) THEN C ------------------------- C KEEP(248)==1 (and MASTER) C ------------------------- KDEC=int(id%IRHS_PTR(JBEG_RHS),8) C Compute IF ((KEEP(248)==1) .AND. & (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR.OR. & (id%KEEP(237).NE.0)) & ) THEN C -- copy from RHS_SPARSE need be done per C column following PERM_RHS C Columns are not contiguous and need be copied one by one IPOS = 1 J = 0 DO I=JBEG_RHS, JBEG_RHS + NBCOL_INBLOC -1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN IPERM = PERM_RHS(I) ENDIF J = J+1 C Note that we work here on compressed IRHS_PTR_COPY COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) C -- skip empty column IF (COLSIZE .EQ. 0) CYCLE IF (id%KEEP(237).NE.0) THEN IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN C if A-1 only, then, for each non empty target C column PERM_RHS(I), scale in first position C in column the diagonal entry C build the scaled rhs ej on each slave. RHS_SPARSE_COPY(IPOS) = id%ROWSCA(IPERM) * & ONE ELSE RHS_SPARSE_COPY(IPOS) = id%ROWSCA(I) * ONE ENDIF ELSE C Loop over nonzeros in column DO K = 1, COLSIZE C Formula for II below is ok, except in case C of maximum transversal (KEEP(23).NE.0) and C transpose system (MTYPE .NE. 1): C II = id%IRHS_SPARSE(id%IRHS_PTR(PERM_RHS(I))+K-1) C In case of maximum transversal + transpose, one C should then apply II=UNS_PERM_INV(II) after the C above definition of II. C C Instead, we rely on IRHS_SPARSE_COPY, whose row C indices have already been permuted in case of C maximum transversal. II = IRHS_SPARSE_COPY( & IRHS_PTR_COPY(I-JBEG_RHS+1) & +K-1) C PERM_RHS(I) corresponds to column in original RHS. C Original IRHS_PTR must be used to access id%RHS_SPARSE IF (MTYPE.EQ.1) THEN RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%ROWSCA(II) ELSE RHS_SPARSE_COPY(IPOS+K-1) = & id%RHS_SPARSE(id%IRHS_PTR(IPERM)+K-1)* & id%COLSCA(II) ENDIF ENDDO ENDIF IPOS = IPOS + COLSIZE ENDDO ELSE ! general sparse RHS ! without permutation IF (MTYPE .eq. 1) THEN DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%ROWSCA(I) ENDDO ELSE DO IZ=1,NZ_THIS_BLOCK I=IRHS_SPARSE_COPY(IZ) RHS_SPARSE_COPY(IZ)=id%RHS_SPARSE(KDEC+IZ-1)* & id%COLSCA(I) ENDDO ENDIF ENDIF ENDIF ! KEEP(248)==1 ENDIF ! LSCAL ENDIF ! id%MYID.EQ.MASTER #if defined(V_T) CALL VTEND(perm_scal_ini,IERR) #endif C C Prepare RHS on master C END C ===================== IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! modifed version of ! NBRHS_EFF need be broadcasted since it is used ! to update BEG_RHS at the end of the DO WHILE CALL MPI_BCAST( NBRHS_EFF,1, MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(NB_RHSSKIPPED,1,MPI_INTEGER,MASTER, & id%COMM,IERR) ENDIF C ----------------------------------- C Two main cases depending on option C for null space computation: C C KEEP(111)=0 : use RHS from user C (sparse or dense) C KEEP(111)!=0: build an RHS on each C proc for null space C computations C ----------------------------------- #if defined(V_T) CALL VTBEGIN(soln_dist,IERR) #endif TIMESCATTER1=MPI_WTIME() IF ((KEEP(111).eq.0).AND.(KEEP(252).EQ.0) & .AND.(KEEP(221).NE.2 )) THEN C ------------------------ C Use RHS provided by user C when not null space and not Fwd in facto C ------------------------ IF (KEEP(248) == 0) THEN C ---------------------------- C -- DENSE RIGHT-HAND-SIDE C ---------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, id%RHS(IBEG), LD_RHS, NBRHS_EFF, & NBRHS_EFF, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (id%MYID .eq. MASTER) THEN PTR_RHS => id%RHS LD_RHS_loc = LD_RHS NCOL_RHS_loc = NBRHS_EFF IBEG_loc = IBEG ELSE PTR_RHS => CDUMMY_TARGET LD_RHS_loc = 1 NCOL_RHS_loc = 1 IBEG_loc = 1_8 ENDIF LIW_PASSED = max( LIW, 1 ) CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & MTYPE, PTR_RHS(IBEG_loc),LD_RHS_loc,NCOL_RHS_loc, & NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 90 ELSE IF (KEEP(248) .EQ. -1) THEN IF (I_AM_SLAVE) THEN IF (id%Nloc_RHS .NE. 0) THEN RHS_loc_size=int(id%LRHS_loc,8)*int(NBRHS_EFF-1,8)+ & int(id%Nloc_RHS,8) RHS_loc_shift=1_8+int(BEG_RHS-1,8)*id%LRHS_loc ELSE RHS_loc_size=1_8 RHS_loc_shift=1_8 ENDIF CALL CMUMPS_SCATTER_DIST_RHS(id%NSLAVES, id%N, & id%MYID_NODES, id%COMM_NODES, & NBRHS_EFF, id%Nloc_RHS, id%LRHS_loc, & MAP_RHS_loc, & IRHS_loc_PTR(1), & idRHS_loc(RHS_loc_shift), & RHS_loc_size, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), NB_FS_RHSCOMP_F, & LSCAL, scaling_data_dr, & LP, LPOK, KEEP(1), NB_BYTES_LOC, INFO(1)) C NB_BYTES_LOC were allocated and freed above NB_BYTES_MAX = max(NB_BYTES_MAX, & NB_BYTES_MAX+NB_BYTES_LOC) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1).LT.0) GOTO 90 ELSE C === KEEP(248)==1 ========= C -- SPARSE RIGHT-HAND-SIDE C ---------------------------- IF (NZ_THIS_BLOCK > 0) THEN CALL MPI_BCAST(RHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_COMPLEX, & MASTER, id%COMM, IERR) ENDIF C -- At this point each process has a copy of the C -- sparse RHS. We need to store it into RHSCOMP. C IF (KEEP(237).NE.0) THEN IF ( I_AM_SLAVE ) THEN C ----- C case of A-1 C ----- C - Take columns with non-zero entry, say j, C - to build Ej and store it in RHSCOMP K=1 ! Column index in RHSCOMP id%RHSCOMP(1_8:int(NBRHS_EFF,8)*int(LD_RHSCOMP,8)) & = ZERO IPOS = 1 DO I = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(I+1) - IRHS_PTR_COPY(I) IF (COLSIZE.GT.0) THEN ! Find global column index J and set ! column K of RHSCOMP to ej (here IBEG is one) J = I - 1 + JBEG_RHS IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN J = PERM_RHS(J) ENDIF IPOSRHSCOMP = id%POSINRHSCOMP_ROW(J) C IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_F) C & .AND.(IPOSRHSCOMP.GT.0) ) THEN IF (IPOSRHSCOMP.GT.0) THEN C Columns J corresponds to ej and thus to variable j C that is on my proc C Note that : C In first entry in column C we have and MUST have already scaled value of diagonal. C This need have been done on master because we do not C have scaling arrays available on slaves. C Furthermore we know that only one entry is C needed the diagonal entry (for the forward with A-1). C id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8)+ & int(IPOSRHSCOMP,8)) = & RHS_SPARSE_COPY(IPOS) ENDIF ! End of J on my proc K = K + 1 IPOS = IPOS + COLSIZE ! go to next column ENDIF ENDDO IF (K.NE.NBRHS_EFF+1) THEN WRITE(6,*) 'Internal Error 9 in solution driver ', & K,NBRHS_EFF call MUMPS_ABORT() ENDIF ENDIF ! I_AM_SLAVE C ------- c END A-1 C ------- ELSE C -------------- C General sparse C -------------- C -- reset to zero RHSCOMP for skipped columns (if any) IF ((KEEP(221).EQ.1).AND.(NB_RHSSKIPPED.GT.0) & .AND.I_AM_SLAVE) THEN DO K = JBEG_RHS-NB_RHSSKIPPED, JBEG_RHS-1 DO I = 1, LD_RHSCOMP id%RHSCOMP(int(K-1,8)*int(LD_RHSCOMP,8) & + int(I,8)) = ZERO ENDDO ENDDO ENDIF IF (I_AM_SLAVE) THEN DO K = 1, NBCOL_INBLOC ! it is equal to NBRHS_EFF in this case KDEC = int(K-1,8) * int(LD_RHSCOMP,8) + & IBEG_RHSCOMP - 1_8 id%RHSCOMP(KDEC+1_8:KDEC+NBENT_RHSCOMP) = ZERO DO IZ=IRHS_PTR_COPY(K), IRHS_PTR_COPY(K+1)-1 I=IRHS_SPARSE_COPY(IZ) IPOSRHSCOMP = id%POSINRHSCOMP_ROW(I) C Since all fully summed variables mapped C on each proc are stored at the beginning C of RHSCOMP, we can compare to KEEP(89) C to know if RHSCOMP should be initialized C So far the tree has not been pruned to exploit C sparsity to compress RHSCOMP so we compare to C NB_FS_RHSCOMP_TOT IF ( (IPOSRHSCOMP.LE.NB_FS_RHSCOMP_TOT) & .AND.(IPOSRHSCOMP.GT.0) ) THEN C ! I is fully summed var mapped on my proc id%RHSCOMP(KDEC+IPOSRHSCOMP)= & id%RHSCOMP(KDEC+IPOSRHSCOMP) + & RHS_SPARSE_COPY(IZ) ENDIF ENDDO ENDDO END IF ! I_AM_SLAVE ENDIF ! KEEP(237) ENDIF ! ==== KEEP(248)==1 ===== C ELSE IF (I_AM_SLAVE) THEN ! I_AM_SLAVE AND (null space or Fwd in facto) IF (KEEP(111).NE.0) THEN C ----------------------- C Null space computations C ----------------------- C C We are working on columns BEG_RHS:BEG_RHS+NBRHS_EFF-1 C of RHS. C Columns in 1..KEEP(112): C Put a one in corresponding C position of the right-hand-side, C and zeros in other places. C Columns in KEEP(112)+1: KEEP(112)+KEEP(17): C root node => set C 0 everywhere and compute the local range C corresponding to IBEG/IEND in root C that will be passed to CMUMPS_SEQ_SOLVE_ROOT_RR C Also keep track of which part of C CMUMPS_RHS must be passed to C CMUMPS_SEQ_SOLVE_ROOT_RR. C IF (KEEP(111).GT.0) THEN IBEG_GLOB_DEF = KEEP(111) IEND_GLOB_DEF = KEEP(111) ELSE IBEG_GLOB_DEF = BEG_RHS IEND_GLOB_DEF = BEG_RHS+NBRHS_EFF-1 ENDIF IF ( id%KEEP(112) .GT. 0 .AND. DO_NULL_PIV) THEN IF (IBEG_GLOB_DEF .GT.id%KEEP(112)) THEN id%KEEP(235) = 0 DO_NULL_PIV = .FALSE. ENDIF IF (IBEG_GLOB_DEF .LT.id%KEEP(112) & .AND. IEND_GLOB_DEF .GT.id%KEEP(112) & .AND. DO_NULL_PIV ) THEN C IEND_GLOB_DEF = id%KEEP(112) C forcing exploit sparsity C - cannot be done at this point C - and is not what the user would have expected the C code to to do anyway !!!! C suppress: id%KEEP(235) = 1 ! End Block of sparsity ON DO_NULL_PIV = .FALSE. ENDIF ENDIF IF (id%KEEP(235).NE.0) THEN C Exploit Sparsity in null space computations C We build /allocate the sparse RHS on MASTER C based on pivnul_list. Then we broadcast it C on the slaves C In this case we have ONLY ONE ENTRY per RHS C NZ_THIS_BLOCK=IEND_GLOB_DEF-IBEG_GLOB_DEF+1 ALLOCATE(IRHS_PTR_COPY(NZ_THIS_BLOCK+1),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_PTR_COPY_ALLOCATED = .TRUE. ALLOCATE(IRHS_SPARSE_COPY(NZ_THIS_BLOCK),stat=allocok) IF (allocok .GT.0 ) THEN INFO(1)=-13 INFO(2)=NZ_THIS_BLOCK GOTO 50 ENDIF IRHS_SPARSE_COPY_ALLOCATED=.TRUE. NB_BYTES = NB_BYTES + & int(NZ_THIS_BLOCK,8)*(K34_8+K34_8) & + K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) IF (id%MYID.eq.MASTER) THEN ! compute IRHS_PTR and IRHS_SPARSE_COPY II = 1 DO I = IBEG_GLOB_DEF, IEND_GLOB_DEF IRHS_PTR_COPY(I-IBEG_GLOB_DEF+1) = I IRHS_SPARSE_COPY(II) = id%PIVNUL_LIST(I) II = II +1 ENDDO IRHS_PTR_COPY(NZ_THIS_BLOCK+1) = NZ_THIS_BLOCK+1 ENDIF C C ===================== ERROR handling and propagation ================ 50 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF (INFO(1) .LT.0 ) GOTO 90 C ====================================================================== CALL MPI_BCAST(IRHS_SPARSE_COPY(1), & NZ_THIS_BLOCK, & MPI_INTEGER, & MASTER, id%COMM,IERR) CALL MPI_BCAST(IRHS_PTR_COPY(1), & NZ_THIS_BLOCK+1, & MPI_INTEGER, & MASTER, id%COMM,IERR) C End IF Exploit Sparsity ENDIF c C Initialize RHSCOMP to 0 ! to be suppressed DO K=1, NBRHS_EFF KDEC = int(K-1,8) * int(LD_RHSCOMP,8) id%RHSCOMP(KDEC+1_8:KDEC+int(LD_RHSCOMP,8))=ZERO END DO C Loop over the columns. C Note that if ( KEEP(220)+KEEP(109)-1 < IBEG_GLOB_DEF C .OR. KEEP(220) > IEND_GLOB_DEF ) then we do not enter C the loop. C Note that local processor has indices C KEEP(220):KEEP(220)+KEEP(109)-1 C C Computation of null space and computation of backward C step incompatible, do one or the other. DO I=max(IBEG_GLOB_DEF,KEEP(220)), & min(IEND_GLOB_DEF,KEEP(220)+KEEP(109)-1) C Local processor is concerned by I-th column of C global right-hand side. JJ= id%POSINRHSCOMP_ROW(id%PIVNUL_LIST(I-KEEP(220)+1)) IF (JJ.GT.0) THEN IF (KEEP(50).EQ.0) THEN ! unsymmetric : always set to fixation id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8) + & int(JJ-1,8) ) = & cmplx(id%DKEEP(2),kind=kind(id%RHSCOMP)) ELSE ! Symmetric: always set to one id%RHSCOMP( IBEG_RHSCOMP+ & int(I-IBEG_GLOB_DEF,8)*int(LD_RHSCOMP,8)+ & int(JJ-1,8) )= & ONE ENDIF ENDIF ENDDO IF ( KEEP(17).NE.0 .AND. & id%MYID_NODES.EQ.MASTER_ROOT) THEN C --------------------------- C Deficiency of the root node C Find range relative to root C --------------------------- C Among IBEG_GLOB_DEF:IEND_GLOB_DEF, find C intersection with KEEP(112)+1:KEEP(112)+KEEP(17) IBEG_ROOT_DEF = max(IBEG_GLOB_DEF,KEEP(112)+1) IEND_ROOT_DEF = min(IEND_GLOB_DEF,KEEP(112)+KEEP(17)) C First column of right-hand side that must C be passed to CMUMPS_SEQ_SOLVE_ROOT_RR is: IROOT_DEF_RHS_COL1 = IBEG_ROOT_DEF-IBEG_GLOB_DEF + 1 C We look for indices relatively to the root node, C substract number of null pivots outside root node IBEG_ROOT_DEF = IBEG_ROOT_DEF-KEEP(112) IEND_ROOT_DEF = IEND_ROOT_DEF-KEEP(112) C Note that if IBEG_ROOT_DEF > IEND_ROOT_DEF, then this C means that nothing must be done on the root node C for this set of right-hand sides. ELSE IBEG_ROOT_DEF = -90999 IEND_ROOT_DEF = -95999 IROOT_DEF_RHS_COL1= 1 ENDIF ELSE ! End of null space (test on KEEP(111)) C case of Fwd in facto C id%RHSCOMP need not be initialized. It will be set on the fly C to zero for normal fully summed variables of the fronts and C to -1 on the roots for the id%N+KEEP(253) variables added C to the roots. ENDIF ! End of null space (test on KEEP(111)) ENDIF ! I am slave TIMESCATTER2=MPI_WTIME()-TIMESCATTER1+TIMESCATTER2 C ------------------------------------------- C Reserve space at the end of WORK_WCB on the C master of the root node. It will be used to C store the reduced RHS. C ------------------------------------------- IF ( I_AM_SLAVE ) THEN LWCB8_SOL_C = LWCB8 IF ( id%MYID_NODES .EQ. MASTER_ROOT ) THEN C This is a special root (otherwise MASTER_ROOT < 0) IF ( associated(id%root%RHS_CNTR_MASTER_ROOT) ) THEN C RHS_CNTR_MASTER_ROOT may have been allocated C during the factorization phase. PTR_RHS_ROOT => id%root%RHS_CNTR_MASTER_ROOT # if defined(MUMPS_F2003) LPTR_RHS_ROOT = size(id%root%RHS_CNTR_MASTER_ROOT,kind=8) # else LPTR_RHS_ROOT = int(size(id%root%RHS_CNTR_MASTER_ROOT),8) # endif ELSE C Otherwise, we use workspace in WCB LPTR_RHS_ROOT = int(NBRHS_EFF,8) * int(SIZE_ROOT,8) IPT_RHS_ROOT = LWCB8 - LPTR_RHS_ROOT + 1_8 PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ELSE LPTR_RHS_ROOT = 1_8 IPT_RHS_ROOT = LWCB8 ! Will be passed, but not accessed PTR_RHS_ROOT => WORK_WCB(IPT_RHS_ROOT:LWCB8) LWCB8_SOL_C = LWCB8_SOL_C - LPTR_RHS_ROOT ENDIF ENDIF IF (KEEP(221) .EQ. 2 ) THEN C Copy/send REDRHS in PTR_RHS_ROOT C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT). C REDRHS was provided on the host IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- Same proc : copy is possible: II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8)-1_8 DO I = 1, SIZE_ROOT PTR_RHS_ROOT(II+I) = id%REDRHS(KDEC+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- send REDRHS IF ( id%MYID .EQ. MASTER) THEN C -- send to MASTER_ROOT_IN_COMM using COMM communicator C assert: id%KEEP(116).EQ.SIZE_ROOT IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One send KDEC = IBEG_REDRHS CALL MPI_SEND(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ELSE C -- NBRHS_EFF sends DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_SEND(id%REDRHS(KDEC),SIZE_ROOT, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- receive from MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- receive all in on shot CALL MPI_RECV(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_RECV(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_COMPLEX, & MASTER, 0, id%COMM,STATUS,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF TIMEC1=MPI_WTIME() IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) C IF ((id%KEEP(235).EQ.0).and.(id%KEEP(237).EQ.0) ) THEN C C --- Normal case : we do not exploit sparsity of the RHS C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) PRUNED_SIZE_LOADED = 0_8 ! From CMUMPS_SOL_ES module CALL CMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, IS(1), & LIW_PASSED, WORK_WCB(1), LWCB8_SOL_C, IWCB, LIWCB, NBRHS_EFF, & id%NA(1),id%LNA,id%NE_STEPS(1), SRW3, MTYPE, ICNTL(1), FROM_PP, & id%STEP(1), id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), & id%PTLUST_S(1), id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, & LIWK_PTRACB, id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1),KEEP(1), & KEEP8(1), id%DKEEP(1), id%COMM_NODES, id%MYID, id%MYID_NODES, & BUFR(1), LBUFR, LBUFR_BYTES, id%ISTEP_TO_INIV2(1), & id%TAB_POS_IN_PERE(1,1), IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), LPTR_RHS_ROOT, SIZE_ROOT, & MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1) & , 1, 1, 1, 1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY & , 1, 1, NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) ELSE C Exploit sparsity of the RHS (all cases) C Remark that JBEG_RHS is already initialized C FROM_PP = .FALSE. NBSPARSE_LOC = (DO_NBSPARSE.AND.NBRHS_EFF.GT.1) CALL CMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED,IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,MTYPE,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1), id%DAD_STEPS(1), id%FILS(1), id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE, LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1),id%NSLAVES,INFO(1),KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR(1),LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1,PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP, id%POSINRHSCOMP_ROW(1), id%POSINRHSCOMP_COL(1), & NZ_THIS_BLOCK, NBCOL_INBLOC, id%NRHS, JBEG_RHS, id%Step2node(1), & id%KEEP(28),IRHS_SPARSE_COPY(1),IRHS_PTR_COPY(1), size(PERM_RHS), & PERM_RHS, size(UNS_PERM_INV), UNS_PERM_INV, NB_FS_RHSCOMP_F, & NB_FS_RHSCOMP_TOT,NBSPARSE_LOC,PTR_RHS_BOUNDS(1),LPTR_RHS_BOUNDS & ) ENDIF ! end of exploit sparsity (pruning nodes of the tree) END IF C ----------------- C End of slave code C ----------------- C C C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) TIMEC2=MPI_WTIME()-TIMEC1+TIMEC2 C C Change error code. IF (INFO(1).eq.-2) then INFO(1)=-11 IF (LPOK) & write(LP,*) & ' WARNING : -11 error code obtained in solve' END IF IF (INFO(1).eq.-3) then INFO(1)=-14 IF (LPOK) & write(LP,*) & ' WARNING : -14 error code obtained in solve' END IF C C Return in case of error. IF (INFO(1).LT.0) GO TO 90 C C ====================================================== C ONLY FORWARD was performed (case of reduced RHS with Schur C option during factorisation) C ====================================================== IF ( KEEP(221) .EQ. 1 ) THEN ! === Begin OF REDUCED RHS ====== C -------------------------------------- C Send (or copy) reduced RHS from PTR_RHS_ROOT located on C MASTER_ROOT_IN_COMM to REDRHS located on MASTER (host node). C (column by column if leading dimension LD_REDRHS C of REDRHS is not equal to SIZE_ROOT) C -------------------------------------- IF ( ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) .AND. & ( id%MYID .EQ. MASTER ) ) THEN C -- same proc --> copy II = 0 DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) - 1_8 DO I = 1, SIZE_ROOT id%REDRHS(KDEC+I) = PTR_RHS_ROOT(II+I) ENDDO II = II+SIZE_ROOT ENDDO ELSE C -- recv in REDRHS IF ( id%MYID .EQ. MASTER ) THEN C -- recv from MASTER_ROOT_IN_COMM IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- One message to receive KDEC = IBEG_REDRHS CALL MPI_RECV(id%REDRHS(KDEC), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ELSE C -- NBRHS_EFF receives DO K=1, NBRHS_EFF KDEC = IBEG_REDRHS+int(K-1,8)*int(LD_REDRHS,8) CALL MPI_RECV(id%REDRHS(KDEC),SIZE_ROOT, & MPI_COMPLEX, & MASTER_ROOT_IN_COMM, 0, id%COMM, & STATUS,IERR) ENDDO ENDIF ELSE IF ( id%MYID .EQ. MASTER_ROOT_IN_COMM ) THEN C -- send to MASTER II = 1 IF (LD_REDRHS.EQ.SIZE_ROOT) THEN C -- send all in on shot CALL MPI_SEND(PTR_RHS_ROOT(II), & SIZE_ROOT*NBRHS_EFF, & MPI_COMPLEX, & MASTER, 0, id%COMM,IERR) ELSE DO K=1, NBRHS_EFF CALL MPI_SEND(PTR_RHS_ROOT(II),SIZE_ROOT, & MPI_COMPLEX, & MASTER, 0, id%COMM,IERR) II = II + SIZE_ROOT ENDDO ENDIF ENDIF C -- other procs are not concerned ENDIF ENDIF ! ====== END OF REDUCED RHS (Fwd only performed) ====== C ======================================================= C BACKWARD was PERFORMED C Postprocess solution that is distributed IF ( KEEP(221) .NE. 1 ) THEN ! BACKWARD was PERFORMED C -- KEEP(221).NE.1 => we are sure that backward has been performed IF (ICNTL21 == 0) THEN ! CENTRALIZED SOLUTION C ======================================================== C GATHER SOLUTION computed during bwd C Each proc holds the pieces of solution corresponding C to all fully summed variables mapped on that processor C (i.e. corresponding to master nodes mapped on that proc) C In case of A-1 we gather directly in RHS_SPARSE C the distributed solution. C Scaling is done in all case on the fly of the reception C Note that when only FORWARD has been performed C RSH_MUMPS holds the solution computed during forward step C (CMUMPS_SOL_R) C there is no need to copy back in RSH_MUMPS the solution C ======================================================== C centralized solution IF (KEEP(237).EQ.0) THEN C CWORK not needed for AM1 LCWORK = max(max(KEEP(247),KEEP(246)),1) ALLOCATE( CWORK(LCWORK), stat=allocok ) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & .AND. (id%NSLAVES.NE.1)) THEN C Precompute map of indices in current column C (no need to reset it between columns ALLOCATE (MAP_RHS(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) ' Problem allocation of MAP_RHS at solve' ENDIF INFO(1) = -13 INFO(2) = id%N ELSE NB_BYTES = NB_BYTES + int(id%N,8) * K34_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF ENDIF C Propagate errors CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C Return in case of error. IF (INFO(1).LT.0) GO TO 90 IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (MTYPE.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) TIMEGATHER1=MPI_WTIME() IF ( .NOT.I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. IF (KEEP(237).EQ.0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution. CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & MTYPE, id%RHS(1), LD_RHS, id%NRHS, JBEG_RHS, & JDUMMY, id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & C_DUMMY, 1 , 1, IDUMMY, 1, & PERM_RHS, size(PERM_RHS) ! for sparse permuted RHS & ) ELSE C only gather target entries of A-1 CALL CMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & C_DUMMY, 1, 1, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & ,IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & IDUMMY, 1, 0 & ) ENDIF ELSE C Avoid temporary copy (IS(1)) that some old C compilers would do otherwise IF (KEEP(237).EQ.0) THEN IF (id%MYID.EQ.MASTER) THEN PTR_RHS => id%RHS NCOL_RHS_loc = id%NRHS LD_RHS_loc = LD_RHS JBEG_RHS_loc = JBEG_RHS ELSE PTR_RHS => CDUMMY_TARGET NCOL_RHS_loc = 1 LD_RHS_loc = 1 JBEG_RHS_loc = 1 ENDIF CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, MTYPE, & PTR_RHS(1), LD_RHS_loc, NCOL_RHS_loc, JBEG_RHS_loc, & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), LCWORK, & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%POSINRHSCOMP_COL(1), id%N, & PERM_RHS, size(PERM_RHS) ! For sparse permuted RHS & ) ELSE ! only gather target entries of A-1 CALL CMUMPS_GATHER_SOLUTION_AM1(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & id%KEEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & LSCAL, PT_SCALING(1), size(PT_SCALING) C --- A-1 related entries & , IRHS_PTR_COPY(1), size(IRHS_PTR_COPY), & IRHS_SPARSE_COPY(1), size(IRHS_SPARSE_COPY), & RHS_SPARSE_COPY(1), size(RHS_SPARSE_COPY), & UNS_PERM_INV, size(UNS_PERM_INV), & id%POSINRHSCOMP_COL(1), id%N, NB_FS_RHSCOMP_TOT & ) ENDIF ENDIF TIMEGATHER2=MPI_WTIME()-TIMEGATHER1+TIMEGATHER2 IF (KEEP(237).EQ.0) DEALLOCATE( CWORK ) IF ( (id%MYID.EQ.MASTER).AND. (KEEP(237).NE.0) & ) THEN C Copy back solution from RHS_SPARSE_COPY TO RHS_SPARSE DO J = JBEG_RHS, JBEG_RHS+NBCOL_INBLOC-1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN PJ = PERM_RHS(J) ELSE PJ =J ENDIF COLSIZE = id%IRHS_PTR(PJ+1) - & id%IRHS_PTR(PJ) IF (COLSIZE.EQ.0) CYCLE JJ = J-JBEG_RHS+1 C Precompute map of indices in current column C (no need to reset it between columns IF (id%NSLAVES.NE.1) THEN DO II=1, COLSIZE MAP_RHS(id%IRHS_SPARSE( & id%IRHS_PTR(PJ) + II - 1)) = II ENDDO DO IZ2 = IRHS_PTR_COPY(JJ),IRHS_PTR_COPY(JJ+1)-1 II = IRHS_SPARSE_COPY(IZ2) id%RHS_SPARSE(id%IRHS_PTR(PJ)+MAP_RHS(II)-1)= & RHS_SPARSE_COPY(IZ2) ENDDO ELSE C Entries within a column are in order C IZ - Column index in Sparse RHS DO IZ= id%IRHS_PTR(PJ), id%IRHS_PTR(PJ+1)-1 IZ2 = IRHS_PTR_COPY(JJ) + & IZ - id%IRHS_PTR(PJ) id%RHS_SPARSE(IZ) = RHS_SPARSE_COPY(IZ2) ENDDO ENDIF ENDDO IF (id%NSLAVES.NE.1) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS),8) * K34_8 DEALLOCATE ( MAP_RHS ) ENDIF ENDIF ! end A-1 on master C C -- END of backward was performed with centralized solution ELSE ! (KEEP(221).NE.1) .AND.(ICNTL21.NE.0)) C C BEGIN of backward performed with distributed solution C time local copy + scaling TIMECOPYSCALE1=MPI_WTIME() C The non working host should not do this: IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) C Only called if more than 1 pivot C was eliminated by the processor. C Note that LSOL_loc >= KEEP(89) IF ( KEEP(89) .GT. 0 ) THEN CALL CMUMPS_DISTRIBUTED_SOLUTION(id%NSLAVES, & id%N,id%MYID_NODES, & MTYPE, id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, & NBRHS_EFF, id%POSINRHSCOMP_COL(1), & id%ISOL_loc(1), id%SOL_loc(1), id%NRHS, & JBEG_RHS-NB_RHSSKIPPED, id%LSOL_loc, & id%PTLUST_S(1), id%PROCNODE_STEPS(1), & id%KEEP(1),id%KEEP8(1), & IS(1), LIW_PASSED, & id%STEP(1), scaling_data_sol, LSCAL, NB_RHSSKIPPED, & PERM_RHS, size(PERM_RHS) ) ! For permuted sparse RHS ENDIF ENDIF TIMECOPYSCALE2=MPI_WTIME()-TIMECOPYSCALE1+TIMECOPYSCALE2 ENDIF C === BACKWARD was PERFORMED WITH DISTRIBUTED SOLUTION === C ======================================================== ENDIF ! ==== END of BACKWARD was PERFORMED (KEEP(221).NE.1) C note that the main DO-loop on blocks is not ended yet C C ============================================ C BEGIN C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C ============================================ IF ( ICNTL10 > 0 .AND. NBRHS_EFF > 1 ) THEN C C ---------------------------------- C Multiple RHS: apply a fixed number C of iterative refinement steps C ---------------------------------- C DO I = 1, ICNTL10 write(6,*) ' Internal ERROR 15 in sol_driver ' C Compute residual: Y <- SAVERHS - A * RHS C Solve RHS <- A^-1 Y, Y modified C Assemble in RHS(REDUCE) C RHS <- RHS + Y C END DO END IF IF (POSTPros) THEN C C SAVERHS holds the original right hand side C Sparse rhs are saved in SAVERHS as dense rhs C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Start iterative refinements. The master is managing the C organisation of work, but slaves are used to solve systems of C equations and, in case of distributed matrix, perform C matrix-vector products. It is more complicated to do this with C the SPMD version than it was with the master/slave approach. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * c IF ( PROK .AND. ICNTL10 .NE. 0 ) WRITE( MP, 270 ) IF ( PROKG .AND. ICNTL10 .NE. 0 ) WRITE( MPG, 270 ) C Initializations and allocations NITREF = abs(ICNTL10) ALLOCATE(R_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 ALLOCATE(C_Y(id%N), stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 IF ( id%MYID .EQ. MASTER ) THEN ALLOCATE( IW1( 2 * id%N ),stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=2 * id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K34_8 ALLOCATE( C_W(id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE( R_W(2*id%N), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(2*id%N,8)*K16_8 IF ( PROKG .AND. ICNTL10 .GT. 0 ) & WRITE( MPG, 240) 'MAXIMUM NUMBER OF STEPS =', NITREF C end allocations on Master END IF ALLOCATE(C_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K35_8 ALLOCATE(R_LOCWK54(id%N),stat = allocok) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 KASE = 0 C Synchro point with broadcast of errors 777 CONTINUE NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) IF ( INFO(1) .LT. 0 ) GOTO 90 C TIMEEA needed if EA and IR with stopping criterium C and IR with fixed n.of steps. TIMEEA = 0.0E0 C TIMEEA1 needed if EA and IR with fixed n.of steps TIMEEA1 = 0.0E0 CALL MUMPS_SECDEB(TIMEIT) C ------------------------- C C RHSOL holds the initial guess for the solution C We start the loop on the Iterative refinement procedure C C C C |- IRefin. L O O P -| C V V C C ========================================================= C Computation of the infinity norm of A C ========================================================= IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C We don't get through these lines if ICNTL10<=0 AND ICNTL11<=0 IF ( KEEP(54) .eq. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ( id%MYID .eq. MASTER ) THEN C ----------------------------------------- C Call CMUMPS_SOL_X outside, if needed, C in order to compute w(i,2)=sum|Aij|,j=1:n C in vector R_W(id%N+i) C ----------------------------------------- IF (KEEP(55).NE.0) THEN C unassembled matrix and norm of row required CALL CMUMPS_SOL_X_ELT(MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & R_W(id%N+1), KEEP(1),KEEP8(1) ) ELSE C assembled matrix IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%IRN(1), id%JCN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_SOL_X & ( id%A(1), id%KEEP8(28), id%N, id%JCN(1), id%IRN(1), & R_W(id%N+1), KEEP(1),KEEP8(1)) END IF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%IRN_loc(1), id%JCN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) ELSE CALL CMUMPS_SOL_X(id%A_loc(1), & id%KEEP8(29), id%N, & id%JCN_loc(1), id%IRN_loc(1), & R_LOCWK54, id%KEEP(1),id%KEEP8(1) ) END IF ELSE R_LOCWK54 = RZERO END IF C ------------------------- C Assemble result on master C ------------------------- IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W( id%N + 1 ), & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) END IF C End if KEEP(54) END IF C IF ( id%MYID .eq. MASTER ) THEN C R_W is available on the master process only RINFOG(4) = real(ZERO) DO I = 1, id%N RINFOG(4) = max(R_W( id%N +I), RINFOG(4)) ENDDO ENDIF C end ICNTL11 =/0 v ICNTL10>0 ENDIF C ========================================================= C END norm of A C ========================================================= C Initializations for the IR NOITER = 0 IFLAG_IR = 0 TESTConv = .FALSE. C Test of convergence should be made IF (( id%MYID .eq. MASTER ).AND.(ICNTL10.GT.0)) THEN TESTConv = .TRUE. ARRET = CNTL(2) IF (ARRET .LT. 0.0E0) THEN ARRET = sqrt(epsilon(0.0E0)) END IF ENDIF C ========================================================= C Starting IR DO 22 IRStep = 1, NITREF +1 C ========================================================= C C ========================================================= C Refine the solution starting from the second step of do loop C ========================================================= IF (( id%MYID .eq. MASTER ).AND.(IRStep.GT.1)) THEN NOITER = NOITER + 1 DO I = 1, id%N id%RHS(IBEG+I-1) = id%RHS(IBEG+I-1) + C_Y(I) ENDDO ENDIF C =========================================== C Computation of the RESIDUAL and of |A||x| C =========================================== IF ( KEEP(54) .eq. 0 ) THEN IF ( id%MYID .eq. MASTER ) THEN IF (KEEP(55).NE.0) THEN C input matrix by element CALL CMUMPS_ELTYD( MTYPE, id%N, & id%NELT, id%ELTPTR(1), id%LELTVAR, & id%ELTVAR(1), id%KEEP8(30), id%A_ELT(1), & SAVERHS, id%RHS(IBEG), & C_Y, R_W, KEEP(50)) ELSE IF ( MTYPE .eq. 1 ) THEN CALL CMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%IRN(1), & id%JCN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_SOL_Y(id%A(1), id%KEEP8(28), & id%N, id%JCN(1), & id%IRN(1), SAVERHS, & id%RHS(IBEG), C_Y, R_W, KEEP(1),KEEP8(1)) ENDIF ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) C -------------------------------------- C Compute Y = SAVERHS - A * RHS C Y, SAVERHS defined only on master C -------------------------------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL CMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C =========================== C_Y = SAVERHS - C_Y C =========================== ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF C -------------------------------------- C Compute C * If MTYPE = 1 C W(i) = Sum | Aij | | RHSj | C j C * If MTYPE = 0 C W(j) = Sum | Aij | | RHSi | C i C R_LOCWK54 used as local array for W C RHS has been broadcasted C -------------------------------------- IF ( I_AM_SLAVE .and. id%KEEP8(29) .NE. 0_8 ) THEN CALL CMUMPS_LOC_OMEGA1( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), R_LOCWK54, KEEP(50), MTYPE ) ELSE R_LOCWK54 = RZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( R_LOCWK54, R_W, & id%N, MPI_REAL, & MPI_SUM,MASTER,id%COMM, IERR) ELSE CALL MPI_REDUCE( R_LOCWK54, R_DUMMY, & id%N, MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) ENDIF ENDIF C ===================================== C END computation RESIDUAL and |A||x| C ===================================== IF ( id%MYID .eq. MASTER ) THEN C IF ((ICNTL11.GT.0).OR.(ICNTL10.GT.0)) THEN C -------------- C Error analysis and test of convergence, C Compute the sparse componentwise backward error: C - at each step if test of convergence of IR is C requested (ICNTL(10)>0) C - at step 1 and NITREF+1 if error analysis C to be computed (ICNTL(11)>0) and if ICNTL(10)< 0 IF (((ICNTL11.GT.0).OR.((ICNTL10.LT.0).AND. & ((IRStep.EQ.1).OR.(IRStep.EQ.NITREF+1))) & .OR.((ICNTL10.EQ.0).AND.(IRStep.EQ.1))) & .OR.(ICNTL10.GT.0)) THEN C Compute w1 and w2 C always if ICNTL10>0 in the other case if ICNTL11>0 C ----------------- IF (ICNTL10.LT.0) CALL MUMPS_SECDEB(TIMEEA1) CALL CMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), NOITER, TESTConv, & MP, ARRET, KEEP(361) ) IF (ICNTL10.LT.0) THEN CALL MUMPS_SECFIN(TIMEEA1) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA1) ENDIF ENDIF IF ((ICNTL11.GT.0).AND.( & (ICNTL10.LT.0.AND.(IRStep.EQ.1.OR.IRStep.EQ.NITREF+1)) & .OR.((ICNTL10.GE.0).AND.(IRStep.EQ.1)) & )) THEN C Error analysis before iterative refinement C or for last if icntl10<0 C ------------------------------------------ CALL MUMPS_SECDEB(TIMEEA) IF (ICNTL10.EQ.0) THEN C No IR : there will be only the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 170 ) ELSEIF (IRStep.EQ.1) THEN C IR : we print the EA of the 1st sol. IF ( MPG .GT. 0 ) WRITE( MPG, 55 ) ELSEIF ((ICNTL10.LT.0).AND.(IRStep.EQ.NITREF+1)) THEN C IR with fixed n. of steps: we print the EA C of the last sol. IF ( MPG .GT. 0 ) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENT REQUESTED =', & NOITER ENDIF ENDIF GIVSOL = .TRUE. CALL CMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) IF ( MPG .GT. 0 ) THEN C Error analysis before iterative refinement WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) END IF CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) C end EA of the first solution END IF END IF C -------------- IF (IRStep.EQ.NITREF +1) THEN C If we are at the NITREF+1 step , we have refined the C solution NITREF times so we have to stop. KASE = 0 C If we test the convergence (ICNTL10.GT.0) and C IFLAG_IR = 0 we set a warning : more than NITREF steps C needed IF ((ICNTL10.GT.0).AND.(IFLAG_IR.EQ.0)) & id%INFO(1) = id%INFO(1) + 8 ELSE IF (ICNTL10.GT.0) THEN C ------------------- C Results of the test of convergence. C IFLAG_IR = 0 we should try to improve the solution C = 1 the stopping criterium is satisfied C = 2 the method is diverging, we go back C to the previous iterate C = 3 the convergence is too slow IF (IFLAG_IR.GT.0) THEN C If the convergence criterion is satisfied C or the convergence too slow C we set KASE=0 (end of the Iterative refinement) KASE = 0 C If the convergence is not improved, C we go back to the previous iterate. C IFLAG_IR can be equal to 2 only if IRStep >= 2 IF (IFLAG_IR.EQ.2) NOITER = NOITER - 1 ELSE C IFLAG_IR=0, try to improve the solution KASE = 2 ENDIF ELSEIF (ICNTL10.LT.0) THEN C ------------------- KASE = 2 ELSE C ICNTL10 = 0, we want to perform only EA and not IR. C ----------------- KASE = 0 END IF ENDIF C End Master ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C If Kase= 0 we quit the IR process IF (KASE.LE.0) GOTO 666 IF (KASE.LT.0) THEN WRITE(*,*) "Internal error 17 in CMUMPS_SOL_DRIVER" ENDIF C ========================================================= C COMPUTE the solution of Ay = r C ========================================================= C Call internal routine to avoid code duplication CALL CMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C ----------------------- C Go back to beginning of C loop to apply next step C of iterative refinement C ----------------------- 22 CONTINUE 666 CONTINUE C ************************************************ C C End of the iterative refinement procedure C C ************************************************ CALL MUMPS_SECFIN(TIMEIT) IF ( id%MYID .EQ. MASTER ) THEN IF ( NITREF .GT. 0 ) THEN id%INFOG(15) = NOITER END IF C id%DKEEP(114) time for the iterative refinement C id%DKEEP(120) time for the error analysis C id%DKEEP(121) time for condition number C these values are meaningful only on the host. IF (ICNTL10.EQ.0) THEN C No IR has been requested. All the time is needed C for computing EA id%DKEEP(120)=real(TIMEIT) ELSE C IR has been requested id%DKEEP(114)=real(TIMEIT)-id%DKEEP(120) ENDIF END IF IF ( PROKG ) THEN IF (ICNTL10.GT.0) THEN WRITE( MPG, 81 ) WRITE( MPG, * ) WRITE( MPG, 141 ) & 'NUMBER OF STEPS OF ITERATIVE REFINEMENTS PERFORMED =', & NOITER ENDIF ENDIF C C ================================================== C BEGIN C Perform error analysis after iterative refinement C ================================================== IF ((ICNTL11 .GT. 0).AND.(ICNTL10.GT.0)) THEN C If IR is requested with test of convergence, C the EA of the last step of IR is done here, C otherwise EA of the last step is done at the C end of IR CALL MUMPS_SECDEB(TIMEEA) KASE = 0 IF (id%MYID .eq. MASTER ) THEN C Test if IFLAG_IR = 2, that is if the the IR was diverging, C we went back to the previous iterate C We have to do EA on the last computed solution. IF (IFLAG_IR.EQ.2) KASE = 2 ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) IF (KASE.EQ.2) THEN C We went back to the previous iterate C We have to do EA on the last computed solution. C Compute the residual in C_Y using IRN, JCN, ASPK C and the solution RHS(IBEG) C The norm of the ith row in R_Y(I). IF ( KEEP(54) .eq. 0 ) THEN C --------------------- C Matrix is centralized C --------------------- IF (id%MYID .EQ. MASTER) THEN IF (KEEP(55).EQ.0) THEN CALL CMUMPS_QD2( MTYPE, id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ELSE CALL CMUMPS_ELTQD2( MTYPE, id%N, & id%NELT, id%ELTPTR(1), & id%LELTVAR, id%ELTVAR(1), & id%KEEP8(30), id%A_ELT(1), & id%RHS(IBEG), SAVERHS, R_Y, C_Y, KEEP(1),KEEP8(1)) ENDIF ENDIF ELSE C --------------------- C Matrix is distributed C --------------------- CALL MPI_BCAST( RHS_IR(IBEG), id%N, & MPI_COMPLEX, MASTER, & id%COMM, IERR ) C ---------------- C Compute residual C ---------------- IF ( I_AM_SLAVE .and. & id%KEEP8(29) .NE. 0_8 ) THEN CALL CMUMPS_LOC_MV8( id%N, id%KEEP8(29), & id%IRN_loc(1), id%JCN_loc(1), id%A_loc(1), & RHS_IR(IBEG), C_LOCWK54, KEEP(50), MTYPE ) ELSE C_LOCWK54 = ZERO END IF IF ( id%MYID .eq. MASTER ) THEN CALL MPI_REDUCE( C_LOCWK54, C_Y, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) C_Y = SAVERHS - C_Y ELSE CALL MPI_REDUCE( C_LOCWK54, C_DUMMY, & id%N, MPI_COMPLEX, & MPI_SUM,MASTER,id%COMM, IERR) END IF ENDIF ENDIF ! KASE.EQ.2 IF (id%MYID .EQ. MASTER) THEN C Compute which equations are associated to w1 and which C ones are associated to w2 in case of IFLAG_IR=2. C If IFLAG_IR = 0 or 1 IW1 should be correct IF (IFLAG_IR.EQ.2) THEN TESTConv = .FALSE. CALL CMUMPS_SOL_OMEGA(id%N,SAVERHS, & id%RHS(IBEG), C_Y, R_W, C_W, IW1, IFLAG_IR, & RINFOG(7), 0, TESTConv, & MP, ARRET, KEEP(361) ) ENDIF ! (IFLAG_IR.EQ.2) c Compute some statistics for GIVSOL = .TRUE. CALL CMUMPS_SOL_Q(MTYPE,INFO(1),id%N, & id%RHS(IBEG), & SAVERHS,R_W(id%N+1),C_Y,GIVSOL, & RINFOG(4),RINFOG(5),RINFOG(6),MPG,ICNTL(1), & KEEP(1),KEEP8(1)) ENDIF ! Master CALL MUMPS_SECFIN(TIMEEA) id%DKEEP(120)=id%DKEEP(120)+real(TIMEEA) ENDIF ! ICNTL11>0 and ICNTL10>0 C ========================================================= C Compute the Condition number associated if requested. C ========================================================= CALL MUMPS_SECDEB(TIMELCOND) IF (ICNTL11 .EQ. 1) THEN IF ( id%MYID .eq. MASTER ) THEN C Notice that D is always the identity ALLOCATE( D(id%N),stat =allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N GOTO 777 ENDIF NB_BYTES = NB_BYTES + int(id%N,8)*K16_8 DO I = 1, id%N D( I ) = RONE END DO ENDIF KASE = 0 222 CONTINUE IF ( id%MYID .EQ. MASTER ) THEN CALL CMUMPS_SOL_LCOND(id%N, SAVERHS, & id%RHS(IBEG), C_Y, D, R_W, C_W, IW1, KASE, & RINFOG(7), RINFOG(9), RINFOG(10), & MP, KEEP(1),KEEP8(1)) ENDIF C -------------- C Broadcast KASE C -------------- CALL MPI_BCAST( KASE, 1, MPI_INTEGER, MASTER, & id%COMM, IERR ) C KASE <= 0 C We reach the end of iterative method to compute C LCOND1 and LCOND2 IF (KASE.LE.0) GOTO 224 CALL CMUMPS_PP_SOLVE() IF (INFO(1) .LT. 0) GOTO 90 C --------------------------- C Go back to beginning of C loop to apply next step C of iterative method C ----------------------- GO TO 222 C End ICNTL11 = 1 ENDIF 224 CONTINUE CALL MUMPS_SECFIN(TIMELCOND) id%DKEEP(121)=id%DKEEP(121)+real(TIMELCOND) IF ((id%MYID .EQ. MASTER).AND.(ICNTL11.GT.0)) THEN IF (ICNTL10.GT.0) THEN C If ICNTL10<0 these stats have been printed before IR IF ( MPG .GT. 0 ) THEN WRITE( MPG, 115 ) & 'RINFOG(7):COMPONENTWISE SCALED RESIDUAL(W1)=', & RINFOG(7) WRITE( MPG, 115 ) & '------(8):---------------------------- (W2)=', & RINFOG(8) ENDIF END IF IF (ICNTL11.EQ.1) THEN C If ICNTL11/=1 these stats haven't been computed IF (MPG.GT.0) THEN WRITE( MPG, 115 ) & '------(9):Upper bound ERROR ...............=', & RINFOG(9) WRITE( MPG, 115 ) & '-----(10):CONDITION NUMBER (1) ............=', & RINFOG(10) WRITE( MPG, 115 ) & '-----(11):CONDITION NUMBER (2) ............=', & RINFOG(11) END IF END IF END IF ! MASTER && ICNTL11.GT.0 IF ( PROKG .AND. abs(ICNTL10) .GT.0 ) WRITE( MPG, 131 ) C=================================================== C Perform error analysis after iterative refinements C END C=================================================== C IF (id%MYID == MASTER) THEN NB_BYTES = NB_BYTES - int(size(C_W),8)*K35_8 DEALLOCATE(C_W) NB_BYTES = NB_BYTES - int(size(R_W),8)*K16_8 & - int(size(IW1),8)*K34_8 DEALLOCATE(R_W) DEALLOCATE(IW1) IF (ICNTL11 .EQ. 1) THEN C We have used D only for LCOND1,2 NB_BYTES = NB_BYTES - int(size(D ),8)*K16_8 DEALLOCATE(D) ENDIF ENDIF NB_BYTES = NB_BYTES - & (int(size(R_Y),8)+int(size(R_LOCWK54),8))*K16_8 NB_BYTES = NB_BYTES - & (int(size(C_Y),8)+int(size(C_LOCWK54),8))*K35_8 DEALLOCATE(R_Y) DEALLOCATE(C_Y) DEALLOCATE(R_LOCWK54) DEALLOCATE(C_LOCWK54) C End POSTPros END IF C============================================ C C ITERATIVE REFINEMENT AND/OR ERROR ANALYSIS C C END C C============================================ C ========================== C Begin reordering on master C corresponding to maximum transversal permutation C in case of centralized solution C (ICNTL21==0) C IF ( id%MYID .EQ. MASTER .AND. ICNTL21==0 & .AND. KEEP(23) .NE. 0.AND.KEEP(237).EQ.0) THEN C ((No transpose and backward performed and NO A-1) C or null space computation): permutation C must be done on solution. IF ((KEEP(221).NE.1 .AND. MTYPE .EQ. 1) & .OR. KEEP(111) .NE.0 .OR. KEEP(252).NE.0 ) THEN C Permute the solution RHS according to the column C permutation held in UNS_PERM C Column J of the permuted matrix corresponds to C column UNS_PERM(J) of the original matrix. C RHS holds the permuted solution C Note that id%N>1 since KEEP(23)=0 when id%N=1 C ALLOCATE( C_RW1( id%N ),stat =allocok ) ! temporary not in NB_BYTES IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=id%N WRITE(*,*) 'could not allocate ', id%N, 'integers.' CALL MUMPS_ABORT() END IF DO K = 1, NBRHS_EFF IF (KEEP(242).EQ.0) THEN KDEC = (K-1)*LD_RHS+IBEG-1 ELSE C ------------------------------- C Columns just computed might not C be contiguous in original RHS C ------------------------------- KDEC = int(PERM_RHS(K-1+JBEG_RHS)-1,8)*int(LD_RHS,8) ENDIF DO I = 1, id%N C_RW1(I) = id%RHS(KDEC+I) ENDDO DO I = 1, id%N JPERM = id%UNS_PERM(I) id%RHS( KDEC+JPERM ) = C_RW1( I ) ENDDO ENDDO DEALLOCATE( C_RW1 ) !temporary not in NB_BYTES END IF END IF C C End reordering on master C ======================== IF (id%MYID.EQ.MASTER .and.ICNTL21==0.and.KEEP(221).NE.1.AND. & (KEEP(237).EQ.0) ) THEN * print out the solution IF ( INFO(1) .GE. 0 .AND. ICNTL(4).GE.3 .AND. ICNTL(3).GT.0) & THEN K = min0(10, id%N) IF (ICNTL(4) .eq. 4 ) K = id%N J = min0(10,NBRHS_EFF) IF (ICNTL(4) .eq. 4 ) J = NBRHS_EFF DO II=1, J WRITE(ICNTL(3),110) BEG_RHS+II-1 WRITE(ICNTL(3),160) & (id%RHS(IBEG+(II-1)*LD_RHS+I-1),I=1,K) ENDDO END IF END IF C ========================== C blocking for multiple RHS (END OF DO WHILE (BEG_RHS.LE.NBRHS) IF ((KEEP(248).EQ.1).AND.(KEEP(237).EQ.0)) THEN ! case of general sparse: in case of empty columns ! NBRHS_EFF might has been updated and broadcasted ! and holds the effective size of a contiguous block of ! non empty columns BEG_RHS = BEG_RHS + NBRHS_EFF ! nb of nonempty columns ELSE BEG_RHS = BEG_RHS + NBRHS ENDIF ENDDO C DO WHILE (BEG_RHS.LE.id%NRHS) C ========================== C C ======================================================== C Reset RHS to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( (id%MYID.EQ.MASTER) & .AND. ( KEEP(248).NE.0 ) ! sparse RHS on input & .AND. ( KEEP(237).EQ.0 ) ! No A-1 & .AND. ( ICNTL21.EQ.0 ) ! Centralized solution & .AND. ( KEEP(221) .NE.1 ) ! Not Reduced RHS step of Schur & .AND. ( JEND_RHS .LT. id%NRHS ) & ) & THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(PERM_RHS(JBEG_NEW) -1,8)*int(LD_RHS,8)+I) & = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 CYCLE ENDDO ELSE DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%N id%RHS(int(JBEG_NEW -1,8)*int(LD_RHS,8) + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ! End DO_PERMUTE_RHS.OR.INTERLEAVE_PAR ENDIF C ======================================================== C Reset id%SOL_loc to zero for all remaining columns that C have not been processed because they were emtpy C ======================================================== IF ( I_AM_SLAVE .AND. (ICNTL21.NE.0) .AND. & ( JEND_RHS .LT. id%NRHS ) .AND. KEEP(221).NE.1 ) THEN JBEG_NEW = JEND_RHS + 1 IF (DO_PERMUTE_RHS.OR.INTERLEAVE_PAR) THEN DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc(int(PERM_RHS(JBEG_NEW) -1,8)* & int(id%LSOL_loc,8)+int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ELSE C DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, KEEP(89) id%SOL_loc((JBEG_NEW -1)*id%LSOL_loc + I) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C ================================================================ C Reset id%RHSCOMP and id%REDRHS to zero for all remaining columns C that have not been processed because they were emtpy C ================================================================ IF ((KEEP(221).EQ.1) .AND. & ( JEND_RHS .LT. id%NRHS ) ) THEN IF (id%MYID .EQ. MASTER) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1, id%SIZE_SCHUR id%REDRHS(int(JBEG_NEW -1,8)*int(LD_REDRHS,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF IF (I_AM_SLAVE) THEN JBEG_NEW = JEND_RHS + 1 DO WHILE ( JBEG_NEW.LE. id%NRHS) DO I=1,NBENT_RHSCOMP id%RHSCOMP(int(JBEG_NEW -1,8)*int(LD_RHSCOMP,8) + & int(I,8)) = ZERO ENDDO JBEG_NEW = JBEG_NEW +1 ENDDO ENDIF ENDIF C C C ! maximum size used on that proc id%INFO(26) = int(NB_BYTES_MAX / 1000000_8) C Centralize memory statistics on the host C C INFOG(30) = size of mem in bytes for solve C for the processor using largest memory C INFOG(31) = size of mem in bytes for solve C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(26), id%INFOG(30), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I10) ') & ' ** Rank of processor needing largest memory in solve :', & IRANK WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used by this processor for solve :', & id%INFOG(30) IF ( KEEP(46) .eq. 0 ) THEN WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & ( id%INFOG(31)-id%INFO(26) ) / id%NSLAVES ELSE WRITE( MPG,'(A,I10) ') & ' ** Avg. Space in MBYTES per working proc during solve :', & id%INFOG(31) / id%NSLAVES END IF ELSE WRITE( MPG,'(A,I10) ') & ' ** Space in MBYTES used for solve :', & id%INFOG(30) ENDIF END IF *=============================== *End of Solve Phase *=============================== C Store and print timings CALL MUMPS_SECFIN(TIME3) id%DKEEP(112)=real(TIME3) id%DKEEP(113)=real(TIMEC2) id%DKEEP(115)=real(TIMESCATTER2) id%DKEEP(116)=real(TIMEGATHER2) id%DKEEP(122)=real(TIMECOPYSCALE2) C Reductions of DKEEP(115,116,117,118,119,122): CALL MPI_REDUCE( id%DKEEP(115), id%DKEEP(160),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(116), id%DKEEP(161),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(117), id%DKEEP(162),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(118), id%DKEEP(163),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(119), id%DKEEP(164),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(122), id%DKEEP(165),1, &MPI_REAL, MPI_MAX, MASTER, id%COMM, IERR ) C IF (PROKG) THEN WRITE ( MPG, *) WRITE ( MPG, *) "Leaving solve with ..." WRITE( MPG, 434 ) id%DKEEP(160) ! max id%DKEEP(115) WRITE( MPG, 432 ) id%DKEEP(113) ! ok without reduction WRITE( MPG, 435 ) id%DKEEP(162) ! max id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MPG, 437 ) id%DKEEP(164) ! id%DKEEP(119) WRITE( MPG, 436 ) id%DKEEP(163) ! id%DKEEP(118) WRITE( MPG, 433 ) id%DKEEP(161) ! max(DKEEP(116)) -- Gather WRITE( MPG, 431 ) id%DKEEP(165) ! max(DKEEP(122)) -- Dist. sol. ENDIF IF ( PROK ) THEN WRITE ( MP, *) WRITE ( MP, *) "Local statistics" WRITE( MP, 434 ) id%DKEEP(115) WRITE( MP, 432 ) id%DKEEP(113) WRITE( MP, 435 ) id%DKEEP(117) IF ((KEEP(38).NE.0).OR.(KEEP(20).NE.0)) & WRITE( MP, 437 ) id%DKEEP(119) WRITE( MP, 436 ) id%DKEEP(118) WRITE( MP, 433 ) id%DKEEP(116) WRITE( MP, 431 ) id%DKEEP(122) END IF 90 CONTINUE IF (INFO(1) .LT.0 ) THEN ENDIF IF (KEEP(485) .EQ. 1) THEN KEEP(350) = KEEP350_SAVE IF (IS_LR_MOD_TO_STRUC_DONE) THEN CALL CMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) CALL MUMPS_FDM_MOD_TO_STRUC('F',id%FDM_F_ENCODING, & id%INFO(1)) ENDIF ENDIF IF (KEEP(201).GT.0)THEN IF (IS_INIT_OOC_DONE) THEN CALL CMUMPS_OOC_END_SOLVE(IERR) IF (IERR.LT.0 .AND. INFO(1) .GE. 0) INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) ENDIF C ------------------------ C Check allocation before C to deallocate (cases of C errors that could happen C before or after allocate C statement) C C Sparse RHS C Free space and reset pointers if needed IF (IRHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_SPARSE_COPY),8)*K34_8 DEALLOCATE(IRHS_SPARSE_COPY) IRHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_SPARSE_COPY) ENDIF IF (IRHS_PTR_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(IRHS_PTR_COPY),8)*K34_8 DEALLOCATE(IRHS_PTR_COPY) IRHS_PTR_COPY_ALLOCATED=.FALSE. NULLIFY(IRHS_PTR_COPY) ENDIF IF (RHS_SPARSE_COPY_ALLOCATED) THEN NB_BYTES = NB_BYTES - & int(size(RHS_SPARSE_COPY),8)*K35_8 DEALLOCATE(RHS_SPARSE_COPY) RHS_SPARSE_COPY_ALLOCATED=.FALSE. NULLIFY(RHS_SPARSE_COPY) ENDIF IF (allocated(MAP_RHS_loc)) THEN NB_BYTES = NB_BYTES - int(size(MAP_RHS_loc),8)*K34_8 DEALLOCATE(MAP_RHS_loc) ENDIF IF (IRHS_loc_PTR_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(IRHS_loc_PTR),8)*K34_8 DEALLOCATE(IRHS_loc_PTR) NULLIFY(IRHS_loc_PTR) IRHS_loc_PTR_ALLOCATED = .FALSE. ENDIF IF (I_AM_SLAVE.AND.LSCAL.AND.KEEP(248).EQ.-1) THEN NB_BYTES = NB_BYTES - & int(size(scaling_data_dr%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_dr%SCALING_LOC) NULLIFY (scaling_data_dr%SCALING_LOC) ENDIF IF (allocated(PERM_RHS)) THEN NB_BYTES = NB_BYTES - int(size(PERM_RHS),8)*K34_8 DEALLOCATE(PERM_RHS) ENDIF C END A-1 IF (allocated(UNS_PERM_INV)) THEN NB_BYTES = NB_BYTES - int(size(UNS_PERM_INV),8)*K34_8 DEALLOCATE(UNS_PERM_INV) ENDIF IF (allocated(BUFR)) THEN NB_BYTES = NB_BYTES - int(size(BUFR),8)*K34_8 DEALLOCATE(BUFR) ENDIF IF ( I_AM_SLAVE ) THEN IF (allocated(RHS_BOUNDS)) THEN NB_BYTES = NB_BYTES - & int(size(RHS_BOUNDS),8)*K34_8 DEALLOCATE(RHS_BOUNDS) ENDIF IF (allocated(IWK_SOLVE)) THEN NB_BYTES = NB_BYTES - int(size(IWK_SOLVE),8)*K34_8 DEALLOCATE( IWK_SOLVE ) ENDIF IF (allocated(PTRACB)) THEN NB_BYTES = NB_BYTES - int(size(PTRACB),8)*K34_8* & int(KEEP(10),8) DEALLOCATE( PTRACB ) ENDIF IF (allocated(IWCB)) THEN NB_BYTES = NB_BYTES - int(size(IWCB),8)*K34_8 DEALLOCATE( IWCB ) ENDIF C ------------------------ C SLAVE CODE C ----------------------- C Deallocate send buffers C ----------------------- IF (id%NSLAVES .GT. 1) THEN CALL CMUMPS_BUF_DEALL_CB( IERR ) CALL CMUMPS_BUF_DEALL_SMALL_BUF( IERR ) ENDIF END IF C IF ( id%MYID .eq. MASTER ) THEN C ------------------------ C SAVERHS may have been C allocated only on master C ------------------------ IF (allocated(SAVERHS)) THEN NB_BYTES = NB_BYTES - int(size(SAVERHS),8)*K35_8 DEALLOCATE( SAVERHS) ENDIF C Nullify RHS_IR might have been pointing to id%RHS NULLIFY(RHS_IR) ELSE C -------------------- C Free right-hand-side C on slave processors C -------------------- IF (associated(RHS_IR)) THEN NB_BYTES = NB_BYTES - int(size(RHS_IR),8)*K35_8 DEALLOCATE(RHS_IR) NULLIFY(RHS_IR) END IF END IF IF (I_AM_SLAVE) THEN C Deallocate temporary workspace SRW3 IF (allocated(SRW3)) THEN NB_BYTES = NB_BYTES - int(size(SRW3),8)*K35_8 DEALLOCATE(SRW3) ENDIF IF (LSCAL .AND. ICNTL21==1) THEN C Free local scaling arrays NB_BYTES = NB_BYTES - & int(size(scaling_data_sol%SCALING_LOC),8)*K16_8 DEALLOCATE(scaling_data_sol%SCALING_LOC) NULLIFY(scaling_data_sol%SCALING_LOC) ENDIF C Free memory until next call to CMUMPS IF (WK_USER_PROVIDED) THEN C S points to WK_USER provided by user C KEEP8(24) holds size of WK_USER C it should be saved and is used C in incore to check that size provided is consistent C (see error -41) NULLIFY(id%S) ELSE IF (associated(id%S).AND.KEEP(201).GT.0) THEN C OOC: free space for S that was allocated NB_BYTES = NB_BYTES - KEEP8(23)*K35_8 id%KEEP8(23)=0_8 DEALLOCATE(id%S) NULLIFY(id%S) ENDIF IF (KEEP(221).NE.1) THEN C -- After reduction of RHS to Schur variables C -- keep compressed RHS generated during FWD step C -- to be used for future expansion IF (associated(id%RHSCOMP)) THEN NB_BYTES = NB_BYTES - id%KEEP8(25)*K35_8 DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_ROW),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN NB_BYTES = NB_BYTES - & int(size(id%POSINRHSCOMP_COL),8)*K34_8 DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF ENDIF IF ( WORK_WCB_ALLOCATED ) THEN NB_BYTES = NB_BYTES - int(size(WORK_WCB),8)*K35_8 DEALLOCATE( WORK_WCB ) ENDIF C Otherwise, WORK_WCB may point to some C position inside id%S, nullify it NULLIFY( WORK_WCB ) ENDIF RETURN 55 FORMAT (//' ERROR ANALYSIS BEFORE ITERATIVE REFINEMENT') 100 FORMAT(//' ****** SOLVE & CHECK STEP ********'/) 110 FORMAT (//' Vector solution for column ',I12) 115 FORMAT(1X, A44,1P,D9.2) 434 FORMAT(' Time to build/scatter RHS =',F15.6) 432 FORMAT(' Time in solution step (fwd/bwd) =',F15.6) 435 FORMAT(' .. Time in forward (fwd) step = ',F15.6) 437 FORMAT(' .. Time in ScaLAPACK root = ',F15.6) 436 FORMAT(' .. Time in backward (bwd) step = ',F15.6) 433 FORMAT(' Time to gather solution(cent.sol)=',F15.6) 431 FORMAT(' Time to copy/scale dist. solution=',F15.6) 150 FORMAT(' GLOBAL STATISTICS PRIOR SOLVE PHASE ...........'/ & ' Number of right-hand-sides =',I12/ & ' Blocking factor for multiple rhs =',I12/ & ' ICNTL (9) =',I12/ & ' --- (10) =',I12/ & ' --- (11) =',I12/ & ' --- (20) =',I12/ & ' --- (21) =',I12/ & ' --- (30) =',I12/ & ' --- (35) =',I12 & ) 151 FORMAT (' --- (25) =',I12) 152 FORMAT (' --- (26) =',I12) 153 FORMAT (' --- (32) =',I12) 160 FORMAT (' RHS'/(1X,1P,5E14.6)) 170 FORMAT (/' ERROR ANALYSIS' ) 240 FORMAT (1X, A42,I4) 270 FORMAT (//' BEGIN ITERATIVE REFINEMENT' ) 81 FORMAT (/' STATISTICS AFTER ITERATIVE REFINEMENT ') 131 FORMAT (/' END ITERATIVE REFINEMENT ') 141 FORMAT(1X, A52,I4) CONTAINS SUBROUTINE CMUMPS_CHECK_DISTRHS( & idNloc_RHS, & idLRHS_loc, & NRHS, & idIRHS_loc, & idRHS_loc, & INFO) C C Purpose: C ======= C C Check distributed RHS format. We assume that C the user has indicated that he/she provided C a distributed RHS (KEEP(248)=-1). We also C assume that the nb of RHS columns NRHS has C been broadcasted to all processes. This C routine should then be called on the workers. C C Arguments: C ========= C INTEGER, INTENT( IN ) :: idNloc_RHS INTEGER, INTENT( IN ) :: idLRHS_loc INTEGER, INTENT( IN ) :: NRHS #if defined(MUMPS_F2003) INTEGER, INTENT( IN ), POINTER :: idIRHS_loc (:) COMPLEX, INTENT( IN ), POINTER :: idRHS_loc (:) #else INTEGER, POINTER :: idIRHS_loc (:) COMPLEX, POINTER :: idRHS_loc (:) #endif INTEGER, INTENT( INOUT ) :: INFO(80) C C Local declarations: C ================== C INTEGER(8) :: REQSIZE8 C C Executable statements: C ===================== C C Quick return if nothing on this proc IF (idNloc_RHS .LE. 0) RETURN C Check for leading dimension IF (NRHS.NE.1) THEN IF ( idLRHS_loc .LT. idNloc_RHS) THEN INFO(1)=-55 INFO(2)=idLRHS_loc RETURN ENDIF ENDIF IF (idNloc_RHS .GT. 0) THEN C Check association and size of index array idIRHS_loc IF (.NOT. associated(idIRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=17 RETURN ELSE IF (size(idIRHS_loc) .LT. idNloc_RHS) THEN INFO(1)=-22 INFO(2)= 17 RETURN ENDIF C Check association and size of value array idRHS_loc IF (.NOT. associated(idRHS_loc)) THEN id%INFO(1)=-22 id%INFO(2)=18 RETURN ELSE C Check size of array of values idRHS_loc REQSIZE8 = int(idLRHS_loc,8)*int(NRHS,8) & + int(-idLRHS_loc+idNloc_RHS,8) #if defined(MUMPS_F2003) IF (size(idRHS_loc,kind=8) .LT. REQSIZE8) THEN #else IF ( REQSIZE8 .LE. int(huge(idNloc_RHS),8) .AND. & size(idRHS_loc) .LT. int(REQSIZE8) ) THEN C (Warning: this assumes that size(idRHS_loc) C does not overflow) #endif INFO(1)=-22 INFO(2)=18 RETURN ENDIF ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_CHECK_DISTRHS SUBROUTINE CMUMPS_PP_SOLVE() IMPLICIT NONE C C Purpose: C ======= C Scatter right-hand side, solve the system, C and gather the solution on the host during C post-processing. C We use an internal subroutine to avoid code C duplication without the complication of adding C new parameters or local variables. All variables C in this routine have the scope of CMUMPS_SOL_DRIVER. C C IF (KASE .NE. 1 .AND. KASE .NE. 2) THEN WRITE(*,*) "Internal error 1 in CMUMPS_PP_SOLVE" CALL MUMPS_ABORT() ENDIF IF ( id%MYID .eq. MASTER ) THEN C Define matrix B as follows: C MTYPE=1 => B=A other values B=At C The user asked to solve the system Bx=b C C THEN C KASE = 1........ RW1 = INV(TRANSPOSE(B)) * RW1 C KASE = 2........ RW1 = INV(B) * RW1 IF ( MTYPE .EQ. 1 ) THEN SOLVET = KASE - 1 ELSE SOLVET = KASE END IF C SOLVET= 1 -> solve A x = B, other values solve Atx=b C We force SOLVET to have value either 0 or 1, in order C to be able to test both values, and also, be able to C test whether SOLVET = MTYPE or not. IF ( SOLVET.EQ.2 ) SOLVET = 0 IF ( LSCAL ) THEN IF ( SOLVET .EQ. 1 ) THEN C Apply rowscaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%ROWSCA( K ) END DO ELSE C Apply column scaling DO K = 1, id%N C_Y( K ) = C_Y( K ) * id%COLSCA( K ) END DO END IF END IF END IF ! MYID.EQ.MASTER C ------------------------------ C Broadcast SOLVET to the slaves C ------------------------------ CALL MPI_BCAST( SOLVET, 1, MPI_INTEGER, MASTER, & id%COMM, IERR) C -------------------------------------------- C Scatter the right hand side C_Y on all procs C -------------------------------------------- IF ( .NOT.I_AM_SLAVE ) THEN C -- Master not working CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & C_DUMMY, 1, 1, & IDUMMY, 0, & JDUMMY, id%KEEP(1), id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ELSE IF (SOLVET.EQ.MTYPE) THEN C POSINRHSCOMP_ROW is with respect to the C original linear system (transposed or not) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW ELSE C Transposed, use column indices of original C system (ie, col indices of A or A^T) PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL ENDIF LIW_PASSED = max( LIW, 1 ) CALL CMUMPS_SCATTER_RHS(id%NSLAVES,id%N, id%MYID, & id%COMM, & SOLVET, C_Y(1), id%N, 1, & 1, & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, 1, & PTR_POSINRHSCOMP_FWD(1), NB_FS_RHSCOMP_F, C & id%PTLUST_S(1), id%KEEP(1), id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), & id%ICNTL(1),id%INFO(1)) ENDIF IF (INFO(1).LT.0) GOTO 89 C C Solve the system C IF ( I_AM_SLAVE ) THEN LIW_PASSED = max( LIW, 1 ) LA_PASSED = max( LA, 1_8 ) IF (SOLVET.EQ.MTYPE) THEN PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_ROW PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_COL ELSE PTR_POSINRHSCOMP_FWD => id%POSINRHSCOMP_COL PTR_POSINRHSCOMP_BWD => id%POSINRHSCOMP_ROW ENDIF FROM_PP=.TRUE. NBSPARSE_LOC = .FALSE. CALL CMUMPS_SOL_C(id%root, id%N, id%S(1), LA_PASSED, id%IS(1), & LIW_PASSED,WORK_WCB(1),LWCB8_SOL_C,IWCB,LIWCB,NBRHS_EFF,id%NA(1), & id%LNA,id%NE_STEPS(1),SRW3,SOLVET,ICNTL(1),FROM_PP,id%STEP(1), & id%FRERE_STEPS(1),id%DAD_STEPS(1),id%FILS(1),id%PTLUST_S(1), & id%PTRFAC(1), IWK_SOLVE(1), LIWK_SOLVE, PTRACB, LIWK_PTRACB, & id%PROCNODE_STEPS(1), id%NSLAVES, INFO(1), KEEP(1), KEEP8(1), & id%DKEEP(1),id%COMM_NODES,id%MYID,id%MYID_NODES, BUFR(1), LBUFR, & LBUFR_BYTES, id%ISTEP_TO_INIV2(1), id%TAB_POS_IN_PERE(1,1), C Next 3 arguments are not used in this call & IBEG_ROOT_DEF,IEND_ROOT_DEF,IROOT_DEF_RHS_COL1, PTR_RHS_ROOT(1), & LPTR_RHS_ROOT, SIZE_ROOT, MASTER_ROOT, id%RHSCOMP(IBEG_RHSCOMP), & LD_RHSCOMP,PTR_POSINRHSCOMP_FWD(1),PTR_POSINRHSCOMP_BWD(1), & 1,1,1,1, IDUMMY, 1, JDUMMY, KDUMMY, 1, LDUMMY, 1, MDUMMY, 1,1, & NBSPARSE_LOC, PTR_RHS_BOUNDS(1), LPTR_RHS_BOUNDS & ) END IF C ------------------ C Change error codes C ------------------ IF (INFO(1).eq.-2) INFO(1)=-12 IF (INFO(1).eq.-3) INFO(1)=-15 C IF (INFO(1) .GE. 0) THEN C We need a workspace of minimal size KEEP(247) C in order to unpack pieces of the solution during C CMUMPS_GATHER_SOLUTION below C - Avoid allocation if error already occurred. C - DEALLOCATE called after GATHER_SOLUTION C CWORK not needed for AM1 ALLOCATE( CWORK(max(max(KEEP(247),KEEP(246)),1)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(max(KEEP(247),KEEP(246)),1) ENDIF ENDIF C ------------------------- C Propagate possible errors C ------------------------- 89 CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & id%COMM,id%MYID) C C Return in case of error. IF (INFO(1).LT.0) RETURN C ------------------------------- C Assemble the solution on master C ------------------------------- C (Note: currently, if this part of code is executed, C then necessarily NBRHS_EFF = 1) C C === GATHER and SCALE solution ============== C IF ((id%MYID.NE.MASTER).OR. .NOT.LSCAL) THEN PT_SCALING => Dummy_SCAL ELSE IF (SOLVET.EQ.1) THEN PT_SCALING => id%COLSCA ELSE PT_SCALING => id%ROWSCA ENDIF ENDIF LIW_PASSED = max( LIW, 1 ) C Solution computed during CMUMPS_SOL_C has been stored C in id%RHSCOMP and is gathered on the master in C_Y IF ( .NOT. I_AM_SLAVE ) THEN C I did not participate to computing part of the solution C (id%RHSCOMP not set/allocate) : receive solution, store C it and scale it. CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & JDUMMY, id%KEEP(1),id%KEEP8(1), id%PROCNODE_STEPS(1), & IDUMMY, 1, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), ! RHSCOMP not on non-working master & C_DUMMY, 1 , 1, IDUMMY, 1, ! for sparse permuted RHS on host & PERM_RHS, size(PERM_RHS) & ) ELSE CALL CMUMPS_GATHER_SOLUTION(id%NSLAVES,id%N, & id%MYID, id%COMM, NBRHS_EFF, & SOLVET, C_Y, id%N, NBRHS_EFF, 1, & id%PTLUST_S(1), id%KEEP(1),id%KEEP8(1), & id%PROCNODE_STEPS(1), & IS(1), LIW_PASSED, & id%STEP(1), BUFR(1), LBUFR, LBUFR_BYTES, & CWORK(1), size(CWORK), & LSCAL, PT_SCALING(1), size(PT_SCALING), & id%RHSCOMP(IBEG_RHSCOMP), LD_RHSCOMP, NBRHS_EFF, & PTR_POSINRHSCOMP_BWD(1), id%N, & PERM_RHS, size(PERM_RHS)) ! for sparse permuted RHS on host ENDIF DEALLOCATE( CWORK ) END SUBROUTINE CMUMPS_PP_SOLVE END SUBROUTINE CMUMPS_SOLVE_DRIVER MUMPS_5.4.1/src/zlr_type.F0000664000175000017500000000501214102210525015462 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_LR_TYPE IMPLICIT NONE TYPE LRB_TYPE COMPLEX(kind=8),POINTER,DIMENSION(:,:) :: Q => null() COMPLEX(kind=8),POINTER,DIMENSION(:,:) :: R => null() INTEGER :: K,M,N LOGICAL :: ISLR END TYPE LRB_TYPE CONTAINS SUBROUTINE DEALLOC_LRB(LRB_OUT,KEEP8) TYPE(LRB_TYPE), INTENT(INOUT) :: LRB_OUT INTEGER(8) :: KEEP8(150) INTEGER :: MEM IF (LRB_OUT%M.EQ.0) RETURN IF (LRB_OUT%N.EQ.0) RETURN MEM = 0 IF (LRB_OUT%ISLR) THEN IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) IF(associated(LRB_OUT%R)) MEM = MEM + size(LRB_OUT%R) ELSE IF(associated(LRB_OUT%Q)) MEM = MEM + size(LRB_OUT%Q) ENDIF !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(71) = KEEP8(71) - int(MEM,8) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(73) = KEEP8(73) - int(MEM,8) !$OMP END ATOMIC IF (LRB_OUT%ISLR) THEN IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF IF (associated(LRB_OUT%R)) THEN DEALLOCATE (LRB_OUT%R) NULLIFY(LRB_OUT%R) ENDIF ELSE IF (associated(LRB_OUT%Q)) THEN DEALLOCATE (LRB_OUT%Q) NULLIFY(LRB_OUT%Q) ENDIF ENDIF END SUBROUTINE DEALLOC_LRB SUBROUTINE DEALLOC_BLR_PANEL(BLR_PANEL, IEND, KEEP8, IBEG_IN) INTEGER, INTENT(IN) :: IEND TYPE(LRB_TYPE), INTENT(INOUT) :: BLR_PANEL(:) INTEGER(8) :: KEEP8(150) INTEGER, INTENT(IN), OPTIONAL :: IBEG_IN INTEGER :: I, IBEG IF (present(IBEG_IN)) THEN IBEG = IBEG_IN ELSE IBEG = 1 ENDIF IF (IEND.GE.IBEG) THEN IF (BLR_PANEL(1)%M.NE.0) THEN DO I=IBEG, IEND CALL DEALLOC_LRB(BLR_PANEL(I), KEEP8) ENDDO ENDIF ENDIF END SUBROUTINE DEALLOC_BLR_PANEL END MODULE ZMUMPS_LR_TYPE MUMPS_5.4.1/src/zfac_process_master2.F0000664000175000017500000001636314102210524017742 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE ZMUMPS_LOAD USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL ZMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL ZMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE ZMUMPS_PROCESS_MASTER2 MUMPS_5.4.1/src/zlr_stats.F0000664000175000017500000006045514102210525015653 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_LR_STATS USE ZMUMPS_LR_TYPE IMPLICIT NONE DOUBLE PRECISION :: MRY_CB_FR, & MRY_CB_LRGAIN, & MRY_LU_FR, & MRY_LU_LRGAIN, & GLOBAL_MRY_LPRO_COMPR, & GLOBAL_MRY_LTOT_COMPR INTEGER :: CNT_NODES DOUBLE PRECISION :: FLOP_LRGAIN, & FLOP_FACTO_FR, & FLOP_FACTO_LR, & FLOP_PANEL, & FLOP_TRSM, & FLOP_TRSM_FR, & FLOP_TRSM_LR, & FLOP_UPDATE_FR, & FLOP_UPDATE_LR, & FLOP_UPDATE_LRLR1, & FLOP_UPDATE_LRLR2, & FLOP_UPDATE_LRLR3, & FLOP_UPDATE_FRLR, & FLOP_UPDATE_FRFR DOUBLE PRECISION :: FLOP_COMPRESS, & FLOP_CB_COMPRESS, & FLOP_MIDBLK_COMPRESS, & FLOP_FRSWAP_COMPRESS, & FLOP_ACCUM_COMPRESS, & FLOP_DECOMPRESS, & FLOP_CB_DECOMPRESS, & FLOP_FRFRONTS, & FLOP_SOLFWD_FR, & FLOP_SOLFWD_LR DOUBLE PRECISION :: FACTOR_PROCESSED_FRACTION INTEGER(KIND=8) :: FACTOR_SIZE DOUBLE PRECISION :: TOTAL_FLOP DOUBLE PRECISION :: TIME_UPDATE DOUBLE PRECISION :: TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TIME_UPDATE_FRLR DOUBLE PRECISION :: TIME_UPDATE_FRFR DOUBLE PRECISION :: TIME_COMPRESS DOUBLE PRECISION :: TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TIME_CB_COMPRESS DOUBLE PRECISION :: TIME_LR_MODULE DOUBLE PRECISION :: TIME_UPD_NELIM DOUBLE PRECISION :: TIME_LRTRSM DOUBLE PRECISION :: TIME_FRTRSM DOUBLE PRECISION :: TIME_PANEL DOUBLE PRECISION :: TIME_FAC_I DOUBLE PRECISION :: TIME_FAC_MQ DOUBLE PRECISION :: TIME_FAC_SQ DOUBLE PRECISION :: TIME_FRFRONTS DOUBLE PRECISION :: TIME_DIAGCOPY DOUBLE PRECISION :: TIME_DECOMP DOUBLE PRECISION :: TIME_DECOMP_UCFS DOUBLE PRECISION :: TIME_DECOMP_ASM1 DOUBLE PRECISION :: TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TIME_DECOMP_ASMS2M DOUBLE PRECISION :: TIME_LRANA_LRGROUPING DOUBLE PRECISION :: TIME_LRANA_SEPGROUPING DOUBLE PRECISION :: TIME_LRANA_GETHALO DOUBLE PRECISION :: TIME_LRANA_KWAY DOUBLE PRECISION :: TIME_LRANA_GNEW DOUBLE PRECISION :: AVG_FLOP_FACTO_LR DOUBLE PRECISION :: MIN_FLOP_FACTO_LR DOUBLE PRECISION :: MAX_FLOP_FACTO_LR INTEGER :: TOTAL_NBLOCKS_ASS, TOTAL_NBLOCKS_CB INTEGER :: MIN_BLOCKSIZE_ASS, MAX_BLOCKSIZE_ASS INTEGER :: MIN_BLOCKSIZE_CB, MAX_BLOCKSIZE_CB DOUBLE PRECISION :: AVG_BLOCKSIZE_ASS, AVG_BLOCKSIZE_CB CONTAINS SUBROUTINE COLLECT_BLOCKSIZES(CUT,NPARTSASS,NPARTSCB) INTEGER, INTENT(IN) :: NPARTSASS, NPARTSCB INTEGER, POINTER, DIMENSION(:) :: CUT INTEGER :: LOC_MIN_ASS, LOC_MIN_CB, LOC_MAX_ASS, LOC_MAX_CB, & LOC_TOT_ASS, LOC_TOT_CB DOUBLE PRECISION :: LOC_AVG_ASS, LOC_AVG_CB INTEGER :: I LOC_TOT_ASS = 0 LOC_TOT_CB = 0 LOC_AVG_ASS = 0.D0 LOC_AVG_CB = 0.D0 LOC_MIN_ASS = 100000 LOC_MIN_CB = 100000 LOC_MAX_ASS = 0 LOC_MAX_CB = 0 DO I = 1,NPARTSASS LOC_AVG_ASS = ( LOC_TOT_ASS * LOC_AVG_ASS & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_ASS + 1) LOC_TOT_ASS = LOC_TOT_ASS + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_ASS) THEN LOC_MIN_ASS = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_ASS) THEN LOC_MAX_ASS = CUT(I+1) - CUT(I) END IF END DO DO I = NPARTSASS+1,NPARTSASS+NPARTSCB LOC_AVG_CB = ( LOC_TOT_CB * LOC_AVG_CB & + CUT(I+1) - CUT(I) ) & / (LOC_TOT_CB + 1) LOC_TOT_CB = LOC_TOT_CB + 1 IF (CUT(I+1) - CUT(I) .LE. LOC_MIN_CB) THEN LOC_MIN_CB = CUT(I+1) - CUT(I) END IF IF (CUT(I+1) - CUT(I) .GE. LOC_MAX_CB) THEN LOC_MAX_CB = CUT(I+1) - CUT(I) END IF END DO AVG_BLOCKSIZE_ASS = (TOTAL_NBLOCKS_ASS*AVG_BLOCKSIZE_ASS & + LOC_TOT_ASS*LOC_AVG_ASS) / (TOTAL_NBLOCKS_ASS+LOC_TOT_ASS) AVG_BLOCKSIZE_CB = (TOTAL_NBLOCKS_CB*AVG_BLOCKSIZE_CB & + LOC_TOT_CB*LOC_AVG_CB) / (TOTAL_NBLOCKS_CB+LOC_TOT_CB) TOTAL_NBLOCKS_ASS = TOTAL_NBLOCKS_ASS + LOC_TOT_ASS TOTAL_NBLOCKS_CB = TOTAL_NBLOCKS_CB + LOC_TOT_CB MIN_BLOCKSIZE_ASS = min(MIN_BLOCKSIZE_ASS,LOC_MIN_ASS) MIN_BLOCKSIZE_CB = min(MIN_BLOCKSIZE_CB,LOC_MIN_CB) MAX_BLOCKSIZE_ASS = max(MAX_BLOCKSIZE_ASS,LOC_MAX_ASS) MAX_BLOCKSIZE_CB = max(MAX_BLOCKSIZE_CB,LOC_MAX_CB) END SUBROUTINE COLLECT_BLOCKSIZES SUBROUTINE UPD_FLOP_DECOMPRESS(F, CB) DOUBLE PRECISION, INTENT(IN) :: F LOGICAL, INTENT(IN) :: CB !$OMP ATOMIC UPDATE FLOP_DECOMPRESS = FLOP_DECOMPRESS + F !$OMP END ATOMIC IF (CB) THEN !$OMP ATOMIC UPDATE FLOP_CB_DECOMPRESS = FLOP_CB_DECOMPRESS + F !$OMP END ATOMIC ENDIF RETURN END SUBROUTINE UPD_FLOP_DECOMPRESS SUBROUTINE UPD_FLOP_COMPRESS(LR_B, REC_ACC, & CB_COMPRESS, FRSWAP) TYPE(LRB_TYPE),INTENT(IN) :: LR_B INTEGER(8) :: M,N,K DOUBLE PRECISION :: HR_COST,BUILDQ_COST, & HR_AND_BUILDQ_COST LOGICAL, OPTIONAL :: REC_ACC, CB_COMPRESS, FRSWAP M = int(LR_B%M,8) N = int(LR_B%N,8) K = int(LR_B%K,8) HR_COST = dble(K*K*K/3_8 + 4_8*K*M*N - (2_8*M+N)*K*K) IF (LR_B%ISLR) THEN BUILDQ_COST = dble(2_8*K*K*M - K*K*K) ELSE BUILDQ_COST = 0.0d0 END IF HR_AND_BUILDQ_COST = HR_COST + BUILDQ_COST !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + HR_AND_BUILDQ_COST !$OMP END ATOMIC IF (present(REC_ACC)) THEN IF (REC_ACC) THEN !$OMP ATOMIC UPDATE FLOP_ACCUM_COMPRESS = FLOP_ACCUM_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(CB_COMPRESS)) THEN IF (CB_COMPRESS) THEN !$OMP ATOMIC UPDATE FLOP_CB_COMPRESS = FLOP_CB_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF IF (present(FRSWAP)) THEN IF (FRSWAP) THEN !$OMP ATOMIC UPDATE FLOP_FRSWAP_COMPRESS = FLOP_FRSWAP_COMPRESS + & HR_AND_BUILDQ_COST !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE UPD_FLOP_COMPRESS SUBROUTINE UPD_FLOP_TRSM(LRB, LorU) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: LorU DOUBLE PRECISION :: LR_COST, FR_COST, LR_GAIN IF (LorU.EQ.0) THEN FR_COST = dble(LRB%M*LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%K*LRB%N*LRB%N) ELSE LR_COST = FR_COST ENDIF ELSE FR_COST = dble(LRB%M-1)*dble(LRB%N*LRB%N) IF (LRB%ISLR) THEN LR_COST = dble(LRB%N-1)*dble(LRB%N*LRB%K) ELSE LR_COST = FR_COST ENDIF ENDIF LR_GAIN = FR_COST - LR_COST !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_TRSM SUBROUTINE UPD_FLOP_UPDATE(LRB1, LRB2, & MIDBLK_COMPRESS, RANK_IN, BUILDQ, & IS_SYMDIAG, LUA_ACTIVATED, REC_ACC) TYPE(LRB_TYPE),INTENT(IN) :: LRB1,LRB2 LOGICAL, INTENT(IN) :: BUILDQ, IS_SYMDIAG, LUA_ACTIVATED INTEGER, INTENT(IN) :: RANK_IN, MIDBLK_COMPRESS LOGICAL, INTENT(IN), OPTIONAL :: REC_ACC DOUBLE PRECISION :: COST_FR, COST_LR, COST_LRLR1, COST_LRLR2, & COST_LRLR3, COST_FRLR, COST_FRFR, & COST_COMPRESS, COST_LR_AND_COMPRESS, LR_GAIN DOUBLE PRECISION :: M1,N1,K1,M2,N2,K2,RANK LOGICAL :: REC_ACC_LOC M1 = dble(LRB1%M) N1 = dble(LRB1%N) K1 = dble(LRB1%K) M2 = dble(LRB2%M) N2 = dble(LRB2%N) K2 = dble(LRB2%K) RANK = dble(RANK_IN) COST_LRLR1 = 0.0D0 COST_LRLR2 = 0.0D0 COST_LRLR3 = 0.0D0 COST_FRLR = 0.0D0 COST_FRFR = 0.0D0 COST_COMPRESS = 0.0D0 IF (present(REC_ACC)) THEN REC_ACC_LOC = REC_ACC ELSE REC_ACC_LOC = .FALSE. ENDIF IF ((.NOT.LRB1%ISLR).AND.(.NOT.LRB2%ISLR)) THEN COST_FRFR = 2.0D0*M1*M2*N1 COST_LR = 2.0D0*M1*M2*N1 COST_FR = 2.0D0*M1*M2*N1 ELSEIF (LRB1%ISLR.AND.(.NOT.LRB2%ISLR)) THEN COST_FRLR = 2.0D0*K1*M2*N1 COST_LRLR3 = 2.0D0*M1*M2*K1 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSEIF ((.NOT.LRB1%ISLR).AND.LRB2%ISLR) THEN COST_FRLR = 2.0D0*M1*K2*N1 COST_LRLR3 = 2.0D0*M1*M2*K2 COST_LR = COST_FRLR + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ELSE IF (MIDBLK_COMPRESS.GE.1) THEN COST_COMPRESS = RANK*RANK*RANK/3.0D0 + & 4.0D0*RANK*K1*K2 - & (2.0D0*K1+K2)*RANK*RANK IF (BUILDQ) THEN COST_COMPRESS = COST_COMPRESS + 4.0D0*RANK*RANK*K1 & - RANK*RANK*RANK ENDIF ENDIF COST_LRLR1 = 2.0D0*K1*K2*N1 IF ((MIDBLK_COMPRESS.GE.1).AND.BUILDQ) THEN COST_LRLR2 = 2.0D0*K1*M1*RANK + 2.0D0*K2*M2*RANK COST_LRLR3 = 2.0D0*M1*M2*RANK ELSE IF (K1 .GE. K2) THEN COST_LRLR2 = 2.0D0*K1*M1*K2 COST_LRLR3 = 2.0D0*M1*M2*K2 ELSE COST_LRLR2 = 2.0D0*K1*M2*K2 COST_LRLR3 = 2.0D0*M1*M2*K1 ENDIF ENDIF COST_LR = COST_LRLR1 + COST_LRLR2 + COST_LRLR3 COST_FR = 2.0D0*M1*M2*N1 ENDIF IF (IS_SYMDIAG) THEN COST_FR = COST_FR/2.0D0 COST_LRLR3 = COST_LRLR3/2.0D0 COST_FRFR = COST_FRFR/2.0D0 COST_LR = COST_LR - COST_LRLR3 - COST_FRFR ENDIF IF (LUA_ACTIVATED) THEN COST_LR = COST_LR - COST_LRLR3 COST_LRLR3 = 0.0D0 IF (REC_ACC_LOC) THEN COST_LR_AND_COMPRESS = COST_LR + COST_COMPRESS !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_LR_AND_COMPRESS !$OMP END ATOMIC ENDIF ENDIF IF (.NOT.REC_ACC_LOC) THEN !$OMP ATOMIC UPDATE FLOP_COMPRESS = FLOP_COMPRESS + COST_COMPRESS !$OMP END ATOMIC LR_GAIN = COST_FR - COST_LR !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN + LR_GAIN !$OMP END ATOMIC ENDIF END SUBROUTINE UPD_FLOP_UPDATE SUBROUTINE UPD_FLOP_UPDATE_LRLR3(LRB, NIV) TYPE(LRB_TYPE),INTENT(IN) :: LRB INTEGER,INTENT(IN) :: NIV DOUBLE PRECISION :: FLOP_COST FLOP_COST = 2.0D0*dble(LRB%M)*dble(LRB%N)*dble(LRB%K) !$OMP ATOMIC UPDATE FLOP_LRGAIN = FLOP_LRGAIN - FLOP_COST !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_UPDATE_LRLR3 SUBROUTINE UPD_FLOP_ROOT(KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID) INTEGER, intent(in) :: KEEP50, NFRONT, NPIV, & NPROW, NPCOL, MYID DOUBLE PRECISION :: COST, COST_PER_PROC INTEGER, PARAMETER :: LEVEL3 = 3 CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NFRONT, KEEP50, LEVEL3, & COST) COST_PER_PROC = dble(int( COST,8) / int(NPROW * NPCOL,8)) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + COST_PER_PROC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_ROOT SUBROUTINE INIT_STATS_GLOBAL(id) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id MRY_LU_FR = 0.D0 MRY_LU_LRGAIN = 0.D0 MRY_CB_FR = 0.D0 MRY_CB_LRGAIN = 0.D0 FLOP_FACTO_FR = 0.D0 FLOP_FACTO_LR = 0.D0 FLOP_LRGAIN = 0.D0 FLOP_CB_COMPRESS = 0.D0 FLOP_CB_DECOMPRESS = 0.D0 FLOP_DECOMPRESS = 0.D0 FLOP_UPDATE_FR = 0.D0 FLOP_UPDATE_LR = 0.D0 FLOP_UPDATE_LRLR1 = 0.D0 FLOP_UPDATE_LRLR2 = 0.D0 FLOP_UPDATE_LRLR3 = 0.D0 FLOP_UPDATE_FRLR = 0.D0 FLOP_UPDATE_FRFR = 0.D0 FLOP_MIDBLK_COMPRESS = 0.D0 FLOP_TRSM_FR = 0.D0 FLOP_TRSM_LR = 0.D0 FLOP_COMPRESS = 0.D0 FLOP_ACCUM_COMPRESS = 0.D0 FLOP_FRSWAP_COMPRESS = 0.D0 FLOP_PANEL = 0.D0 FLOP_TRSM = 0.D0 FLOP_FRFRONTS = 0.D0 FLOP_SOLFWD_FR = 0.D0 FLOP_SOLFWD_LR = 0.D0 TOTAL_NBLOCKS_ASS = 0 TOTAL_NBLOCKS_CB = 0 AVG_BLOCKSIZE_ASS = 0.D0 AVG_BLOCKSIZE_CB = 0.D0 MIN_BLOCKSIZE_ASS = huge(1) MAX_BLOCKSIZE_ASS = 0 MIN_BLOCKSIZE_CB = huge(1) MAX_BLOCKSIZE_CB = 0 CNT_NODES = 0 TIME_UPDATE = 0.D0 TIME_MIDBLK_COMPRESS = 0.D0 TIME_UPDATE_LRLR1 = 0.D0 TIME_UPDATE_LRLR2 = 0.D0 TIME_UPDATE_LRLR3 = 0.D0 TIME_UPDATE_FRLR = 0.D0 TIME_UPDATE_FRFR = 0.D0 TIME_COMPRESS = 0.D0 TIME_CB_COMPRESS = 0.D0 TIME_LR_MODULE = 0.D0 TIME_UPD_NELIM = 0.D0 TIME_LRTRSM = 0.D0 TIME_FRTRSM = 0.D0 TIME_PANEL = 0.D0 TIME_FAC_I = 0.D0 TIME_FAC_MQ = 0.D0 TIME_FAC_SQ = 0.D0 TIME_FRFRONTS = 0.D0 TIME_DIAGCOPY = 0.D0 TIME_FRSWAP_COMPRESS = 0.D0 TIME_DECOMP = 0.D0 TIME_DECOMP_UCFS = 0.D0 TIME_DECOMP_ASM1 = 0.D0 TIME_DECOMP_LOCASM2 = 0.D0 TIME_DECOMP_MAPLIG1 = 0.D0 TIME_DECOMP_ASMS2S = 0.D0 TIME_DECOMP_ASMS2M = 0.D0 END SUBROUTINE INIT_STATS_GLOBAL SUBROUTINE UPD_MRY_LU_FR(NASS, NCB, SYM, NELIM) INTEGER,INTENT(IN) :: NASS, NCB, SYM, NELIM DOUBLE PRECISION :: MRY INTEGER :: NPIV NPIV = NASS - NELIM IF (SYM .GT. 0) THEN MRY = dble(NPIV)*(dble(NPIV)+1.D0)/2.D0 & + dble(NPIV)*dble(NCB+NELIM) ELSE MRY = dble(NPIV)*dble(NPIV) & + 2.0D0*dble(NPIV)*dble(NCB+NELIM) END IF !$OMP ATOMIC UPDATE MRY_LU_FR = MRY_LU_FR + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_FR SUBROUTINE UPD_MRY_CB(NROWS, NCOLS, & SYM, NIV, LRGAIN) INTEGER,INTENT(IN) :: NROWS, NCOLS, SYM, NIV, LRGAIN DOUBLE PRECISION :: MRY, LRGAIND IF (SYM.EQ.0) THEN MRY = dble(NCOLS)*dble(NROWS) ELSE MRY = dble(NCOLS-NROWS)*dble(NROWS) + & dble(NROWS)*dble(NROWS+1)/2.D0 ENDIF !$OMP ATOMIC UPDATE MRY_CB_FR = MRY_CB_FR + MRY !$OMP END ATOMIC LRGAIND=dble(LRGAIN) !$OMP ATOMIC UPDATE MRY_CB_LRGAIN = MRY_CB_LRGAIN + LRGAIND !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_CB SUBROUTINE UPD_MRY_LU_LRGAIN(BLR_PANEL, NB_INASM, & NB_INCB, DIR) INTEGER,INTENT(IN) :: NB_INASM, NB_INCB TYPE(LRB_TYPE), INTENT(IN) :: BLR_PANEL(:) CHARACTER(len=1) :: DIR DOUBLE PRECISION :: FLOPFR, FLOPLR, MRY INTEGER :: I FLOPFR = 0.0D0 FLOPLR = 0.0D0 MRY = 0.0D0 IF (NB_INASM.GT.0.AND.DIR .EQ.'V') THEN FLOPFR = FLOPFR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) FLOPLR = FLOPLR + dble(BLR_PANEL(1)%N)*dble(BLR_PANEL(1)%N-1) ENDIF DO I = 1, NB_INASM+NB_INCB IF (DIR .EQ. 'V') THEN FLOPFR = FLOPFR + & 2.0D0*dble(BLR_PANEL(I)%M)*dble(BLR_PANEL(I)%N) IF (BLR_PANEL(I)%ISLR) THEN FLOPLR = FLOPLR + & 2.0D0*dble((BLR_PANEL(I)%M+BLR_PANEL(I)%N) & *BLR_PANEL(I)%K) ELSE FLOPLR = FLOPLR + & 2.0D0*dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N) ENDIF ENDIF IF (BLR_PANEL(I)%ISLR) THEN MRY = MRY + dble(BLR_PANEL(I)%M*BLR_PANEL(I)%N & - BLR_PANEL(I)%K*(BLR_PANEL(I)%M + BLR_PANEL(I)%N)) ENDIF ENDDO !$OMP ATOMIC UPDATE MRY_LU_LRGAIN = MRY_LU_LRGAIN + MRY !$OMP END ATOMIC RETURN END SUBROUTINE UPD_MRY_LU_LRGAIN SUBROUTINE UPD_FLOP_FACTO_FR( NFRONT, NASS, NPIV, SYM, NIV) INTEGER,INTENT(IN) :: NFRONT, SYM, NASS, NPIV, NIV DOUBLE PRECISION :: FLOP CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP) !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC END SUBROUTINE UPD_FLOP_FACTO_FR SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2( NROW1, NCOL1, & NASS1, KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FACTO_FR = FLOP_FACTO_FR + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE STATS_COMPUTE_FLOP_SLAVE_TYPE2 SUBROUTINE UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, SYM, & NIV) INTEGER, INTENT(IN) :: NFRONT, NPIV, NASS, SYM, NIV DOUBLE PRECISION :: FLOP_FAC CALL MUMPS_GET_FLOPS_COST(NFRONT, NPIV, NASS, & SYM, NIV, FLOP_FAC) !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP_FAC !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONTS SUBROUTINE UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP50, INODE) INTEGER,INTENT(IN) :: NROW1, NCOL1, KEEP50, NASS1, INODE DOUBLE PRECISION :: NROW2, NCOL2, NASS2 DOUBLE PRECISION :: FLOP NROW2 = dble(NROW1) NCOL2 = dble(NCOL1) NASS2 = dble(NASS1) IF (KEEP50.EQ.0) THEN FLOP = NROW2*NASS2*NASS2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2) ELSE FLOP = & NROW2*NASS2*NASS2 & + NROW2*NASS2*NROW2 & + 2.0D0*NROW2*NASS2*(NCOL2-NASS2-NROW2) ENDIF !$OMP ATOMIC UPDATE FLOP_FRFRONTS = FLOP_FRFRONTS + FLOP !$OMP END ATOMIC RETURN END SUBROUTINE UPD_FLOP_FRFRONT_SLAVE SUBROUTINE COMPUTE_GLOBAL_GAINS(NB_ENTRIES_FACTOR, & FLOP_NUMBER, NB_ENTRIES_FACTOR_withLR, & PROKG, MPG) INTEGER(8), INTENT(IN) :: NB_ENTRIES_FACTOR INTEGER, INTENT(IN) :: MPG LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION, INTENT(IN) :: FLOP_NUMBER INTEGER(8), INTENT(OUT) :: & NB_ENTRIES_FACTOR_withLR IF (NB_ENTRIES_FACTOR < 0) THEN IF (PROKG.AND.MPG.GT.0) THEN WRITE(MPG,*) "NEGATIVE NUMBER OF ENTRIES IN FACTOR" WRITE(MPG,*) "===> OVERFLOW ?" END IF END IF IF (MRY_LU_FR .EQ. 0) THEN GLOBAL_MRY_LPRO_COMPR = 100.0D0 ELSE GLOBAL_MRY_LPRO_COMPR = 100.0D0 * & MRY_LU_LRGAIN/MRY_LU_FR ENDIF IF (MRY_CB_FR .EQ. 0) THEN MRY_CB_FR = 100.0D0 END IF NB_ENTRIES_FACTOR_withLR = NB_ENTRIES_FACTOR - & int(MRY_LU_LRGAIN,8) IF (NB_ENTRIES_FACTOR.EQ.0) THEN FACTOR_PROCESSED_FRACTION = 100.0D0 GLOBAL_MRY_LTOT_COMPR = 100.0D0 ELSE FACTOR_PROCESSED_FRACTION = 100.0D0 * & MRY_LU_FR/dble(NB_ENTRIES_FACTOR) GLOBAL_MRY_LTOT_COMPR = & 100.0D0*MRY_LU_LRGAIN/dble(NB_ENTRIES_FACTOR) ENDIF TOTAL_FLOP = FLOP_NUMBER FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN + FLOP_COMPRESS & + FLOP_DECOMPRESS RETURN END SUBROUTINE COMPUTE_GLOBAL_GAINS SUBROUTINE SAVEandWRITE_GAINS(LOCAL, K489, DKEEP, N, & ICNTL36, & DEPTH, BCKSZ, NASSMIN, NFRONTMIN, SYM, K486, & K472, K475, K478, K480, K481, K483, K484, & K8110, K849, & NBTREENODES, NPROCS, MPG, PROKG) INTEGER, INTENT(IN) :: LOCAL,K489,DEPTH, N, & ICNTL36, BCKSZ,NASSMIN, & NFRONTMIN, K486, NBTREENODES, MPG, & K472, K475, K478, K480, K481, K483, K484, & SYM, NPROCS INTEGER(8), INTENT(IN) :: K8110, K849 LOGICAL, INTENT(IN) :: PROKG DOUBLE PRECISION :: DKEEP(230) LOGICAL PROK PROK = (PROKG.AND.(MPG.GE.0)) IF (PROK) THEN WRITE(MPG,'(/A,A)') & '-------------- Beginning of BLR statistics -------------------', & '--------------' WRITE(MPG,'(A,I2)') & ' ICNTL(36) BLR variant = ', ICNTL36 WRITE(MPG,'(A,ES8.1)') & ' CNTL(7) Dropping parameter controlling accuracy = ', & DKEEP(8) WRITE(MPG,'(A)') & ' Statistics after BLR factorization :' WRITE(MPG,'(A,I8)') & ' Number of BLR fronts = ', & CNT_NODES ENDIF IF (PROK) WRITE(MPG,'(A,F8.1,A)') & ' Fraction of factors in BLR fronts =', & FACTOR_PROCESSED_FRACTION,'% ' IF (PROK) THEN WRITE(MPG,'(A)') & ' Statistics on the number of entries in factors :' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(29) Theoretical nb of entries in factors =' & ,dble(K8110),' (100.0%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' INFOG(35) Effective nb of entries (% of INFOG(29)) =' & ,dble(K849),' (' & ,dble(100)*(dble(K849)/dble(max(K8110,1_8))) & ,'%)' ENDIF IF (PROK) WRITE(MPG,'(A)') & ' Statistics on operation counts (OPC):' TOTAL_FLOP = MAX(TOTAL_FLOP,EPSILON(1.0D0)) DKEEP(55)=dble(TOTAL_FLOP) DKEEP(60)=dble(100) DKEEP(56)=dble(FLOP_FACTO_LR+FLOP_FRFRONTS) DKEEP(61)=dble(100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP) IF (PROK) THEN WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(3) Total theoretical operations counts =' & ,TOTAL_FLOP,' (',100*TOTAL_FLOP/TOTAL_FLOP,'%)' WRITE(MPG,'(A,ES10.3,A,F5.1,A)') & ' RINFOG(14) Total effective OPC (% of RINFOG(3)) =' & ,FLOP_FACTO_LR+FLOP_FRFRONTS,' (' &,100*(FLOP_FACTO_LR+FLOP_FRFRONTS)/TOTAL_FLOP &,'%)' ENDIF IF (PROK) WRITE(MPG,'(A,A)') & '-------------- End of BLR statistics -------------------------', & '--------------' RETURN END SUBROUTINE SAVEandWRITE_GAINS END MODULE ZMUMPS_LR_STATS MUMPS_5.4.1/src/zsol_fwd.F0000664000175000017500000001456014102210525015451 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOL_R(N, A, LA, IW, LIW, WCB, LWCB, & NRHS, & PTRICB, IWCB, LIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & STEP, & FRERE, DAD, FILS, & NSTK, IPOOL, LPOOL, PTRIST, PTRFAC, MYLEAF, MYROOT, & INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE ZMUMPS_STATIC_PTR_M, ONLY : ZMUMPS_SET_STATIC_PTR, & ZMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER, INTENT(IN) :: N, LIW, LPOOL, LIWCB INTEGER, INTENT(IN) :: SLAVEF, MYLEAF, MYROOT, COMM, MYID INTEGER INFO( 80 ), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER NRHS COMPLEX(kind=8) A( LA ), WCB( LWCB ) INTEGER(8), intent(in) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT( LRHS_ROOT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER STEP( N ), FRERE( KEEP(28) ), FILS( N ), & DAD( KEEP(28) ) INTEGER NSTK(KEEP(28)), IPOOL( LPOOL ) INTEGER PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRICB( KEEP(28) ) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) INTEGER IW( LIW ), IWCB( LIWCB ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), LRHSCOMP COMPLEX(kind=8), intent(inout) :: RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY(1) LOGICAL FLAG COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER NBFIN, MYROOT_LEFT INTEGER POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INODE, IFATH INTEGER III, LEAF LOGICAL BLOQ EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL ERROR_WAS_BROADCASTED DUMMY(1) = 1 KEEP(266)=0 POSIWCB = LIWCB POSWCB = LWCB PLEFTWCB= 1_8 PTRICB = 0 LEAF = MYLEAF + 1 III = 1 NBFIN = SLAVEF MYROOT_LEFT = MYROOT IF ( MYROOT_LEFT .EQ. 0 ) THEN NBFIN = NBFIN - 1 CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, & RACINE_SOLVE, SLAVEF, KEEP) IF (NBFIN.EQ.0) GOTO 260 END IF 50 CONTINUE IF (SLAVEF .EQ. 1) THEN CALL ZMUMPS_GET_INODE_FROM_POOL & ( IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF BLOQ = ( ( III .EQ. LEAF ) & ) CALL ZMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 .OR. NBFIN .EQ. 0 ) GOTO 260 IF (.not. FLAG) THEN IF (III .NE. LEAF) THEN CALL ZMUMPS_GET_INODE_FROM_POOL & (IPOOL(1), LPOOL, III, LEAF, INODE, & KEEP(208) ) GOTO 60 ENDIF ENDIF GOTO 50 60 CONTINUE CALL ZMUMPS_SET_STATIC_PTR(A) CALL ZMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL ZMUMPS_SOLVE_NODE_FWD( INODE, & huge(INODE), huge(INODE), & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, N, & IPOOL, LPOOL, LEAF, NBFIN, NSTK, & IWCB, LIWCB, WCB, LWCB, A_PTR(1), LA_PTR, & IW, LIW, NRHS, & POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE & , FROM_PP & , ERROR_WAS_BROADCASTED & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF GOTO 260 ENDIF IFATH = DAD(STEP(INODE)) IF ( IFATH .EQ. 0 ) THEN MYROOT_LEFT = MYROOT_LEFT - 1 IF (MYROOT_LEFT .EQ. 0) THEN NBFIN = NBFIN - 1 IF (SLAVEF .GT. 1) THEN CALL ZMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, & COMM, RACINE_SOLVE, SLAVEF, KEEP) ENDIF END IF ELSE IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IFATH)), KEEP(199)) & .EQ. MYID ) THEN IF ( PTRICB(STEP(INODE)) .EQ. 1 .OR. & PTRICB(STEP(INODE)) .EQ. -1 ) THEN NSTK(STEP(IFATH)) = NSTK(STEP(IFATH)) - 1 IF (NSTK(STEP(IFATH)) .EQ. 0) THEN IPOOL(LEAF) = IFATH LEAF = LEAF + 1 IF (LEAF .GT. LPOOL) THEN WRITE(*,*) & 'Internal error ZMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() ENDIF ENDIF PTRICB(STEP(INODE)) = 0 ENDIF ENDIF ENDIF IF ( NBFIN .EQ. 0 ) GOTO 260 GOTO 50 260 CONTINUE CALL ZMUMPS_CLEAN_PENDING(INFO(1), KEEP, BUFR, LBUFR,LBUFR_BYTES, & COMM, DUMMY(1), & SLAVEF, .TRUE., .FALSE.) RETURN END SUBROUTINE ZMUMPS_SOL_R MUMPS_5.4.1/src/dmumps_save_restore_files.F0000664000175000017500000002617014102210523021070 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_SAVE_RESTORE_FILES USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER :: LEN_SAVE_FILE PARAMETER( LEN_SAVE_FILE = 550) CONTAINS SUBROUTINE MUMPS_READ_HEADER(fileunit, ierr, size_read, SIZE_INT & ,SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE & ,READ_ARITH, READ_INT_TYPE_64 & ,READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME & ,READ_HASH,READ_SYM,READ_PAR,READ_NPROCS & ,FORTRAN_VERSION_OK) INTEGER,intent(in) :: fileunit INTEGER,intent(out) :: ierr INTEGER(8), intent(inout) :: size_read INTEGER,intent(in) :: SIZE_INT, SIZE_INT8 INTEGER(8), intent(out) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE CHARACTER, intent(out) :: READ_ARITH LOGICAL, intent(out) :: READ_INT_TYPE_64 INTEGER, intent(out) :: READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(out)::READ_OOC_FIRST_FILE_NAME CHARACTER(len=23), intent(out) :: READ_HASH INTEGER, intent(out) :: READ_SYM,READ_PAR,READ_NPROCS LOGICAL, intent(out) :: FORTRAN_VERSION_OK CHARACTER(len=5) :: READ_FORTRAN_VERSION INTEGER :: SIZE_CHARACTER, SIZE_LOGICAL INTEGER :: dummy SIZE_CHARACTER = 1 SIZE_LOGICAL = 4 FORTRAN_VERSION_OK = .true. read(fileunit,iostat=ierr) READ_FORTRAN_VERSION if(ierr.ne.0) GOTO 100 if (READ_FORTRAN_VERSION.NE."MUMPS") THEN ierr = 0 FORTRAN_VERSION_OK = .false. GOTO 100 endif size_read=size_read+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_HASH if(ierr.ne.0) GOTO 100 size_read=size_read+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(ierr.ne.0) GOTO 100 size_read=size_read+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_ARITH if(ierr.ne.0) GOTO 100 size_read=size_read+int(1,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_SYM,READ_PAR,READ_NPROCS if(ierr.ne.0) GOTO 100 size_read=size_read+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_INT_TYPE_64 if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif read(fileunit,iostat=ierr) READ_OOC_FILE_NAME_LENGTH if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif IF(READ_OOC_FILE_NAME_LENGTH.EQ.-999) THEN read(fileunit,iostat=ierr) dummy if(ierr.ne.0) GOTO 100 size_read=size_read+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif ELSE read(fileunit,iostat=ierr) & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH) if(ierr.ne.0) GOTO 100 size_read=size_read+int( & READ_OOC_FILE_NAME_LENGTH*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*1,kind=8) #endif #if defined(OOC_VERBOSE) write(*,*) 'First ooc file: ', & READ_OOC_FIRST_FILE_NAME(1:READ_OOC_FILE_NAME_LENGTH-2) #endif ENDIF 100 continue RETURN END SUBROUTINE MUMPS_READ_HEADER SUBROUTINE DMUMPS_CHECK_HEADER(id, BASIC_CHECK, READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC),intent(inout) :: id LOGICAL, intent(in) :: BASIC_CHECK LOGICAL, intent(in) :: READ_INT_TYPE_64 CHARACTER(len=23), intent(in) :: READ_HASH INTEGER, intent(in) :: READ_NPROCS CHARACTER, intent(in) :: READ_ARITH INTEGER, intent(in) :: READ_SYM,READ_PAR LOGICAL :: INT_TYPE_64 CHARACTER(len=23) :: HASH_MASTER CHARACTER :: ARITH INTEGER :: IERR IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF if(INT_TYPE_64.neqv.READ_INT_TYPE_64) THEN id%INFO(1) = -73 id%INFO(2) = 2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%MYID.EQ.0) THEN HASH_MASTER=READ_HASH ENDIF call MPI_BCAST(HASH_MASTER,23,MPI_CHARACTER,0,id%COMM,IERR) if(HASH_MASTER.ne.READ_HASH) THEN id%INFO(1) = -73 id%INFO(2) = 3 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(id%NPROCS.ne.READ_NPROCS) THEN id%INFO(1) = -73 id%INFO(2) = 4 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF (.NOT.BASIC_CHECK) THEN ARITH="DMUMPS"(1:1) if(ARITH.ne.READ_ARITH) THEN id%INFO(1) = -73 id%INFO(2) = 5 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%SYM.ne.READ_SYM)) THEN id%INFO(1) = -73 id%INFO(2) = 6 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if((id%MYID.EQ.0).AND.(id%PAR.ne.READ_PAR)) THEN write (*,*) id%MYID, 'PAR ',id%PAR, 'READ_PAR ', READ_PAR id%INFO(1) = -73 id%INFO(2) = 7 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF 100 continue RETURN END SUBROUTINE DMUMPS_CHECK_HEADER SUBROUTINE MUMPS_CLEAN_SAVED_DATA(MYID,ierr,SUPPFILE,INFOFILE) INCLUDE 'mpif.h' INTEGER,intent(in) :: MYID INTEGER,intent(out) :: ierr CHARACTER(len=LEN_SAVE_FILE),intent(in):: SUPPFILE,INFOFILE INTEGER::supp,tmp_err ierr = 0 tmp_err = 0 supp=200+MYID open(UNIT=supp,FILE=SUPPFILE,STATUS='old', & form='unformatted',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) if(tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif endif if (ierr .eq. 0) then if (tmp_err.ne.0) then ierr = 1 tmp_err = 0 endif open(UNIT=supp,FILE=INFOFILE,STATUS='old',iostat=tmp_err) if (tmp_err.eq.0) THEN close(UNIT=supp,STATUS='delete',iostat=tmp_err) endif if (tmp_err.ne.0) THEN ierr = ierr + 2 tmp_err = 0 endif endif END SUBROUTINE MUMPS_CLEAN_SAVED_DATA SUBROUTINE DMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) INCLUDE 'mpif.h' TYPE (DMUMPS_STRUC),intent(inout) :: id CHARACTER(len=LEN_SAVE_FILE),intent(out):: SAVE_FILE, INFO_FILE INTEGER::len_save_dir,len_save_prefix CHARACTER(len=255):: tmp_savedir,savedir CHARACTER(len=255):: tmp_saveprefix,saveprefix CHARACTER(len=10):: STRING_MYID CHARACTER:: LAST_CHAR_DIR INFO_FILE='' SAVE_FILE='' tmp_savedir='' tmp_saveprefix='' IF(id%SAVE_DIR.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_dir_C(len_save_dir,tmp_savedir) if(tmp_savedir(1:len_save_dir).EQ."NAME_NOT_INITIALIZED") then id%INFO(1) = -77 id%INFO(2) = 0 else savedir=trim(adjustl(tmp_savedir(1:len_save_dir))) len_save_dir=len_trim(savedir(1:len_save_dir)) endif ELSE savedir=trim(adjustl(id%SAVE_DIR)) len_save_dir=len_trim(savedir) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 IF(id%SAVE_PREFIX.EQ."NAME_NOT_INITIALIZED") THEN call mumps_get_save_prefix_C(len_save_prefix,tmp_saveprefix) if(tmp_saveprefix(1:len_save_prefix).EQ."NAME_NOT_INITIALIZED") & then saveprefix="save" len_save_prefix=len_trim(saveprefix) else saveprefix= & trim(adjustl(tmp_saveprefix(1:len_save_prefix))) len_save_prefix=len_trim(saveprefix(1:len_save_prefix)) endif ELSE saveprefix=trim(adjustl(id%SAVE_PREFIX)) len_save_prefix=len_trim(saveprefix) ENDIF write(STRING_MYID,'(I10)') id%MYID LAST_CHAR_DIR=savedir(len_save_dir:len_save_dir) if(LAST_CHAR_DIR.NE."/") then SAVE_FILE=trim(adjustl(savedir))//"/" else SAVE_FILE=trim(adjustl(savedir)) endif INFO_FILE=trim(adjustl(SAVE_FILE)) SAVE_FILE=trim(adjustl(SAVE_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".mumps" INFO_FILE=trim(adjustl(INFO_FILE)) & //trim(adjustl(saveprefix)) & //"_" & //trim(adjustl(STRING_MYID)) & //".info" 100 continue RETURN END SUBROUTINE DMUMPS_GET_SAVE_FILES SUBROUTINE DMUMPS_CHECK_FILE_NAME(id,NAME_LENGTH,FILE_NAME,CHECK) TYPE (DMUMPS_STRUC),intent(in) :: id INTEGER,intent(in) :: NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE),intent(in) :: FILE_NAME LOGICAL,intent(out) :: CHECK INTEGER :: I CHECK = .false. IF (NAME_LENGTH.NE.-999) THEN IF (associated(id%OOC_FILE_NAME_LENGTH) .AND. & associated(id%OOC_FILE_NAMES)) THEN IF (NAME_LENGTH .EQ. id%OOC_FILE_NAME_LENGTH(1)) THEN CHECK = .true. I = 1 DO WHILE(I.LE.NAME_LENGTH) IF (FILE_NAME(I:I).NE.id%OOC_FILE_NAMES(1,I)) THEN CHECK = .false. I = NAME_LENGTH + 1 ELSE I = I + 1 ENDIF END DO ENDIF ENDIF ENDIF END SUBROUTINE DMUMPS_CHECK_FILE_NAME END MODULE DMUMPS_SAVE_RESTORE_FILES SUBROUTINE DMUMPS_SAVE_FILES_RETURN() RETURN END SUBROUTINE DMUMPS_SAVE_FILES_RETURN MUMPS_5.4.1/src/ztype3_root.F0000664000175000017500000015217514102210524016127 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ASS_ROOT( root, KEEP50, & NROW_SON, NCOL_SON, INDROW_SON, & INDCOL_SON, NSUPCOL, VAL_SON, VAL_ROOT, & LOCAL_M, LOCAL_N, & RHS_ROOT, NLOC_ROOT, CBP ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER, INTENT(IN) :: KEEP50 INTEGER NCOL_SON, NROW_SON, NSUPCOL INTEGER, intent(in) :: CBP INTEGER INDROW_SON( NROW_SON ), INDCOL_SON( NCOL_SON ) INTEGER LOCAL_M, LOCAL_N COMPLEX(kind=8) VAL_SON( NCOL_SON, NROW_SON ) COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NLOC_ROOT COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC_ROOT ) INTEGER I, J, INDROW, INDCOL, IPOSROOT, JPOSROOT IF (CBP .EQ. 0) THEN DO I = 1, NROW_SON INDROW = INDROW_SON(I) IPOSROOT = (root%NPROW*((INDROW-1)/root%MBLOCK)+root%MYROW) & * root%MBLOCK + mod(INDROW-1,root%MBLOCK) + 1 DO J = 1, NCOL_SON-NSUPCOL INDCOL = INDCOL_SON(J) IF (KEEP50.NE.0) THEN JPOSROOT = (root%NPCOL*((INDCOL-1)/root%NBLOCK)+root%MYCOL) & * root%NBLOCK + mod(INDCOL-1,root%NBLOCK) + 1 IF (IPOSROOT < JPOSROOT) THEN CYCLE ENDIF ENDIF VAL_ROOT( INDROW, INDCOL ) = & VAL_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) END DO DO J = NCOL_SON-NSUPCOL+1, NCOL_SON INDCOL = INDCOL_SON(J) RHS_ROOT( INDROW, INDCOL ) = & RHS_ROOT( INDROW, INDCOL ) + VAL_SON(J,I) ENDDO END DO ELSE DO I=1, NROW_SON DO J = 1, NCOL_SON RHS_ROOT( INDROW_SON( I ), INDCOL_SON(J)) = & RHS_ROOT(INDROW_SON(I),INDCOL_SON(J)) + VAL_SON(J,I) ENDDO ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ASS_ROOT RECURSIVE SUBROUTINE ZMUMPS_BUILD_AND_SEND_CB_ROOT & ( COMM_LOAD, ASS_IRECV, N, ISON, IROOT, & PTRI, PTRR, & root, NBROW, NBCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, SHIFT_VAL_SON_ARG, LDA_ARG, TAG, & MYID, COMM, BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE ZMUMPS_OOC USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N, ISON, IROOT, TAG INTEGER PTRI( KEEP(28) ) INTEGER(8) :: PTRR( KEEP(28) ) INTEGER NBROW, NBCOL INTEGER, INTENT(IN):: LDA_ARG INTEGER(8), INTENT(IN) :: SHIFT_VAL_SON_ARG INTEGER SHIFT_LIST_ROW_SON, SHIFT_LIST_COL_SON INTEGER MYID, COMM LOGICAL TRANSPOSE_ASM INCLUDE 'mpif.h' INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER LIW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NSTK( N ) INTEGER COMP, IFLAG, IERROR INTEGER PERM(N) INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NBFIN, SLAVEF DOUBLE PRECISION OPASSW, OPELIW INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER INTARR( KEEP8(27) ) COMPLEX(kind=8) DBLARR( KEEP8(26) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX(kind=8), DIMENSION(:), POINTER :: SONA_PTR INTEGER(8) :: LSONA_PTR, POSSONA_PTR INTEGER allocok INTEGER, ALLOCATABLE, DIMENSION(:) :: PTRROW, PTRCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: NSUPROW, NSUPCOL INTEGER, ALLOCATABLE, DIMENSION(:) :: ROW_INDEX_LIST INTEGER, ALLOCATABLE, DIMENSION(:) :: COL_INDEX_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER I, POS_IN_ROOT, IROW, JCOL, IGLOB, JGLOB INTEGER PDEST, IERR INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: POSROOT INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER NRLOCAL, NCLOCAL INTEGER :: LDA INTEGER(8) :: SHIFT_VAL_SON LOGICAL SET_IRECV, BLOCKING, MESSAGE_RECEIVED INTEGER NBROWS_ALREADY_SENT INTEGER SIZE_MSG INTEGER LP INCLUDE 'mumps_headers.h' LOGICAL SKIPLAST_RHS_ROWS, BCP_SYM_NONEMPTY INTEGER BBPCBP INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE BBPCBP = 0 LP = ICNTL(1) IF ( ICNTL(4) .LE. 0 ) LP = -1 IF (LDA_ARG < 0) THEN CALL ZMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ELSE LDA = LDA_ARG SHIFT_VAL_SON = SHIFT_VAL_SON_ARG ENDIF ALLOCATE(PTRROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(PTRCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif ALLOCATE(NSUPROW(root%NPROW + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPROW + 1 endif ALLOCATE(NSUPCOL(root%NPCOL + 1 ), stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = root%NPCOL + 1 endif IF (IFLAG.LT.0) THEN IF (LP > 0) write(6,*) MYID, ' : MEMORY ALLOCATION ', & 'FAILURE in ZMUMPS_BUILD_AND_SEND_CB_ROOT' CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF SKIPLAST_RHS_ROWS = ((KEEP(253).GT.0).AND.(KEEP(50).EQ.0)) BCP_SYM_NONEMPTY = .FALSE. PTRROW = 0 PTRCOL = 0 NSUPROW = 0 NSUPCOL = 0 DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) THEN BCP_SYM_NONEMPTY = .TRUE. POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ELSE IF (IGLOB .GT. N) THEN POS_IN_ROOT = IGLOB - N ELSE POS_IN_ROOT = root%RG2L_COL( IGLOB ) ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF (IGLOB.GT.N) & NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 PTRCOL( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 END IF END DO IF (KEEP(50).NE.0 .AND.(.NOT.TRANSPOSE_ASM).AND.BCP_SYM_NONEMPTY) & BBPCBP = 1 DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_COL_SON + I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (KEEP(50).EQ.0) THEN IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL(JGLOB) ELSE POS_IN_ROOT = JGLOB-N ENDIF JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) IF (JGLOB.GT.N) THEN NSUPCOL(JCOL+1) = NSUPCOL(JCOL+1) + 1 ENDIF PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 ELSE POS_IN_ROOT = root%RG2L_COL(JGLOB) JCOL = mod((POS_IN_ROOT-1) / root%NBLOCK, root%NPCOL ) PTRCOL ( JCOL + 2 ) = PTRCOL( JCOL + 2 ) + 1 IF (BCP_SYM_NONEMPTY) THEN POS_IN_ROOT = root%RG2L_ROW(JGLOB) IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) NSUPROW(IROW+1) = NSUPROW(IROW+1)+1 PTRROW( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 ENDIF ENDIF ELSE IF (JGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB-N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) PTRROW ( IROW + 2 ) = PTRROW( IROW + 2 ) + 1 END IF END DO PTRROW( 1 ) = 1 DO IROW = 2, root%NPROW + 1 PTRROW( IROW ) = PTRROW( IROW ) + PTRROW( IROW - 1 ) END DO PTRCOL( 1 ) = 1 DO JCOL = 2, root%NPCOL + 1 PTRCOL( JCOL ) = PTRCOL( JCOL ) + PTRCOL( JCOL - 1 ) END DO ALLOCATE(ROW_INDEX_LIST(PTRROW(root%NPROW+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRROW(root%NPROW+1)-1+1 endif ALLOCATE(COL_INDEX_LIST(PTRCOL(root%NPCOL+1)-1+1), & stat=allocok) if (allocok .GT. 0) THEN IFLAG =-13 IERROR = PTRCOL(root%NPCOL+1)-1+1 endif DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (SKIPLAST_RHS_ROWS.AND.(IGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF (IGLOB.GT.N) CYCLE POS_IN_ROOT = root%RG2L_ROW( IGLOB ) IROW = mod( ( POS_IN_ROOT - 1 ) / root%MBLOCK, & root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW ( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ELSE IF (IGLOB.LE.N) THEN POS_IN_ROOT = root%RG2L_COL( IGLOB ) ELSE POS_IN_ROOT = IGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / root%NBLOCK, & root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 END IF END DO DO I = 1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF ((KEEP(50).GT.0) .AND. (JGLOB.GT.N)) CYCLE IF ( .NOT. TRANSPOSE_ASM ) THEN IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_COL( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF JCOL = mod( ( POS_IN_ROOT - 1 ) / & root%NBLOCK, root%NPCOL ) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ELSE IF ( JGLOB.LE.N ) THEN POS_IN_ROOT = root%RG2L_ROW( JGLOB ) ELSE POS_IN_ROOT = JGLOB - N ENDIF IROW = mod( ( POS_IN_ROOT - 1 ) / & root%MBLOCK, root%NPROW ) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 END IF END DO IF (BCP_SYM_NONEMPTY) THEN DO I = 1, NBROW IGLOB = IW( PTRI(STEP(ISON)) + & SHIFT_LIST_ROW_SON + I - 1 ) IF (IGLOB.LE.N) CYCLE POS_IN_ROOT = IGLOB - N JCOL = mod((POS_IN_ROOT-1)/root%NBLOCK,root%NPCOL) COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ) = I PTRCOL ( JCOL + 1 ) = PTRCOL( JCOL + 1 ) + 1 ENDDO DO I=1, NBCOL JGLOB = IW( PTRI(STEP(ISON))+SHIFT_LIST_COL_SON+I - 1 ) IF (JGLOB.GT.N) THEN EXIT ELSE POS_IN_ROOT = root%RG2L_ROW(JGLOB) ENDIF IROW = mod((POS_IN_ROOT-1)/root%MBLOCK,root%NPROW) ROW_INDEX_LIST( PTRROW( IROW + 1 ) ) = I PTRROW( IROW + 1 ) = PTRROW( IROW + 1 ) + 1 ENDDO ENDIF DO IROW = root%NPROW, 2, -1 PTRROW( IROW ) = PTRROW( IROW - 1 ) END DO PTRROW( 1 ) = 1 DO JCOL = root%NPCOL, 2, -1 PTRCOL( JCOL ) = PTRCOL( JCOL - 1 ) END DO PTRCOL( 1 ) = 1 JCOL = root%MYCOL IROW = root%MYROW IF ( root%yes ) THEN if (IROW .ne. root%MYROW .or. JCOL.ne.root%MYCOL) then write(*,*) ' error in grid position buildandsendcbroot' CALL MUMPS_ABORT() end if IF ( PTRIST(STEP(IROOT)).EQ.0.AND. & PTLUST_S(STEP(IROOT)).EQ.0) THEN CALL ZMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, IW, LIW, & A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP, IERROR ) KEEP(121) = -1 IF (IFLAG.LT.0) THEN CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF ELSE KEEP(121) = KEEP(121) - 1 IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL ZMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL ZMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT+N ) IF (KEEP(47) .GE. 3) THEN CALL ZMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF END IF CALL ZMUMPS_DM_SET_DYNPTR( IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) IF (KEEP(60) .NE. 0 ) THEN LOCAL_M = root%SCHUR_LLD LOCAL_N = root%SCHUR_NLOC NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) CALL ZMUMPS_ROOT_LOCAL_ASSEMBLY( N, & root%SCHUR_POINTER(1), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) ELSE IF ( PTRIST(STEP( IROOT )) .GE. 0 ) THEN IF ( PTRIST(STEP( IROOT )) .EQ. 0 ) THEN LOCAL_N = IW( PTLUST_S(STEP(IROOT)) + 1 + KEEP(IXSZ)) LOCAL_M = IW( PTLUST_S(STEP(IROOT)) + 2 + KEEP(IXSZ)) POSROOT = PTRFAC(IW( PTLUST_S(STEP(IROOT)) +4+KEEP(IXSZ) )) ELSE LOCAL_N = - IW( PTRIST(STEP(IROOT)) +KEEP(IXSZ)) LOCAL_M = IW( PTRIST(STEP(IROOT)) + 1 +KEEP(IXSZ)) POSROOT = PAMASTER(STEP( IROOT )) ENDIF NCLOCAL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) NRLOCAL = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) CALL ZMUMPS_ROOT_LOCAL_ASSEMBLY( N, A( POSROOT ), & LOCAL_M, LOCAL_N, & root%NPCOL, root%NPROW, root%MBLOCK, root%NBLOCK, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NRLOCAL, & NCLOCAL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%RG2L_ROW(1), root%RG2L_COL(1), TRANSPOSE_ASM, & KEEP, & root%RHS_ROOT(1,1), root%RHS_NLOC ) END IF ENDIF END IF DO IROW = 0, root%NPROW - 1 DO JCOL = 0, root%NPCOL - 1 PDEST = IROW * root%NPCOL + JCOL IF ( (root%MYROW.eq.IROW.and.root%MYCOL.eq.JCOL) .and. & MYID.ne.PDEST) THEN write(*,*) 'error: myrow,mycol=',root%MYROW,root%MYCOL write(*,*) ' MYID,PDEST=',MYID,PDEST CALL MUMPS_ABORT() END IF IF ( root%MYROW .NE. IROW .OR. root%MYCOL .NE. JCOL) THEN NBROWS_ALREADY_SENT = 0 IERR = -1 DO WHILE ( IERR .EQ. -1 ) NSUBSET_ROW = PTRROW( IROW + 2 ) - PTRROW( IROW + 1 ) NSUBSET_COL = PTRCOL( JCOL + 2 ) - PTRCOL( JCOL + 1 ) IF ( LRLU .LT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) & .AND. LRLUS .GT. int(NSUBSET_ROW,8) * int(NSUBSET_COL,8) ) & THEN CALL ZMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) MYID,": pb compress in", & "ZMUMPS_BUILD_AND_SEND_CB_ROOT" WRITE(*,*) MYID,': LRLU, LRLUS=',LRLU,LRLUS CALL MUMPS_ABORT() END IF END IF CALL ZMUMPS_DM_SET_DYNPTR( & IW(PTRI(STEP(ISON))+XXS), A, LA, & PTRR(STEP(ISON)), IW(PTRI(STEP(ISON))+XXD), & IW(PTRI(STEP(ISON))+XXR), & SONA_PTR, POSSONA_PTR, LSONA_PTR ) CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE3_I( N, ISON, & NBCOL, NBROW, & IW( PTRI(STEP(ISON)) + SHIFT_LIST_COL_SON ), & IW( PTRI(STEP(ISON)) + SHIFT_LIST_ROW_SON ), & LDA, SONA_PTR( POSSONA_PTR + SHIFT_VAL_SON ), & TAG, & ROW_INDEX_LIST( PTRROW( IROW + 1 ) ), & COL_INDEX_LIST( PTRCOL( JCOL + 1 ) ), & NSUBSET_ROW, NSUBSET_COL, & NSUPROW(IROW+1), NSUPCOL(JCOL+1), & root%NPROW, root%NPCOL, root%MBLOCK, & root%RG2L_ROW(1), root%RG2L_COL(1), & root%NBLOCK, PDEST, & COMM, IERR, A( POSFAC ), LRLU, TRANSPOSE_ASM, & SIZE_MSG, NBROWS_ALREADY_SENT, KEEP, BBPCBP ) IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL ZMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK, & COMP, IFLAG, IERROR, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, MYID, SLAVEF, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW,PTRAIW,INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IF (LDA_ARG < 0) THEN CALL ZMUMPS_SET_LDA_SHIFT_VAL_SON( & IW, LIW, PTRI(STEP(ISON)), & LDA, SHIFT_VAL_SON) ENDIF END IF END DO IF ( IERR == -2 ) THEN IFLAG = -17 IERROR = SIZE_MSG IF (LP > 0) WRITE(LP, *) "FAILURE, SEND BUFFER TOO & SMALL DURING ZMUMPS_BUILD_AND_SEND_CB_ROOT" CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF IF ( IERR == -3 ) THEN IF (LP > 0) WRITE(LP, *) "FAILURE, RECV BUFFER TOO & SMALL DURING ZMUMPS_BUILD_AND_SEND_CB_ROOT" IFLAG = -20 IERROR = SIZE_MSG CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) GOTO 500 ENDIF END IF END DO END DO 500 CONTINUE DEALLOCATE(PTRROW) DEALLOCATE(PTRCOL) DEALLOCATE(ROW_INDEX_LIST) DEALLOCATE(COL_INDEX_LIST) RETURN CONTAINS SUBROUTINE ZMUMPS_SET_LDA_SHIFT_VAL_SON(IW, LIW, IOLDPS, & LDA, SHIFT_VAL_SON) INTEGER, INTENT(IN) :: LIW, IOLDPS INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT) :: LDA INTEGER(8), INTENT(OUT) :: SHIFT_VAL_SON INCLUDE 'mumps_headers.h' INTEGER :: LCONT, NROW, NPIV, NASS, NELIM LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (IW(IOLDPS+XXS).EQ.S_NOLCBNOCONTIG38.OR. & IW(IOLDPS+XXS).EQ.S_ALL) THEN SHIFT_VAL_SON = int(NPIV,8) LDA = LCONT + NPIV ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCBCONTIG38) THEN SHIFT_VAL_SON = int(NROW,8)*int(LCONT+NPIV-NELIM,8) LDA = NELIM ELSE IF (IW(IOLDPS+XXS).EQ.S_NOLCLEANED38) THEN SHIFT_VAL_SON=0_8 LDA = NELIM ELSE WRITE(*,*) MYID, & ": internal error in ZMUMPS_SET_LDA_SHIFT_VAL_SON", & IW(IOLDPS+XXS), "ISON=",ISON CALL MUMPS_ABORT() ENDIF RETURN END SUBROUTINE ZMUMPS_SET_LDA_SHIFT_VAL_SON END SUBROUTINE ZMUMPS_BUILD_AND_SEND_CB_ROOT SUBROUTINE ZMUMPS_ROOT_LOCAL_ASSEMBLY( N, VAL_ROOT, & LOCAL_M, LOCAL_N, & NPCOL, NPROW, MBLOCK, NBLOCK, NBCOL_SON, NBROW_SON, INDCOL_SON, & INDROW_SON, LD_SON, VAL_SON, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, NSUPROW, NSUPCOL, & RG2L_ROW, RG2L_COL, TRANSPOSE_ASM, & KEEP, RHS_ROOT, NLOC ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, LOCAL_M, LOCAL_N COMPLEX(kind=8) VAL_ROOT( LOCAL_M, LOCAL_N ) INTEGER NPCOL, NPROW, MBLOCK, NBLOCK INTEGER NBCOL_SON, NBROW_SON INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER LD_SON INTEGER NSUPROW, NSUPCOL COMPLEX(kind=8) VAL_SON( LD_SON, NBROW_SON ) INTEGER KEEP(500) INTEGER NSUBSET_ROW, NSUBSET_COL INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER RG2L_ROW( N ), RG2L_COL( N ) LOGICAL TRANSPOSE_ASM INTEGER NLOC COMPLEX(kind=8) RHS_ROOT( LOCAL_M, NLOC) INTEGER ISUB, JSUB, I, J, IPOS_ROOT, JPOS_ROOT INTEGER ILOC_ROOT, JLOC_ROOT, IGLOB, JGLOB IF (KEEP(50).EQ.0) THEN DO ISUB = 1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL-NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO DO JSUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( J, I ) ENDDO END DO ELSE IF ( .NOT. TRANSPOSE_ASM ) THEN DO ISUB = 1, NSUBSET_ROW - NSUPROW I = SUBSET_ROW( ISUB ) IGLOB = INDROW_SON( I ) IPOS_ROOT = RG2L_ROW( IGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 DO JSUB = 1, NSUBSET_COL -NSUPCOL J = SUBSET_COL( JSUB ) JGLOB = INDCOL_SON( J ) JPOS_ROOT = RG2L_COL( JGLOB ) IF (KEEP(50).NE.0. AND. JPOS_ROOT .GT. IPOS_ROOT) CYCLE JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO END DO DO JSUB = NSUBSET_COL -NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( JSUB ) JGLOB = INDROW_SON( J ) JPOS_ROOT = JGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO ISUB = NSUBSET_ROW - NSUPROW +1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IGLOB = INDCOL_SON( I ) IPOS_ROOT = RG2L_ROW(IGLOB) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT(ILOC_ROOT, JLOC_ROOT) = & RHS_ROOT(ILOC_ROOT, JLOC_ROOT) + VAL_SON( I, J ) END DO END DO ELSE DO ISUB = 1, NSUBSET_COL-NSUPCOL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = RG2L_COL( IGLOB ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) = & VAL_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL I = SUBSET_COL( ISUB ) IGLOB = INDROW_SON( I ) JPOS_ROOT = IGLOB - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 DO JSUB = 1, NSUBSET_ROW J = SUBSET_ROW( JSUB ) JGLOB = INDCOL_SON( J ) IPOS_ROOT = RG2L_ROW( JGLOB ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) = & RHS_ROOT( ILOC_ROOT, JLOC_ROOT ) + VAL_SON( J, I ) END DO ENDDO END IF END IF RETURN END SUBROUTINE ZMUMPS_ROOT_LOCAL_ASSEMBLY SUBROUTINE ZMUMPS_INIT_ROOT_ANA &( MYID, NPROCS, N, root, COMM_ROOT, IROOT, FILS, & K50, K46, K51 & , K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK & ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID, MYID_ROOT TYPE (ZMUMPS_ROOT_STRUC)::root INTEGER COMM_ROOT INTEGER N, IROOT, NPROCS, K50, K46, K51 INTEGER FILS( N ) INTEGER K60, IDNPROW, IDNPCOL, IDMBLOCK, IDNBLOCK INTEGER INODE, NPROWtemp, NPCOLtemp LOGICAL SLAVE root%ROOT_SIZE = 0 root%TOT_ROOT_SIZE = 0 SLAVE = ( MYID .ne. 0 .or. & ( MYID .eq. 0 .and. K46 .eq. 1 ) ) INODE = IROOT DO WHILE ( INODE .GT. 0 ) INODE = FILS( INODE ) root%ROOT_SIZE = root%ROOT_SIZE + 1 END DO IF ( ( K60 .NE. 2 .AND. K60 .NE. 3 ) .OR. & IDNPROW .LE. 0 .OR. IDNPCOL .LE. 0 & .OR. IDMBLOCK .LE.0 .OR. IDNBLOCK.LE.0 & .OR. IDNPROW * IDNPCOL .GT. NPROCS ) THEN root%MBLOCK = K51 root%NBLOCK = K51 CALL ZMUMPS_DEF_GRID( NPROCS, root%NPROW, root%NPCOL, & root%ROOT_SIZE, K50 ) IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IDNPROW = root%NPROW IDNPCOL = root%NPCOL IDMBLOCK = root%MBLOCK IDNBLOCK = root%NBLOCK ENDIF ELSE IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN root%NPROW = IDNPROW root%NPCOL = IDNPCOL root%MBLOCK = IDMBLOCK root%NBLOCK = IDNBLOCK ENDIF IF ( K60 .EQ. 2 .OR. K60 .EQ. 3 ) THEN IF (SLAVE) THEN root%LPIV = 0 IF (K46.EQ.0) THEN MYID_ROOT=MYID-1 ELSE MYID_ROOT=MYID ENDIF IF (MYID_ROOT < root%NPROW*root%NPCOL) THEN root%MYROW = MYID_ROOT / root%NPCOL root%MYCOL = mod(MYID_ROOT, root%NPCOL) root%yes = .true. ELSE root%MYROW = -1 root%MYCOL = -1 root%yes = .FALSE. ENDIF ELSE root%yes = .FALSE. ENDIF ELSE IF ( SLAVE ) THEN IF ( root%gridinit_done) THEN IF (root%yes) THEN CALL blacs_gridexit( root%CNTXT_BLACS ) root%gridinit_done = .FALSE. ENDIF END IF root%CNTXT_BLACS = COMM_ROOT CALL blacs_gridinit( root%CNTXT_BLACS, 'R', & root%NPROW, root%NPCOL ) root%gridinit_done = .TRUE. CALL blacs_gridinfo( root%CNTXT_BLACS, & NPROWtemp, NPCOLtemp, & root%MYROW, root%MYCOL ) IF ( root%MYROW .NE. -1 ) THEN root%yes = .true. ELSE root%yes = .false. END IF root%LPIV = 0 ELSE root%yes = .FALSE. ENDIF RETURN END SUBROUTINE ZMUMPS_INIT_ROOT_ANA SUBROUTINE ZMUMPS_INIT_ROOT_FAC( N, root, FILS, IROOT, & KEEP, INFO ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE ( ZMUMPS_ROOT_STRUC ):: root INTEGER N, IROOT, INFO(80), KEEP(500) INTEGER FILS( N ) INTEGER INODE, I, allocok IF ( associated( root%RG2L_ROW ) ) THEN DEALLOCATE( root%RG2L_ROW ) NULLIFY( root%RG2L_ROW ) ENDIF IF ( associated( root%RG2L_COL ) ) THEN DEALLOCATE( root%RG2L_COL ) NULLIFY( root%RG2L_COL ) ENDIF ALLOCATE( root%RG2L_ROW( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO(1)=-13 INFO(2)=N RETURN ENDIF ALLOCATE( root%RG2L_COL( N ), stat = allocok ) IF ( allocok .GT. 0 ) THEN DEALLOCATE( root%RG2L_ROW ); NULLIFY( root%RG2L_ROW ) INFO(1)=-13 INFO(2)=N RETURN ENDIF INODE = IROOT I = 1 DO WHILE ( INODE .GT. 0 ) root%RG2L_ROW( INODE ) = I root%RG2L_COL( INODE ) = I I = I + 1 INODE = FILS( INODE ) END DO root%TOT_ROOT_SIZE=0 RETURN END SUBROUTINE ZMUMPS_INIT_ROOT_FAC SUBROUTINE ZMUMPS_DEF_GRID( NPROCS, NPROW, NPCOL, SIZE, K50 ) IMPLICIT NONE INTEGER NPROCS, NPROW, NPCOL, SIZE, K50 INTEGER NPROWtemp, NPCOLtemp, NPROCSused, FLATNESS LOGICAL KEEPIT IF ( K50 .EQ. 1 ) THEN FLATNESS = 2 ELSE FLATNESS = 3 ENDIF NPROW = int(sqrt(dble(NPROCS))) NPROWtemp = NPROW NPCOL = int(NPROCS / NPROW) NPCOLtemp = NPCOL NPROCSused = NPROWtemp * NPCOLtemp 10 CONTINUE IF ( NPROWtemp >= NPCOLtemp/FLATNESS .AND. NPROWtemp > 1) THEN NPROWtemp = NPROWtemp - 1 NPCOLtemp = int(NPROCS / NPROWtemp) KEEPIT=.FALSE. IF ( NPROWtemp * NPCOLtemp .GE. NPROCSused ) THEN IF ( ( K50 .NE. 1 .AND. NPROWtemp >= NPCOLtemp/FLATNESS) & .OR. NPROWtemp * NPCOLtemp .GT. NPROCSused ) & KEEPIT=.TRUE. END IF IF ( KEEPIT ) THEN NPROW = NPROWtemp NPCOL = NPCOLtemp NPROCSused = NPROW * NPCOL END IF GO TO 10 END IF RETURN END SUBROUTINE ZMUMPS_DEF_GRID SUBROUTINE ZMUMPS_SCATTER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N ) COMPLEX(kind=8) ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, IDEST, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine ZMUMPS_SCATTER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) IDEST = IROW * NPCOL + ICOL IF ( IDEST .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 WK(KK)=ASEQ(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK, SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & IDEST, 128, COMM, IERR ) ELSE IF ( MYID .EQ. IDEST ) THEN CALL MPI_RECV( WK(1), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT,128,COMM,STATUS,IERR) KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 APAR(II,JJ)=WK(KK) KK=KK+1 END DO END DO JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) & = ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE ZMUMPS_SCATTER_ROOT SUBROUTINE ZMUMPS_GATHER_ROOT(MYID, M, N, ASEQ, & LOCAL_M, LOCAL_N, & MBLOCK, NBLOCK, & APAR, & MASTER_ROOT, & NPROW, NPCOL, & COMM) IMPLICIT NONE INTEGER MYID, MASTER_ROOT, COMM INTEGER M, N INTEGER NPROW, NPCOL INTEGER LOCAL_M, LOCAL_N INTEGER MBLOCK, NBLOCK COMPLEX(kind=8) APAR( LOCAL_M, LOCAL_N ) COMPLEX(kind=8) ASEQ( M, N ) INCLUDE 'mpif.h' INTEGER I, J, SIZE_IBLOCK, SIZE_JBLOCK, ISOUR, IROW, ICOL INTEGER IBLOCK, JBLOCK, II, JJ, KK INTEGER IAPAR, JAPAR, IERR, allocok INTEGER :: STATUS(MPI_STATUS_SIZE) COMPLEX(kind=8),DIMENSION(:), ALLOCATABLE :: WK LOGICAL JUPDATE ALLOCATE(WK( MBLOCK * NBLOCK ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of WK in ' & // 'routine ZMUMPS_GATHER_ROOT ' CALL MUMPS_ABORT() endif IAPAR = 1 JAPAR = 1 DO J = 1, N, NBLOCK SIZE_JBLOCK = NBLOCK IF ( J + NBLOCK > N ) THEN SIZE_JBLOCK = N - J + 1 END IF JUPDATE = .FALSE. DO I = 1, M, MBLOCK SIZE_IBLOCK = MBLOCK IF ( I + MBLOCK > M ) THEN SIZE_IBLOCK = M - I + 1 END IF IBLOCK = I / MBLOCK JBLOCK = J / NBLOCK IROW = mod ( IBLOCK, NPROW ) ICOL = mod ( JBLOCK, NPCOL ) ISOUR = IROW * NPCOL + ICOL IF ( ISOUR .NE. MASTER_ROOT ) THEN IF ( MYID .EQ. MASTER_ROOT ) THEN CALL MPI_RECV( WK(1), SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & ISOUR, 128, COMM, STATUS, IERR ) KK=1 DO JJ=J,J+SIZE_JBLOCK-1 DO II=I,I+SIZE_IBLOCK-1 ASEQ(II,JJ)=WK(KK) KK=KK+1 END DO END DO ELSE IF ( MYID .EQ. ISOUR ) THEN KK=1 DO JJ=JAPAR,JAPAR+SIZE_JBLOCK-1 DO II=IAPAR,IAPAR+SIZE_IBLOCK-1 WK(KK)=APAR(II,JJ) KK=KK+1 END DO END DO CALL MPI_SSEND( WK( 1 ), & SIZE_IBLOCK*SIZE_JBLOCK, & MPI_DOUBLE_COMPLEX, & MASTER_ROOT,128,COMM,IERR) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF ELSE IF ( MYID.EQ. MASTER_ROOT ) THEN ASEQ(I:I+SIZE_IBLOCK-1,J:J+SIZE_JBLOCK-1) & = APAR( IAPAR:IAPAR+SIZE_IBLOCK-1, & JAPAR:JAPAR+SIZE_JBLOCK-1 ) JUPDATE = .TRUE. IAPAR = IAPAR + SIZE_IBLOCK END IF END DO IF ( JUPDATE ) THEN IAPAR = 1 JAPAR = JAPAR + SIZE_JBLOCK END IF END DO DEALLOCATE(WK) RETURN END SUBROUTINE ZMUMPS_GATHER_ROOT SUBROUTINE ZMUMPS_ROOT_ALLOC_STATIC(root, IROOT, N, & IW, LIW, A, LA, & FILS, DAD, MYID, SLAVEF, PROCNODE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, ITLOC, RHS_MUMPS, & COMP, LRLUS, IFLAG, KEEP,KEEP8,DKEEP,IERROR ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) TYPE (ZMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA, LRLU, IPTRLU, LRLUS INTEGER IROOT, LIW, N, IWPOS, IWPOSCB INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER, INTENT(IN) :: SLAVEF INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER ITLOC( N + KEEP(253) ) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER COMP, IFLAG, IERROR INCLUDE 'mumps_headers.h' INTEGER FILS( N ), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER INTARR(KEEP8(27)) COMPLEX(kind=8) DBLARR(KEEP8(26)) INTEGER numroc EXTERNAL numroc COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER(8) :: LREQA_ROOT INTEGER LREQI_ROOT, LOCAL_M, LOCAL_N, allocok LOGICAL :: EARLYT3ROOTINS LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF (KEEP(253).GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max(1, root%RHS_NLOC) ELSE root%RHS_NLOC = 1 ENDIF IF (associated( root%RHS_ROOT) ) & DEALLOCATE (root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(LOCAL_M,root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = LOCAL_M*root%RHS_NLOC RETURN ENDIF IF (KEEP(253).NE.0) THEN root%RHS_ROOT = ZERO CALL ZMUMPS_ASM_RHS_ROOT ( N, FILS, & root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) IF ( IFLAG .LT. 0 ) RETURN ENDIF IF (KEEP(60) .NE. 0) THEN PTRIST(STEP(IROOT)) = -6666666 ELSE LREQI_ROOT = 2 + KEEP(IXSZ) LREQA_ROOT = int(LOCAL_M,8) * int(LOCAL_N,8) IF (LREQA_ROOT.EQ.0_8) THEN PTRIST(STEP(IROOT)) = -9999999 RETURN ENDIF CALL ZMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, LREQI_ROOT, & LREQA_ROOT, IROOT, S_NOTFREE, .TRUE., COMP, & LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) RETURN PTRIST ( STEP(IROOT) ) = IWPOSCB + 1 PAMASTER( STEP(IROOT) ) = IPTRLU + 1_8 IW( IWPOSCB + 1 + KEEP(IXSZ)) = - LOCAL_N IW( IWPOSCB + 2 + KEEP(IXSZ)) = LOCAL_M ENDIF EARLYT3ROOTINS = KEEP(200) .EQ.0 IF (LOCAL_N > 0 .AND. .NOT. EARLYT3ROOTINS ) THEN IF (KEEP(60) .EQ. 0) THEN CALL ZMUMPS_SET_TO_ZERO(A(IPTRLU+1_8), LOCAL_M, & LOCAL_M, LOCAL_N, KEEP) ELSE CALL ZMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, LOCAL_M, LOCAL_N, KEEP) ENDIF IF (KEEP(55) .eq. 0) THEN IF (KEEP(60) .EQ. 0) THEN CALL ZMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL ZMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, LOCAL_M, LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ENDIF ELSE IF (KEEP(60) .EQ. 0) THEN CALL ZMUMPS_ASM_ELT_ROOT( N, root, & A(IPTRLU+1_8), LOCAL_M, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ELSE CALL ZMUMPS_ASM_ELT_ROOT( N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, & root%SCHUR_MLOC, root%SCHUR_NLOC, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_ROOT_ALLOC_STATIC SUBROUTINE ZMUMPS_ASM_ELT_ROOT( N, root, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & KEEP, KEEP8, & MYID) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, LOCAL_M, LOCAL_N, KEEP(500) INTEGER :: LOCAL_M_LLD INTEGER(8) KEEP8(150) COMPLEX(kind=8) VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER, INTENT(INOUT) :: INTARR(LINTARR) COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER(8) :: J1, J2, K8, IPTR INTEGER :: IELT, I, J, IGLOB, JGLOB, SIZEI, IBEG INTEGER :: ARROW_ROOT INTEGER :: IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER :: ILOCROOT, JLOCROOT ARROW_ROOT = 0 DO IPTR = FRTPTR(KEEP(38)), FRTPTR(KEEP(38)+1) - 1 IELT = FRTELT( IPTR ) J1 = PTRAIW(IELT) J2 = PTRAIW(IELT+1)-1 K8 = PTRARW(IELT) SIZEI=int(J2-J1)+1 DO J=1, SIZEI JGLOB = INTARR(J1+J-1) INTARR(J1+J-1) = root%RG2L_ROW(JGLOB) ENDDO DO J = 1, SIZEI JGLOB = INTARR(J1+J-1) IF ( KEEP(50).eq. 0 ) THEN IBEG = 1 ELSE IBEG = J END IF DO I = IBEG, SIZEI IGLOB = INTARR(J1+I-1) IF ( KEEP(50).eq.0 ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IF ( INTARR(J1+I-1).GT. INTARR(J1+J-1) ) THEN IPOSROOT = INTARR(J1+I-1) JPOSROOT = INTARR(J1+J-1) ELSE IPOSROOT = INTARR(J1+J-1) JPOSROOT = INTARR(J1+I-1) END IF END IF IROW_GRID = mod( ( IPOSROOT - 1 )/root%MBLOCK, & root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/root%NBLOCK, & root%NPCOL ) IF ( IROW_GRID.EQ.root%MYROW .AND. & JCOL_GRID.EQ.root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + DBLARR(K8) ENDIF K8 = K8 + 1_8 END DO END DO ARROW_ROOT = ARROW_ROOT + int(PTRARW(IELT+1_8)-PTRARW(IELT)) END DO KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_ASM_ELT_ROOT SUBROUTINE ZMUMPS_ASM_RHS_ROOT & ( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, KEEP(500), IFLAG, IERROR INTEGER FILS(N) TYPE (ZMUMPS_ROOT_STRUC ) :: root COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER JCOL, IPOS_ROOT, JPOS_ROOT, & IROW_GRID, JCOL_GRID, ILOCRHS, JLOCRHS, & INODE INODE = KEEP(38) DO WHILE (INODE.GT.0) IPOS_ROOT = root%RG2L_ROW( INODE ) IROW_GRID = mod( ( IPOS_ROOT - 1 ) / root%MBLOCK, root%NPROW ) IF ( IROW_GRID .NE. root%MYROW ) GOTO 100 ILOCRHS = root%MBLOCK * ( ( IPOS_ROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOS_ROOT - 1, root%MBLOCK ) + 1 DO JCOL = 1, KEEP(253) JPOS_ROOT = JCOL JCOL_GRID = mod((JPOS_ROOT-1)/root%NBLOCK, root%NPCOL) IF (JCOL_GRID.NE.root%MYCOL ) CYCLE JLOCRHS = root%NBLOCK * ( ( JPOS_ROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOS_ROOT - 1, root%NBLOCK ) + 1 root%RHS_ROOT(ILOCRHS, JLOCRHS) = & RHS_MUMPS(INODE+(JCOL-1)*KEEP(254)) ENDDO 100 CONTINUE INODE=FILS(INODE) ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_RHS_ROOT SUBROUTINE ZMUMPS_ASM_ARR_ROOT( N, root, IROOT, & VALROOT, LOCAL_M_LLD, LOCAL_M, LOCAL_N, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, LINTARR, LDBLARR, & MYID) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER :: N, MYID, IROOT, LOCAL_M, LOCAL_N INTEGER :: LOCAL_M_LLD INTEGER FILS( N ) INTEGER(8), INTENT(IN) :: PTRARW( N ), PTRAIW( N ) COMPLEX(kind=8) VALROOT(LOCAL_M_LLD,LOCAL_N) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR(LINTARR) COMPLEX(kind=8) DBLARR(LDBLARR) COMPLEX(kind=8) VAL INTEGER(8) :: JJ, J1,JK, J2,J3, J4, AINPUT INTEGER IORG, IBROT, NUMORG, & IROW, JCOL INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INTEGER ILOCROOT, JLOCROOT NUMORG = root%ROOT_SIZE IBROT = IROOT DO IORG = 1, NUMORG JK = PTRAIW(IBROT) AINPUT = PTRARW(IBROT) IBROT = FILS(IBROT) JJ = JK + 1 J1 = JJ + 1 J2 = J1 + INTARR(JK) J3 = J2 + 1 J4 = J2 - INTARR(JJ) JCOL = INTARR(J1) DO JJ = J1, J2 IROW = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID = mod( ( IPOSROOT - 1 ) / root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 ) / root%NBLOCK, root%NPCOL ) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO IF (J3 .LE. J4) THEN IROW = INTARR(J1) DO JJ= J3,J4 JCOL = INTARR(JJ) VAL = DBLARR(AINPUT) AINPUT = AINPUT + 1 IPOSROOT = root%RG2L_ROW( IROW ) JPOSROOT = root%RG2L_COL( JCOL ) IROW_GRID= mod( ( IPOSROOT - 1 )/root%MBLOCK, root%NPROW) JCOL_GRID= mod( ( JPOSROOT - 1 )/root%NBLOCK, root%NPCOL) IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 VALROOT( ILOCROOT, JLOCROOT ) = & VALROOT( ILOCROOT, JLOCROOT ) + VAL END IF END DO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_ASM_ARR_ROOT MUMPS_5.4.1/src/sfac_process_root2slave.F0000664000175000017500000003155114102210521020447 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND) USE SMUMPS_LOAD USE SMUMPS_OOC USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER TOT_ROOT_SIZE, TOT_CONT_TO_RECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA, POSFAC INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER ND( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)) INTEGER LPTRAR, NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) REAL :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) INTEGER :: allocok REAL, DIMENSION(:,:), POINTER :: TMP INTEGER NEW_LOCAL_M, NEW_LOCAL_N INTEGER OLD_LOCAL_M, OLD_LOCAL_N INTEGER I, J INTEGER LREQI, IROOT INTEGER(8) :: LREQA INTEGER POSHEAD, IPOS_SON,IERR LOGICAL MASTER_OF_ROOT, NO_OLD_ROOT REAL ZERO PARAMETER( ZERO = 0.0E0 ) INCLUDE 'mumps_headers.h' INTEGER numroc, MUMPS_PROCNODE EXTERNAL numroc, MUMPS_PROCNODE IROOT = KEEP( 38 ) root%TOT_ROOT_SIZE = TOT_ROOT_SIZE MASTER_OF_ROOT = ( MYID .EQ. & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) ) NEW_LOCAL_M = numroc( TOT_ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) NEW_LOCAL_M = max( 1, NEW_LOCAL_M ) NEW_LOCAL_N = numroc( TOT_ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) IF ( PTRIST(STEP( IROOT )).GT.0) THEN OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) ELSE OLD_LOCAL_N = 0 OLD_LOCAL_M = NEW_LOCAL_M ENDIF IF (PTRIST(STEP(IROOT)) .EQ.0) THEN NO_OLD_ROOT = .TRUE. ELSE NO_OLD_ROOT =.FALSE. ENDIF IF (KEEP(60) .NE. 0) THEN IF ( MASTER_OF_ROOT ) THEN LREQI=6+2*TOT_ROOT_SIZE+KEEP(IXSZ) LREQA=0_8 IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN CALL SMUMPS_COMPRE_NEW( N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB1 compress root2slave:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA-LRLUS, IERROR) GOTO 700 END IF ENDIF IF ( IWPOS + LREQI - 1. GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 ENDIF PTLUST(STEP(IROOT))= IWPOS IWPOS = IWPOS + LREQI POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI )=LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR) ) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD) ) IW( POSHEAD + XXS )=-9999 IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD +KEEP(IXSZ)) = 0 IW( POSHEAD + 1 +KEEP(IXSZ)) = -1 IW( POSHEAD + 2 +KEEP(IXSZ)) = -1 IW( POSHEAD + 4 +KEEP(IXSZ)) = STEP(IROOT) IW( POSHEAD + 5 +KEEP(IXSZ)) = 0 IW( POSHEAD + 3 +KEEP(IXSZ)) = TOT_ROOT_SIZE ELSE PTLUST(STEP(IROOT)) = -4444 ENDIF PTRIST(STEP(IROOT)) = 0 PTRFAC(STEP(IROOT)) = -4445_8 IF (root%yes .and. NO_OLD_ROOT) THEN IF (NEW_LOCAL_N .GT. 0) THEN CALL SMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) IF (KEEP(55).EQ.0) THEN CALL SMUMPS_ASM_ARR_ROOT( N, root, IROOT, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL SMUMPS_ASM_ELT_ROOT(N, root, & root%SCHUR_POINTER(1), root%SCHUR_LLD, root%SCHUR_MLOC, & root%SCHUR_NLOC, LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF ENDIF ENDIF ELSE IF ( MASTER_OF_ROOT ) THEN LREQI = 6 + 2 * TOT_ROOT_SIZE+KEEP(IXSZ) ELSE LREQI = 6+KEEP(IXSZ) END IF LREQA = int(NEW_LOCAL_M, 8) * int(NEW_LOCAL_N, 8) CALL SMUMPS_GET_SIZE_NEEDED( & LREQI , LREQA, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 700 PTLUST(STEP( IROOT )) = IWPOS IWPOS = IWPOS + LREQI IF (LREQA.EQ.0_8) THEN PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ELSE PTRAST (STEP(IROOT)) = POSFAC PTRFAC (STEP(IROOT)) = POSFAC ENDIF POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(KEEP8(67), LRLUS) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) POSHEAD = PTLUST( STEP(IROOT)) IW( POSHEAD + XXI ) = LREQI CALL MUMPS_STOREI8( LREQA, IW(POSHEAD + XXR)) CALL MUMPS_STOREI8( 0_8, IW(POSHEAD + XXD)) IW( POSHEAD + XXS ) = S_NOTFREE IW(POSHEAD+XXS+1:POSHEAD+KEEP(IXSZ)-1)=-99999 IW( POSHEAD + KEEP(IXSZ) ) = 0 IW( POSHEAD + 1 + KEEP(IXSZ) ) = NEW_LOCAL_N IW( POSHEAD + 2 + KEEP(IXSZ) ) = NEW_LOCAL_M IW( POSHEAD + 4 + KEEP(IXSZ) ) = STEP(IROOT) IW( POSHEAD + 5 + KEEP(IXSZ) ) = 0 IF ( MASTER_OF_ROOT ) THEN IW( POSHEAD + 3 + KEEP(IXSZ) ) = TOT_ROOT_SIZE ELSE IW( POSHEAD + 3 + KEEP(IXSZ) ) = 0 ENDIF IF ( PTRIST(STEP(IROOT)) .EQ. 0) THEN CALL SMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) IF (KEEP(55) .EQ.0 ) THEN CALL SMUMPS_ASM_ARR_ROOT( N, root, IROOT, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), MYID ) ELSE CALL SMUMPS_ASM_ELT_ROOT( N, root, & A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), KEEP, KEEP8, MYID ) ENDIF PAMASTER(STEP(IROOT)) = 0_8 ELSE IF ( PTRIST(STEP(IROOT)) .LT. 0 ) THEN CALL SMUMPS_SET_TO_ZERO(A(PTRAST(STEP(IROOT))), & NEW_LOCAL_M, NEW_LOCAL_M, NEW_LOCAL_N, KEEP) ELSE OLD_LOCAL_N = -IW( PTRIST(STEP( IROOT )) + KEEP(IXSZ) ) OLD_LOCAL_M = IW( PTRIST(STEP( IROOT )) + 1 + KEEP(IXSZ)) IF ( TOT_ROOT_SIZE .eq. root%ROOT_SIZE ) THEN IF ( LREQA .NE. int(OLD_LOCAL_M,8) * int(OLD_LOCAL_N,8) ) & THEN write(*,*) 'error 1 in PROCESS_ROOT2SLAVE', & OLD_LOCAL_M, OLD_LOCAL_N CALL MUMPS_ABORT() END IF CALL SMUMPS_COPYI8SIZE(LREQA, & A( PAMASTER(STEP(IROOT)) ), & A( PTRAST (STEP(IROOT)) ) ) ELSE CALL SMUMPS_COPY_ROOT( A( PTRAST(STEP(IROOT))), & NEW_LOCAL_M, & NEW_LOCAL_N, A( PAMASTER( STEP(IROOT)) ), OLD_LOCAL_M, & OLD_LOCAL_N ) END IF IF ( PTRIST( STEP( IROOT ) ) .GT. 0 ) THEN IPOS_SON= PTRIST( STEP(IROOT)) CALL SMUMPS_FREE_BLOCK_CB_STATIC(.FALSE., & MYID, N, IPOS_SON, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) END IF ENDIF PTRIST(STEP( IROOT )) = 0 PAMASTER(STEP( IROOT )) = 0_8 ENDIF IF ( NO_OLD_ROOT ) THEN IF (KEEP(253) .GT.0) THEN root%RHS_NLOC = numroc( KEEP(253), root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) root%RHS_NLOC = max( root%RHS_NLOC, 1 ) ELSE root%RHS_NLOC = 1 ENDIF IF (associated(root%RHS_ROOT)) DEALLOCATE(root%RHS_ROOT) ALLOCATE(root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0 ) THEN IFLAG = -13 IERROR = NEW_LOCAL_N * root%RHS_NLOC GOTO 700 ENDIF IF (KEEP(253) .NE. 0) THEN root%RHS_ROOT=ZERO CALL SMUMPS_ASM_RHS_ROOT( N, FILS, root, KEEP, RHS_MUMPS, & IFLAG, IERROR ) ENDIF ELSE IF (NEW_LOCAL_M.GT.OLD_LOCAL_M .AND. KEEP(253) .GT.0) THEN TMP => root%RHS_ROOT NULLIFY(root%RHS_ROOT) ALLOCATE (root%RHS_ROOT(NEW_LOCAL_M, root%RHS_NLOC), & stat=allocok) IF ( allocok.GT.0) THEN IFLAG=-13 IERROR = NEW_LOCAL_M*root%RHS_NLOC GOTO 700 ENDIF DO J = 1, root%RHS_NLOC DO I = 1, OLD_LOCAL_M root%RHS_ROOT(I,J)=TMP(I,J) ENDDO DO I = OLD_LOCAL_M+1, NEW_LOCAL_M root%RHS_ROOT(I,J) = ZERO ENDDO ENDDO DEALLOCATE(TMP) NULLIFY(TMP) ENDIF KEEP(121) = KEEP(121) + TOT_CONT_TO_RECV IF ( KEEP(121) .eq. 0 ) THEN IF (KEEP(201).EQ.1) THEN CALL SMUMPS_OOC_FORCE_WRT_BUF_PANEL(IERR) ELSE IF (KEEP(201).EQ.2) THEN CALL SMUMPS_FORCE_WRITE_BUF(IERR) ENDIF CALL SMUMPS_INSERT_POOL_N( N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT + N ) IF (KEEP(47) .GE. 3) THEN CALL SMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE SMUMPS_PROCESS_ROOT2SLAVE SUBROUTINE SMUMPS_COPY_ROOT &( NEW, M_NEW, N_NEW,OLD, M_OLD, N_OLD ) INTEGER M_NEW, N_NEW, M_OLD, N_OLD REAL NEW( M_NEW, N_NEW ), OLD( M_OLD, N_OLD ) INTEGER J REAL ZERO PARAMETER( ZERO = 0.0E0 ) DO J = 1, N_OLD NEW( 1: M_OLD, J ) = OLD( 1: M_OLD, J ) NEW( M_OLD + 1: M_NEW, J ) = ZERO END DO NEW( 1: M_NEW,N_OLD + 1: N_NEW ) = ZERO RETURN END SUBROUTINE SMUMPS_COPY_ROOT MUMPS_5.4.1/src/mumps_headers.h0000664000175000017500000000657214102210475016530 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C Common header positions: C C XXI -> size of integer record C XXR -> size of real record C XXS -> status of the node C XXN -> node number C XXP -> pointer to previous record C XXA -> active fronts data management C XXF -> blr data passed from factorization to solve C XXLR -> Low rank status of a node (0=FR, C 1=LowRank CB only C 2=LowRank factors/panels only C 3=LowRank CB+factor/panel) C XXEBF -> End of Blocfacto (0=not yet, 1=finished) C XXD -> dynamic data size C XXG -> GPU information (currently number of pinned rows NFRONT-NBROWS_CPU) C REMARK: .h file could be replaced by a module with functions to get node status C added in the module. C INTEGER, PARAMETER :: XXI = 0, XXR = 1, XXS = 3, XXN = 4, XXP = 5 INTEGER, PARAMETER :: XXA = 6, XXF = 7 INTEGER, PARAMETER :: XXLR = 8 INTEGER, PARAMETER :: XXNBPR = 9 INTEGER, PARAMETER :: XXEBF = 10 INTEGER, PARAMETER :: XXD = 11 INTEGER, PARAMETER :: XXG = 13 C C Size of header in incore and out-of-core C INTEGER XSIZE_IC, XSIZE_OOC_SYM, XSIZE_OOC_UNSYM INTEGER XSIZE_OOC_NOPANEL ! To store virtual addresses C At the moment, all headers are of the same size because C no OOC specific information are stored in header. CM other OOC specific information directly in the headers. PARAMETER (XSIZE_IC=14,XSIZE_OOC_SYM=14,XSIZE_OOC_UNSYM=14, & XSIZE_OOC_NOPANEL=14) C C ------------------------------------------------------- C Position of header size (formerly XSIZE) in KEEP array. C KEEP(IXSZ) is set at the beginning of the factorization C to either XSIZE_IC, XSIZE_OOC_SYM or XSIZE_OOC_UNSYM. C ------------------------------------------------------- INTEGER IXSZ PARAMETER(IXSZ= 222) ! KEEP(222) used INTEGER, PARAMETER :: S_CB1COMP = 314 INTEGER S_ACTIVE, S_ALL, S_NOLCBCONTIG, & S_NOLCBNOCONTIG, S_NOLCLEANED, & S_NOLCBNOCONTIG38, S_NOLCBCONTIG38, & S_NOLCLEANED38, & S_NOLNOCB, S_NOLNOCBCLEANED, & C_FINI PARAMETER(S_ACTIVE=400, S_ALL=401, S_NOLCBCONTIG=402, & S_NOLCBNOCONTIG=403, S_NOLCLEANED=404, & S_NOLCBNOCONTIG38=405, S_NOLCBCONTIG38=406, & S_NOLCLEANED38=407, & S_NOLNOCB=408, S_NOLNOCBCLEANED=409, & C_FINI=1) INTEGER, PARAMETER :: S_FREE = 54321 INTEGER, PARAMETER :: S_NOTFREE = -123 INTEGER, PARAMETER :: TOP_OF_STACK = -999999 INTEGER XTRA_SLAVES_SYM, XTRA_SLAVES_UNSYM PARAMETER(XTRA_SLAVES_SYM=4, XTRA_SLAVES_UNSYM=2) INTEGER S_ROOT2SON_CALLED, S_REC_CONTSTATIC, & S_ROOTBAND_INIT PARAMETER(S_ROOT2SON_CALLED=-341,S_REC_CONTSTATIC=1, & S_ROOTBAND_INIT=0) MUMPS_5.4.1/src/dsol_aux.F0000664000175000017500000013450314102210522015435 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_FREETOPSO( N, KEEP28, IWCB, LIWW, & W, LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB, KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) DOUBLE PRECISION W(LWC) INTEGER SIZFI, SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN DO WHILE ( IWCB( IWPOSCB + 2 ) .eq. 0 ) SIZFR = IWCB( IWPOSCB + 1 ) SIZFI = 2 IWPOSCB = IWPOSCB + SIZFI POSWCB = POSWCB + SIZFR IF ( IWPOSCB .eq. LIWW ) RETURN END DO RETURN END SUBROUTINE DMUMPS_FREETOPSO SUBROUTINE DMUMPS_COMPSO(N,KEEP28,IWCB,LIWW,W,LWC, & POSWCB,IWPOSCB,PTRICB,PTRACB) IMPLICIT NONE INTEGER(8), INTENT(IN) :: LWC INTEGER(8), INTENT(INOUT) :: POSWCB INTEGER N,LIWW,IWPOSCB,KEEP28 INTEGER IWCB(LIWW),PTRICB(KEEP28) INTEGER(8) :: PTRACB(KEEP28) DOUBLE PRECISION W(LWC) INTEGER IPTIW,SIZFI,LONGI INTEGER(8) :: IPTA, LONGR, SIZFR, I8 INTEGER :: I IPTIW = IWPOSCB IPTA = POSWCB LONGI = 0 LONGR = 0_8 IF ( IPTIW .EQ. LIWW ) RETURN 10 CONTINUE IF (IWCB(IPTIW+2).EQ.0) THEN SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IF (LONGI.NE.0) THEN DO 20 I=0,LONGI-1 IWCB(IPTIW + SIZFI - I) = IWCB (IPTIW - I) 20 CONTINUE DO 30 I8=0,LONGR-1 W(IPTA + SIZFR - I8) = W(IPTA - I8) 30 CONTINUE ENDIF DO 40 I=1,KEEP28 IF ((PTRICB(I).LE.(IPTIW+1)).AND. & (PTRICB(I).GT.IWPOSCB) ) THEN PTRICB(I) = PTRICB(I) + SIZFI PTRACB(I) = PTRACB(I) + SIZFR ENDIF 40 CONTINUE IWPOSCB = IWPOSCB + SIZFI IPTIW = IPTIW + SIZFI POSWCB = POSWCB + SIZFR IPTA = IPTA + SIZFR ELSE SIZFR = int(IWCB(IPTIW+1),8) SIZFI = 2 IPTIW = IPTIW + SIZFI LONGI = LONGI + SIZFI IPTA = IPTA + SIZFR LONGR = LONGR + SIZFR ENDIF IF (IPTIW.NE.LIWW) GOTO 10 RETURN END SUBROUTINE DMUMPS_COMPSO SUBROUTINE DMUMPS_SOL_X(A, NZ8, N, IRN, ICN, Z, KEEP,KEEP8) INTEGER N, I, J, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8) KEEP8(150) INTEGER IRN(NZ8), ICN(NZ8) DOUBLE PRECISION A(NZ8) DOUBLE PRECISION Z(N) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER(8) :: K INTRINSIC abs DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) ENDDO ELSE DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) Z(I) = Z(I) + abs(A(K)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SOL_X SUBROUTINE DMUMPS_SCAL_X(A, NZ8, N, IRN, ICN, Z, & KEEP, KEEP8, COLSCA) INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION, INTENT(IN) :: A(NZ8) DOUBLE PRECISION, INTENT(IN) :: COLSCA(N) DOUBLE PRECISION, INTENT(OUT) :: Z(N) DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 INTEGER :: I, J INTEGER(8) :: K DO 10 I = 1, N Z(I) = ZERO 10 CONTINUE IF (KEEP(50) .EQ.0) THEN DO K = 1_8, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) ENDDO ELSE DO K = 1, NZ8 I = IRN(K) J = ICN(K) IF ((I .LT. 1) .OR. (I .GT. N)) CYCLE IF ((J .LT. 1) .OR. (J .GT. N)) CYCLE Z(I) = Z(I) + abs(A(K)*COLSCA(J)) IF (J.NE.I) THEN Z(J) = Z(J) + abs(A(K)*COLSCA(I)) ENDIF ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_SCAL_X SUBROUTINE DMUMPS_SOL_Y(A, NZ8, N, IRN, ICN, RHS, X, R, W, & KEEP,KEEP8) IMPLICIT NONE INTEGER, INTENT(IN) :: N, KEEP(500) INTEGER(8), INTENT(IN) :: NZ8 INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: IRN(NZ8), ICN(NZ8) DOUBLE PRECISION, INTENT(IN) :: A(NZ8), RHS(N), X(N) DOUBLE PRECISION, INTENT(OUT) :: W(N) DOUBLE PRECISION, INTENT(OUT) :: R(N) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION D DO I = 1, N R(I) = RHS(I) W(I) = ZERO ENDDO IF (KEEP(264).EQ.0) THEN IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .GT. N) .OR. (J .GT. N) .OR. (I .LT. 1) .OR. & (J .LT. 1)) CYCLE D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ELSE IF (KEEP(50) .EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) D = A(K8) * X(J) R(I) = R(I) - D W(I) = W(I) + abs(D) IF (I.NE.J) THEN D = A(K8) * X(I) R(J) = R(J) - D W(J) = W(J) + abs(D) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SOL_Y SUBROUTINE DMUMPS_SOL_MULR(N, R, W) INTEGER, intent(in) :: N DOUBLE PRECISION, intent(in) :: W(N) DOUBLE PRECISION, intent(inout) :: R(N) INTEGER I DO 10 I = 1, N R(I) = R(I) * W(I) 10 CONTINUE RETURN END SUBROUTINE DMUMPS_SOL_MULR SUBROUTINE DMUMPS_SOL_B(N, KASE, X, EST, W, IW, GRAIN) INTEGER, intent(in) :: N INTEGER, intent(inout) :: KASE INTEGER IW(N) DOUBLE PRECISION W(N), X(N) DOUBLE PRECISION, intent(inout) :: EST INTEGER, intent(in) :: GRAIN INTRINSIC abs, nint, real, sign INTEGER DMUMPS_IXAMAX EXTERNAL DMUMPS_IXAMAX INTEGER ITMAX PARAMETER (ITMAX = 5) INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN DOUBLE PRECISION TEMP SAVE ITER, J, JLAST, JUMP DOUBLE PRECISION ZERO, ONE PARAMETER( ZERO = 0.0D0 ) PARAMETER( ONE = 1.0D0 ) DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: RONE = 1.0D0 IF (KASE .EQ. 0) THEN DO 10 I = 1, N X(I) = ONE / dble(N) 10 CONTINUE KASE = 1 JUMP = 1 RETURN ENDIF SELECT CASE (JUMP) CASE (1) GOTO 20 CASE(2) GOTO 40 CASE(3) GOTO 70 CASE(4) GOTO 120 CASE(5) GOTO 160 CASE DEFAULT END SELECT 20 CONTINUE IF (N .EQ. 1) THEN W(1) = X(1) EST = abs(W(1)) GOTO 190 ENDIF DO 30 I = 1, N X(I) = sign( RONE,dble(X(I)) ) IW(I) = nint(dble(X(I))) 30 CONTINUE KASE = 2 JUMP = 2 RETURN 40 CONTINUE J = DMUMPS_IXAMAX(N, X, 1, GRAIN) ITER = 2 50 CONTINUE DO 60 I = 1, N X(I) = ZERO 60 CONTINUE X(J) = ONE KASE = 1 JUMP = 3 RETURN 70 CONTINUE DO 80 I = 1, N W(I) = X(I) 80 CONTINUE DO 90 I = 1, N IF (nint(sign(RONE, dble(X(I)))) .NE. IW(I)) GOTO 100 90 CONTINUE GOTO 130 100 CONTINUE DO 110 I = 1, N X(I) = sign(RONE, dble(X(I))) IW(I) = nint(dble(X(I))) 110 CONTINUE KASE = 2 JUMP = 4 RETURN 120 CONTINUE JLAST = J J = DMUMPS_IXAMAX(N, X, 1, GRAIN) IF ((abs(X(JLAST)) .NE. abs(X(J))) .AND. (ITER .LT. ITMAX)) THEN ITER = ITER + 1 GOTO 50 ENDIF 130 CONTINUE EST = RZERO DO 140 I = 1, N EST = EST + abs(W(I)) 140 CONTINUE ALTSGN = RONE DO 150 I = 1, N X(I) = ALTSGN * (RONE + dble(I - 1) / dble(N - 1)) ALTSGN = -ALTSGN 150 CONTINUE KASE = 1 JUMP = 5 RETURN 160 CONTINUE TEMP = RZERO DO 170 I = 1, N TEMP = TEMP + abs(X(I)) 170 CONTINUE TEMP = 2.0D0 * TEMP / dble(3 * N) IF (TEMP .GT. EST) THEN DO 180 I = 1, N W(I) = X(I) 180 CONTINUE EST = TEMP ENDIF 190 KASE = 0 RETURN END SUBROUTINE DMUMPS_SOL_B SUBROUTINE DMUMPS_QD2( MTYPE, N, NZ8, ASPK, IRN, ICN, & LHS, WRHS, W, RHS, KEEP,KEEP8) IMPLICIT NONE INTEGER MTYPE, N INTEGER(8), INTENT(IN) :: NZ8 INTEGER, INTENT(IN) :: IRN( NZ8 ), ICN( NZ8 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(IN) :: ASPK( NZ8 ) DOUBLE PRECISION, INTENT(IN) :: LHS( N ), WRHS( N ) DOUBLE PRECISION, INTENT(OUT):: RHS( N ) DOUBLE PRECISION, INTENT(OUT):: W( N ) INTEGER I, J INTEGER(8) :: K8 DOUBLE PRECISION, PARAMETER :: DZERO = 0.0D0 DO I = 1, N W(I) = DZERO RHS(I) = WRHS(I) ENDDO IF ( KEEP(50) .EQ. 0 ) THEN IF (MTYPE .EQ. 1) THEN IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) ENDDO ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDDO ENDIF ENDIF ELSE IF (KEEP(264).EQ.0) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. & (J .GT. N)) CYCLE RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) RHS(I) = RHS(I) - ASPK(K8) * LHS(J) W(I) = W(I) + abs(ASPK(K8)) IF (J.NE.I) THEN RHS(J) = RHS(J) - ASPK(K8) * LHS(I) W(J) = W(J) + abs(ASPK(K8)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_QD2 SUBROUTINE DMUMPS_ELTQD2( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & LHS, WRHS, W, RHS, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION A_ELT(NA_ELT8) DOUBLE PRECISION LHS( N ), WRHS( N ), RHS( N ) DOUBLE PRECISION W(N) CALL DMUMPS_MV_ELT(N, NELT, ELTPTR, ELTVAR, A_ELT, & LHS, RHS, KEEP(50), MTYPE ) RHS = WRHS - RHS CALL DMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) RETURN END SUBROUTINE DMUMPS_ELTQD2 SUBROUTINE DMUMPS_SOL_X_ELT( MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8 ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION A_ELT(NA_ELT8) DOUBLE PRECISION TEMP DOUBLE PRECISION W(N) INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + abs( A_ELT(K8)) K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + abs(A_ELT( K8 )) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + abs(A_ELT( K8 )) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SOL_X_ELT SUBROUTINE DMUMPS_SOL_SCALX_ELT(MTYPE, N, & NELT, ELTPTR, LELTVAR, ELTVAR, NA_ELT8, A_ELT, & W, KEEP,KEEP8, COLSCA ) IMPLICIT NONE INTEGER MTYPE, N, NELT, LELTVAR INTEGER(8), INTENT(IN) :: NA_ELT8 INTEGER ELTPTR(NELT+1), ELTVAR(LELTVAR) INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION COLSCA(N) DOUBLE PRECISION A_ELT(NA_ELT8) DOUBLE PRECISION W(N) DOUBLE PRECISION TEMP, TEMP2 INTEGER I, J, IEL, SIZEI, IELPTR INTEGER(8) :: K8 DOUBLE PRECISION DZERO PARAMETER(DZERO = 0.0D0) W = DZERO K8 = 1_8 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( KEEP(50).EQ.0 ) THEN IF (MTYPE.EQ.1) THEN DO J = 1, SIZEI TEMP2 = abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI W( ELTVAR( IELPTR + I) ) = & W( ELTVAR( IELPTR + I) ) & + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO END DO ELSE DO J = 1, SIZEI TEMP = W( ELTVAR( IELPTR + J ) ) TEMP2= abs(COLSCA(ELTVAR( IELPTR + J) )) DO I = 1, SIZEI TEMP = TEMP + abs(A_ELT( K8 )) * TEMP2 K8 = K8 + 1_8 END DO W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + TEMP END DO ENDIF ELSE DO J = 1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs( A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J)) ) K8 = K8 + 1_8 DO I = J+1, SIZEI W(ELTVAR( IELPTR + J )) = & W(ELTVAR( IELPTR + J )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + J))) W(ELTVAR( IELPTR + I ) ) = & W(ELTVAR( IELPTR + I )) + & abs(A_ELT( K8 )*COLSCA(ELTVAR( IELPTR + I))) K8 = K8 + 1_8 END DO ENDDO ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_SOL_SCALX_ELT SUBROUTINE DMUMPS_ELTYD( MTYPE, N, NELT, ELTPTR, & LELTVAR, ELTVAR, NA_ELT8, A_ELT, & SAVERHS, X, Y, W, K50 ) IMPLICIT NONE INTEGER N, NELT, K50, MTYPE, LELTVAR INTEGER(8) :: NA_ELT8 INTEGER ELTPTR( NELT + 1 ), ELTVAR( LELTVAR ) DOUBLE PRECISION A_ELT( NA_ELT8 ), X( N ), Y( N ), & SAVERHS(N) DOUBLE PRECISION W(N) INTEGER IEL, I , J, K, SIZEI, IELPTR DOUBLE PRECISION ZERO DOUBLE PRECISION TEMP DOUBLE PRECISION TEMP2 PARAMETER( ZERO = 0.0D0 ) Y = SAVERHS W = ZERO K = 1 DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN IF ( MTYPE .eq. 1 ) THEN DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * TEMP W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + & abs( A_ELT( K ) * TEMP ) K = K + 1 END DO END DO ELSE DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) TEMP2 = W( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) TEMP2 = TEMP2 + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP W( ELTVAR( IELPTR + J ) ) = TEMP2 END DO END IF ELSE DO J = 1, SIZEI Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) K = K + 1 DO I = J+1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) - & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) W( ELTVAR( IELPTR + I ) ) = & W( ELTVAR( IELPTR + I ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + J ) ) ) W( ELTVAR( IELPTR + J ) ) = & W( ELTVAR( IELPTR + J ) ) + abs( & A_ELT( K ) * X( ELTVAR( IELPTR + I ) ) ) K = K + 1 END DO END DO END IF END DO RETURN END SUBROUTINE DMUMPS_ELTYD SUBROUTINE DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) USE DMUMPS_OOC IMPLICIT NONE INTEGER INODE,KEEP(500),N INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER IERR DOUBLE PRECISION A(LA) INTEGER RETURN_VALUE LOGICAL MUST_BE_PERMUTED RETURN_VALUE=DMUMPS_SOLVE_IS_INODE_IN_MEM(INODE,PTRFAC, & KEEP(28),A,LA,IERR) IF(RETURN_VALUE.EQ.OOC_NODE_NOT_IN_MEM)THEN IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_SOLVE_ALLOC_FACTOR_SPACE(INODE,PTRFAC, & KEEP,KEEP8,A,IERR) IF(IERR.LT.0)THEN RETURN ENDIF CALL DMUMPS_READ_OOC( & A(PTRFAC(STEP(INODE))), & INODE,IERR & ) IF(IERR.LT.0)THEN RETURN ENDIF ELSE IF(IERR.LT.0)THEN RETURN ENDIF ENDIF IF(RETURN_VALUE.NE.OOC_NODE_PERMUTED)THEN MUST_BE_PERMUTED=.TRUE. CALL DMUMPS_SOLVE_MODIFY_STATE_NODE(INODE) ELSE MUST_BE_PERMUTED=.FALSE. ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_GET_OOC_NODE SUBROUTINE DMUMPS_BUILD_MAPPING_INFO(id) USE DMUMPS_STRUC_DEF IMPLICIT NONE INCLUDE 'mpif.h' TYPE(DMUMPS_STRUC), TARGET :: id INTEGER, ALLOCATABLE, DIMENSION(:) :: LOCAL_LIST INTEGER :: I,IERR,TMP,NSTEPS,N_LOCAL_LIST INTEGER :: MASTER,TAG_SIZE,TAG_LIST INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_AM_SLAVE PARAMETER(MASTER=0, TAG_SIZE=85,TAG_LIST=86) I_AM_SLAVE = (id%MYID .NE. MASTER & .OR. ((id%MYID.EQ.MASTER).AND.(id%KEEP(46).EQ.1))) NSTEPS = id%KEEP(28) ALLOCATE(LOCAL_LIST(NSTEPS),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF N_LOCAL_LIST = 0 IF(I_AM_SLAVE) THEN DO I=1,NSTEPS IF(id%PTLUST_S(I).NE.0) THEN N_LOCAL_LIST = N_LOCAL_LIST + 1 LOCAL_LIST(N_LOCAL_LIST) = I END IF END DO IF(id%MYID.NE.MASTER) THEN CALL MPI_SEND(N_LOCAL_LIST, 1, & MPI_INTEGER, MASTER, TAG_SIZE, id%COMM,IERR) CALL MPI_SEND(LOCAL_LIST, N_LOCAL_LIST, & MPI_INTEGER, MASTER, TAG_LIST, id%COMM,IERR) DEALLOCATE(LOCAL_LIST) ALLOCATE(id%IPTR_WORKING(1), & id%WORKING(1), & STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating ', & 'IPTR_WORKING and WORKING' CALL MUMPS_ABORT() END IF END IF END IF IF(id%MYID.EQ.MASTER) THEN ALLOCATE(id%IPTR_WORKING(id%NPROCS+1), STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating IPTR_WORKING' CALL MUMPS_ABORT() END IF id%IPTR_WORKING = 0 id%IPTR_WORKING(1) = 1 id%IPTR_WORKING(MASTER+2) = N_LOCAL_LIST DO I=1, id%NPROCS-1 CALL MPI_RECV(TMP, 1, MPI_INTEGER, MPI_ANY_SOURCE, & TAG_SIZE, id%COMM, STATUS, IERR) id%IPTR_WORKING(STATUS(MPI_SOURCE)+2) = TMP END DO DO I=2, id%NPROCS+1 id%IPTR_WORKING(I) = id%IPTR_WORKING(I) & + id%IPTR_WORKING(I-1) END DO ALLOCATE(id%WORKING(id%IPTR_WORKING(id%NPROCS+1)-1),STAT=IERR) IF(IERR.GT.0) THEN WRITE(*,*)'Problem in solve: error allocating LOCAL_LIST' CALL MUMPS_ABORT() END IF TMP = MASTER + 1 IF (I_AM_SLAVE) THEN id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1) & -id%IPTR_WORKING(TMP)) ENDIF DO I=1,id%NPROCS-1 CALL MPI_RECV(LOCAL_LIST, NSTEPS, MPI_INTEGER, & MPI_ANY_SOURCE, TAG_LIST, id%COMM, STATUS, IERR) TMP = STATUS(MPI_SOURCE)+1 id%WORKING(id%IPTR_WORKING(TMP):id%IPTR_WORKING(TMP+1)-1) & = LOCAL_LIST(1:id%IPTR_WORKING(TMP+1)- & id%IPTR_WORKING(TMP)) END DO DEALLOCATE(LOCAL_LIST) END IF END SUBROUTINE DMUMPS_BUILD_MAPPING_INFO SUBROUTINE DMUMPS_SOL_OMEGA(N, RHS, & X, Y, R_W, C_W, IW, IFLAG, & OMEGA, NOITER, TESTConv, & LP, ARRET, GRAIN ) IMPLICIT NONE INTEGER N, IFLAG INTEGER IW(N,2) DOUBLE PRECISION RHS(N) DOUBLE PRECISION X(N), Y(N) DOUBLE PRECISION R_W(N,2) DOUBLE PRECISION C_W(N) INTEGER LP, NOITER LOGICAL TESTConv DOUBLE PRECISION OMEGA(2) DOUBLE PRECISION ARRET INTEGER, intent(in) :: GRAIN DOUBLE PRECISION, PARAMETER :: CGCE=0.2D0 DOUBLE PRECISION, PARAMETER :: CTAU=1.0D3 INTEGER I, IMAX DOUBLE PRECISION OM1, OM2, DXMAX DOUBLE PRECISION TAU, DD DOUBLE PRECISION OLDOMG(2) DOUBLE PRECISION, PARAMETER :: ZERO=0.0D0 DOUBLE PRECISION, PARAMETER :: ONE=1.0D0 INTEGER DMUMPS_IXAMAX INTRINSIC abs, max SAVE OM1, OLDOMG IMAX = DMUMPS_IXAMAX(N, X, 1, GRAIN) DXMAX = abs(X(IMAX)) OMEGA(1) = ZERO OMEGA(2) = ZERO DO I = 1, N TAU = (R_W(I, 2) * DXMAX + abs(RHS(I))) * dble(N) * CTAU DD = R_W(I, 1) + abs(RHS(I)) IF (DD .GT. TAU * epsilon(CTAU)) THEN OMEGA(1) = max(OMEGA(1), abs(Y(I)) / DD) IW(I, 1) = 1 ELSE IF (TAU .GT. ZERO) THEN OMEGA(2) = max(OMEGA(2), & abs(Y(I)) / (DD + R_W(I, 2) * DXMAX)) ENDIF IW(I, 1) = 2 ENDIF ENDDO IF (TESTConv) THEN OM2 = OMEGA(1) + OMEGA(2) IF (OM2 .LT. ARRET ) THEN IFLAG = 1 GOTO 70 ENDIF IF (NOITER .GE. 1) THEN IF (OM2 .GT. OM1 * CGCE) THEN IF (OM2 .GT. OM1) THEN OMEGA(1) = OLDOMG(1) OMEGA(2) = OLDOMG(2) DO I = 1, N X(I) = C_W(I) ENDDO IFLAG = 2 GOTO 70 ENDIF IFLAG = 3 GOTO 70 ENDIF ENDIF DO I = 1, N C_W(I) = X(I) ENDDO OLDOMG(1) = OMEGA(1) OLDOMG(2) = OMEGA(2) OM1 = OM2 ENDIF IFLAG = 0 RETURN 70 CONTINUE RETURN END SUBROUTINE DMUMPS_SOL_OMEGA SUBROUTINE DMUMPS_SOL_LCOND(N, RHS, & X, Y, D, R_W, C_W, IW, KASE, & OMEGA, ERX, COND, & LP, KEEP,KEEP8 ) IMPLICIT NONE INTEGER N, KASE, KEEP(500) INTEGER(8) KEEP8(150) INTEGER IW(N,2) DOUBLE PRECISION RHS(N) DOUBLE PRECISION X(N), Y(N) DOUBLE PRECISION D(N) DOUBLE PRECISION R_W(N,2) DOUBLE PRECISION C_W(N) INTEGER LP DOUBLE PRECISION COND(2),OMEGA(2) LOGICAL LCOND1, LCOND2 INTEGER JUMP, I, IMAX DOUBLE PRECISION ERX, DXMAX DOUBLE PRECISION DXIMAX DOUBLE PRECISION, PARAMETER :: ZERO = 0.0D0 DOUBLE PRECISION, PARAMETER :: ONE = 1.0D0 INTEGER DMUMPS_IXAMAX INTRINSIC abs, max SAVE LCOND1, LCOND2, JUMP, DXIMAX, DXMAX IF (KASE .EQ. 0) THEN LCOND1 = .FALSE. LCOND2 = .FALSE. COND(1) = ONE COND(2) = ONE ERX = ZERO JUMP = 1 ENDIF SELECT CASE (JUMP) CASE (1) GOTO 30 CASE(2) GOTO 10 CASE(3) GOTO 110 CASE(4) GOTO 150 CASE(5) GOTO 35 CASE DEFAULT END SELECT 10 CONTINUE 30 CONTINUE 35 CONTINUE IMAX = DMUMPS_IXAMAX(N, X, 1, KEEP(361)) DXMAX = abs(X(IMAX)) DO I = 1, N IF (IW(I, 1) .EQ. 1) THEN R_W(I, 1) = R_W(I, 1) + abs(RHS(I)) R_W(I, 2) = ZERO LCOND1 = .TRUE. ELSE R_W(I, 2) = R_W(I, 2) * DXMAX + R_W(I, 1) R_W(I, 1) = ZERO LCOND2 = .TRUE. ENDIF ENDDO DO I = 1, N C_W(I) = X(I) * D(I) ENDDO IMAX = DMUMPS_IXAMAX(N, C_W(1), 1, KEEP(361)) DXIMAX = abs(C_W(IMAX)) IF (.NOT.LCOND1) GOTO 130 100 CONTINUE CALL DMUMPS_SOL_B(N, KASE, Y, COND(1), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 120 IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, R_W) JUMP = 3 RETURN 110 CONTINUE IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, R_W) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, D) GOTO 100 120 CONTINUE IF (DXIMAX .GT. ZERO) COND(1) = COND(1) / DXIMAX ERX = OMEGA(1) * COND(1) 130 CONTINUE IF (.NOT.LCOND2) GOTO 170 KASE = 0 140 CONTINUE CALL DMUMPS_SOL_B(N, KASE, Y, COND(2), C_W, IW(1, 2), KEEP(361)) IF (KASE .EQ. 0) GOTO 160 IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, D) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, R_W(1, 2)) JUMP = 4 RETURN 150 CONTINUE IF (KASE .EQ. 1) CALL DMUMPS_SOL_MULR(N, Y, R_W(1, 2)) IF (KASE .EQ. 2) CALL DMUMPS_SOL_MULR(N, Y, D) GOTO 140 160 IF (DXIMAX .GT. ZERO) THEN COND(2) = COND(2) / DXIMAX ENDIF ERX = ERX + OMEGA(2) * COND(2) 170 CONTINUE RETURN END SUBROUTINE DMUMPS_SOL_LCOND SUBROUTINE DMUMPS_SOL_CPY_FS2RHSCOMP( JBDEB, JBFIN, NBROWS, & KEEP, RHSCOMP, NRHS, LRHSCOMP, FIRST_ROW_RHSCOMP, W, LD_W, & FIRST_ROW_W ) INTEGER :: JBDEB, JBFIN, NBROWS INTEGER :: NRHS, LRHSCOMP INTEGER :: FIRST_ROW_RHSCOMP INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) INTEGER :: LD_W, FIRST_ROW_W DOUBLE PRECISION :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER :: JJ, K, ISHIFT !$OMP PARALLEL DO PRIVATE(ISHIFT, JJ), IF !$OMP& (JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& NBROWS * (JBFIN-JBDEB+1) > 2*KEEP(363)) DO K = JBDEB, JBFIN ISHIFT = FIRST_ROW_W + LD_W * (K-JBDEB) DO JJ = 0, NBROWS-1 RHSCOMP(FIRST_ROW_RHSCOMP+JJ,K) = W(ISHIFT+JJ) END DO END DO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_SOL_CPY_FS2RHSCOMP SUBROUTINE DMUMPS_SOL_BWD_GTHR( JBDEB, JBFIN, J1, J2, & RHSCOMP, NRHS, LRHSCOMP, W, LD_W, FIRST_ROW_W, & IW, LIW, KEEP, N, POSINRHSCOMP_BWD ) INTEGER, INTENT(IN) :: JBDEB, JBFIN, J1, J2 INTEGER, INTENT(IN) :: NRHS, LRHSCOMP INTEGER, INTENT(IN) :: FIRST_ROW_W, LD_W, LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(LRHSCOMP,NRHS) DOUBLE PRECISION :: W(LD_W*(JBFIN-JBDEB+1)) INTEGER, INTENT(IN) :: N INTEGER, INTENT(IN) :: POSINRHSCOMP_BWD(N) INTEGER :: ISHIFT, JJ, K, IPOSINRHSCOMP !$OMP PARALLEL DO PRIVATE(JJ,ISHIFT,IPOSINRHSCOMP), IF !$OMP& ((JBFIN-JBDEB+1 > 2*KEEP(362) .AND. !$OMP& (JBFIN-JBDEB+1)*(J2-KEEP(253)-J1+1)>2*KEEP(363))) DO K=JBDEB, JBFIN ISHIFT = FIRST_ROW_W+(K-JBDEB)*LD_W DO JJ = J1, J2-KEEP(253) IPOSINRHSCOMP = abs(POSINRHSCOMP_BWD(IW(JJ))) W(ISHIFT+JJ-J1)= RHSCOMP(IPOSINRHSCOMP,K) ENDDO ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_SOL_BWD_GTHR SUBROUTINE DMUMPS_SOL_Q(MTYPE, IFLAG, N, & LHS, WRHS, W, RES, GIVNORM, ANORM, XNORM, SCLNRM, & MPRINT, ICNTL, KEEP,KEEP8) INTEGER MTYPE,N,IFLAG,ICNTL(60), KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION RES(N),LHS(N) DOUBLE PRECISION WRHS(N) DOUBLE PRECISION W(N) DOUBLE PRECISION RESMAX,RESL2,XNORM, SCLNRM DOUBLE PRECISION ANORM,DZERO LOGICAL GIVNORM,PROK INTEGER MPRINT, MP INTEGER K INTRINSIC abs, max, sqrt MP = ICNTL(2) PROK = (MPRINT .GT. 0) DZERO = 0.0D0 IF (.NOT.GIVNORM) ANORM = DZERO RESMAX = DZERO RESL2 = DZERO DO 40 K = 1, N RESMAX = max(RESMAX, abs(RES(K))) RESL2 = RESL2 + abs(RES(K)) * abs(RES(K)) IF (.NOT.GIVNORM) ANORM = max(ANORM, W(K)) 40 CONTINUE XNORM = DZERO DO 50 K = 1, N XNORM = max(XNORM, abs(LHS(K))) 50 CONTINUE IF ( XNORM .EQ. DZERO .OR. (exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM)+exponent(XNORM) .LT. & minexponent(XNORM) + KEEP(122) ) & .OR. & ( exponent(ANORM) + exponent(XNORM) -exponent(RESMAX) & .LT. minexponent(XNORM) + KEEP(122) ) & ) THEN IF (mod(IFLAG/2,2) .EQ. 0) THEN IFLAG = IFLAG + 2 ENDIF IF ((MP .GT. 0) .AND. (ICNTL(4) .GE. 2)) WRITE( MP, * ) & ' max-NORM of computed solut. is zero or close to zero. ' ENDIF IF (RESMAX .EQ. DZERO) THEN SCLNRM = DZERO ELSE SCLNRM = RESMAX / (ANORM * XNORM) ENDIF RESL2 = sqrt(RESL2) IF (PROK) WRITE( MPRINT, 90 ) RESMAX, RESL2, ANORM, XNORM, & SCLNRM 90 FORMAT (/' RESIDUAL IS ............ (MAX-NORM) =',1PD9.2/ & ' .. (2-NORM) =',1PD9.2/ & ' RINFOG(4):NORM OF input Matrix (MAX-NORM)=',1PD9.2/ & ' RINFOG(5):NORM OF Computed SOLUT (MAX-NORM)=',1PD9.2/ & ' RINFOG(6):SCALED RESIDUAL ...... (MAX-NORM)=',1PD9.2) RETURN END SUBROUTINE DMUMPS_SOL_Q SUBROUTINE DMUMPS_SOLVE_FWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF (KEEP(50).NE.0 .OR. MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'U', 'T', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','U','T','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'L', 'N', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','L','N','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_FWD_TRSOLVE SUBROUTINE DMUMPS_SOLVE_BWD_TRSOLVE (A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LDA_WCB, PPIV_COURANT, MTYPE, KEEP) INTEGER, INTENT(IN) :: MTYPE, LDADIAG, NPIV, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDA_WCB INTEGER(8), INTENT(IN) :: LA, APOS, LWCB, PPIV_COURANT DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) IF (MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'L', 'T', 'N', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','L','T','N', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'U', 'N', 'U', NPIV, A(APOS), LDADIAG, & WCB(PPIV_COURANT), 1 ) ELSE #endif CALL dtrsm( 'L','U','N','U', NPIV, NRHS_B, ONE, & A(APOS), LDADIAG, WCB(PPIV_COURANT), & LDA_WCB ) #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF RETURN END SUBROUTINE DMUMPS_SOLVE_BWD_TRSOLVE SUBROUTINE DMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NX, LDA, NY, & NRHS_B, WCB, LWCB, PTRX, LDX, & PTRY, LDY, & MTYPE, KEEP, COEF_Y ) INTEGER, INTENT(IN) :: MTYPE, NY, NX, KEEP(500) INTEGER, INTENT(IN) :: NRHS_B, LDY, LDA, LDX INTEGER(8), INTENT(IN) :: LA, APOS1, LWCB, PTRX, & PTRY DOUBLE PRECISION, INTENT(IN) :: A(LA) DOUBLE PRECISION, INTENT(INOUT) :: WCB(LWCB) DOUBLE PRECISION, INTENT(IN) :: COEF_Y DOUBLE PRECISION ALPHA, ZERO, ONE PARAMETER (ZERO = 0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) IF ( NX .NE. 0 .AND. NY.NE.0 ) THEN IF ( MTYPE .eq. 1 ) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv('T', NX, NY, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, COEF_Y, & WCB(PTRY), 1) ELSE #endif CALL dgemm('T', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, COEF_Y, & WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dgemv('N',NY, NX, ALPHA, A(APOS1), & LDA, WCB(PTRX), 1, & COEF_Y, WCB(PTRY), 1 ) ELSE #endif CALL dgemm('N', 'N', NY, NRHS_B, NX, ALPHA, & A(APOS1), LDA, WCB(PTRX), LDX, & COEF_Y, WCB(PTRY), LDY) #if defined(MUMPS_USE_BLAS2) END IF #endif END IF END IF RETURN END SUBROUTINE DMUMPS_SOLVE_GEMM_UPDATE SUBROUTINE DMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) USE DMUMPS_OOC INTEGER, INTENT(IN) :: MTYPE, INODE, N, NPIV, LIELL, & NELIM, NSLAVES INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, LIW, JBDEB, JBFIN INTEGER, INTENT(IN) :: IW(LIW), IPOS, POSINRHSCOMP_FWD(N) INTEGER(8), INTENT(IN) :: LWCB, APOS, LA, PPIV_COURANT INTEGER, INTENT(IN) :: LD_WCBPIV INTEGER, INTENT(IN) :: KEEP(500) DOUBLE PRECISION, INTENT(IN) :: WCB( LWCB ), A( LA ) DOUBLE PRECISION, INTENT(INOUT) :: RHSCOMP(LRHSCOMP, NRHS) LOGICAL, INTENT(IN) :: OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: TempNROW, J1, J3, PANEL_SIZE, TYPEF INTEGER :: IPOSINRHSCOMP, JJ, K, NBK, LDAJ, & LDAJ_ini, NBK_ini, LDAJ_FIRST_PANEL, NRHS_B INTEGER(8) :: IFR8 , APOS1, APOS2, APOSOFF, IFR_ini8, & POSWCB1, POSWCB2 DOUBLE PRECISION :: VALPIV, A11, A22, A12, DETPIV !$ LOGICAL :: OMP_FLAG DOUBLE PRECISION ONE PARAMETER (ONE = 1.0D0) NRHS_B = JBFIN-JBDEB+1 IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J3 = IPOS + LIELL + NPIV END IF IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) IF ( KEEP(50) .eq. 0 ) THEN !$ OMP_FLAG=(NRHS_B.GE.KEEP(362).AND.NRHS_B*NPIV.GE.KEEP(363)) !$OMP PARALLEL DO PRIVATE(IFR8) IF (OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = PPIV_COURANT + (K-JBDEB)*LD_WCBPIV RHSCOMP(IPOSINRHSCOMP:IPOSINRHSCOMP+NPIV-1, K) = & WCB(IFR8:IFR8+int(NPIV-1,8)) ENDDO !$OMP END PARALLEL DO ELSE IFR8 = PPIV_COURANT - 1_8 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNROW= NPIV LDAJ_FIRST_PANEL=LIELL TYPEF= TYPEF_U ENDIF PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) LDAJ = TempNROW ELSE LDAJ = NPIV ENDIF APOS1 = APOS JJ = J1 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN NBK = 0 ENDIF IFR_ini8 = PPIV_COURANT - 1_8 LDAJ_ini = LDAJ IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & NBK_ini = NBK !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & ((J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363))) !$OMP PARALLEL DO PRIVATE(JJ,IFR8,NBK,APOS1,APOS2,APOSOFF,VALPIV, !$OMP& POSWCB1, POSWCB2,A11,A22,A12,DETPIV,LDAJ) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = IFR_ini8 + int(K-JBDEB,8)*int(LD_WCBPIV,8) NBK = NBK_ini APOS1 = APOS LDAJ = LDAJ_ini JJ = J1 DO IF (JJ .GT. J3) EXIT IFR8 = IFR8 + 1_8 IF (IW(JJ+LIELL) .GT. 0) THEN VALPIV = ONE/A( APOS1 ) RHSCOMP(IPOSINRHSCOMP+JJ-J1 , K ) = & WCB( IFR8 ) * VALPIV IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.EQ.PANEL_SIZE) THEN NBK = 0 LDAJ = LDAJ - PANEL_SIZE ENDIF ENDIF APOS1 = APOS1 + int(LDAJ + 1,8) JJ = JJ+1 ELSE IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 ENDIF APOS2 = APOS1+int(LDAJ+1,8) IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN APOSOFF = APOS1+int(LDAJ,8) ELSE APOSOFF=APOS1+1_8 ENDIF A11 = A(APOS1) A22 = A(APOS2) A12 = A(APOSOFF) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(APOS2)/DETPIV A12 = -A12/DETPIV POSWCB1 = IFR8 POSWCB2 = POSWCB1+1_8 RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) = & WCB(POSWCB1)*A11 & + WCB(POSWCB2)*A12 RHSCOMP(IPOSINRHSCOMP+JJ-J1+1,K) = & WCB(POSWCB1)*A12 & + WCB(POSWCB2)*A22 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) & THEN NBK = NBK+1 IF (NBK.GE.PANEL_SIZE) THEN LDAJ = LDAJ - NBK NBK = 0 ENDIF ENDIF APOS1 = APOS2 + int(LDAJ + 1,8) JJ = JJ+2 IFR8 = IFR8+1_8 ENDIF ENDDO ENDDO !$OMP END PARALLEL DO END IF RETURN END SUBROUTINE DMUMPS_SOLVE_LD_AND_RELOAD SUBROUTINE DMUMPS_SET_SCALING_LOC( scaling_data, N, ILOC, LILOC, & COMM, MYID, I_AM_SLAVE, MASTER, NB_BYTES, NB_BYTES_MAX, & K16_8, LP, LPOK, ICNTL, INFO ) IMPLICIT NONE type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t), INTENT(INOUT) :: scaling_data INTEGER, INTENT(IN) :: N, LILOC, COMM, MYID, MASTER, LP INTEGER, INTENT(IN) :: ILOC(LILOC) INTEGER(8), INTENT(INOUT) :: NB_BYTES, NB_BYTES_MAX INTEGER(8), INTENT(IN) :: K16_8 LOGICAL, INTENT(IN) :: I_AM_SLAVE, LPOK INTEGER, INTENT(INOUT) :: INFO(80) INTEGER, INTENT(IN) :: ICNTL(60) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SCALING INTEGER :: I, IERR_MPI, allocok INCLUDE 'mpif.h' NULLIFY(scaling_data%SCALING_LOC) IF (I_AM_SLAVE) THEN ALLOCATE(scaling_data%SCALING_LOC(max(1,LILOC)), & stat=allocok) IF (allocok > 0) THEN INFO(1)=-13 INFO(2)=max(1,LILOC) GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(max(1,LILOC),8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ENDIF IF (MYID .NE. MASTER) THEN ALLOCATE(SCALING(N), stat=allocok) IF (allocok > 0) THEN IF (LPOK) THEN WRITE(LP,*) 'Error allocating temporary scaling array' ENDIF INFO(1)=-13 INFO(2)=N GOTO 35 ENDIF NB_BYTES = NB_BYTES + int(N,8)*K16_8 NB_BYTES_MAX = max(NB_BYTES_MAX,NB_BYTES) ELSE SCALING => scaling_data%SCALING ENDIF 35 CONTINUE CALL MUMPS_PROPINFO( ICNTL(1), INFO(1), & COMM, MYID ) IF (INFO(1) .LT. 0) GOTO 90 CALL MPI_BCAST( SCALING(1), N, MPI_DOUBLE_PRECISION, & MASTER, COMM, IERR_MPI) IF ( I_AM_SLAVE ) THEN DO I = 1, LILOC IF (ILOC(I) .GE. 1 .AND. ILOC(I) .LE. N) THEN scaling_data%SCALING_LOC(I) = SCALING(ILOC(I)) ENDIF ENDDO ENDIF 90 CONTINUE IF (MYID.NE. MASTER) THEN IF (associated(SCALING)) THEN DEALLOCATE(SCALING) NB_BYTES = NB_BYTES - int(N,8)*K16_8 ENDIF ENDIF NULLIFY(SCALING) IF (INFO(1) .LT. 0) THEN IF (associated(scaling_data%SCALING_LOC)) THEN DEALLOCATE(scaling_data%SCALING_LOC) NULLIFY(scaling_data%SCALING_LOC) ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_SCALING_LOC MUMPS_5.4.1/src/mumps_pord.c0000664000175000017500000002335214102210474016046 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ /* * This file contains interfaces to external ordering packages. * At the moment, PORD (J. Schulze) and SCOTCH are interfaced. */ #include "mumps_pord.h" void MUMPS_CALL MUMPS_PORD_INTSIZE(MUMPS_INT *pord_intsize) { #if defined(pord) # if defined(PORD_INTSIZE64) || defined(INTSIZE64) *pord_intsize=64; # else *pord_intsize=32; # endif #else *pord_intsize=-99999; #endif } #if defined(pord) /* Interface to PORD */ #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa ) #else void MUMPS_CALL MUMPS_PORDF( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa ) #endif { *ncmpa = mumps_pord( *nvtx, *nedges, xadj, adjncy, nv ); } /* Interface to PORD with weighted graph */ #if defined(INTSIZE64) || defined(PORD_INTSIZE64) void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT8 *nvtx, MUMPS_INT8 *nedges, MUMPS_INT8 *xadj, MUMPS_INT8 *adjncy, MUMPS_INT8 *nv, MUMPS_INT *ncmpa, MUMPS_INT8 *totw ) #else void MUMPS_CALL MUMPS_PORDF_WND( MUMPS_INT *nvtx, MUMPS_INT *nedges, MUMPS_INT *xadj, MUMPS_INT *adjncy, MUMPS_INT *nv, MUMPS_INT *ncmpa, MUMPS_INT *totw ) #endif { *ncmpa = mumps_pord_wnd( *nvtx, *nedges, xadj, adjncy, nv, totw ); } /************************************************************ mumps_pord is used in ana_aux.F permutation and inverse permutation not set on output, but may be printed in default file: "perm_pord" and "iperm_pord", if associated part uncommneted. But, if uncommetnted a bug occurs in psl_ma41_analysi.F ******************************************************************/ /*********************************************************/ MUMPS_INT mumps_pord ( PORD_INT nvtx, PORD_INT nedges, /* NZ-like */ PORD_INT *xadj_pe, /* NZ-like */ PORD_INT *adjncy, PORD_INT *nv ) { /********************************** Arguments: input: ----- - nvtx : dimension of the Problem (N) - nedges : number of entries (NZ) - adjncy : non-zeros entries (IW input) input/output: ------------- - xadj_pe : in: pointer through beginning of column non-zeros entries out: "father array" (PE) ouput: ------ - nv : "nfront array" (NV) *************************************/ graph_t *G; elimtree_t *T; timings_t cpus[12]; options_t options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, 0 }; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT *first, *link, nfronts, J, K, u, vertex, vertex_root, count; /* Explicit shifting of indices to be optimized */ for (u = nvtx; u >= 0; u--) { xadj_pe[u] = xadj_pe[u] - 1; } for (K = nedges-1; K >= 0; K--) { adjncy[K] = adjncy[K] - 1; } /* initialization of the graph */ mymalloc(G, 1, graph_t); G->xadj = xadj_pe; G->adjncy = adjncy; G->nvtx = nvtx; G->nedges = nedges; /* FIXME: G->vwght and G->tocwght accessed if G->type==UNWEIGHTED? */ mymalloc(G->vwght, nvtx, PORD_INT); G->type = UNWEIGHTED; G->totvwght = nvtx; for (u = 0; u < nvtx; u++) G->vwght[u] = 1; /* main function of the Ordering */ T = SPACE_ordering(G, options, cpus); nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; /* firstchild = T->firstchild; */ vtx2front = T->vtx2front; /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (J = 0; J < nfronts; J++) first[J] = -1; for (u = nvtx-1; u >= 0; u--) { J = vtx2front[u]; link[u] = first[J]; first[J] = u; } /* ----------------------------------------------------------- fill the two arrays corresponding to the MUMPS tree structure ----------------------------------------------------------- */ count = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { vertex_root = first[K]; if (vertex_root == -1) { /* Should never happen */ # if defined(PORD_INTSIZE64) || defined(INTSIZE64) printf(" Internal error in mumps_pord, %ld\n",K); # else printf(" Internal error in mumps_pord, %d\n",K); # endif exit(-1); } /* for the principal column of the supervariable */ if (parent[K] == -1) xadj_pe[vertex_root] = 0; /* root of the tree */ else xadj_pe[vertex_root] = - (first[parent[K]]+1); nv[vertex_root] = ncolfactor[K] + ncolupdate[K]; count++; for (vertex = link[vertex_root]; vertex != -1; vertex = link[vertex]) /* for the secondary columns of the supervariable */ { xadj_pe[vertex] = - (vertex_root+1); nv[vertex] = 0; count++; } } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); free(G->vwght); free(G); freeElimTree(T); return (0); } /*********************************************************/ MUMPS_INT mumps_pord_wnd ( PORD_INT nvtx, PORD_INT nedges, PORD_INT *xadj_pe, PORD_INT *adjncy, PORD_INT *nv, PORD_INT *totw ) { /********************************** Arguments: input: ----- - nvtx : dimension of the Problem (N) - nedges : number of entries (NZ) - adjncy : non-zeros entries (IW input) - totw : sum of the weigth of the vertices input/output: ------------- - xadj_pe : in: pointer through beginning of column non-zeros entries out: "father array" (PE) - nv : in: weight of the vertices out: "nfront array" (NV) *************************************/ graph_t *G; elimtree_t *T; timings_t cpus[12]; options_t options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, 0 }; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT *first, *link, nfronts, J, K, u, vertex, vertex_root, count; /* Explicit shifting of indices to be optimized */ for (u = nvtx; u >= 0; u--) { xadj_pe[u] = xadj_pe[u] - 1; } for (K = nedges-1; K >= 0; K--) { adjncy[K] = adjncy[K] - 1; } /* initialization of the graph */ mymalloc(G, 1, graph_t); G->xadj = xadj_pe; G->adjncy= adjncy; G->nvtx = nvtx; G->nedges = nedges; G->type = WEIGHTED; G->totvwght = (*totw); /* FIXME: avoid allocation and do: G->vwght=nv; instead? */ mymalloc(G->vwght, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) G->vwght[u] = nv[u]; /* main function of the Ordering */ T = SPACE_ordering(G, options, cpus); nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; /* firstchild = T->firstchild; */ vtx2front = T->vtx2front; /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (J = 0; J < nfronts; J++) first[J] = -1; for (u = nvtx-1; u >= 0; u--) { J = vtx2front[u]; link[u] = first[J]; first[J] = u; } /* ----------------------------------------------------------- fill the two arrays corresponding to the MUMPS tree structure ----------------------------------------------------------- */ count = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { vertex_root = first[K]; if (vertex_root == -1) { /* Should never happen */ # if defined(PORD_INTSIZE64) || defined(INTSIZE64) printf(" Internal error in mumps_pord, %ld\n",K); # else printf(" Internal error in mumps_pord, %d\n",K); # endif exit(-1); } /* for the principal column of the supervariable */ if (parent[K] == -1) xadj_pe[vertex_root] = 0; /* root of the tree */ else xadj_pe[vertex_root] = - (first[parent[K]]+1); nv[vertex_root] = ncolfactor[K] + ncolupdate[K]; count++; for (vertex = link[vertex_root]; vertex != -1; vertex = link[vertex]) /* for the secondary columns of the supervariable */ { xadj_pe[vertex] = - (vertex_root+1); nv[vertex] = 0; count++; } } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); free(G->vwght); free(G); freeElimTree(T); return (0); } #endif /* pord */ MUMPS_5.4.1/src/sfac_process_root2son.F0000664000175000017500000003202214102210521020126 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE & SMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & INODE, NELIM_ROOT, root, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER INODE, NELIM_ROOT INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD(KEEP(28)) REAL :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER INTARR(KEEP8(27)) REAL DBLARR(KEEP8(26)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER I, LCONT, NCOL_TO_SEND, LDA INTEGER(8) :: SHIFT_VAL_SON, POSELT INTEGER FPERE, IOLDPS, NFRONT, NPIV, NASS, NSLAVES, & H_INODE, NELIM, NBCOL, LIST_NELIM_ROW, & LIST_NELIM_COL, NELIM_LOCAL, TYPE_SON, & NROW, NCOL, NBROW, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, LDAFS, IERR, & ISON, PDEST_MASTER_ISON INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER MSGSOU, MSGTAG LOGICAL TRANSPOSE_ASM INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE FPERE = KEEP(38) TYPE_SON = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ).EQ.MYID) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS+1+KEEP(IXSZ)) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) NELIM = NASS - NPIV NBCOL = NFRONT - NPIV LIST_NELIM_ROW = IOLDPS + H_INODE + NPIV LIST_NELIM_COL = LIST_NELIM_ROW + NFRONT IF (NELIM.LE.0) THEN write(6,*) ' ERROR 1 in SMUMPS_PROCESS_ROOT2SON ', NELIM write(6,*) MYID,':Process root2son: INODE=',INODE, & 'Header=',IW(PTLUST_S(STEP(INODE)):PTLUST_S(STEP(INODE)) & +5+KEEP(IXSZ)) CALL MUMPS_ABORT() ENDIF NELIM_LOCAL = NELIM_ROOT DO I=1, NELIM root%RG2L_ROW(IW(LIST_NELIM_ROW)) = NELIM_LOCAL root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_ROW = LIST_NELIM_ROW + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO NBROW = NFRONT - NPIV NROW = NELIM IF ( KEEP( 50 ) .eq. 0 ) THEN NCOL = NFRONT - NPIV ELSE NCOL = NELIM END IF SHIFT_LIST_ROW_SON = H_INODE + NPIV SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV IF ( KEEP(50).eq.0 .OR. TYPE_SON .eq. 1 ) THEN LDAFS = NFRONT ELSE LDAFS = NASS END IF SHIFT_VAL_SON = int(NPIV,8) * int(LDAFS,8) + int(NPIV,8) CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, & ASS_IRECV, & N, INODE, FPERE, & PTLUST_S(1), PTRAST(1), & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDAFS, & ROOT_NON_ELIM_CB, MYID, COMM, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S(1), PTRFAC(1), PTRAST(1), & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE.,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG.LT.0 ) RETURN IF (TYPE_SON.EQ.1) THEN NROW = NFRONT - NASS NCOL = NELIM SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NPIV SHIFT_VAL_SON = int(NASS,8) * int(NFRONT,8) + int(NPIV,8) IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NROW, NCOL, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP, & TRANSPOSE_ASM,ND,FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS ) IF (IFLAG.LT.0 ) RETURN ENDIF IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) PTRFAC(STEP(INODE))=POSELT IF ( TYPE_SON .eq. 1 ) THEN NBROW = NFRONT - NPIV ELSE NBROW = NELIM END IF IF ( TYPE_SON .eq. 1 .OR. KEEP(50).EQ.0) THEN LDA = NFRONT ELSE LDA = NPIV+NBROW ENDIF CALL SMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) IW(IOLDPS + KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1 +KEEP(IXSZ)) = NASS - NPIV IF (TYPE_SON.EQ.2) THEN IW(IOLDPS + 2 +KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2 +KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3 +KEEP(IXSZ)) = NPIV CALL SMUMPS_COMPRESS_LU(0_8,MYID,N,IOLDPS,TYPE_SON,IW,LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST,PTRFAC,STEP, KEEP,KEEP8, .FALSE.,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 RETURN ENDIF ELSE ISON = INODE PDEST_MASTER_ISON = & MUMPS_PROCNODE( PROCNODE_STEPS(STEP(ISON)), KEEP(199) ) IF ( PTRIST(STEP(ISON)) .EQ. 0) THEN CALL SMUMPS_TREAT_DESCBAND( ISON, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE,LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF DO WHILE ( & ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) .OR. & ( KEEP(50) .NE. 0 .AND. & IW( PTRIST(STEP(ISON)) + 6 +KEEP(IXSZ)) .NE. 0 ) ) IF ( KEEP(50).eq.0) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO ELSE IF ( IW( PTRIST(STEP(ISON)) + 1 +KEEP(IXSZ)) .NE. & IW( PTRIST(STEP(ISON)) + 3 +KEEP(IXSZ)) ) THEN MSGSOU = PDEST_MASTER_ISON MSGTAG = BLOC_FACTO_SYM ELSE MSGSOU = MPI_ANY_SOURCE MSGTAG = BLOC_FACTO_SYM_SLAVE END IF END IF BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, LPTRAR, & NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN END DO IOLDPS = PTRIST(STEP(INODE)) LCONT = IW(IOLDPS+KEEP(IXSZ)) NROW = IW(IOLDPS+2+KEEP(IXSZ)) NPIV = IW(IOLDPS+3+KEEP(IXSZ)) NASS = IW(IOLDPS+4+KEEP(IXSZ)) NELIM = NASS-NPIV IF (NELIM.LE.0) THEN write(6,*) MYID,': INODE,LCONT, NROW, NPIV, NASS, NELIM=', & INODE,LCONT, NROW, NPIV, NASS, NELIM write(6,*) MYID,': IOLDPS=',IOLDPS write(6,*) MYID,': ERROR 2 in SMUMPS_PROCESS_ROOT2SON ' CALL MUMPS_ABORT() ENDIF NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE = 6 + NSLAVES + KEEP(IXSZ) LIST_NELIM_COL = IOLDPS + H_INODE + NROW + NPIV NELIM_LOCAL = NELIM_ROOT DO I = 1, NELIM root%RG2L_COL(IW(LIST_NELIM_COL)) = NELIM_LOCAL root%RG2L_ROW(IW(LIST_NELIM_COL)) = NELIM_LOCAL NELIM_LOCAL = NELIM_LOCAL + 1 LIST_NELIM_COL = LIST_NELIM_COL + 1 ENDDO SHIFT_LIST_ROW_SON = 6 + IW(IOLDPS+5+KEEP(IXSZ)) + KEEP(IXSZ) SHIFT_LIST_COL_SON = SHIFT_LIST_ROW_SON + NROW + NPIV NCOL_TO_SEND = NELIM LDA = -9999 SHIFT_VAL_SON = -9999_8 IF ( KEEP( 50 ) .eq. 0 ) THEN TRANSPOSE_ASM = .FALSE. ELSE TRANSPOSE_ASM = .TRUE. END IF CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTRIST, PTRAST, & root, NROW, NCOL_TO_SEND, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, LDA, & ROOT_NON_ELIM_CB, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,TRANSPOSE_ASM, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF (IFLAG.LT.0 ) RETURN IF (KEEP(214).EQ.2) THEN CALL SMUMPS_STACK_BAND( N, INODE, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP,TYPE_SON & ) ENDIF IF (IFLAG.LT.0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_ROOT2SON MUMPS_5.4.1/src/dtools.F0000664000175000017500000022036514102210522015125 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE DMUMPS_LOAD USE DMUMPS_OOC !$ USE OMP_LIB USE DMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER IWPOS, LDLT INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(N), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I, SIZESHIFT, ITMP8 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR INTEGER PARPIV_T1 LOGICAL LR_ACTIVATED IERR=0 LDLT = KEEP(50) IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF (LDLT.EQ.0) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF IF ( TYPE .EQ. 2 ) THEN IF (LDLT.EQ.0) THEN SIZECB = int(NELIM,8) * int(LCONT,8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN SIZECB = int(NELIM+1,8) * int(NELIM + NPIV,8) ELSE SIZECB = int(NELIM,8) * int(NELIM + NPIV,8) ENDIF ENDIF ELSE LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (LDLT.EQ.0) THEN CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(LCONT,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ELSE CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(NROW,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZELU ELSE SIZESHIFT = 0_8 IF (SIZECB.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL DMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in DMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ MOVEPTRAST = .FALSE. DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 DMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 DMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 DMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZESHIFT MOVEPTRAST = .TRUE. PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 DMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 DMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZECB+SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZELU-SIZESHIFT, POSFAC-SIZECB-SIZESHIFT-1_8 A( I ) = A( I + SIZECB + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - (SIZECB+SIZESHIFT) LRLU = LRLU + (SIZECB+SIZESHIFT) ITMP8 = (SIZECB+SIZESHIFT) - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU-SIZESHIFT,-(SIZECB+SIZESHIFT)+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE DMUMPS_COMPRESS_LU SUBROUTINE DMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE DMUMPS_OOC USE DMUMPS_LOAD USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE DOUBLE PRECISION A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL DMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL DMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL DMUMPS_COMPRE_NEW( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress DMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL DMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+LREQA ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN CALL DMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in DMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL DMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL DMUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_STACK_BAND SUBROUTINE DMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_FREE_BLOCK IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) DOUBLE PRECISION A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE DOUBLE PRECISION, DIMENSION(:), POINTER :: FORTRAN_POINTER ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL DMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL DMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE DMUMPS_FREE_BAND SUBROUTINE DMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF END SUBROUTINE DMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE DMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: DMUMPS_LBUF_INT INTEGER(8) :: DMUMPS_LBUFR_BYTES8, DMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8 * N8 IF (KEEP(23).ne.0 .and. I_AM_MASTER) NB_INT=NB_INT + N8 IF (KEEP(55).eq.0) THEN NB_INT = NB_INT + 2_8 * N8 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) ENDIF IF (KEEP(55) .ne. 0 ) THEN NB_INT = NB_INT + N8 + 1_8 + NELT8 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 CALL DMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF NB_REAL = NB_REAL + KEEP8(26) IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF IF ( I_AM_SLAVE .and. KEEP(38) .ne. 0 ) THEN NB_INT = NB_INT + 2_8 * N8 END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = max( NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + (NB_REAL+TEMPR) * int(KEEP(35),8) & , TEMP ) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN DMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE DMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF DMUMPS_LBUFR_BYTES8 = max( DMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(489).GT.0) THEN DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( 0.5D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0,8) ELSE DMUMPS_LBUFR_BYTES8 = DMUMPS_LBUFR_BYTES8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUFR_BYTES8)/100D0,8) ENDIF DMUMPS_LBUFR_BYTES8 = min(DMUMPS_LBUFR_BYTES8, & int(huge (KEEP(43))-100,8)) NB_BYTES = NB_BYTES + DMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE DMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF DMUMPS_LBUF8 = max( DMUMPS_LBUF8, 100000_8 ) DMUMPS_LBUF8 = DMUMPS_LBUF8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(DMUMPS_LBUF8)/100D0, 8) DMUMPS_LBUF8 = min(DMUMPS_LBUF8, int(huge (KEEP(43)-100),8)) DMUMPS_LBUF8 = max(DMUMPS_LBUF8, DMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + DMUMPS_LBUF8 ENDIF DMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(DMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN NB_INT = NB_INT + N8*KEEP(400) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 2 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 2 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI IF (KEEP(494).NE.0) THEN NB_INT = NB_INT + N8 ENDIF ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( dble(MEMORY_BYTES) / dble(1000000) ) RETURN END SUBROUTINE DMUMPS_MAX_MEM SUBROUTINE DMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE DMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL DMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE DMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE DMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(36)) * ( 1.0D0 - & dble(ICNTL38)/dble(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -dble(KEEP8(11)-KEEP8(32)) * & dble(ICNTL38) / 1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(38)) * ( 1.0D0 - & dble(ICNTL38+ICNTL39)/ & dble(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL38+ICNTL39)/1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(37)) * ( 1.0D0 - & dble(ICNTL39)/dble(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL39)/1000.0D0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (KEEP8(4)/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF CALL DMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, & .FALSE., & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE DMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL DMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE DMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE DMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE DOUBLE PRECISION M_ARRAY(M_SIZE) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D0) M_ARRAY=ZERO RETURN END SUBROUTINE DMUMPS_SETMAXTOZERO SUBROUTINE DMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE DMUMPS_COMPUTE_NBROWSinF SUBROUTINE DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE DMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB DOUBLE PRECISION A(ASIZE) DOUBLE PRECISION M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW DOUBLE PRECISION ZERO,TMP PARAMETER (ZERO=0.0D0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE DMUMPS_COMPUTE_MAXPERCOL SUBROUTINE DMUMPS_SIZE_IN_STRUCT( id, NB_INT, NB_CMPLX, NB_CHAR ) USE DMUMPS_STRUC_DEF IMPLICIT NONE TYPE(DMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) NB_INT=NB_INT+size(id%STEP) IF (associated(id%NE_STEPS )) NB_INT=NB_INT+size(id%NE_STEPS ) IF (associated(id%ND_STEPS)) NB_INT=NB_INT+size(id%ND_STEPS) IF (associated(id%Step2node)) NB_INT=NB_INT+size(id%Step2node) IF (associated(id%FRERE_STEPS)) NB_INT=NB_INT+size(id%FRERE_STEPS) IF (associated(id%DAD_STEPS)) NB_INT=NB_INT+size(id%DAD_STEPS) IF (associated(id%FILS)) NB_INT=NB_INT+size(id%FILS) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) NB_INT=NB_INT+size(id%KEEP8) * id%KEEP(10) IF (associated(id%PTRFAC)) NB_INT=NB_INT+size(id%PTRFAC) * & id%KEEP(10) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%NA)) NB_INT=NB_INT+size(id%NA) IF (associated(id%PROCNODE_STEPS)) & NB_INT=NB_INT+size(id%PROCNODE_STEPS) IF (associated(id%PTLUST_S)) NB_INT=NB_INT+size(id%PTLUST_S) IF (associated(id%INTARR)) NB_INT=NB_INT+id%KEEP8(27) IF (associated(id%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES) IF (associated(id%SYM_PERM)) & NB_INT=NB_INT+size(id%SYM_PERM) IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE) IF (associated(id%I_AM_CAND)) & NB_INT=NB_INT+size(id%I_AM_CAND) IF (associated(id%MEM_DIST)) & NB_INT=NB_INT+size(id%MEM_DIST) IF (associated(id%POSINRHSCOMP_ROW)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_ROW) IF(id%POSINRHSCOMP_COL_ALLOC.AND.associated(id%POSINRHSCOMP_COL)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_COL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) & NB_INT=NB_INT+size(id%LRGROUPS) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(id%root%RG2L_COL)) & NB_INT=NB_INT+size(id%root%RG2L_COL) IF (associated(id%root%RG2L_ROW)) & NB_INT=NB_INT+size(id%root%RG2L_ROW) IF (associated(id%root%IPIV)) & NB_INT=NB_INT+size(id%root%IPIV) IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_CNTR_MASTER_ROOT) IF (associated(id%root%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(id%root%SCHUR_POINTER) IF (associated(id%root%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(id%root%QR_TAU) IF (associated(id%root%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_ROOT) IF (associated(id%root%SVD_U)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_U) IF (associated(id%root%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_VT) IF (associated(id%root%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%root%SINGULAR_VALUES) IF (associated(id%DBLARR)) NB_CMPLX=NB_CMPLX+id%KEEP8(26) IF (associated(id%RHSCOMP)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL NB_CMPLX = NB_CMPLX + id%KEEP8(71) + id%KEEP8(64) RETURN END SUBROUTINE DMUMPS_SIZE_IN_STRUCT SUBROUTINE DMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 DOUBLE PRECISION, intent(in) :: SRC(N8) DOUBLE PRECISION, intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL dcopy(N8, SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL dcopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE DMUMPS_COPYI8SIZE SUBROUTINE DMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE DMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 DOUBLE PRECISION, INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL DMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE DMUMPS_SET_TMP_PTR SUBROUTINE DMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE DMUMPS_OOC, ONLY : IO_BLOCK, & DMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) DOUBLE PRECISION, INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL DMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE DMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) USE DMUMPS_BUF, ONLY : DMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) DOUBLE PRECISION VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT CALL DMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT DOUBLE PRECISION, intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL DMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE DMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE DMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR DOUBLE PRECISION, intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL DMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE DMUMPS_COMPRESS_CB_I SUBROUTINE DMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, OMP_NUM & ) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: WORK(MAXI_CLUSTER*MAXI_CLUSTER*OMP_NUM) DOUBLE PRECISION :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL DMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE DMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE DMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA DOUBLE PRECISION, intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL DMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE DMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR DOUBLE PRECISION, TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL DMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE DMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE DMUMPS_LR_TYPE, ONLY : LRB_TYPE USE DMUMPS_FAC_LR, ONLY : DMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO DOUBLE PRECISION, intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS DOUBLE PRECISION, INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL DMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE DMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I MUMPS_5.4.1/src/cfac_process_rtnelind.F0000664000175000017500000001117414102210523020147 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_RTNELIND( ROOT, & INODE, NELIM, NSLAVES, ROW_LIST, & COL_LIST, SLAVE_LIST, & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND ) USE CMUMPS_LOAD USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: ROOT INTEGER INODE, NELIM, NSLAVES INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER ROW_LIST(*), COL_LIST(*), & SLAVE_LIST(*) INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER PTRIST( KEEP(28) ), PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), ITLOC( N + KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER IFLAG, IERROR INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF INTEGER COMM, COMM_LOAD, ND(KEEP(28)), FILS(N), DAD(KEEP(28)) INTEGER IROOT, TYPE_INODE, DEB_ROW, DEB_COL, & NOINT INTEGER(8) :: NOREAL INCLUDE 'mumps_headers.h' INCLUDE 'mumps_tags.h' INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE IROOT = KEEP(38) NSTK_S(STEP(IROOT))= NSTK_S(STEP(IROOT)) - 1 KEEP(42) = KEEP(42) + NELIM TYPE_INODE= MUMPS_TYPENODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) IF (TYPE_INODE.EQ.1) THEN IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + 1 ELSE KEEP(41) = KEEP(41) + 3 ENDIF ELSE IF (NELIM.EQ.0) THEN KEEP(41) = KEEP(41) + NSLAVES ELSE KEEP(41) = KEEP(41) + 2*NSLAVES + 1 ENDIF ENDIF IF (NELIM.EQ.0) THEN PIMASTER(STEP(INODE)) = 0 ELSE NOINT = 6 + NSLAVES + NELIM + NELIM + KEEP(IXSZ) NOREAL= 0_8 CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN WRITE(*,*) ' Failure in int space allocation in CB area ', & ' during assembly of root : CMUMPS_PROCESS_RTNELIND', & ' size required was :', NOINT, & 'INODE=',INODE,' NELIM=',NELIM, ' NSLAVES=', NSLAVES RETURN ENDIF PIMASTER(STEP( INODE )) = IWPOSCB + 1 PAMASTER(STEP( INODE )) = IPTRLU + 1_8 IW( IWPOSCB + 1+KEEP(IXSZ) ) = 2*NELIM IW( IWPOSCB + 2+KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0 IW( IWPOSCB + 5+KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN IW( IWPOSCB+7+KEEP(IXSZ):IWPOSCB+7+KEEP(IXSZ)+NSLAVES-1) = & SLAVE_LIST(1:NSLAVES) ENDIF DEB_ROW = IWPOSCB+7+NSLAVES+KEEP(IXSZ) IW(DEB_ROW : DEB_ROW+NELIM -1) = ROW_LIST(1:NELIM) DEB_COL = DEB_ROW + NELIM IW(DEB_COL : DEB_COL+NELIM -1) = COL_LIST(1:NELIM) ENDIF IF (NSTK_S(STEP(IROOT)) .EQ. 0 ) THEN CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IROOT ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF END IF RETURN END SUBROUTINE CMUMPS_PROCESS_RTNELIND MUMPS_5.4.1/src/zmumps_gpu.c0000664000175000017500000000117314102210474016064 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include #include #include #include "zmumps_gpu.h" void MUMPS_CALL zmumps_gpu_return() { /* GPU feature will be available in the future */ } MUMPS_5.4.1/src/dfac_asm_master_m.F0000664000175000017500000021335714102210522017250 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_FAC_ASM_MASTER_M CONTAINS SUBROUTINE DMUMPS_FAC_ASM_NIV1( COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, ND, & FILS, FRERE, DAD, MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER,PTRARW, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, SON_LEVEL2, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, LRLUSM, & ICNTL, KEEP,KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & & NSTK_S,PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, IPOOL, LPOOL, LEAF, & PERM, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, JOBASS, ETATASS & , LRGROUPS & ) !$ USE OMP_LIB USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_IS_DYNAMIC, & DMUMPS_DM_FREE_BLOCK USE MUMPS_BUILD_SORT_INDEX_M USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE, & DMUMPS_BLR_ASM_NIV1 USE DMUMPS_LR_DATA_M, ONLY : DMUMPS_BLR_INIT_FRONT, & DMUMPS_BLR_SAVE_NFS4FATHER USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER IZERO PARAMETER (IZERO=0) INTEGER N, NSTEPS INTEGER(8) LA, LRLU, LRLUS, LRLUSM, IPTRLU, POSFAC INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE,MAXFRW, & IWPOSCB, COMP INTEGER, TARGET :: IWPOS, LIW INTEGER IDUMMY(1) INTEGER, PARAMETER :: LIDUMMY = 1 INTEGER, TARGET :: IW(LIW) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER ITLOC(N+KEEP(253)), & ND(KEEP(28)), PERM(N), & FILS(N), FRERE(KEEP(28)), DAD(KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), PIMASTER(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRFAC(KEEP(28)), PTRAST(KEEP(28)), & PAMASTER(KEEP(28)) INTEGER COMM, NBFIN, SLAVEF, MYID INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER JOBASS,ETATASS LOGICAL SON_LEVEL2 DOUBLE PRECISION, TARGET :: A(LA) INTEGER, INTENT(IN) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INTEGER LPOOL, LEAF INTEGER LBUFR, LBUFR_BYTES INTEGER IPOOL( LPOOL ) INTEGER NSTK_S(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER BUFR( LBUFR ) LOGICAL PACKED_CB, IS_CB_LR INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INCLUDE 'mumps_headers.h' INTEGER LP, HS, HF LOGICAL LPOK INTEGER NBPANELS_L, NBPANELS_U INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER(8) NFRONT8, LAELL8, LAELL_REQ8, ITMP8, KEEP8TMPCOPY INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER LREQ_OOC INTEGER :: SON_XXS, SON_XXLR INTEGER(8) LSTK8, SIZFR8 LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER SIZFI, NCB INTEGER NCOLS, NROWS, LDA_SON INTEGER NELIM, IORG, IBROT #if ! defined(ZERO_TRIANGLE) INTEGER(8) :: NUMROWS, JJ3 #endif INTEGER :: TOPDIAG !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER JPOS,ICT11 INTEGER IJROW,NBCOL,NUMORG,IOLDPS INTEGER(8) IACHK, POSELT, LAPOS2, IACHK_ini INTEGER(8) APOS, APOS2, APOS3, POSEL1, ICT12 INTEGER(8) :: JJ2, ICT13 INTEGER(8) :: JK8, J18, J28, J38, J48, JJ8 INTEGER(8) :: AINPUT8 INTEGER :: K1, K2, K3, KK, KK1 INTEGER :: J253 INTEGER NSLAVES, NSLSON, NPIVS,NPIV_ANA,NPIV INTEGER PTRCOL, ISLAVE, PDEST,LEVEL INTEGER ISON_IN_PLACE LOGICAL SKIP_TOP_STACK INTEGER ISON_TOP INTEGER(8) SIZE_ISON_TOP8, DYN_SIZE_ISON_TOP8 LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE !$ LOGICAL OMP_PARALLEL_FLAG LOGICAL LEVEL1, NIV1 INTEGER TROW_SIZE INTEGER INDX, FIRST_INDEX, SHIFT_INDEX INTEGER PARPIV_T1 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER, POINTER :: SON_IWPOS, SON_LIW INTEGER, POINTER, DIMENSION(:) :: SON_IW DOUBLE PRECISION, POINTER, DIMENSION(:) :: SON_A INTEGER NCBSON LOGICAL SAME_PROC INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE INTRINSIC real DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR EXTERNAL MUMPS_INSSARBR LOGICAL MUMPS_INSSARBR LOGICAL SSARBR DOUBLE PRECISION FLOP1,FLOP1_EFF EXTERNAL MUMPS_IN_OR_ROOT_SSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR !$ NOMP = OMP_GET_MAX_THREADS() LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) NELT = 1 LPTRAR = N NFS4FATHER = -1 PACKED_CB = .FALSE. IS_CB_LR = .FALSE. IN = INODE LEVEL = MUMPS_TYPENODE(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) IF (LEVEL.NE.1) THEN WRITE(*,*) 'INTERNAL ERROR 1 in DMUMPS_FAC_ASM_NIV1 ' CALL MUMPS_ABORT() END IF NSLAVES = 0 HF = 6 + NSLAVES + KEEP(IXSZ) IF (JOBASS.EQ.0) THEN ETATASS= 0 ELSE ETATASS= 2 IOLDPS = PTLUST(STEP(INODE)) NFRONT = IW(IOLDPS + KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) ICT11 = IOLDPS + HF - 1 + NFRONT SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 ISON = FRERE(STEP(ISON)) ENDDO ENDIF GOTO 123 ENDIF NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) END DO NPIV_ANA=NUMORG NSTEPS = NSTEPS + 1 NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON IF (ISON .NE. 0) THEN DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 SON_IW => IW NASS = NASS + SON_IW(PIMASTER(STEP(ISON))+1+KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) END DO ENDIF NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG CALL IS_FRONT_BLR_CANDIDATE(INODE, 1, ND(STEP(INODE)), & NUMORG, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) IF (DAD(STEP(INODE)).NE.0) THEN IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199) ) & .NE. MYID & .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(DAD(STEP(INODE)))), & KEEP(199)) & .EQ.1 & ) THEN IF (LRSTATUS.EQ.1 .OR. LRSTATUS.EQ.3) THEN LRSTATUS = LRSTATUS-1 ENDIF ENDIF ENDIF COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NFRONT, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216), LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'INTERNAL ERROR 2 after compress ' WRITE(LP, * ) 'IN DMUMPS_FAC_ASM_NIV1 ' WRITE(LP, * ) 'LRLU,LRLUS=', LRLU,LRLUS ENDIF GOTO 270 END IF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 END IF IOLDPS = IWPOS IWPOS = IWPOS + LREQ ISON_TOP = -9999 ISON_IN_PLACE = -9999 SIZE_ISON_TOP8 = 0_8 IF (KEEP(234).NE.0) THEN IF ( IWPOSCB .NE. LIW ) THEN IF ( IWPOSCB+IW(IWPOSCB+1+XXI).NE.LIW) THEN ISON = IW( IWPOSCB + 1 + XXN ) IF ( DAD( STEP( ISON ) ) .EQ. INODE .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & .EQ. 1 ) & THEN ISON_TOP = ISON CALL MUMPS_GETI8(SIZE_ISON_TOP8,IW(IWPOSCB + 1 + XXR)) CALL MUMPS_GETI8(DYN_SIZE_ISON_TOP8, IW(IWPOSCB + 1 + XXD)) IF (DYN_SIZE_ISON_TOP8 .EQ. 0_8) THEN IF (LRLU .LT. int(NFRONT,8) * int(NFRONT,8)) THEN ISON_IN_PLACE = ISON ENDIF ENDIF END IF END IF END IF END IF NIV1 = .TRUE. CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP, KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, IDUMMY, LIDUMMY ) IF (INFO(1).LT.0) GOTO 300 IF (NFRONT_EFF.NE.NFRONT) THEN IF (NFRONT.GT.NFRONT_EFF) THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(STEP(INODE)), & KEEP(199)))THEN NPIV=NASS1-(NFRONT_EFF-ND(STEP(INODE))) CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1) NPIV=NPIV_ANA CALL MUMPS_GET_FLOPS_COST(ND(STEP(INODE))+KEEP(253), & NPIV,NPIV, & KEEP(50),1,FLOP1_EFF) CALL DMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1-FLOP1_EFF, & KEEP,KEEP8) ENDIF IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) ' INTERNAL ERROR 3 ', & ' IN DMUMPS_FAC_ASM_NIV1 ', & ' NFRONT, NFRONT_EFF = ', & NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF NCB = NFRONT - NASS1 MAXFRW = max0(MAXFRW, NFRONT) ICT11 = IOLDPS + HF - 1 + NFRONT CALL DMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) NFRONT8=int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 IF(PARPIV_T1.NE.0) THEN LAELL8 = LAELL8+int(NASS1,8) ENDIF LAELL_REQ8 = LAELL8 IF ( ISON_IN_PLACE > 0 ) THEN LAELL_REQ8 = LAELL8 - SIZE_ISON_TOP8 ENDIF SKIP_TOP_STACK = (ISON_IN_PLACE.GT.0) CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL_REQ8, SKIP_TOP_STACK, & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 + SIZE_ISON_TOP8 LRLUSM = min( LRLUS, LRLUSM ) ITMP8 = LAELL8 - SIZE_ISON_TOP8 IF (KEEP(405).EQ.0) THEN KEEP8(69) = KEEP8(69) + ITMP8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + ITMP8 KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8(68), KEEP8TMPCOPY) !$OMP END ATOMIC ENDIF POSELT = POSFAC POSFAC = POSFAC + LAELL8 SSARBR=MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) CALL DMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS, & 0_8, & LAELL8-SIZE_ISON_TOP8, & KEEP,KEEP8, & LRLUS) IF (KEEP(405).EQ.0) KEEP(429)= KEEP(429)+1 #if defined(ZERO_TRIANGLE) LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. NFRONT .LT. KEEP(63) ) THEN LAPOS2 = min(POSELT + LAELL8 - 1_8, IPTRLU) !$ CHUNK8=int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT + 1_8 > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A( JJ8 ) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8), KEEP(218))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & NCB, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1,TOPDIAG) ENDIF IF (ETATASS.EQ.1) THEN IF (KEEP(234).NE.0) THEN WRITE(*,*) & "Internal error: ETATASS.EQ.1 and IN-PLACE ACTIVATED" CALL MUMPS_ABORT() ENDIF !$ CHUNK = max( KEEP(360)/2, (NFRONT+NOMP-1) / NOMP ) !$OMP PARALLEL DO PRIVATE(APOS, JJ3) SCHEDULE( STATIC, CHUNK ) !$OMP& IF (NFRONT8 - 1_8 > KEEP(360)) DO JJ8 = 0_8, NFRONT8 - 1_8 JJ3 = min(JJ8+TOPDIAG,int(NASS1-1,8)) APOS = POSELT + JJ8 * NFRONT8 A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO ELSE NUMROWS = min(NFRONT8, (IPTRLU-POSELT) / NFRONT8 ) !$ CHUNK = max(KEEP(360)/2, !$ & ( ((int(NUMROWS)+NOMP-1) / NOMP + 2) / 3) ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK ) !$OMP& IF (int(NUMROWS - 1) .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, NUMROWS - 1_8 APOS = POSELT + JJ8 * NFRONT8 JJ3 = min( NFRONT8 - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS + JJ3) = ZERO ENDDO !$OMP END PARALLEL DO IF( NUMROWS .LT. NFRONT8 ) THEN APOS = POSELT + NFRONT8*NUMROWS A(APOS : min(IPTRLU,APOS+NUMROWS)) = ZERO ENDIF ENDIF END IF #endif PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS IW(IOLDPS + KEEP(IXSZ)) = NFRONT IW(IOLDPS + KEEP(IXSZ)+ 1) = 0 IW(IOLDPS + KEEP(IXSZ) + 2) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 3) = -NASS1 IW(IOLDPS + KEEP(IXSZ) + 4) = STEP(INODE) IW(IOLDPS + KEEP(IXSZ) + 5) = NSLAVES IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN CALL DMUMPS_BLR_INIT_FRONT (IW(IOLDPS+XXF), INFO, & MTK405=KEEP(405)) IF (INFO(1).LT.0) GOTO 500 ENDIF ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) CALL DMUMPS_BLR_SAVE_NFS4FATHER ( IW(IOLDPS+XXF), & ESTIM_NFS4FATHER_ATSON ) IF (INFO(1).LT.0) GOTO 500 ENDIF ENDIF ENDIF 123 CONTINUE IF (NUMSTK.NE.0) THEN IF (ISON_TOP > 0) THEN ISON = ISON_TOP ELSE ISON = IFSON ENDIF DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) SON_IW => IW SON_LIW => LIW SON_IWPOS => IWPOS SON_A => A LSTK = SON_IW(ISTCHK + KEEP(IXSZ)) LSTK8 = int(LSTK,8) NELIM = SON_IW(ISTCHK + KEEP(IXSZ) + 1) NPIVS = SON_IW(ISTCHK + KEEP(IXSZ) + 3) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = SON_IW(ISTCHK + KEEP(IXSZ) + 5) HS = 6 + KEEP(IXSZ) + NSLSON NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.SON_IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT = PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT = ISTCHK ENDIF SON_XXS = SON_IW(ISTCHK_CB_RIGHT+XXS) SON_XXLR = SON_IW(ISTCHK_CB_RIGHT+XXLR) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IS_CB_LR = ( SON_XXLR.EQ.1 .OR. SON_XXLR.EQ.3 ) & .AND. (KEEP(489).EQ.1.OR.KEEP(489).EQ.3) LEVEL1 = NSLSON.EQ.0 IF (.NOT.SAME_PROC) THEN NROWS = SON_IW( ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF SIZFI = HS + NROWS + NCOLS K1 = ISTCHK + HS + NROWS + NPIVS IF ( .NOT. LEVEL1 .AND. NELIM.EQ.0 ) GOTO 205 IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN K2 = K1 + LSTK - 1 IF (PACKED_CB) THEN SIZFR8 = (LSTK8*(LSTK8+1_8)/2_8) ELSE SIZFR8 = LSTK8*LSTK8 ENDIF ELSE IF ( KEEP(50).eq.0 ) THEN SIZFR8 = int(NELIM,8) * LSTK8 ELSE IF (PACKED_CB) THEN SIZFR8 = int(NELIM,8) * int(NELIM+1,8)/2_8 ELSE SIZFR8 = int(NELIM,8) * int(NELIM,8) ENDIF END IF K2 = K1 + NELIM - 1 ENDIF IF (JOBASS.EQ.0) THEN IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + LSTK8*LSTK8 ELSE OPASSW = OPASSW + LSTK8*(LSTK8+1)/2_8 ENDIF ELSE IF (KEEP(50).EQ.0) THEN OPASSW = OPASSW + int(NELIM,8)*LSTK8 ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM,8)/2_8 ENDIF ENDIF ENDIF CALL MUMPS_GETI8(DYN_SIZE, SON_IW(ISTCHK_CB_RIGHT+XXD)) IS_DYNAMIC_CB = DYN_SIZE .GT. 0_8 IF ( IS_DYNAMIC_CB ) THEN CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) ENDIF IF (IS_CB_LR .AND. LEVEL1) THEN POSEL1 = PTRAST(STEP(INODE)) CALL DMUMPS_BLR_ASM_NIV1 (A, LA, & POSEL1, NFRONT, NASS1, SON_IW(ISTCHK+XXF), & SON_IW, SON_LIW, & LSTK, NELIM, K1, K1+LSTK-1, KEEP(50), & KEEP, KEEP8, OPASSW) ENDIF IF ( KEEP(50) .eq. 0 ) THEN POSEL1 = PTRAST(STEP(INODE)) - NFRONT8 IF (NFRONT .EQ. LSTK.AND. ISON.EQ.ISON_IN_PLACE & .AND.IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 ) THEN GOTO 205 ENDIF IF (K2.GE.K1) THEN RESET_TO_ZERO = (IACHK .LT. POSFAC .AND. & ISON.EQ.ISON_IN_PLACE) RISK_OF_SAME_POS = IACHK + SIZFR8 - 1_8 .EQ. POSFAC - 1_8 & .AND. ISON.EQ.ISON_IN_PLACE RISK_OF_SAME_POS_THIS_LINE = .FALSE. IACHK_ini = IACHK !$ OMP_PARALLEL_FLAG = (RESET_TO_ZERO.EQV..FALSE.).AND. !$ & ((K2-K1).GT.KEEP(360)) !$OMP PARALLEL IF(OMP_PARALLEL_FLAG) PRIVATE(APOS, KK1, JJ2,IACHK) !$OMP& FIRSTPRIVATE(RISK_OF_SAME_POS_THIS_LINE,RESET_TO_ZERO) !$OMP DO DO 170 KK = K1, K2 APOS = POSEL1 + int(SON_IW(KK),8) * int(NFRONT,8) IACHK = IACHK_ini + int(KK-K1,8)*int(LSTK,8) IF (RESET_TO_ZERO) THEN IF (RISK_OF_SAME_POS) THEN IF (KK.EQ.K2) THEN RISK_OF_SAME_POS_THIS_LINE = & (ISON .EQ. ISON_IN_PLACE) & .AND. ( APOS + int(SON_IW(K1+LSTK-1)-1,8).EQ. & IACHK+int(LSTK-1,8) ) ENDIF ENDIF IF ((IACHK .GE. POSFAC).AND.(KK>K1))THEN RESET_TO_ZERO =.FALSE. ENDIF IF (RISK_OF_SAME_POS_THIS_LINE) THEN DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1 + KK1 - 1) - 1,8) IF ( IACHK+int(KK1-1,8) .NE. JJ2 ) THEN A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDIF ENDDO ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(IACHK + int(KK1 - 1,8)) A(IACHK + int(KK1 -1,8)) = ZERO ENDDO ENDIF ELSE DO KK1 = 1, LSTK JJ2 = APOS + int(SON_IW(K1+KK1-1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) ENDDO ENDIF 170 CONTINUE !$OMP END DO !$OMP END PARALLEL END IF ELSE IF (LEVEL1 .AND. .NOT. IS_CB_LR) THEN LDA_SON = LSTK ELSE LDA_SON = NELIM ENDIF IF (ISON .EQ. ISON_IN_PLACE) THEN CALL DMUMPS_LDLT_ASM_NIV12_IP(A, LA, & PTRAST(STEP( INODE )), NFRONT, NASS1, & IACHK, LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB) ELSE IF (SIZFR8 .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & PTRAST(STEP( INODE )), NFRONT, NASS1, & LDA_SON, SIZFR8, & SON_IW( K1 ), K2 - K1 + 1, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF ENDIF 205 IF (LEVEL1) THEN IF (SAME_PROC) ISTCHK = PTRIST(STEP(ISON)) IF ((SAME_PROC).AND.ETATASS.NE.1) THEN IF (KEEP(50).NE.0) THEN K2 = K1 + LSTK - 1 DO KK = K1, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO ELSE K2 = K1 + LSTK - 1 K3 = K1 + NELIM DO KK = K3, K2 SON_IW(KK) = SON_IW(KK - NROWS) ENDDO IF (NELIM .NE. 0) THEN K3 = K3 - 1 DO KK = K1, K3 JPOS = SON_IW(KK) + ICT11 SON_IW(KK) = IW(JPOS) ENDDO ENDIF ENDIF ENDIF IF (ETATASS.NE.1) THEN IF ( SAME_PROC ) THEN PTRIST(STEP(ISON)) = -99999999 ELSE PIMASTER(STEP( ISON )) = -99999999 ENDIF CALL DMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, & (ISON .EQ. ISON_TOP) & ) IF (IS_DYNAMIC_CB) THEN CALL DMUMPS_DM_FREE_BLOCK( SON_A, SIZFR8, & KEEP(405).EQ.1, KEEP8 ) ENDIF ENDIF ELSE PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP, KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, IDUMMY, & NFRONT, NASS1, NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, IPOOL, LPOOL, & LEAF, NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, ND, FRERE, & LPTRAR, NELT, IW, IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL DMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & IZERO, IDUMMY, IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP, KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP, KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE., LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ENDIF ISON = FRERE(STEP(ISON)) IF (ISON .LE. 0) THEN ISON = IFSON ENDIF 220 CONTINUE END IF IF (ETATASS.EQ.2) GOTO 500 POSELT = PTRAST(STEP(INODE)) IBROT = INODE DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - NFRONT - 1,8) DO JJ8 = J18, J28 APOS2 = ICT12 + int(INTARR(JJ8),8) * NFRONT8 A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + 1_8 ENDDO IF (J38 .LE. J48) THEN ICT13 = POSELT + int(IJROW - 1,8) * NFRONT8 NBCOL = int(J48 - J38 + 1_8) DO 250 JJ8 = 1_8, int(NBCOL,8) APOS3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8) - 1_8,8) A(APOS3) = A(APOS3) + DBLARR(AINPUT8 + JJ8 - 1_8) 250 CONTINUE ENDIF IF (KEEP(50).EQ.0) THEN DO J253=1, KEEP(253) APOS = POSELT+ & int(IJROW-1,8) * NFRONT8 + & int(NFRONT-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ELSE DO J253=1, KEEP(253) APOS = POSELT+ & int(NFRONT-KEEP(253)+J253-1,8) * NFRONT8 + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE IF (PARPIV_T1.NE.0.AND.(.NOT.SON_LEVEL2)) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX ( & N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) ENDIF GOTO 500 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) &' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_FAC_ASM' ENDIF GOTO 490 290 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, SEND BUFFER TOO SMALL DURING DMUMPS_FAC_ASM' ENDIF INFO(1) = -17 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE, RECV BUFFER TOO SMALL DURING DMUMPS_FAC_ASM' ENDIF INFO(1) = -20 LREQ = NCBSON + 6+NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF( INFO(1).EQ.-13 ) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING DMUMPS_FAC_ASM' ENDIF INFO(2) = NUMSTK + 1 ENDIF 490 CONTINUE IF ( KEEP(405) .EQ. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV1 SUBROUTINE DMUMPS_FAC_ASM_NIV2(COMM_LOAD, ASS_IRECV, & N, INODE, IW, LIW, A, LA, INFO, & ND, FILS, FRERE, DAD, & CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & MAXFRW, root, & OPASSW, OPELIW, PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, PTRARW, NSTK_S, & PTRAIW, ITLOC, RHS_MUMPS, NSTEPS, & COMP, LRLU, IPTRLU, IWPOS, IWPOSCB, POSFAC, LRLUS, & ICNTL, KEEP, KEEP8,DKEEP,INTARR,LINTARR,DBLARR,LDBLARR, & PROCNODE_STEPS, SLAVEF, COMM,MYID, & BUFR, LBUFR, LBUFR_BYTES, NBFIN, LEAF, IPOOL, LPOOL, & PERM, MEM_DISTRIB & , LRGROUPS & ) !$ USE OMP_LIB USE MUMPS_BUILD_SORT_INDEX_M USE DMUMPS_BUF USE DMUMPS_LOAD USE DMUMPS_LR_CORE, ONLY : IS_FRONT_BLR_CANDIDATE USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_PTR, & DMUMPS_DM_IS_DYNAMIC USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER N,LIW,NSTEPS, NBFIN INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER(8) :: LRLUS, LRLU, IPTRLU, POSFAC, LA INTEGER, INTENT(INOUT) :: INFO(2) INTEGER INODE, MAXFRW, LPOOL, LEAF, & IWPOS, IWPOSCB, COMP, SLAVEF DOUBLE PRECISION, TARGET :: A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW INTEGER COMM, MYID, LBUFR, LBUFR_BYTES INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER IPOOL(LPOOL) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) INTEGER IW(LIW), ITLOC(N+KEEP(253)), & ND(KEEP(28)), & FILS(N), FRERE(KEEP(28)), DAD (KEEP(28)), & PTRIST(KEEP(28)), PTLUST(KEEP(28)), & STEP(N), & PIMASTER(KEEP(28)), & NSTK_S(KEEP(28)), PERM(N) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER PROCNODE_STEPS(KEEP(28)), BUFR(LBUFR) INTEGER(8), INTENT(IN) :: LINTARR,LDBLARR DOUBLE PRECISION DBLARR(LDBLARR) INTEGER INTARR(LINTARR) INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) !$ INTEGER :: NOMP INTEGER LP, HS, HF, HF_OLD, NCBSON, NSLAVES_OLD LOGICAL LPOK INTEGER NCBSON_MAX INTEGER IN,NUMSTK,NASS,ISON,IFSON,NASS1,IELL INTEGER :: IBC_SOURCE DOUBLE PRECISION, DIMENSION(:), POINTER :: SON_A INTEGER :: MAXWASTEDPROCS PARAMETER (MAXWASTEDPROCS=1) INTEGER NFS4FATHER, ESTIM_NFS4FATHER_ATSON INTEGER IFATH INTEGER I INTEGER NFRONT,NFRONT_EFF,ISTCHK,ISTCHK_CB_RIGHT,LSTK,LREQ INTEGER :: SON_XXS INTEGER(8) :: LAELL8 INTEGER LREQ_OOC INTEGER NBPANELS_L, NBPANELS_U LOGICAL PACKED_CB, IS_CB_LR INTEGER(8) :: LCB LOGICAL :: IS_DYNAMIC_CB INTEGER(8) :: DYN_SIZE INTEGER NCB INTEGER MP INTEGER :: K1, K2, KK, KK1 INTEGER :: J253 INTEGER(8) :: JK8, AINPUT8, J18, J28, J38, J48, JJ8 INTEGER(8) :: LAPOS2, JJ2, JJ3 INTEGER(8) :: ICT13 INTEGER(8) :: IACHK, APOS, APOS2, POSELT, ICT12, POSEL1 #if ! defined(ZERO_TRIANGLE) INTEGER :: TOPDIAG #endif !$ INTEGER :: CHUNK !$ INTEGER(8) :: CHUNK8 INTEGER NELIM,NPIVS,NCOLS,NROWS, & IBROT,IORG INTEGER LDAFS, LDA_SON INTEGER IJROW,NBCOL,NUMORG,IOLDPS, NUMORG_SPLIT INTEGER NSLAVES, NSLSON INTEGER NBLIG, PTRCOL, PTRROW, PDEST INTEGER PDEST1(1) INTEGER :: ISLAVE INTEGER TYPESPLIT INTEGER ISON_IN_PLACE LOGICAL IS_ofType5or6, SPLIT_MAP_RESTART INTEGER NMB_OF_CAND, NMB_OF_CAND_ORIG LOGICAL SAME_PROC, NIV1, SON_LEVEL2 LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER TROW_SIZE, INDX, FIRST_INDEX, SHIFT_INDEX INTEGER LRSTATUS LOGICAL COMPRESS_PANEL, LR_ACTIVATED, COMPRESS_CB, & OOCWRITE_COMPATIBLE_WITH_BLR INTEGER IZERO INTEGER IDUMMY(1) PARAMETER( IZERO = 0 ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, MUMPS_TYPESPLIT DOUBLE PRECISION ZERO DOUBLE PRECISION RZERO PARAMETER( RZERO = 0.0D0 ) PARAMETER( ZERO = 0.0D0 ) INTEGER NELT, LPTRAR logical :: force_cand INTEGER ETATASS INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSMAX DOUBLE PRECISION MAXARR INTEGER INIV2, SIZE_TMP_SLAVES_LIST, allocok INTEGER NCB_SPLIT, SIZE_LIST_SPLIT, NBSPLIT INTEGER, ALLOCATABLE, DIMENSION(:) :: TMP_SLAVES_LIST, COPY_CAND INTEGER, ALLOCATABLE, DIMENSION(:) :: SONROWS_PER_ROW INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR INTEGER :: NB_BLR, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE !$ NOMP = OMP_GET_MAX_THREADS() MP = ICNTL(2) LP = ICNTL(1) LPOK = ((LP.GT.0).AND.(ICNTL(4).GE.1)) IS_ofType5or6 = .FALSE. PACKED_CB = .FALSE. ETATASS = 0 IN = INODE NSTEPS = NSTEPS + 1 KEEP(429) = KEEP(429)+1 NUMORG = 0 DO WHILE (IN.GT.0) NUMORG = NUMORG + 1 IN = FILS(IN) ENDDO NUMSTK = 0 NASS = 0 IFSON = -IN ISON = IFSON NCBSON_MAX = 0 NELT = 1 LPTRAR = 1 DO WHILE (ISON .GT. 0) NUMSTK = NUMSTK + 1 IF ( KEEP(48)==5 .AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) .EQ. 1) THEN NCBSON_MAX = & max(NCBSON_MAX,IW(PIMASTER(STEP(ISON))+KEEP(IXSZ))) ENDIF NASS = NASS + IW(PIMASTER(STEP(ISON)) + 1 + KEEP(IXSZ)) ISON = FRERE(STEP(ISON)) ENDDO NFRONT = ND(STEP(INODE)) + NASS + KEEP(253) NASS1 = NASS + NUMORG NCB = NFRONT - NASS1 CALL IS_FRONT_BLR_CANDIDATE(INODE, 2, NFRONT, NASS1, KEEP(486), & KEEP(489), KEEP(490), KEEP(491), KEEP(492), & KEEP(20), KEEP(60), DAD(STEP(INODE)), KEEP(38), & LRSTATUS, N, LRGROUPS) COMPRESS_PANEL = (LRSTATUS.GE.2) COMPRESS_CB = ((LRSTATUS.EQ.1).OR. & (LRSTATUS.EQ.3)) LR_ACTIVATED = (LRSTATUS.GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN COMPRESS_PANEL = .TRUE. LRSTATUS = 3 ENDIF OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF((KEEP(24).eq.0).or.(KEEP(24).eq.1)) then force_cand=.FALSE. ELSE force_cand=(mod(KEEP(24),2).eq.0) end if TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) IS_ofType5or6 = (TYPESPLIT.EQ.5 .OR. TYPESPLIT.EQ.6) ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) SPLIT_MAP_RESTART = .FALSE. IF (force_cand) THEN INIV2 = ISTEP_TO_INIV2( STEP( INODE )) NMB_OF_CAND = CAND( SLAVEF+1, INIV2 ) NMB_OF_CAND_ORIG = NMB_OF_CAND SIZE_TMP_SLAVES_LIST = NMB_OF_CAND IF (IS_ofType5or6) THEN DO I=NMB_OF_CAND+1,SLAVEF IF ( CAND( I, INIV2 ).LT.0) EXIT NMB_OF_CAND = NMB_OF_CAND +1 ENDDO SIZE_TMP_SLAVES_LIST = NSLSON-1 IF (INODE.EQ.-999999) THEN SPLIT_MAP_RESTART = .TRUE. ENDIF ENDIF IF (IS_ofType5or6.AND.SPLIT_MAP_RESTART) THEN TYPESPLIT = 4 IS_ofType5or6 = .FALSE. SIZE_TMP_SLAVES_LIST = NMB_OF_CAND CAND (SLAVEF+1, INIV2) = SIZE_TMP_SLAVES_LIST ENDIF ELSE INIV2 = 1 SIZE_TMP_SLAVES_LIST = SLAVEF - 1 NMB_OF_CAND = SLAVEF - 1 NMB_OF_CAND_ORIG = SLAVEF - 1 ENDIF ALLOCATE(TMP_SLAVES_LIST(SIZE_TMP_SLAVES_LIST),stat=allocok) IF (allocok > 0 ) THEN GOTO 265 ENDIF IF ( (TYPESPLIT.EQ.4) & .OR.(TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) & ) THEN IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL DMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL DMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) IF (SPLIT_MAP_RESTART) THEN IS_ofType5or6 = .TRUE. TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) CAND( SLAVEF+1, INIV2 ) = NMB_OF_CAND_ORIG ENDIF ELSE ISTCHK = PIMASTER(STEP(IFSON)) PDEST = ISTCHK + 6 + KEEP(IXSZ) NSLSON = IW(ISTCHK + KEEP(IXSZ) + 5) IF (KEEP(376) .EQ. 1) THEN NFRONT = IW( PIMASTER(STEP(IFSON)) + KEEP(IXSZ)) ENDIF CALL DMUMPS_SPLIT_PROPAGATE_PARTI ( & INODE, TYPESPLIT, IFSON, & CAND(1,INIV2), NMB_OF_CAND_ORIG, & IW(PDEST), NSLSON, & STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, ISTEP_TO_INIV2, INIV2, & TAB_POS_IN_PERE, NSLAVES, & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST & ) ENDIF ELSE CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, SLAVEF, KEEP,KEEP8, & ICNTL, CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, & SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) LREQ_OOC = 0 IF (KEEP(201).EQ.1.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_GET_PP_SIZES(KEEP(50), NASS1, NFRONT, NASS1, & NBPANELS_L, NBPANELS_U, LREQ_OOC) ENDIF LREQ = HF + 2 * NFRONT + LREQ_OOC IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN CALL DMUMPS_COMPRE_NEW(N, KEEP(28), & IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & KEEP(216),LRLUS,KEEP(IXSZ), & COMP, DKEEP(97), MYID, SLAVEF, & KEEP(199), PROCNODE_STEPS, DAD) IF (LRLU .NE. LRLUS) THEN IF (LPOK) THEN WRITE(LP, * ) 'PB compress DMUMPS_FAC_ASM_NIV2 ', & 'LRLU,LRLUS=',LRLU,LRLUS ENDIF GOTO 270 ENDIF IF ((IWPOS + LREQ -1) .GT. IWPOSCB) GOTO 270 ENDIF IOLDPS = IWPOS IWPOS = IWPOS + LREQ NIV1 = .FALSE. ALLOCATE(SONROWS_PER_ROW(NFRONT-NASS1), stat=allocok) IF (allocok > 0) THEN GOTO 275 ENDIF ISON_IN_PLACE = -9999 CALL MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE, & SON_LEVEL2, NIV1, KEEP,KEEP8, INFO(1), & ISON_IN_PLACE, & PROCNODE_STEPS, SLAVEF, SONROWS_PER_ROW, & NFRONT-NASS1) IF (INFO(1).LT.0) GOTO 250 IF ( NFRONT .NE. NFRONT_EFF ) THEN IF ( & (TYPESPLIT.EQ.5) .OR. (TYPESPLIT.EQ.6)) THEN WRITE(*,*) ' Internal error 1 in fac_ass due to splitting ', & ' INODE, NFRONT, NFRONT_EFF =', INODE, NFRONT, NFRONT_EFF WRITE(*,*) ' SPLITTING NOT YET READY FOR THAT' CALL MUMPS_ABORT() ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN NCB = NFRONT_EFF - NASS1 NSLAVES_OLD = NSLAVES HF_OLD = HF IF (TYPESPLIT.EQ.4) THEN ALLOCATE(COPY_CAND(SLAVEF+1),stat=allocok) IF (allocok > 0 ) THEN GOTO 245 ENDIF CALL DMUMPS_SPLIT_PREP_PARTITION ( & INODE, STEP, N, SLAVEF, & PROCNODE_STEPS, KEEP, DAD, FILS, & CAND(1,INIV2), ICNTL, COPY_CAND, & NBSPLIT, NUMORG_SPLIT, TMP_SLAVES_LIST(1), & SIZE_TMP_SLAVES_LIST & ) NCB_SPLIT = NCB-NUMORG_SPLIT SIZE_LIST_SPLIT = SIZE_TMP_SLAVES_LIST - NBSPLIT CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP,KEEP8, & ICNTL, COPY_CAND, & MEM_DISTRIB(0), NCB_SPLIT, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST(NBSPLIT+1), & SIZE_LIST_SPLIT,INODE & ) DEALLOCATE (COPY_CAND) CALL DMUMPS_SPLIT_POST_PARTITION ( & INODE, STEP, N, SLAVEF, NBSPLIT, NCB, & PROCNODE_STEPS, KEEP, DAD, FILS, & ICNTL, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES & ) ELSE CALL DMUMPS_LOAD_SET_PARTITION( NCBSON_MAX, & SLAVEF, KEEP, KEEP8, ICNTL, & CAND(1,INIV2), & MEM_DISTRIB(0), NCB, NFRONT_EFF, NSLAVES, & TAB_POS_IN_PERE(1,INIV2), & TMP_SLAVES_LIST, SIZE_TMP_SLAVES_LIST,INODE & ) ENDIF HF = NSLAVES + 6 + KEEP(IXSZ) IWPOS = IWPOS - ((2*NFRONT)-(2*NFRONT_EFF)) - & (NSLAVES_OLD - NSLAVES) IF (NSLAVES_OLD .NE. NSLAVES) THEN IF (NSLAVES_OLD > NSLAVES) THEN DO KK=0,2*NFRONT_EFF-1 IW(IOLDPS+HF+KK)=IW(IOLDPS+HF_OLD+KK) ENDDO ELSE IF (IWPOS - 1 > IWPOSCB ) GOTO 270 DO KK=2*NFRONT_EFF-1, 0, -1 IW(IOLDPS+HF+KK) = IW(IOLDPS+HF_OLD+KK) ENDDO END IF END IF NFRONT = NFRONT_EFF LREQ = HF + 2 * NFRONT + LREQ_OOC ELSE IF (LPOK) THEN WRITE(LP,*) MYID,': INTERNAL ERROR 2 ', & ' IN DMUMPS_FAC_ASM_NIV2 , INODE=', & INODE, ' NFRONT, NFRONT_EFF=', NFRONT, NFRONT_EFF ENDIF GOTO 270 ENDIF ENDIF IF (KEEP(201).EQ.1.AND.KEEP(50).NE.1.AND. & OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_OOC_PP_SET_PTR(KEEP(50), & NBPANELS_L, NBPANELS_U, NASS1, & IOLDPS + HF + 2 * NFRONT, IW, LIW) ENDIF MAXFRW = max0(MAXFRW, NFRONT) PTLUST(STEP(INODE)) = IOLDPS IW(IOLDPS+KEEP(IXSZ)) = NFRONT IW(IOLDPS + 1+KEEP(IXSZ)) = 0 IW(IOLDPS + 2+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 3+KEEP(IXSZ)) = -NASS1 IW(IOLDPS + 4+KEEP(IXSZ)) = STEP(INODE) IW(IOLDPS+5+KEEP(IXSZ)) = NSLAVES IW(IOLDPS+6+KEEP(IXSZ):IOLDPS+5+KEEP(IXSZ)+NSLAVES)= & TMP_SLAVES_LIST(1:NSLAVES) ESTIM_NFS4FATHER_ATSON = -9999 IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN IFATH = DAD( STEP( INODE) ) IF (IFATH.NE.0) THEN IF (COMPRESS_CB.AND. & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)),KEEP(199)) & .EQ. 2 ) THEN IOLDPS = PTLUST(STEP(INODE)) CALL DMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) ENDIF ENDIF ENDIF CALL DMUMPS_LOAD_MASTER_2_ALL(MYID, SLAVEF, COMM_LOAD, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP, KEEP8, IW(IOLDPS+6+KEEP(IXSZ)), NSLAVES,INODE) IF(KEEP(86).EQ.1)THEN IF(mod(KEEP(24),2).eq.0)THEN CALL DMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & CAND(SLAVEF+1,INIV2), & CAND(1,INIV2), & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ELSEIF((KEEP(24).EQ.0).OR.(KEEP(24).EQ.1))THEN CALL DMUMPS_LOAD_SEND_MD_INFO(SLAVEF, & SLAVEF-1, & TMP_SLAVES_LIST, & TAB_POS_IN_PERE(1,ISTEP_TO_INIV2(STEP(INODE))), & NASS1, KEEP,KEEP8, TMP_SLAVES_LIST, & NSLAVES,INODE) ENDIF ENDIF DEALLOCATE(TMP_SLAVES_LIST) IF (KEEP(50).EQ.0) THEN LAELL8 = int(NASS1,8) * int(NFRONT,8) LDAFS = NFRONT ELSE LAELL8 = int(NASS1,8)*int(NASS1,8) IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) & LAELL8 = LAELL8+int(NASS1,8) LDAFS = NASS1 ENDIF CALL DMUMPS_GET_SIZE_NEEDED & (0, LAELL8, .FALSE., & KEEP(1), KEEP8(1), & N,KEEP(28),IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS,IWPOSCB, & PTRIST,PTRAST, & STEP, PIMASTER,PAMASTER,KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), MYID, & SLAVEF, PROCNODE_STEPS, DAD, & INFO(1), INFO(2)) IF (INFO(1).LT.0) GOTO 490 LRLU = LRLU - LAELL8 LRLUS = LRLUS - LAELL8 KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL8 KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSELT = POSFAC PTRAST(STEP(INODE)) = POSELT PTRFAC(STEP(INODE)) = POSELT POSFAC = POSFAC + LAELL8 IW(IOLDPS+XXI) = LREQ CALL MUMPS_STOREI8(LAELL8,IW(IOLDPS+XXR)) CALL MUMPS_STOREI8(0_8,IW(IOLDPS+XXD)) IW(IOLDPS+XXS) = -9999 IW(IOLDPS+XXN) = -99999 IW(IOLDPS+XXP) = -99999 IW(IOLDPS+XXA) = -99999 IW(IOLDPS+XXF) = -99999 IW(IOLDPS+XXLR) = LRSTATUS CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE.,LA-LRLUS,0_8,LAELL8, & KEEP,KEEP8,LRLUS) POSEL1 = POSELT - int(LDAFS,8) #if defined(ZERO_TRIANGLE) LAPOS2 = POSELT + LAELL8 - 1_8 A(POSELT:LAPOS2) = ZERO #else IF ( KEEP(50) .eq. 0 .OR. LDAFS .lt. KEEP(63) ) THEN LAPOS2 = POSELT + LAELL8 - 1_8 !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (LAPOS2 - POSELT > int(KEEP(361),8) .AND. NOMP .GT. 1) DO JJ8 = POSELT, LAPOS2 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = max(KEEP(7), KEEP(8))-1 IF (LR_ACTIVATED) THEN NULLIFY(BEGS_BLR) CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS1, & 0, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) NB_BLR = NPARTSASS + NPARTSCB CALL MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS1) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max(KEEP(360)/2, !$ & ( (( LDAFS + NOMP -1 ) / NOMP + 2) / 3) ) APOS = POSELT !$OMP PARALLEL DO PRIVATE(APOS,JJ3) SCHEDULE(STATIC, CHUNK) !$OMP& IF (LDAFS - 1 .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(LDAFS-1,8) APOS = POSELT + JJ8 * int(LDAFS,8) JJ3 = min( int(LDAFS,8) - 1_8, JJ8 + TOPDIAG ) A(APOS:APOS+JJ3) = ZERO END DO !$OMP END PARALLEL DO IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) A(APOSMAX:APOSMAX+int(LDAFS-1,8))=ZERO ENDIF END IF #endif IF ((NUMSTK.NE.0).AND.(NASS.NE.0)) THEN ISON = IFSON DO 220 IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + KEEP(IXSZ) + 1) IF (NELIM.EQ.0) GOTO 210 LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS=0 NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF ( SAME_PROC ) THEN ISTCHK_CB_RIGHT=PTRIST(STEP(ISON)) ELSE ISTCHK_CB_RIGHT=ISTCHK ENDIF SON_XXS = IW(ISTCHK_CB_RIGHT + XXS) PACKED_CB = ( SON_XXS .EQ. S_CB1COMP ) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + KEEP(IXSZ) + 2) ELSE NROWS = NCOLS ENDIF IF (KEEP(50).EQ.0) THEN LDA_SON = LSTK LCB = int(NELIM,8)*int(LSTK,8) ELSE IF (NSLSON.EQ.0) THEN IF (SAME_PROC) THEN IS_CB_LR = IW(ISTCHK_CB_RIGHT+XXLR).EQ. 1 .OR. & IW(ISTCHK_CB_RIGHT+XXLR).EQ. 3 IF (IS_CB_LR) THEN LDA_SON = NELIM ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = LSTK ENDIF ELSE LDA_SON = NELIM ENDIF IF (PACKED_CB) THEN LCB = (int(NELIM,8)*int(NELIM+1,8))/2_8 ELSE LCB = int(LDA_SON,8)*int(NELIM,8) ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN OPASSW = OPASSW + dble(LCB) ELSE OPASSW = OPASSW + int(NELIM,8)*int(NELIM+1,8)/2_8 ENDIF IS_DYNAMIC_CB = & DMUMPS_DM_IS_DYNAMIC(IW(ISTCHK_CB_RIGHT+XXD: & ISTCHK_CB_RIGHT+XXD+1)) IF ( IS_DYNAMIC_CB ) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(ISTCHK_CB_RIGHT+XXD)) CALL DMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), DYN_SIZE, & SON_A ) IACHK = 1_8 ELSE IACHK = PAMASTER(STEP(ISON)) SON_A=>A ENDIF K1 = ISTCHK + HS + NROWS + NPIVS K2 = K1 + NELIM - 1 IF (KEEP(50).eq.0) THEN IF (IS_ofType5or6) THEN APOS = POSELT DO JJ8 = 1_8, int(NELIM,8)*int(LSTK,8) A(APOS+JJ8-1_8) = A(APOS+JJ8-1_8) + SON_A(IACHK+JJ8-1_8) ENDDO ELSE DO 170 KK = K1, K2 APOS = POSEL1 + int(IW(KK),8) * int(LDAFS,8) DO 160 KK1 = 1, LSTK JJ2 = APOS + int(IW(K1 + KK1 - 1),8) - 1_8 A(JJ2) = A(JJ2) + SON_A(IACHK + int(KK1 - 1,8)) 160 CONTINUE IACHK = IACHK + int(LSTK,8) 170 CONTINUE ENDIF ELSE IF (LCB .GT. 0) THEN CALL DMUMPS_LDLT_ASM_NIV12(A, LA, SON_A(IACHK), & POSELT, LDAFS, NASS1, & LDA_SON, LCB, & IW( K1 ), NELIM, NELIM, ETATASS, & PACKED_CB !$ & , KEEP(360) & ) ENDIF ENDIF 210 ISON = FRERE(STEP(ISON)) 220 CONTINUE ENDIF IBROT = INODE APOSMAX = POSELT + int(NASS1,8)*int(NASS1,8) DO 260 IORG = 1, NUMORG JK8 = PTRAIW(IBROT) AINPUT8 = PTRARW(IBROT) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) J38 = J28 + 1_8 J48 = J28 - INTARR(JJ8) IJROW = INTARR(J18) ICT12 = POSELT + int(IJROW - 1 - LDAFS, 8) MAXARR = RZERO DO JJ8 = J18, J28 IF (KEEP(219).NE.0) THEN IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ELSEIF (KEEP(50).EQ.2) THEN MAXARR = max(MAXARR,abs(DBLARR(AINPUT8))) ENDIF ELSE IF (INTARR(JJ8).LE.NASS1) THEN APOS2 = ICT12 + int(INTARR(JJ8),8) * int(LDAFS,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) ENDIF ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IF(KEEP(219).NE.0.AND.KEEP(50) .EQ. 2) THEN A(APOSMAX+int(IJROW-1,8)) = MAXARR ENDIF IF (J38 .GT. J48) GOTO 255 ICT13 = POSELT + int(IJROW - 1,8) * int(LDAFS,8) NBCOL = int(J48 - J38 + 1_8) DO JJ8 = 1_8, int(NBCOL,8) JJ3 = ICT13 + int(INTARR(J38 + JJ8 - 1_8),8) - 1_8 A(JJ3) = A(JJ3) + DBLARR(AINPUT8 + JJ8 - 1_8) ENDDO 255 CONTINUE IF (KEEP(50).EQ.0) THEN DO J253 = 1, KEEP(253) APOS = POSELT + & int(IJROW-1,8) * int(LDAFS,8) + & int(LDAFS-KEEP(253)+J253-1,8) A(APOS) = A(APOS) + RHS_MUMPS( (J253-1)*KEEP(254)+IBROT ) ENDDO ENDIF IBROT = FILS(IBROT) 260 CONTINUE PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 PDEST = IOLDPS + 6 + KEEP(IXSZ) IBC_SOURCE = MYID DO ISLAVE = 1, NSLAVES CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB, & NSLAVES, & NBLIG, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 IERR = -1 DO WHILE (IERR .EQ.-1) IF ( KEEP(50) .eq. 0 ) THEN NBCOL = NFRONT CALL DMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & IZERO, IDUMMY, & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ELSE NBCOL = NASS1+SHIFT_INDEX+NBLIG CALL DMUMPS_BUF_SEND_DESC_BANDE( INODE, & sum(SONROWS_PER_ROW(FIRST_INDEX:FIRST_INDEX+NBLIG-1)), & NBLIG, IW(PTRROW), NBCOL, IW(PTRCOL), NASS1, & NSLAVES-ISLAVE, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)+ISLAVE), & ESTIM_NFS4FATHER_ATSON, & IW(PDEST), IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , IW(IOLDPS+XXLR) & ) ENDIF IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 IF (MESSAGE_RECEIVED) THEN IOLDPS = PTLUST(STEP(INODE)) PTRCOL = IOLDPS + HF + NFRONT PTRROW = IOLDPS + HF + NASS1 + SHIFT_INDEX ENDIF ENDIF ENDDO IF (IERR .EQ. -2) GOTO 300 IF (IERR .EQ. -3) GOTO 305 PTRROW = PTRROW + NBLIG PDEST = PDEST + 1 ENDDO DEALLOCATE(SONROWS_PER_ROW) IF (NUMSTK.EQ.0) GOTO 500 ISON = IFSON DO IELL = 1, NUMSTK ISTCHK = PIMASTER(STEP(ISON)) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF ( NPIVS .LT. 0 ) NPIVS = 0 NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOS) IF (.NOT.SAME_PROC) THEN NROWS = IW(ISTCHK + 2 + KEEP(IXSZ) ) ELSE NROWS = NCOLS ENDIF PDEST = ISTCHK + 6 + KEEP(IXSZ) NCBSON = LSTK - NELIM PTRCOL = ISTCHK + HS + NROWS + NPIVS + NELIM IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN NFS4FATHER = NCBSON DO I=0,NCBSON-1 IF(IW(PTRCOL+I) .GT. NASS1) THEN NFS4FATHER = I EXIT ENDIF ENDDO NFS4FATHER = NFS4FATHER + NELIM ELSE NFS4FATHER = 0 ENDIF IF (NSLSON.EQ.0) THEN NSLSON = 1 PDEST1(1) = MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) IF (PDEST1(1).EQ.MYID) THEN CALL DMUMPS_MAPLIG_FILS_NIV1( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & NFRONT, NASS1, NFS4FATHER, NCBSON, IW( PTRCOL ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, & INFO(1), INFO(2), MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP, KEEP8, DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & LRGROUPS ) IF ( INFO(1) .LT. 0 ) GOTO 500 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM CALL DMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT,NASS1,NFS4FATHER, & ISON, MYID, & NSLAVES, IW( PTLUST(STEP(INODE)) + 6 +KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, PDEST1, NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, & NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF ELSE IF (PIMASTER(STEP(ISON)).GT.0) THEN IERR = -1 DO WHILE (IERR.EQ.-1) PTRCOL = PIMASTER(STEP(ISON)) + HS + NROWS + NPIVS + NELIM PDEST = PIMASTER(STEP(ISON)) + 6 + KEEP(IXSZ) CALL DMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, & NSLAVES, IW(PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & IW(PTRCOL), NCBSON, & COMM, IERR, IW(PDEST), NSLSON, SLAVEF, & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & ) IF (IERR.EQ.-1) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), & INFO(2), COMM, & PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root,OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, IW, IW, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF ENDDO IF (IERR .EQ. -2) GOTO 290 IF (IERR .EQ. -3) GOTO 295 ENDIF DO ISLAVE = 0, NSLSON-1 IF (IW(PDEST+ISLAVE).EQ.MYID) THEN CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE+1, NCBSON, & NSLSON, & TROW_SIZE, FIRST_INDEX ) SHIFT_INDEX = FIRST_INDEX - 1 INDX = PTRCOL + SHIFT_INDEX CALL DMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES, & IW( PTLUST(STEP(INODE))+6+KEEP(IXSZ)), & NFRONT, NASS1,NFS4FATHER, & TROW_SIZE, IW( INDX ), & PROCNODE_STEPS, & SLAVEF, POSFAC, IWPOS, IWPOSCB, IPTRLU, LRLU, & LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, & PIMASTER, PAMASTER, NSTK_S, COMP, INFO(1), INFO(2), & MYID, COMM, PERM, IPOOL, LPOOL, LEAF, & NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ND, FRERE, LPTRAR, NELT, IW, & IW, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, LRGROUPS) IF ( INFO(1) .LT. 0 ) GOTO 500 EXIT ENDIF ENDDO ENDIF ISON = FRERE(STEP(ISON)) ENDDO GOTO 500 250 CONTINUE IF (INFO(1).EQ.-13) THEN IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER DYNAMIC ALLOCATION DURING & DMUMPS_FAC_ASM_NIV2' ENDIF INFO(2) = NUMSTK + 1 ENDIF GOTO 490 245 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING COPY_CAND', & ' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SLAVEF+1 GOTO 490 265 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING TMP_SLAVES_LIST', & ' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = SIZE_TMP_SLAVES_LIST GOTO 490 270 CONTINUE INFO(1) = -8 INFO(2) = LREQ IF (LPOK) THEN WRITE( LP, * ) & ' FAILURE IN INTEGER ALLOCATION DURING DMUMPS_FAC_ASM_NIV2' ENDIF GOTO 490 275 CONTINUE IF (LPOK) THEN WRITE( LP, * ) ' FAILURE ALLOCATING SONROWS_PER_ROW', & ' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -13 INFO(2) = NFRONT-NASS1 GOTO 490 290 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (1) DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 295 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (1) DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NCBSON + 6 + NSLSON+KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 300 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, SEND BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -17 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 305 CONTINUE IF ((ICNTL(1) .GT. 0) .AND. (ICNTL(4) .GE. 1)) THEN LP = ICNTL(1) WRITE( LP, * ) &' FAILURE, RECV BUFFER TOO SMALL (2)', &' DURING DMUMPS_FAC_ASM_NIV2' ENDIF INFO(1) = -20 LREQ = NBLIG + NBCOL + 4 + KEEP(IXSZ) INFO(2) = LREQ * KEEP( 34 ) GOTO 490 490 CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 500 CONTINUE RETURN END SUBROUTINE DMUMPS_FAC_ASM_NIV2 END MODULE DMUMPS_FAC_ASM_MASTER_M MUMPS_5.4.1/src/ssol_matvec.F0000664000175000017500000002371214102210525016140 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_MV_ELT( N, NELT, ELTPTR, ELTVAR, A_ELT, & X, Y, K50, MTYPE ) IMPLICIT NONE C C Purpose C ======= C C To perform the matrix vector product C A_ELT X = Y if MTYPE = 1 C A_ELT^T X = Y if MTYPE = 0 C C If K50 is different from 0, then the elements are C supposed to be in symmetric packed storage; the C lower part is stored by columns. C Otherwise, the element is square, stored by columns. C C Note C ==== C C A_ELT is processed entry by entry and this code is not C optimized. In particular, one could gather/scatter C X / Y for each element to improve performance. C C Arguments C ========= C INTEGER N, NELT, K50, MTYPE INTEGER ELTPTR( NELT + 1 ), ELTVAR( * ) REAL A_ELT( * ), X( N ), Y( N ) C C Local variables C =============== C INTEGER IEL, I , J, SIZEI, IELPTR INTEGER(8) :: K8 REAL TEMP REAL ZERO PARAMETER( ZERO = 0.0E0 ) C C C Executable statements C ===================== C Y = ZERO K8 = 1_8 C -------------------- C Process the elements C -------------------- DO IEL = 1, NELT SIZEI = ELTPTR( IEL + 1 ) - ELTPTR( IEL ) IELPTR = ELTPTR( IEL ) - 1 IF ( K50 .eq. 0 ) THEN C ------------------- C Unsymmetric element C stored by columns C ------------------- IF ( MTYPE .eq. 1 ) THEN C ----------------- C Compute A_ELT x X C ----------------- DO J = 1, SIZEI TEMP = X( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * TEMP K8 = K8 + 1 END DO END DO ELSE C ------------------- C Compute A_ELT^T x X C ------------------- DO J = 1, SIZEI TEMP = Y( ELTVAR( IELPTR + J ) ) DO I = 1, SIZEI TEMP = TEMP + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO Y( ELTVAR( IELPTR + J ) ) = TEMP END DO END IF ELSE C ----------------- C Symmetric element C L stored by cols C ----------------- DO J = 1, SIZEI C Diagonal counted once Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) K8 = K8 + 1 DO I = J+1, SIZEI C Off diagonal + transpose Y( ELTVAR( IELPTR + I ) ) = & Y( ELTVAR( IELPTR + I ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + J ) ) Y( ELTVAR( IELPTR + J ) ) = & Y( ELTVAR( IELPTR + J ) ) + & A_ELT( K8 ) * X( ELTVAR( IELPTR + I ) ) K8 = K8 + 1 END DO END DO END IF END DO RETURN END SUBROUTINE SMUMPS_MV_ELT SUBROUTINE SMUMPS_LOC_MV8 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C C Perform a distributed matrix vector product. C Y_loc <- A X if MTYPE = 1 C Y_loc <- A^T X if MTYPE = 0 C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done on exit. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) REAL A_loc( NZ_loc8 ), X( N ), Y_loc( N ) INTEGER LDLT, MTYPE C C Locals variables: C ================ C INTEGER I, J INTEGER(8) :: K8 REAL ZERO PARAMETER( ZERO = 0.0E0 ) Y_loc = ZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + A_loc(K8) * X(J) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + A_loc(K8) * X(I) ENDIF ENDDO END IF RETURN END SUBROUTINE SMUMPS_LOC_MV8 SUBROUTINE SMUMPS_MV8( N, NZ8, IRN, ICN, ASPK, X, Y, & LDLT, MTYPE, MAXTRANS, PERM, & IFLAG, IERROR ) C C Purpose: C ======= C C Perform matrix-vector product C Y <- A X if MTYPE = 1 C Y <- A^T X if MTYPE = 0 C C C Note: C ==== C C MAXTRANS should be set to 1 if a column permutation C was applied on A and we still want the matrix vector C product wrt the original matrix. C C Arguments: C ========= C INTEGER N, LDLT, MTYPE, MAXTRANS INTEGER(8) :: NZ8 INTEGER IRN( NZ8 ), ICN( NZ8 ) INTEGER PERM( N ) REAL ASPK( NZ8 ), X( N ), Y( N ) INTEGER, intent(inout) :: IFLAG, IERROR C C Local variables C =============== C INTEGER I, J INTEGER(8) :: K8 REAL, DIMENSION(:), ALLOCATABLE :: PX REAL ZERO INTEGER :: allocok PARAMETER( ZERO = 0.0E0 ) Y = ZERO ALLOCATE(PX(N), stat=allocok) IF (allocok < 0) THEN IFLAG = -13 IERROR = N RETURN ENDIF C C -------------------------------------- C Permute X if A has been permuted C with some max-trans column permutation C -------------------------------------- IF ( MAXTRANS .eq. 1 .and. MTYPE .eq. 1) THEN DO I = 1, N PX(I) = X( PERM( I ) ) END DO ELSE PX = X END IF IF ( LDLT .eq. 0 ) THEN C C Complete unsymmetric matrix was provided (LU facto) IF (MTYPE .EQ. 1) THEN DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) ENDDO ELSE DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(J) = Y(J) + ASPK(K8) * PX(I) ENDDO ENDIF C ELSE C C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ8 I = IRN(K8) J = ICN(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y(I) = Y(I) + ASPK(K8) * PX(J) IF (J.NE.I) THEN Y(J) = Y(J) + ASPK(K8) * PX(I) ENDIF ENDDO END IF IF ( MAXTRANS .EQ. 1 .AND. MTYPE .eq. 0 ) THEN PX = Y DO I = 1, N Y( PERM( I ) ) = PX( I ) END DO END IF DEALLOCATE(PX) RETURN END SUBROUTINE SMUMPS_MV8 C C SUBROUTINE SMUMPS_LOC_OMEGA1 &( N, NZ_loc8, IRN_loc, JCN_loc, A_loc, X, Y_loc, & LDLT, MTYPE) IMPLICIT NONE C C Purpose: C ======= C Compute C * If MTYPE = 1 C Y_loc(i) = Sum | Aij | | Xj | C j C * If MTYPE = 0 C Y_loc(j) = Sum | Aij | | Xi | C C C Notes: C ===== C C 1) assembly of all Y_loc still has to be done. C 2) X should be available on all processors. C C Arguments: C ========= C INTEGER N INTEGER(8) :: NZ_loc8 INTEGER IRN_loc( NZ_loc8 ), JCN_loc( NZ_loc8 ) REAL A_loc( NZ_loc8 ), X( N ) REAL Y_loc( N ) INTEGER LDLT, MTYPE C C Local variables: C =============== C INTEGER I, J INTEGER(8) :: K8 REAL, PARAMETER :: RZERO=0.0E0 C Y_loc = RZERO IF ( LDLT .eq. 0 ) THEN C Unsymmetric IF ( MTYPE .eq. 1 ) THEN C No transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) ENDDO ELSE C Transpose DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) & .OR. (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDDO END IF ELSE C Lower (or upper) part of symmetric C matrix was provided (LDLT facto) DO K8 = 1_8, NZ_loc8 I = IRN_loc(K8) J = JCN_loc(K8) IF ((I .LE. 0) .OR. (I .GT. N) .OR. & (J .LE. 0) .OR. (J .GT. N) & ) CYCLE Y_loc(I) = Y_loc(I) + abs( A_loc(K8) * X(J) ) IF (J.NE.I) THEN Y_loc(J) = Y_loc(J) + abs( A_loc(K8) * X(I) ) ENDIF ENDDO END IF RETURN END SUBROUTINE SMUMPS_LOC_OMEGA1 MUMPS_5.4.1/src/mumps_common.c0000664000175000017500000000475214102210474016375 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mumps_common.h" /* Special case of mapping and pivnul_list -- allocated from MUMPS */ static MUMPS_INT * MUMPS_MAPPING; static MUMPS_INT * MUMPS_PIVNUL_LIST; /* as uns_perm and sym_perm */ static MUMPS_INT * MUMPS_SYM_PERM; static MUMPS_INT * MUMPS_UNS_PERM; MUMPS_INT* mumps_get_mapping() { return MUMPS_MAPPING; } void MUMPS_CALL MUMPS_ASSIGN_MAPPING(MUMPS_INT * f77mapping) { MUMPS_MAPPING = f77mapping; } void MUMPS_CALL MUMPS_NULLIFY_C_MAPPING() { MUMPS_MAPPING = 0; } MUMPS_INT* mumps_get_pivnul_list() { return MUMPS_PIVNUL_LIST; } void MUMPS_CALL MUMPS_ASSIGN_PIVNUL_LIST(MUMPS_INT * f77pivnul_list) { MUMPS_PIVNUL_LIST = f77pivnul_list; } void MUMPS_CALL MUMPS_NULLIFY_C_PIVNUL_LIST() { MUMPS_PIVNUL_LIST = 0; } MUMPS_INT* mumps_get_sym_perm() { return MUMPS_SYM_PERM; } void MUMPS_CALL MUMPS_ASSIGN_SYM_PERM(MUMPS_INT * f77sym_perm) { MUMPS_SYM_PERM = f77sym_perm; } void MUMPS_CALL MUMPS_NULLIFY_C_SYM_PERM() { MUMPS_SYM_PERM = 0; } MUMPS_INT* mumps_get_uns_perm() { return MUMPS_UNS_PERM; } void MUMPS_CALL MUMPS_ASSIGN_UNS_PERM(MUMPS_INT * f77uns_perm) { MUMPS_UNS_PERM = f77uns_perm; } void MUMPS_CALL MUMPS_NULLIFY_C_UNS_PERM() { MUMPS_UNS_PERM = 0; } void MUMPS_CALL MUMPS_ICOPY_32TO64_64C_IP_C(MUMPS_INT *inouttab, MUMPS_INT8 *sizetab) /* Copies in-place *sizetab int values starting at address inouttab into *sizetab int64_t values starting at the same address. */ { MUMPS_INT8 i8; /* signed integer needed for reversed loop below */ for (i8=*sizetab-1; i8 >=0; i8--) { /* outtab8[i8]=(MUMPS_INT8)intab4[i8]; */ ((MUMPS_INT8 *)inouttab)[i8]=(MUMPS_INT8)inouttab[i8]; } } void MUMPS_CALL MUMPS_ICOPY_64TO32_64C_IP_C(MUMPS_INT8 *inouttab, MUMPS_INT8 *sizetab) /* Copies in-place *sizetab int64_t values starting at address inouttab into *sizetab int values starting at the same address */ { MUMPS_INT8 i8; for (i8=0; i8 < *sizetab; i8++) { /* outtab4[i8]=(MUMPS_INT)intab8[i8]; */ ((MUMPS_INT *)inouttab)[i8]=(MUMPS_INT)inouttab[i8]; } } MUMPS_5.4.1/src/cfac_process_message.F0000664000175000017500000010363314102210523017756 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE CMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_LOAD USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER MSGSOU, MSGTAG, MSGLEN INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER KEEP(500), ICNTL( 60 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) INTEGER, intent(in) :: LRGROUPS(N) COMPLEX A( LA ) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER COMM_LOAD, ASS_IRECV INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INIV2, ISHIFT, IBEG INTEGER ISHIFT_HDR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE LOGICAL FLAG INTEGER MP, LP INTEGER TMP( 2 ) INTEGER NBRECU, POSITION, INODE, ISON, IROOT INTEGER NSLAVES_PERE, NFRONT_PERE, NASS_PERE, & LMAP, FPERE, NELIM, & HDMAPLIG,NFS4FATHER, & TOT_ROOT_SIZE, TOT_CONT_TO_RECV DOUBLE PRECISION FLOP1 CHARACTER(LEN=35) :: SUBNAME INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) MP = ICNTL(2) LP = ICNTL(1) SUBNAME="??????" CALL CMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( MSGTAG .EQ. RACINE ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NBRECU, & 1, MPI_INTEGER, COMM, IERR) NBRECU = BUFR( 1 ) NBFIN = NBFIN - NBRECU ELSEIF ( MSGTAG .EQ. NOEUD ) THEN CALL CMUMPS_PROCESS_NODE( MYID, KEEP, KEEP8, DKEEP, & BUFR, LBUFR, LBUFR_BYTES, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, FPERE, FLAG, IFLAG, IERROR, COMM, & ITLOC, RHS_MUMPS ) SUBNAME="CMUMPS_PROCESS_NODE" IF ( IFLAG .LT. 0 ) GO TO 500 IF ( FLAG ) THEN CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), KEEP(28), KEEP(76), & KEEP(80), KEEP(47), STEP, FPERE ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( FPERE, N, & PROCNODE_STEPS,KEEP(199), & ND, FILS, FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), FLOP1, & IW, LIW, KEEP(IXSZ) ) IF (FPERE.NE.KEEP(20)) & CALL CMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF ELSEIF ( MSGTAG .EQ. END_NIV2_LDLT ) THEN INODE = BUFR( 1 ) CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, & PROCNODE_STEPS, SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, -INODE ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF ELSEIF ( MSGTAG .EQ. TERREUR ) THEN IFLAG = -001 IERROR = MSGSOU GOTO 100 ELSEIF ( MSGTAG .EQ. MAITRE_DESC_BANDE ) THEN CALL CMUMPS_PROCESS_DESC_BANDE( MYID,BUFR, LBUFR, & LBUFR_BYTES, IWPOS, & IWPOSCB, & IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP, & KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2, #if ! defined (NO_FDM_DESCBAND) & -1, #endif & IFLAG, IERROR ) SUBNAME="CMUMPS_PROCESS_DESC_BANDE" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. MAITRE2 ) THEN CALL CMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & KEEP, KEEP8, DKEEP, ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) SUBNAME="CMUMPS_PROCESS_MASTER2" IF ( IFLAG .LT. 0 ) GO to 500 ELSEIF ( MSGTAG .EQ. BLOC_FACTO .OR. & MSGTAG .EQ. BLOC_FACTO_RELAY ) THEN CALL CMUMPS_PROCESS_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM , IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM_SLAVE ) THEN CALL CMUMPS_PROCESS_BLFAC_SLAVE( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8,DKEEP, IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. BLOC_FACTO_SYM ) THEN CALL CMUMPS_PROCESS_SYM_BLOCFACTO( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST, PTRFAC, root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ELSEIF ( MSGTAG .EQ. CONTRIB_TYPE2 ) THEN CALL CMUMPS_PROCESS_CONTRIB_TYPE2( COMM_LOAD, ASS_IRECV, & MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, POSFAC, & N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, PERM, COMP, root, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, NSTK_S, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, NBFIN, MYID, COMM, & ICNTL,KEEP,KEEP8,DKEEP,IFLAG, IERROR, IPOOL, LPOOL, LEAF, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSEIF ( MSGTAG .EQ. MAPLIG ) THEN HDMAPLIG = 7 INODE = BUFR( 1 ) ISON = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) NFRONT_PERE = BUFR( 4 ) NASS_PERE = BUFR( 5 ) LMAP = BUFR( 6 ) NFS4FATHER = BUFR( 7 ) IF ( NSLAVES_PERE.NE.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ISHIFT = NSLAVES_PERE+1 TAB_POS_IN_PERE(1:NSLAVES_PERE+1, INIV2) = & BUFR(HDMAPLIG+1:HDMAPLIG+1+NSLAVES_PERE) TAB_POS_IN_PERE(SLAVEF+2, INIV2) = NSLAVES_PERE ELSE ISHIFT = 0 ENDIF IBEG = HDMAPLIG+1+ISHIFT CALL CMUMPS_MAPLIG( COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & INODE, ISON, NSLAVES_PERE, & BUFR(IBEG), & NFRONT_PERE, NASS_PERE, NFS4FATHER,LMAP, & BUFR(IBEG+NSLAVES_PERE), & PROCNODE_STEPS, SLAVEF, POSFAC, IWPOS, IWPOSCB, & IPTRLU, LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, & IFLAG, IERROR, MYID, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, ICNTL, KEEP,KEEP8,DKEEP, root, & OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_CONT_STATIC ) THEN CALL CMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW) SUBNAME="CMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_NON_ELIM_CB ) THEN IROOT = KEEP( 38 ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IROOT)), & KEEP(199) ) IF ( PTLUST( STEP(IROOT)) .EQ. 0 ) THEN KEEP(266)=KEEP(266)-1 CALL MPI_RECV( TMP, 2 * KEEP(34), MPI_PACKED, & MSGSOU, ROOT_2SLAVE, & COMM, STATUS, IERR ) CALL CMUMPS_PROCESS_ROOT2SLAVE( TMP( 1 ), TMP( 2 ), & root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP,ND ) SUBNAME="CMUMPS_PROCESS_ROOT2SLAVE" IF ( IFLAG .LT. 0 ) GOTO 500 END IF CALL CMUMPS_PROCESS_CONTRIB_TYPE3( & BUFR, LBUFR, LBUFR_BYTES, & root, N, IW, LIW, A, LA, & LRLU, IPTRLU, IWPOS, IWPOSCB, & PTRIST, PTLUST, PTRFAC, PTRAST, STEP, PIMASTER, PAMASTER, & COMP, LRLUS, IPOOL, LPOOL, LEAF, & FILS, DAD, MYID, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRAIW, PTRARW, INTARR, DBLARR, & KEEP, KEEP8, DKEEP, IFLAG, IERROR, COMM, COMM_LOAD, & ITLOC, RHS_MUMPS, & ND, PROCNODE_STEPS, SLAVEF, OPASSW ) SUBNAME="CMUMPS_PROCESS_CONTRIB_TYPE3" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. ROOT_2SON ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) CALL CMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, & ISON, NELIM, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GO TO 100 IF ( MYID.NE.MUMPS_PROCNODE(PROCNODE_STEPS(STEP(ISON)), & KEEP(199)) ) THEN IF (KEEP(50).EQ.0) THEN ISHIFT_HDR = 6 ELSE ISHIFT_HDR = 8 ENDIF IF (IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)).EQ. & S_REC_CONTSTATIC) THEN IW(PTRIST(STEP(ISON))+ISHIFT_HDR+KEEP(IXSZ)) = & S_ROOT2SON_CALLED ELSE CALL CMUMPS_FREE_BAND( N, ISON, PTRIST, PTRAST, & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, & MUMPS_TYPENODE(PROCNODE_STEPS(STEP(ISON)),KEEP(199)) & ) ENDIF ENDIF ELSE IF ( MSGTAG .EQ. ROOT_2SLAVE ) THEN TOT_ROOT_SIZE = BUFR( 1 ) TOT_CONT_TO_RECV = BUFR( 2 ) CALL CMUMPS_PROCESS_ROOT2SLAVE( TOT_ROOT_SIZE, & TOT_CONT_TO_RECV, root, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & LPTRAR, NELT, FRTPTR, FRTELT, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8, DKEEP, ND ) IF ( IFLAG .LT. 0 ) GO TO 100 ELSE IF ( MSGTAG .EQ. ROOT_NELIM_INDICES ) THEN ISON = BUFR( 1 ) NELIM = BUFR( 2 ) NSLAVES_PERE = BUFR( 3 ) CALL CMUMPS_PROCESS_RTNELIND( root, & ISON, NELIM, NSLAVES_PERE, BUFR(4), BUFR(4+BUFR(2)), & BUFR(4+2*BUFR(2)), & & PROCNODE_STEPS, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) SUBNAME="CMUMPS_PROCESS_RTNELIND" IF ( IFLAG .LT. 0 ) GO TO 500 ELSE IF ( MSGTAG .EQ. UPDATE_LOAD ) THEN WRITE(*,*) "Internal error 3 in CMUMPS_TRAITER_MESSAGE" CALL MUMPS_ABORT() ELSE IF ( MSGTAG .EQ. TAG_DUMMY ) THEN ELSE IF ( LP > 0 ) & WRITE(LP,*) MYID, &': Internal error, routine CMUMPS_TRAITER_MESSAGE.',MSGTAG IFLAG = -100 IERROR= MSGTAG GOTO 500 ENDIF 100 CONTINUE RETURN 500 CONTINUE IF ( ICNTL(1) .GT. 0 .AND. ICNTL(4).GE.1 ) THEN LP=ICNTL(1) IF (IFLAG.EQ.-9) THEN WRITE(LP,*) 'FAILURE, WORKSPACE TOO SMALL DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-8) THEN WRITE(LP,*) 'FAILURE IN INTEGER ALLOCATION DURING ',SUBNAME ENDIF IF (IFLAG.EQ.-13) THEN WRITE(LP,*) 'FAILURE IN DYNAMIC ALLOCATION DURING ',SUBNAME ENDIF ENDIF CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE CMUMPS_TRAITER_MESSAGE RECURSIVE SUBROUTINE CMUMPS_RECV_AND_TREAT( & COMM_LOAD, ASS_IRECV, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT , & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER COMM_LOAD, ASS_IRECV INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER(8) :: POSFAC, LA, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST( KEEP(28) ) INTEGER STEP(N), PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N+KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) INTEGER MSGSOU, MSGTAG, MSGLEN, IERR MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN IFLAG = -20 IERROR = MSGLEN WRITE(*,*) ' RECEPTION BUF TOO SMALL, Msgtag/len=', & MSGTAG,MSGLEN CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF KEEP(266)=KEEP(266)-1 CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, MSGSOU, & MSGTAG, & COMM, STATUS, IERR ) CALL CMUMPS_TRAITER_MESSAGE( & COMM_LOAD, ASS_IRECV, & MSGSOU, MSGTAG, MSGLEN, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) RETURN END SUBROUTINE CMUMPS_RECV_AND_TREAT RECURSIVE SUBROUTINE CMUMPS_TRY_RECVTREAT( & COMM_LOAD, ASS_IRECV, BLOCKING, SET_IRECV, & MESSAGE_RECEIVED, MSGSOU, MSGTAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & STACK_RIGHT_AUTHORIZED, LRGROUPS ) USE CMUMPS_LOAD USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL, INTENT (IN) :: BLOCKING LOGICAL, INTENT (IN) :: SET_IRECV LOGICAL, INTENT (INOUT) :: MESSAGE_RECEIVED INTEGER, INTENT (IN) :: MSGSOU, MSGTAG INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST( KEEP(28) ), & PTLUST(KEEP(28)) INTEGER STEP(N), & PIMASTER(KEEP(28)) INTEGER COMP INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) ) INTEGER PERM(N) INTEGER IFLAG, IERROR, COMM INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER MYID, SLAVEF, NBFIN DOUBLE PRECISION OPASSW, OPELIW INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) INTEGER ND( KEEP(28) ), FRERE( KEEP(28) ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER INTARR( KEEP8(27) ) COMPLEX DBLARR( KEEP8(26) ) LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED LOGICAL FLAG, RIGHT_MESS, FLAGbis INTEGER LP, MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER IERR INTEGER :: STATUS_BIS(MPI_STATUS_SIZE) INTEGER, SAVE :: RECURS = 0 CALL CMUMPS_LOAD_RECV_MSGS(COMM_LOAD) IF ( .NOT. STACK_RIGHT_AUTHORIZED ) THEN RETURN ENDIF RECURS = RECURS + 1 LP = ICNTL(1) IF (ICNTL(4).LT.1) LP=-1 IF ( MESSAGE_RECEIVED ) THEN MSGSOU_LOC = MPI_ANY_SOURCE MSGTAG_LOC = MPI_ANY_TAG GOTO 250 ENDIF IF ( ASS_IRECV .NE. MPI_REQUEST_NULL) THEN IF (KEEP(117).NE.0) THEN WRITE(*,*) "Problem of active IRECV with KEEP(117)=",KEEP(117) CALL MUMPS_ABORT() ENDIF RIGHT_MESS = .TRUE. IF (BLOCKING) THEN CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) FLAG = .TRUE. IF ( ( (MSGSOU.NE.MPI_ANY_SOURCE) .OR. & (MSGTAG.NE.MPI_ANY_TAG) ) ) THEN IF ( MSGSOU.NE.MPI_ANY_SOURCE) THEN RIGHT_MESS = MSGSOU.EQ.STATUS(MPI_SOURCE) ENDIF IF ( MSGTAG.NE.MPI_ANY_TAG) THEN RIGHT_MESS = & ( (MSGTAG.EQ.STATUS(MPI_TAG)).AND.RIGHT_MESS ) ENDIF IF (.NOT.RIGHT_MESS) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS_BIS, IERR) ENDIF ENDIF ELSE CALL MPI_TEST(ASS_IRECV, & FLAG, STATUS, IERR) ENDIF IF (IERR.LT.0) THEN IFLAG = -20 IF (LP.GT.0) & write(LP,*) ' Error return from MPI_TEST ', & IFLAG, ' in CMUMPS_TRY_RECVTREAT' CALL CMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN ENDIF IF ( FLAG ) THEN KEEP(266)=KEEP(266)-1 MESSAGE_RECEIVED = .TRUE. MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (.NOT.RIGHT_MESS) RECURS = RECURS + 10 CALL CMUMPS_TRAITER_MESSAGE( COMM_LOAD, ASS_IRECV, & MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (.NOT.RIGHT_MESS) RECURS = RECURS - 10 IF ( IFLAG .LT. 0 ) RETURN IF (.NOT.RIGHT_MESS) THEN IF (ASS_IRECV .NE. MPI_REQUEST_NULL) THEN CALL MUMPS_ABORT() ENDIF CALL MPI_IPROBE(MSGSOU,MSGTAG, & COMM, FLAGbis, STATUS, IERR) IF (FLAGbis) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) CALL CMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL,LEAF,NBFIN,MYID,SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, & KEEP,KEEP8, DKEEP,ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDIF ELSE IF (BLOCKING) THEN CALL MPI_PROBE(MSGSOU,MSGTAG, & COMM, STATUS, IERR) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, FLAG, STATUS, IERR) ENDIF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) MESSAGE_RECEIVED = .TRUE. CALL CMUMPS_RECV_AND_TREAT( COMM_LOAD, ASS_IRECV, & STATUS, BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, IFLAG, & IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) RETURN ENDIF ENDIF 250 CONTINUE RECURS = RECURS - 1 IF ( NBFIN .EQ. 0 ) RETURN IF ( RECURS .GT. 3 ) RETURN IF ( KEEP(36).EQ.1 .AND. SET_IRECV .AND. & (ASS_IRECV.EQ.MPI_REQUEST_NULL) .AND. & MESSAGE_RECEIVED ) THEN CALL MPI_IRECV ( BUFR(1), & LBUFR_BYTES, MPI_PACKED, MPI_ANY_SOURCE, & MPI_ANY_TAG, COMM, & ASS_IRECV, IERR ) ENDIF RETURN END SUBROUTINE CMUMPS_TRY_RECVTREAT SUBROUTINE CMUMPS_CANCEL_IRECV( INFO1, & KEEP, ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, & COMM, & MYID, SLAVEF) USE CMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER LBUFR, LBUFR_BYTES INTEGER ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER COMM INTEGER MYID, SLAVEF, INFO1, DEST INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL NO_ACTIVE_IRECV INTEGER IERR, DUMMY INTRINSIC mod IF (SLAVEF .EQ. 1) RETURN IF (ASS_IRECV.EQ.MPI_REQUEST_NULL) THEN NO_ACTIVE_IRECV=.TRUE. ELSE CALL MPI_TEST(ASS_IRECV, NO_ACTIVE_IRECV, & STATUS, IERR) IF (NO_ACTIVE_IRECV) THEN KEEP(266) = KEEP(266) - 1 ENDIF ENDIF CALL MPI_BARRIER(COMM,IERR) DUMMY = 1 DEST = mod(MYID+1, SLAVEF) CALL CMUMPS_BUF_SEND_1INT & (DUMMY, DEST, TAG_DUMMY, COMM, KEEP, IERR) IF (NO_ACTIVE_IRECV) THEN CALL MPI_RECV( BUFR, LBUFR, & MPI_INTEGER, MPI_ANY_SOURCE, & TAG_DUMMY, COMM, STATUS, IERR ) ELSE CALL MPI_WAIT(ASS_IRECV, & STATUS, IERR) ENDIF KEEP(266)=KEEP(266)-1 RETURN END SUBROUTINE CMUMPS_CANCEL_IRECV SUBROUTINE CMUMPS_CLEAN_PENDING( & INFO1, KEEP, BUFR, LBUFR, LBUFR_BYTES, & COMM_NODES, COMM_LOAD, SLAVEF, & CLEAN_COMM_NODES, CLEAN_COMM_LOAD ) USE CMUMPS_BUF IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR, LBUFR_BYTES INTEGER, INTENT(OUT) :: BUFR( LBUFR ) INTEGER, INTENT(IN) :: COMM_NODES, COMM_LOAD, SLAVEF, INFO1 INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, INTENT(IN) :: CLEAN_COMM_LOAD, CLEAN_COMM_NODES INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG, BUFFERS_EMPTY, BUFFERS_EMPTY_ON_ALL_PROCS INTEGER :: MSGSOU_LOC, MSGTAG_LOC, MSGLEN_LOC INTEGER :: COMM_EFF INTEGER :: IERR INTEGER :: IBUF_EMPTY, IBUF_EMPTY_ON_ALL_PROCS INTEGER :: TOTAL_SEND_MINUS_RECV266 INTEGER :: TOTAL_SEND_MINUS_RECV267 IF (SLAVEF.EQ.1) RETURN IF (.NOT. CLEAN_COMM_NODES .AND. .NOT. CLEAN_COMM_LOAD) THEN RETURN ENDIF DO WHILE (.TRUE.) FLAG = .TRUE. DO WHILE ( FLAG ) FLAG = .FALSE. IF (CLEAN_COMM_NODES) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_NODES CALL MPI_IPROBE(MPI_ANY_SOURCE,MPI_ANY_TAG, & COMM_NODES, FLAG, STATUS, IERR) END IF END IF IF (CLEAN_COMM_LOAD) THEN IF ( .NOT. FLAG ) THEN COMM_EFF = COMM_LOAD CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM_LOAD, FLAG, STATUS, IERR) END IF END IF IF (FLAG) THEN MSGSOU_LOC = STATUS( MPI_SOURCE ) MSGTAG_LOC = STATUS( MPI_TAG ) IF (COMM_EFF .EQ. COMM_NODES) THEN KEEP(266) = KEEP(266) - 1 ELSE KEEP(267) = KEEP(267) - 1 ENDIF CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN_LOC, IERR ) IF (MSGLEN_LOC .LE. LBUFR_BYTES) THEN CALL MPI_RECV( BUFR, LBUFR_BYTES, & MPI_PACKED, MSGSOU_LOC, & MSGTAG_LOC, COMM_EFF, STATUS, IERR ) ENDIF ENDIF END DO CALL CMUMPS_BUF_ALL_EMPTY( CLEAN_COMM_NODES, & CLEAN_COMM_LOAD, & BUFFERS_EMPTY ) IF ( BUFFERS_EMPTY ) THEN IBUF_EMPTY = 0 ELSE IBUF_EMPTY = 1 ENDIF IF (CLEAN_COMM_NODES) THEN COMM_EFF = COMM_NODES ELSE COMM_EFF = COMM_LOAD ENDIF CALL MPI_ALLREDUCE(IBUF_EMPTY, & IBUF_EMPTY_ON_ALL_PROCS, & 1, MPI_INTEGER, MPI_MAX, & COMM_EFF, IERR) IF ( IBUF_EMPTY_ON_ALL_PROCS == 0) THEN BUFFERS_EMPTY_ON_ALL_PROCS = .TRUE. ELSE BUFFERS_EMPTY_ON_ALL_PROCS = .FALSE. ENDIF IF (BUFFERS_EMPTY_ON_ALL_PROCS) THEN IF (CLEAN_COMM_NODES) THEN CALL MPI_ALLREDUCE(KEEP(266), & TOTAL_SEND_MINUS_RECV266, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV266 = 0 ENDIF IF (CLEAN_COMM_LOAD) THEN CALL MPI_ALLREDUCE(KEEP(267), & TOTAL_SEND_MINUS_RECV267, & 1, MPI_INTEGER, MPI_SUM, & COMM_EFF, IERR) ELSE TOTAL_SEND_MINUS_RECV267 = 0 ENDIF IF (TOTAL_SEND_MINUS_RECV266 .EQ. 0 .AND. & TOTAL_SEND_MINUS_RECV267 .EQ. 0) THEN EXIT ENDIF ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_CLEAN_PENDING MUMPS_5.4.1/src/cmumps_struc_def.F0000664000175000017500000000102414102210524017152 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_STRUC_DEF INCLUDE 'cmumps_struc.h' END MODULE CMUMPS_STRUC_DEF MUMPS_5.4.1/src/zarrowheads.F0000664000175000017500000010221014102210524016140 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ANA_DIST_ARROWHEADS( MYID, SLAVEF, N, & PROCNODE, STEP, PTRAIW, PTRARW, ISTEP_TO_INIV2, & I_AM_CAND, & KEEP, KEEP8, ICNTL, id ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE (ZMUMPS_STRUC) :: id INTEGER MYID, N, SLAVEF INTEGER KEEP( 500 ), ICNTL( 60 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE( KEEP(28) ), STEP( N ) INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) LOGICAL I_AM_SLAVE LOGICAL I_AM_CAND_LOC INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE, MUMPS_TYPESPLIT INTEGER ISTEP, I, NCOL, NROW, allocok INTEGER TYPE_PARALL, ITYPE, IRANK, INIV2, TYPESPLIT LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS INTEGER(8) :: IPTRI, IPTRR EARLYT3ROOTINS = KEEP(200) .EQ. 0 TYPE_PARALL = KEEP(46) I_AM_SLAVE = (KEEP(46).EQ.1 .OR. MYID.NE.0) KEEP8(26) = 0_8 KEEP8(27) = 0_8 DO I = 1, N ISTEP=abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & ( id%CANDIDATES (id%CANDIDATES(SLAVEF+1, INIV2)+1,INIV2 ) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK = IRANK + 1 END IF IF ( & ( (ITYPE .EQ. 1.OR.ITYPE.EQ.2) .AND. & IRANK .EQ. MYID ) & .OR. & ( T4_MASTER_CONCERNED ) & ) THEN KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ELSE IF ( ITYPE .EQ. 3 ) THEN IF (EARLYT3ROOTINS) THEN ELSE KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) ENDIF ELSE IF ( ITYPE .EQ. 2 .AND. I_AM_CAND_LOC ) THEN PTRARW( I ) = 0_8 KEEP8(26) = KEEP8(26) + 1_8 + PTRAIW(I)+PTRARW(I) KEEP8(27) = KEEP8(27) + 3_8 + PTRAIW(I)+PTRARW(I) END IF END DO IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( KEEP8(27) > 0 ) THEN ALLOCATE( id%INTARR( KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 CALL MUMPS_SET_IERROR(KEEP8(27),id%INFO(2)) RETURN END IF ELSE ALLOCATE( id%INTARR( 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -7 id%INFO(2) = 1 RETURN END IF END IF IPTRI = 1_8 IPTRR = 1_8 DO I = 1, N ISTEP = abs(STEP(I)) ITYPE = MUMPS_TYPENODE( PROCNODE(ISTEP), KEEP(199) ) IRANK = MUMPS_PROCNODE( PROCNODE(ISTEP), KEEP(199) ) TYPESPLIT = MUMPS_TYPESPLIT ( PROCNODE(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. IF (ITYPE.EQ.2) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) THEN I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN IF ( TYPE_PARALL .eq. 0 ) THEN T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID-1 ) ELSE T4_MASTER_CONCERNED = & (id%CANDIDATES (id%CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) & .EQ.MYID ) ENDIF ENDIF ENDIF ENDIF IF ( TYPE_PARALL .eq. 0 ) THEN IRANK =IRANK + 1 END IF IF ( & ( ITYPE .eq. 2 .and. & IRANK .eq. MYID ) & .or. & ( ITYPE .eq. 1 .and. & IRANK .eq. MYID ) & .or. & ( T4_MASTER_CONCERNED ) & ) THEN NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ELSE IF ( ITYPE .eq. 3) THEN IF ( EARLYT3ROOTINS ) THEN PTRAIW(I)=0 PTRARW(I)=0 ELSE NCOL = int(PTRAIW( I )) NROW = int(PTRARW( I )) id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3,8) IPTRR = IPTRR + int(NCOL + NROW + 1,8) ENDIF ELSE IF ( ITYPE .eq. 2 .AND. I_AM_CAND_LOC ) THEN NCOL = int(PTRAIW( I )) NROW = 0 id%INTARR( IPTRI ) = NCOL id%INTARR( IPTRI + 1 ) = -NROW id%INTARR( IPTRI + 2 ) = I PTRAIW( I ) = IPTRI PTRARW( I ) = IPTRR IPTRI = IPTRI + int(NCOL + NROW + 3, 8) IPTRR = IPTRR + int(NCOL + NROW + 1, 8) ELSE PTRAIW(I) = 0_8 PTRARW(I) = 0_8 END IF END DO IF ( IPTRI - 1_8 .NE. KEEP8(27) ) THEN WRITE(*,*) 'Error 1 in ana_arrowheads', & ' IPTRI - 1, KEEP8(27)=', IPTRI - 1, KEEP8(27) CALL MUMPS_ABORT() END IF IF ( IPTRR - 1_8 .NE. KEEP8(26) ) THEN WRITE(*,*) 'Error 2 in ana_arrowheads' CALL MUMPS_ABORT() END IF RETURN END SUBROUTINE ZMUMPS_ANA_DIST_ARROWHEADS SUBROUTINE ZMUMPS_FACTO_SEND_ARROWHEADS( N, NZ, ASPK, & IRN, ICN, PERM, & LSCAL,COLSCA,ROWSCA, & MYID, SLAVEF, PROCNODE_STEPS, NBRECORDS, & LP, COMM, root, KEEP, KEEP8, FILS, RG2L, & INTARR, LINTARR, DBLARR, LDBLARR, PTRAIW, PTRARW, FRERE_STEPS, & STEP, A, LA, ISTEP_TO_INIV2, I_AM_CAND, CANDIDATES ) !$ USE OMP_LIB USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER :: N, COMM, NBRECORDS INTEGER(8), INTENT(IN) :: NZ INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) COMPLEX(kind=8) ASPK(NZ) DOUBLE PRECISION COLSCA(*), ROWSCA(*) INTEGER IRN(NZ), ICN(NZ) INTEGER PERM(N), PROCNODE_STEPS(KEEP(28)) INTEGER RG2L( N ), FILS( N ) INTEGER ISTEP_TO_INIV2(KEEP(71)) LOGICAL I_AM_CAND(max(1,KEEP(56))) INTEGER LP, SLAVEF, MYID INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) LOGICAL LSCAL TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER(8), INTENT(IN) :: LA INTEGER(8), INTENT(INOUT) :: PTRAIW( N ), PTRARW( N ) INTEGER :: FRERE_STEPS( KEEP(28) ) INTEGER :: STEP(N) INTEGER(8) :: LINTARR, LDBLARR INTEGER :: INTARR( LINTARR ) COMPLEX(kind=8) :: DBLARR( LDBLARR ) COMPLEX(kind=8) :: A( LA ) INTEGER, DIMENSION(:,:), ALLOCATABLE :: BUFI COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE :: BUFR INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT COMPLEX(kind=8) VAL INTEGER IOLD,JOLD,ISEND,JSEND,DEST,I,IARR INTEGER IPOSROOT, JPOSROOT INTEGER IROW_GRID, JCOL_GRID INTEGER INODE, ISTEP INTEGER NBUFS INTEGER ARROW_ROOT, TAILLE INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT INTEGER TYPE_NODE, MASTER_NODE LOGICAL I_AM_CAND_LOC, I_AM_SLAVE INTEGER JARR, ILOCROOT, JLOCROOT INTEGER allocok, INIV2, TYPESPLIT, T4MASTER INTEGER(8) :: I1, IA, IS1, IS, IAS, ISHIFT, K INTEGER NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 ARROW_ROOT = 0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 I_AM_SLAVE=(MYID.NE.0.OR.KEEP(46).EQ.1) IF ( KEEP(46) .eq. 0 ) THEN NBUFS = SLAVEF ELSE NBUFS = SLAVEF - 1 ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating IW4' CALL MUMPS_ABORT() END IF DO I = 1, N I1 = PTRAIW( I ) IA = PTRARW( I ) IF ( IA .GT. 0 ) THEN DBLARR( IA ) = ZERO IW4( I, 1 ) = INTARR( I1 ) IW4( I, 2 ) = -INTARR( I1 + 1 ) INTARR( I1 + 2 ) = I END IF END DO IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, & PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF END IF IF (NBUFS.GT.0) THEN ALLOCATE( BUFI(NBRECORDS*2+1,NBUFS),stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFI' CALL MUMPS_ABORT() END IF ALLOCATE( BUFR( NBRECORDS, NBUFS ), stat=allocok ) IF ( allocok .GT. 0 ) THEN WRITE(*,*) 'Error allocating BUFR' CALL MUMPS_ABORT() END IF DO I = 1, NBUFS BUFI( 1, I ) = 0 ENDDO ENDIF INODE = KEEP(38) I = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = I INODE = FILS( INODE ) I = I + 1 END DO NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP.GE.2 .AND. SLAVEF.EQ.1 & .AND. KEEP(46) .EQ. 1 !$OMP PARALLEL PRIVATE(K, I, DEST, I_AM_CAND_LOC, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, !$OMP& ILOCROOT, JLOCROOT, IPOSROOT, JPOSROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA, ISHIFT, IS1, IS, IAS, TAILLE, VAL, !$OMP& IARR, JARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P) !$OMP& REDUCTION(+: ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K=1, NZ IOLD = IRN(K) JOLD = ICN(K) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE END IF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = JOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs( STEP(IARR) ) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) I_AM_CAND_LOC = .FALSE. T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 IF ( TYPE_NODE .EQ. 1 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF ELSE IF ( TYPE_NODE .EQ. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = MASTER_NODE + 1 ELSE DEST = MASTER_NODE END IF END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF (I_AM_SLAVE) I_AM_CAND_LOC = I_AM_CAND(INIV2) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) IF ( KEEP(46) .eq. 0 ) THEN T4MASTER=T4MASTER+1 ENDIF ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L(JSEND) JPOSROOT = RG2L(IARR) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * root%NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * root%NPCOL + JCOL_GRID END IF ELSE DEST = -2 ENDIF END IF IF (LSCAL) THEN VAL = ASPK(K)*ROWSCA(IOLD)*COLSCA(JOLD) ELSE VAL = ASPK(K) ENDIF IF ( DEST .eq. 0 & .or. & ( DEST .eq. -1 .and. KEEP( 46 ) .eq. 1 .AND. & ( I_AM_CAND_LOC .OR. MASTER_NODE .EQ. 0 ) ) & .or. & ( T4MASTER.EQ.0 ) & .or. & ( DEST .EQ. -2 .AND. KEEP( 46 ) .EQ. 1 ) & ) THEN IARR = ISEND JARR = JSEND IF ( TYPE_NODE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IROW_GRID .EQ. root%MYROW .AND. & JCOL_GRID .EQ. root%MYCOL ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE WRITE(*,*) MYID,':INTERNAL Error: root arrowhead ' WRITE(*,*) MYID,':is not belonging to me. IARR,JARR=' & ,IARR,JARR CALL MUMPS_ABORT() END IF ELSE IF ( IARR .GE. 0 ) THEN IF ( IARR .eq. JARR ) THEN IA = PTRARW( IARR ) DBLARR( IA ) = DBLARR( IA ) + VAL ELSE IS1 = PTRAIW(IARR) ISHIFT = int(INTARR(IS1) + IW4(IARR,2),8) IW4(IARR,2) = IW4(IARR,2) - 1 INTARR(IS1 + ISHIFT + 2_8) = JARR DBLARR(PTRARW(IARR)+ISHIFT) = VAL END IF ELSE IARR = -IARR ISHIFT = int(PTRAIW(IARR)+IW4(IARR,1)+2,8) INTARR(ISHIFT) = JARR IAS = PTRARW(IARR)+int(IW4(IARR,1),8) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS) = VAL IF ( IW4(IARR,1) .EQ. 0 .AND. & STEP( IARR) > 0 ) THEN IF ( MASTER_NODE == MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF END IF END IF IF ( DEST.EQ. -1 ) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79).GT.0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0.AND.(DEST.GE.0)) DEST=DEST+1 IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE IF (DEST.NE.0) & CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) IF (KEEP(46).EQ.0) DEST=DEST+1 IF (DEST.NE.0) & CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDDO ENDIF DEST = MASTER_NODE IF (KEEP(46).EQ.0) DEST=DEST+1 IF ( DEST .NE. 0 ) THEN CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF IF ((T4_MASTER_CONCERNED).AND.(T4MASTER.GT.0)) THEN CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( DEST .GT. 0 ) THEN CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) IF ( T4MASTER.GT.0 ) THEN CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ELSE IF ( T4MASTER.GT.0 ) THEN CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & T4MASTER, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ELSE IF ( DEST .EQ. -2 ) THEN DO I = 0, SLAVEF-1 DEST = I IF (KEEP(46) .EQ. 0) DEST = DEST + 1 IF (DEST .NE. 0) THEN CALL ZMUMPS_ARROW_FILL_SEND_BUF( ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP(46)) ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF !$OMP END PARALLEL KEEP(49) = ARROW_ROOT IF (NBUFS.GT.0) THEN CALL ZMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, & LP, COMM, KEEP( 46 ) ) ENDIF IF ( KEEP( 46 ) .NE. 0 ) DEALLOCATE( IW4 ) IF (NBUFS.GT.0) THEN DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) ENDIF RETURN END SUBROUTINE ZMUMPS_FACTO_SEND_ARROWHEADS SUBROUTINE ZMUMPS_ARROW_FILL_SEND_BUF(ISEND, JSEND, VAL, & DEST, BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER ISEND, JSEND, DEST, NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) COMPLEX(kind=8) BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP COMPLEX(kind=8) VAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER IERR INTEGER TAILLE_SENDI, TAILLE_SENDR, IREQ IF (BUFI(1,DEST)+1.GT.NBRECORDS) THEN TAILLE_SENDI = BUFI(1,DEST) * 2 + 1 TAILLE_SENDR = BUFI(1,DEST) CALL MPI_SEND(BUFI(1,DEST),TAILLE_SENDI, & MPI_INTEGER, & DEST, ARROWHEAD, COMM, IERR ) CALL MPI_SEND( BUFR(1,DEST), TAILLE_SENDR, & MPI_DOUBLE_COMPLEX, DEST, & ARROWHEAD, COMM, IERR ) BUFI(1,DEST) = 0 ENDIF IREQ = BUFI(1,DEST) + 1 BUFI(1,DEST) = IREQ BUFI( IREQ * 2, DEST ) = ISEND BUFI( IREQ * 2 + 1, DEST ) = JSEND BUFR( IREQ, DEST ) = VAL RETURN END SUBROUTINE ZMUMPS_ARROW_FILL_SEND_BUF SUBROUTINE ZMUMPS_ARROW_FINISH_SEND_BUF( & BUFI, BUFR, NBRECORDS, NBUFS, LP, COMM, & TYPE_PARALL ) IMPLICIT NONE INTEGER NBUFS, NBRECORDS, TYPE_PARALL INTEGER BUFI( NBRECORDS * 2 + 1, NBUFS ) COMPLEX(kind=8) BUFR( NBRECORDS, NBUFS ) INTEGER COMM INTEGER LP INTEGER ISLAVE, TAILLE_SENDI, TAILLE_SENDR, IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' DO ISLAVE = 1,NBUFS TAILLE_SENDI = BUFI(1,ISLAVE) * 2 + 1 TAILLE_SENDR = BUFI(1,ISLAVE) BUFI(1,ISLAVE) = - BUFI(1,ISLAVE) CALL MPI_SEND(BUFI(1,ISLAVE),TAILLE_SENDI, & MPI_INTEGER, & ISLAVE, ARROWHEAD, COMM, IERR ) IF ( TAILLE_SENDR .NE. 0 ) THEN CALL MPI_SEND( BUFR(1,ISLAVE), TAILLE_SENDR, & MPI_DOUBLE_COMPLEX, ISLAVE, & ARROWHEAD, COMM, IERR ) END IF ENDDO RETURN END SUBROUTINE ZMUMPS_ARROW_FINISH_SEND_BUF RECURSIVE SUBROUTINE ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTLIST, DBLLIST, TAILLE, LO, HI ) IMPLICIT NONE INTEGER N, TAILLE INTEGER PERM( N ) INTEGER INTLIST( TAILLE ) COMPLEX(kind=8) DBLLIST( TAILLE ) INTEGER LO, HI INTEGER I,J INTEGER ISWAP, PIVOT COMPLEX(kind=8) zswap I = LO J = HI PIVOT = PERM(INTLIST((I+J)/2)) 10 IF (PERM(INTLIST(I)) < PIVOT) THEN I=I+1 GOTO 10 ENDIF 20 IF (PERM(INTLIST(J)) > PIVOT) THEN J=J-1 GOTO 20 ENDIF IF (I < J) THEN ISWAP = INTLIST(I) INTLIST(I) = INTLIST(J) INTLIST(J)=ISWAP zswap = DBLLIST(I) DBLLIST(I) = DBLLIST(J) DBLLIST(J) = zswap ENDIF IF ( I <= J) THEN I = I+1 J = J-1 ENDIF IF ( I <= J ) GOTO 10 IF ( LO < J ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, LO, J) IF ( I < HI ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS(N, PERM, & INTLIST, DBLLIST, TAILLE, I, HI) RETURN END SUBROUTINE ZMUMPS_QUICK_SORT_ARROWHEADS SUBROUTINE ZMUMPS_FACTO_RECV_ARROWHD2( N, & DBLARR, LDBLARR, INTARR, LINTARR, PTRAIW, PTRARW, & KEEP, KEEP8, MYID, COMM, NBRECORDS, & A, LA, root, & PROCNODE_STEPS, & SLAVEF, PERM, FRERE_STEPS, STEP, INFO1, INFO2 & ) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER N, MYID, COMM INTEGER(8), INTENT(IN) :: LDBLARR, LINTARR INTEGER INTARR(LINTARR) INTEGER(8), INTENT(IN) :: PTRAIW(N), PTRARW(N) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), intent(IN) :: LA INTEGER PROCNODE_STEPS( KEEP(28) ), PERM( N ) INTEGER SLAVEF, NBRECORDS COMPLEX(kind=8) A( LA ) INTEGER INFO1, INFO2 COMPLEX(kind=8) DBLARR(LDBLARR) INTEGER FRERE_STEPS( KEEP(28) ), STEP(N) TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER, POINTER, DIMENSION(:) :: BUFI COMPLEX(kind=8), POINTER, DIMENSION(:) :: BUFR INTEGER, POINTER, DIMENSION(:,:) :: IW4 LOGICAL :: EARLYT3ROOTINS LOGICAL FINI INTEGER IREC, NB_REC, IARR, JARR, I, allocok INTEGER(8) :: I18, IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER LOCAL_M, LOCAL_N, ILOCROOT, JLOCROOT, & IPOSROOT, JPOSROOT, TAILLE, & IPROC INTEGER(8) :: PTR_ROOT INTEGER ARROW_ROOT, TYPE_PARALL INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE COMPLEX(kind=8) VAL COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER MASTER PARAMETER(MASTER=0) INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER numroc EXTERNAL numroc TYPE_PARALL = KEEP(46) ARROW_ROOT=0 EARLYT3ROOTINS = KEEP(200) .EQ. 0 ALLOCATE( BUFI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS * 2 + 1 WRITE(*,*) MYID,': Could not allocate BUFI: goto 500' GOTO 500 END IF ALLOCATE( BUFR( NBRECORDS ) , stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = NBRECORDS WRITE(*,*) MYID,': Could not allocate BUFR: goto 500' GOTO 500 END IF ALLOCATE( IW4(N,2), stat = allocok ) IF ( allocok .GT. 0 ) THEN INFO1 = -13 INFO2 = 2 * N WRITE(*,*) MYID,': Could not allocate IW4: goto 500' GOTO 500 END IF IF ( KEEP(38).NE.0 .AND. EARLYT3ROOTINS ) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL ZMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF FINI = .FALSE. DO I=1,N I18 = PTRAIW(I) IA8 = PTRARW(I) IF (IA8.GT.0_8) THEN DBLARR(IA8) = ZERO IW4(I,1) = INTARR(I18) IW4(I,2) = -INTARR(I18+1_8) INTARR(I18+2)=I ENDIF ENDDO DO WHILE (.NOT.FINI) CALL MPI_RECV( BUFI(1), 2*NBRECORDS+1, & MPI_INTEGER, MASTER, & ARROWHEAD, & COMM, STATUS, IERR ) NB_REC = BUFI(1) IF (NB_REC.LE.0) THEN FINI = .TRUE. NB_REC = -NB_REC ENDIF IF (NB_REC.EQ.0) EXIT CALL MPI_RECV( BUFR(1), NBRECORDS, MPI_DOUBLE_COMPLEX, & MASTER, ARROWHEAD, & COMM, STATUS, IERR ) DO IREC=1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) IF ( MUMPS_TYPENODE( PROCNODE_STEPS(abs(STEP(abs(IARR)))), & KEEP(199) ) .eq. 3 & .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & = A( PTR_ROOT + int(JLOCROOT - 1,8) & * int(LOCAL_M,8) & + int(ILOCROOT - 1,8)) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( TYPE_PARALL .eq. 0 ) THEN IPROC = IPROC + 1 END IF IF (IPROC .EQ. MYID) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL ZMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) END IF END IF ENDIF ENDDO END DO DEALLOCATE( BUFI ) DEALLOCATE( BUFR ) DEALLOCATE( IW4 ) 500 CONTINUE KEEP(49) = ARROW_ROOT RETURN END SUBROUTINE ZMUMPS_FACTO_RECV_ARROWHD2 SUBROUTINE ZMUMPS_SET_TO_ZERO(A, LLD, M, N, KEEP) !$ USE OMP_LIB, ONLY : OMP_GET_MAX_THREADS IMPLICIT NONE INTEGER, INTENT(IN) :: LLD, M, N COMPLEX(kind=8) :: A(int(LLD,8)*int(N-1,8)+int(M,8)) INTEGER :: KEEP(500) COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0,0.0D0) INTEGER I, J !$ INTEGER :: NOMP INTEGER(8) :: I8, LA !$ NOMP = OMP_GET_MAX_THREADS() IF (LLD .EQ. M) THEN LA=int(LLD,8)*int(N-1,8)+int(M,8) !$OMP PARALLEL DO PRIVATE(I8) SCHEDULE(STATIC,KEEP(361)) !$OMP& IF ( LA > int(KEEP(361),8) .AND. NOMP .GT. 1) DO I8=1, LA A(I8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO PRIVATE(I,J) COLLAPSE(2) !$OMP& SCHEDULE(STATIC,KEEP(361)) IF (int(M,8)*int(N,8) !$OMP& .GT. KEEP(361).AND. NOMP .GT.1) DO I = 1, N DO J = 1, M A( int(I-1,8)*int(LLD,8)+ int(J,8) ) = ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_SET_TO_ZERO SUBROUTINE ZMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8), INTENT(INOUT) :: A(LA) INTEGER :: KEEP(500) TYPE (ZMUMPS_ROOT_STRUC) :: root INTEGER :: LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT IF (KEEP(60)==0) THEN CALL ZMUMPS_GET_ROOT_INFO(root, LOCAL_M, LOCAL_N, PTR_ROOT, LA) IF (LOCAL_N .GT. 0) THEN CALL ZMUMPS_SET_TO_ZERO(A(PTR_ROOT), & LOCAL_M, LOCAL_M, LOCAL_N, KEEP) ENDIF ELSE IF (root%yes) THEN CALL ZMUMPS_SET_TO_ZERO(root%SCHUR_POINTER(1), & root%SCHUR_LLD, root%SCHUR_MLOC, root%SCHUR_NLOC, & KEEP) ENDIF RETURN END SUBROUTINE ZMUMPS_SET_ROOT_TO_ZERO SUBROUTINE ZMUMPS_GET_ROOT_INFO(root, & LOCAL_M, LOCAL_N, PTR_ROOT, LA) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (ZMUMPS_ROOT_STRUC), INTENT(IN) :: root INTEGER, INTENT(OUT) :: LOCAL_M, LOCAL_N INTEGER(8), INTENT(OUT) :: PTR_ROOT INTEGER(8), INTENT(IN) :: LA INTEGER, EXTERNAL :: numroc LOCAL_M = numroc( root%ROOT_SIZE, root%MBLOCK, & root%MYROW, 0, root%NPROW ) LOCAL_M = max( 1, LOCAL_M ) LOCAL_N = numroc( root%ROOT_SIZE, root%NBLOCK, & root%MYCOL, 0, root%NPCOL ) PTR_ROOT = LA - int(LOCAL_M,8) * int(LOCAL_N,8) + 1_8 RETURN END SUBROUTINE ZMUMPS_GET_ROOT_INFO MUMPS_5.4.1/src/crank_revealing.F0000664000175000017500000001072314102210523016747 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_GET_NS_OPTIONS_FACTO(N,KEEP,ICNTL,MPG) IMPLICIT NONE INTEGER N, KEEP(500), ICNTL(60), MPG KEEP(19)=0 RETURN END SUBROUTINE CMUMPS_GET_NS_OPTIONS_FACTO SUBROUTINE CMUMPS_GET_NS_OPTIONS_SOLVE(ICNTL, KEEP, & NRHS, MPG, INFO) IMPLICIT NONE INTEGER, intent(in) :: KEEP(500), NRHS, MPG, ICNTL(60) INTEGER, intent(inout):: INFO(80) IF (KEEP(19).EQ.0.AND.KEEP(110).EQ.0) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 56 IF (KEEP(110).EQ.0) INFO(2) = 24 IF(MPG.GT.0) THEN WRITE( MPG,'(A)') &'** ERROR : Null space computation requirement' WRITE( MPG,'(A)') &'** not consistent with factorization options' ENDIF GOTO 333 ENDIF ENDIF IF (ICNTL(9).NE.1) THEN IF (KEEP(111).NE.0) THEN INFO(1) = -37 INFO(2) = 9 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option transposed system (ICNTL(9).ne.1) ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(19).EQ.2) THEN IF ((KEEP(111).NE.0).AND.(KEEP(50).EQ.0)) THEN INFO(1) = -37 INFO(2) = 0 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') &'** ERROR ICNTL(25) incompatible with ' WRITE( MPG,'(A)') &'** option RRQR (ICNLT(56)=2) and unsym. matrices ' ENDIF ENDIF GOTO 333 ENDIF IF (KEEP(111).eq.-1.AND.NRHS.NE.KEEP(112)+KEEP(17))THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(111).gt.0 .AND. NRHS .NE. 1) THEN INFO(1)=-32 INFO(2)=NRHS GOTO 333 ENDIF IF (KEEP(248) .NE.0.AND.KEEP(111).NE.0) THEN IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) and ICNTL(30) functionalities ', & ' incompatible with null space' ENDIF INFO(1) = -37 IF (KEEP(237).NE.0) THEN INFO(2) = 30 IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(30) functionality ', & ' incompatible with null space' ENDIF ELSE IF (MPG.GT.0) THEN WRITE(MPG,'(A)') & ' ERROR: ICNTL(20) functionality ', & ' incompatible with null space' ENDIF INFO(2) = 20 ENDIF GOTO 333 ENDIF IF (( KEEP(111) .LT. -1 ) .OR. & (KEEP(111).GT.KEEP(112)+KEEP(17)) .OR. & (KEEP(111) .EQ.-1 .AND. KEEP(112)+KEEP(17).EQ.0)) & THEN INFO(1)=-36 INFO(2)=KEEP(111) GOTO 333 ENDIF IF (KEEP(221).NE.0.AND.KEEP(111).NE.0) THEN INFO(1)=-37 INFO(2)=26 GOTO 333 ENDIF 333 CONTINUE RETURN END SUBROUTINE CMUMPS_GET_NS_OPTIONS_SOLVE SUBROUTINE CMUMPS_RR_INIT_POINTERS(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) id NULLIFY(id%root%QR_TAU) NULLIFY(id%root%SVD_U) NULLIFY(id%root%SVD_VT) NULLIFY(id%root%SINGULAR_VALUES) RETURN END SUBROUTINE CMUMPS_RR_INIT_POINTERS SUBROUTINE CMUMPS_RR_FREE_POINTERS(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE TYPE (CMUMPS_STRUC) id IF (associated(id%root%QR_TAU)) THEN DEALLOCATE(id%root%QR_TAU) NULLIFY(id%root%QR_TAU) ENDIF IF (associated(id%root%SVD_U)) THEN DEALLOCATE(id%root%SVD_U) NULLIFY(id%root%SVD_U) ENDIF IF (associated(id%root%SVD_VT)) THEN DEALLOCATE(id%root%SVD_VT) NULLIFY(id%root%SVD_VT) ENDIF IF (associated(id%root%SINGULAR_VALUES)) THEN DEALLOCATE(id%root%SINGULAR_VALUES) NULLIFY(id%root%SINGULAR_VALUES) ENDIF RETURN END SUBROUTINE CMUMPS_RR_FREE_POINTERS MUMPS_5.4.1/src/dana_mtrans.F0000664000175000017500000007707214102210525016120 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C C History: C ------- C This maximum transversal set of routines are C based on the work done by Jacko Koster at CERFACS for C his PhD thesis from Institut National Polytechnique de Toulouse C at CERFACS (1995-1997) and includes modifications provided C by the author as well as work done by Stephane Pralet C first at CERFACS during his PhD thesis (2003-2004) then C at INPT-IRIT (2004-2005) during his post-doctoral position. C C The main research publication references for this work are: C [1] I. S. Duff, (1981), C "Algorithm 575. Permutations for a zero-free diagonal", C ACM Trans. Math. Software 7(3), 387-390. C [2] I. S. Duff and J. Koster, (1998), C "The design and use of algorithms for permuting large C entries to the diagonal of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 20, no. 4, pp. 889-901. C [3] I. S. Duff and J. Koster, (2001), C "On algorithms for permuting large entries to the diagonal C of sparse matrices", C SIAM J. Matrix Anal. Appl., vol. 22, no. 4, pp. 973-996. C SUBROUTINE DMUMPS_MTRANSI(ICNTL,CNTL) IMPLICIT NONE INTEGER NICNTL, NCNTL PARAMETER (NICNTL=10, NCNTL=10) INTEGER ICNTL(NICNTL) DOUBLE PRECISION CNTL(NCNTL) INTEGER I ICNTL(1) = 6 ICNTL(2) = 6 ICNTL(3) = -1 ICNTL(4) = -1 ICNTL(5) = 0 DO 10 I = 6,NICNTL ICNTL(I) = 0 10 CONTINUE CNTL(1) = 0.0D0 CNTL(2) = 0.0D0 DO 20 I = 3,NCNTL CNTL(I) = 0.0D0 20 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSI SUBROUTINE DMUMPS_MTRANSB & (M,N,NE,IP,IRN,A,IPERM,NUM,JPERM,PR,Q,L,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),JPERM(N),Q(M),L(M) INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER(8), INTENT(OUT) :: PR(N) DOUBLE PRECISION :: A(NE) DOUBLE PRECISION :: D(M), RINF INTEGER :: I,II,J,JJ,JORD,Q0,QLEN,IDUM,JDUM,ISP,JSP, & I0,UP,LOW, IK INTEGER(8) :: K,KK,KK1,KK2 DOUBLE PRECISION CSP,DI,DNEW,DQ0,AI,A0,BV,TBV,RLX DOUBLE PRECISION ZERO,MINONE,ONE PARAMETER (ZERO=0.0D0,MINONE=-1.0D0,ONE=1.0D0) INTRINSIC abs,min EXTERNAL DMUMPS_MTRANSD, DMUMPS_MTRANSE, & DMUMPS_MTRANSF, DMUMPS_MTRANSX RLX = D(1) NUM = 0 BV = RINF DO 10 I = 1,N JPERM(I) = 0 PR(I) = IP(I) 10 CONTINUE DO 12 I = 1,M IPERM(I) = 0 D(I) = ZERO 12 CONTINUE DO 30 J = 1,N A0 = MINONE DO 20 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.GT.D(I)) D(I) = AI IF (JPERM(J).NE.0) GO TO 20 IF (AI.GE.BV) THEN A0 = BV IF (IPERM(I).NE.0) GO TO 20 JPERM(J) = I IPERM(I) = J NUM = NUM + 1 ELSE IF (AI.LE.A0) GO TO 20 A0 = AI I0 = I ENDIF 20 CONTINUE IF (A0.NE.MINONE .AND. A0.LT.BV) THEN BV = A0 IF (IPERM(I0).NE.0) GO TO 30 IPERM(I0) = J JPERM(J) = I0 NUM = NUM + 1 ENDIF 30 CONTINUE IF (M.EQ.N) THEN DO 35 I = 1,M BV = min(BV,D(I)) 35 CONTINUE ENDIF IF (NUM.EQ.N) GO TO 1000 DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 DO 50 K = IP(J),IP(J+1)-1_8 I = IRN(K) AI = abs(A(K)) IF (AI.LT.BV) GO TO 50 IF (IPERM(I).EQ.0) GO TO 90 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 50 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).NE.0) GO TO 70 IF (abs(A(KK)).GE.BV) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 50 CONTINUE GO TO 95 80 JPERM(JJ) = II IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = I IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = MINONE L(I) = 0 99 CONTINUE TBV = BV * (ONE-RLX) DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 QLEN = 0 LOW = M + 1 UP = M + 1 CSP = MINONE J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = abs(A(K)) IF (CSP.GE.DNEW) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE D(I) = DNEW IF (DNEW.GE.TBV) THEN LOW = LOW - 1 Q(LOW) = I ELSE QLEN = QLEN + 1 L(I) = QLEN CALL DMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 115 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = Q(1) IF (CSP.GE.D(I)) GO TO 160 BV = D(I) TBV = BV * (ONE-RLX) DO 152 IDUM = 1,M CALL DMUMPS_MTRANSE(QLEN,M,Q,D,L,1) L(I) = 0 LOW = LOW - 1 Q(LOW) = I IF (QLEN.EQ.0) GO TO 153 I = Q(1) IF (D(I).LT.TBV) GO TO 153 152 CONTINUE ENDIF 153 UP = UP - 1 Q0 = Q(UP) DQ0 = D(Q0) L(Q0) = UP J = IPERM(Q0) DO 155 K = IP(J),IP(J+1)-1_8 I = IRN(K) IF (L(I).GE.UP) GO TO 155 DNEW = min(DQ0,abs(A(K))) IF (CSP.GE.DNEW) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = I JSP = J IF (CSP.GE.TBV) GO TO 160 ELSE DI = D(I) IF (DI.GE.TBV .OR. DI.GE.DNEW) GO TO 155 D(I) = DNEW IF (DNEW.GE.TBV) THEN IF (DI.NE.MINONE) THEN CALL DMUMPS_MTRANSF(L(I),QLEN,M,Q,D,L,1) ENDIF L(I) = 0 LOW = LOW - 1 Q(LOW) = I ELSE IF (DI.EQ.MINONE) THEN QLEN = QLEN + 1 L(I) = QLEN ENDIF CALL DMUMPS_MTRANSD(I,M,Q,D,L,1) ENDIF JJ = IPERM(I) PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.MINONE) GO TO 190 BV = min(BV,CSP) TBV = BV * (ONE-RLX) NUM = NUM + 1 I = ISP J = JSP DO 170 JDUM = 1,NUM+1 I0 = JPERM(J) JPERM(J) = I IPERM(I) = J J = int(PR(J)) IF (J.EQ.-1) GO TO 190 I = I0 170 CONTINUE 190 DO 191 IK = UP,M I = Q(IK) D(I) = MINONE L(I) = 0 191 CONTINUE DO 192 IK = LOW,UP-1 I = Q(IK) D(I) = MINONE 192 CONTINUE DO 193 IK = 1,QLEN I = Q(IK) D(I) = MINONE L(I) = 0 193 CONTINUE 100 CONTINUE 1000 IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,L,JPERM) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSB SUBROUTINE DMUMPS_MTRANSD(I,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER I,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DI POS = L(I) IF (POS.LE.1) GO TO 20 DI = D(I) IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE DMUMPS_MTRANSD SUBROUTINE DMUMPS_MTRANSE(QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = 1 IF (IWAY.EQ.1) THEN DO 10 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 10 CONTINUE ELSE DO 15 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 20 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 20 Q(POS) = Q(POSK) L(Q(POS)) = POS POS = POSK 15 CONTINUE ENDIF 20 Q(POS) = I L(I) = POS RETURN END SUBROUTINE DMUMPS_MTRANSE SUBROUTINE DMUMPS_MTRANSF(POS0,QLEN,N,Q,D,L,IWAY) IMPLICIT NONE INTEGER POS0,QLEN,N,IWAY INTEGER Q(N),L(N) DOUBLE PRECISION D(N) INTEGER I,IDUM,K,POS,POSK,QK PARAMETER (K=2) DOUBLE PRECISION DK,DR,DI IF (QLEN.EQ.POS0) THEN QLEN = QLEN - 1 RETURN ENDIF I = Q(QLEN) DI = D(I) QLEN = QLEN - 1 POS = POS0 IF (IWAY.EQ.1) THEN IF (POS.LE.1) GO TO 20 DO 10 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.LE.D(QK)) GO TO 20 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 20 10 CONTINUE 20 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 30 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.LT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.GE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 30 CONTINUE ELSE IF (POS.LE.1) GO TO 34 DO 32 IDUM = 1,N POSK = POS/K QK = Q(POSK) IF (DI.GE.D(QK)) GO TO 34 Q(POS) = QK L(QK) = POS POS = POSK IF (POS.LE.1) GO TO 34 32 CONTINUE 34 Q(POS) = I L(I) = POS IF (POS.NE.POS0) RETURN DO 36 IDUM = 1,N POSK = K*POS IF (POSK.GT.QLEN) GO TO 40 DK = D(Q(POSK)) IF (POSK.LT.QLEN) THEN DR = D(Q(POSK+1)) IF (DK.GT.DR) THEN POSK = POSK + 1 DK = DR ENDIF ENDIF IF (DI.LE.DK) GO TO 40 QK = Q(POSK) Q(POS) = QK L(QK) = POS POS = POSK 36 CONTINUE ENDIF 40 Q(POS) = I L(I) = POS RETURN END SUBROUTINE DMUMPS_MTRANSF SUBROUTINE DMUMPS_MTRANSQ(IP,LENL,LENH,W,WLEN,A,NVAL,VAL) IMPLICIT NONE INTEGER ::WLEN,NVAL INTEGER :: LENL(*),LENH(*),W(*) INTEGER(8) :: IP(*) DOUBLE PRECISION :: A(*),VAL INTEGER XX,J,K,S,POS INTEGER(8) :: II PARAMETER (XX=10) DOUBLE PRECISION SPLIT(XX),HA NVAL = 0 DO 10 K = 1,WLEN J = W(K) DO 15 II = IP(J)+int(LENL(J),8),IP(J)+int(LENH(J)-1,8) HA = A(II) IF (NVAL.EQ.0) THEN SPLIT(1) = HA NVAL = 1 ELSE DO 20 S = NVAL,1,-1 IF (SPLIT(S).EQ.HA) GO TO 15 IF (SPLIT(S).GT.HA) THEN POS = S + 1 GO TO 21 ENDIF 20 CONTINUE POS = 1 21 DO 22 S = NVAL,POS,-1 SPLIT(S+1) = SPLIT(S) 22 CONTINUE SPLIT(POS) = HA NVAL = NVAL + 1 ENDIF IF (NVAL.EQ.XX) GO TO 11 15 CONTINUE 10 CONTINUE 11 IF (NVAL.GT.0) VAL = SPLIT((NVAL+1)/2) RETURN END SUBROUTINE DMUMPS_MTRANSQ SUBROUTINE DMUMPS_MTRANSR(N,NE,IP,IRN,A) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER, INTENT(INOUT) :: IRN(NE) DOUBLE PRECISION, INTENT(INOUT) :: A(NE) INTEGER :: THRESH,TDLEN PARAMETER (THRESH=15,TDLEN=50) INTEGER :: J, LEN, HI INTEGER(8) :: K, IPJ, TD, FIRST, LAST, MID, R, S DOUBLE PRECISION :: HA, KEY INTEGER(8) :: TODO(TDLEN) DO 100 J = 1,N LEN = int(IP(J+1) - IP(J)) IF (LEN.LE.1) GO TO 100 IPJ = IP(J) IF (LEN.LT.THRESH) GO TO 400 TODO(1) = IPJ TODO(2) = IPJ +int(LEN,8) TD = 2_8 500 CONTINUE FIRST = TODO(TD-1) LAST = TODO(TD) KEY = A((FIRST+LAST)/2) DO 475 K = FIRST,LAST-1 HA = A(K) IF (HA.EQ.KEY) GO TO 475 IF (HA.GT.KEY) GO TO 470 KEY = HA GO TO 470 475 CONTINUE TD = TD - 2_8 GO TO 425 470 MID = FIRST DO 450 K = FIRST,LAST-1 IF (A(K).LE.KEY) GO TO 450 HA = A(MID) A(MID) = A(K) A(K) = HA HI = IRN(MID) IRN(MID) = IRN(K) IRN(K) = HI MID = MID + 1 450 CONTINUE IF (MID-FIRST.GE.LAST-MID) THEN TODO(TD+2) = LAST TODO(TD+1) = MID TODO(TD) = MID ELSE TODO(TD+2) = MID TODO(TD+1) = FIRST TODO(TD) = LAST TODO(TD-1) = MID ENDIF TD = TD + 2_8 425 CONTINUE IF (TD.EQ.0_8) GO TO 400 IF (TODO(TD)-TODO(TD-1).GE.int(THRESH,8)) GO TO 500 TD = TD - 2_8 GO TO 425 400 DO 200 R = IPJ+1_8,IPJ+int(LEN-1,8) IF (A(R-1) .LT. A(R)) THEN HA = A(R) HI = IRN(R) A(R) = A(R-1_8) IRN(R) = IRN(R-1_8) DO 300 S = R-1,IPJ+1_8,-1_8 IF (A(S-1) .LT. HA) THEN A(S) = A(S-1) IRN(S) = IRN(S-1) ELSE A(S) = HA IRN(S) = HI GO TO 200 END IF 300 CONTINUE A(IPJ) = HA IRN(IPJ) = HI END IF 200 CONTINUE 100 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSR SUBROUTINE DMUMPS_MTRANSS(M,N,NE,IP,IRN,A,IPERM,NUMX, & W,LEN,LENL,LENH,FC,IW,IW4,RLX,RINF) IMPLICIT NONE INTEGER, INTENT(IN) :: M,N INTEGER(8), INTENT(IN) :: NE INTEGER, INTENT(OUT) :: NUMX INTEGER(8), INTENT(IN) :: IP(N+1) INTEGER :: IRN(NE),IPERM(N), & W(N),LEN(N),LENL(N),LENH(N),FC(N),IW(M),IW4(3*N+M) DOUBLE PRECISION A(NE),RLX,RINF INTEGER :: NUM,NVAL,WLEN,I,J,L,CNT,MOD, IDUM INTEGER(8) :: K, II, KDUM1, KDUM2 DOUBLE PRECISION :: BVAL,BMIN,BMAX EXTERNAL DMUMPS_MTRANSQ,DMUMPS_MTRANSU,DMUMPS_MTRANSX DO 20 J = 1,N FC(J) = J LEN(J) = int(IP(J+1) - IP(J)) 20 CONTINUE DO 21 I = 1,M IW(I) = 0 21 CONTINUE CNT = 1 MOD = 1 NUMX = 0 CALL DMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUMX,N, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) NUM = NUMX IF (NUM.NE.N) THEN BMAX = RINF ELSE BMAX = RINF DO 30 J = 1,N BVAL = 0.0D0 DO 25 K = IP(J),IP(J+1)-1_8 IF (A(K).GT.BVAL) BVAL = A(K) 25 CONTINUE IF (BVAL.LT.BMAX) BMAX = BVAL 30 CONTINUE BMAX = 1.001D0 * BMAX ENDIF BVAL = 0.0D0 BMIN = 0.0D0 WLEN = 0 DO 48 J = 1,N L = int(IP(J+1) - IP(J)) LENH(J) = L LEN(J) = L DO 45 K = IP(J),IP(J+1)-1_8 IF (A(K).LT.BMAX) GO TO 46 45 CONTINUE K = IP(J+1) 46 LENL(J) = int(K - IP(J)) IF (LENL(J).EQ.L) GO TO 48 WLEN = WLEN + 1 W(WLEN) = J 48 CONTINUE DO 90 KDUM1 = 1_8,NE IF (NUM.EQ.NUMX) THEN DO 50 I = 1,M IPERM(I) = IW(I) 50 CONTINUE DO 80 KDUM2 = 1_8,NE BMIN = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL DMUMPS_MTRANSQ(IP,LENL,LEN,W,WLEN,A,NVAL,BVAL) IF (NVAL.LE.1) GO TO 1000 K = 1 DO 70 IDUM = 1,N IF (K.GT.WLEN) GO TO 71 J = W(K) DO 55 II = IP(J)+int(LEN(J)-1,8), & IP(J)+int(LENL(J),8),-1_8 IF (A(II).GE.BVAL) GO TO 60 I = IRN(II) IF (IW(I).NE.J) GO TO 55 IW(I) = 0 NUM = NUM - 1 FC(N-NUM) = J 55 CONTINUE 60 LENH(J) = LEN(J) LEN(J) = int(II - IP(J) + 1) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 70 CONTINUE 71 IF (NUM.LT.NUMX) GO TO 81 80 CONTINUE 81 MOD = 1 ELSE BMAX = BVAL IF (BMAX-BMIN .LE. RLX) GO TO 1000 CALL DMUMPS_MTRANSQ(IP,LEN,LENH,W,WLEN,A,NVAL,BVAL) IF (NVAL.EQ.0. OR. BVAL.EQ.BMIN) GO TO 1000 K = 1 DO 87 IDUM = 1,N IF (K.GT.WLEN) GO TO 88 J = W(K) DO 85 II = IP(J)+int(LEN(J),8),IP(J)+int(LENH(J)-1,8) IF (A(II).LT.BVAL) GO TO 86 85 CONTINUE 86 LENL(J) = LEN(J) LEN(J) = int(II - IP(J)) IF (LENL(J).EQ.LENH(J)) THEN W(K) = W(WLEN) WLEN = WLEN - 1 ELSE K = K + 1 ENDIF 87 CONTINUE 88 MOD = 0 ENDIF CNT = CNT + 1 CALL DMUMPS_MTRANSU(CNT,MOD,M,N,IRN,NE,IP,LEN,FC,IW, & NUM,NUMX, & IW4(1),IW4(N+1),IW4(2*N+1),IW4(2*N+M+1)) 90 CONTINUE 1000 IF (M.EQ.N .and. NUMX.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,IW,W) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSS C SUBROUTINE DMUMPS_MTRANSU & (ID,MOD,M,N,IRN,LIRN,IP,LENC,FC,IPERM,NUM,NUMX, & PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: ID,MOD,M,N,NUM,NUMX INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN), & FC(N),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) INTEGER I,J,J1,JORD,NFC,K,KK, & NUM0,NUM1,NUM2,ID0,ID1,LAST INTEGER(8) :: IN1, IN2, II IF (ID.EQ.1) THEN DO 5 I = 1,M CV(I) = 0 5 CONTINUE DO 6 J = 1,N ARP(J) = 0 6 CONTINUE NUM1 = N NUM2 = N ELSE IF (MOD.EQ.1) THEN DO 8 J = 1,N ARP(J) = 0 8 CONTINUE ENDIF NUM1 = NUMX NUM2 = N - NUMX ENDIF NUM0 = NUM NFC = 0 ID0 = (ID-1)*N DO 100 JORD = NUM0+1,N ID1 = ID0 + JORD J = FC(JORD-NUM0) PR(J) = -1 DO 70 K = 1,JORD IF (ARP(J).GE.LENC(J)) GO TO 30 IN1 = IP(J) + int(ARP(J),8) IN2 = IP(J) + int(LENC(J) - 1,8) DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = LENC(J) 30 OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.ID1) GO TO 40 J1 = J J = IPERM(I) CV(I) = ID1 PR(J) = J1 OUT(J1) = int(IN2 - II) - 1 GO TO 70 40 CONTINUE 50 J1 = PR(J) IF (J1.EQ.-1) THEN NFC = NFC + 1 FC(NFC) = J IF (NFC.GT.NUM2) THEN LAST = JORD GO TO 101 ENDIF GO TO 100 ENDIF J = J1 60 CONTINUE 70 CONTINUE 80 IPERM(I) = J ARP(J) = int(II - IP(J)) + 1 NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 95 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 95 IF (NUM.EQ.NUM1) THEN LAST = JORD GO TO 101 ENDIF 100 CONTINUE LAST = N 101 DO 110 JORD = LAST+1,N NFC = NFC + 1 FC(NFC) = FC(JORD-NUM0) 110 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSU C SUBROUTINE DMUMPS_MTRANSW(M,N,NE,IP,IRN,A,IPERM,NUM, & JPERM,L32,OUT,PR,Q,L,U,D,RINF) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: NE INTEGER :: IRN(NE),IPERM(M),Q(M),L32(max(M,N)) INTEGER(8) :: IP(N+1), PR(N), L(M), JPERM(N), OUT(N) DOUBLE PRECISION A(NE),U(M),D(M),RINF,RINF3 INTEGER :: I,I0,II,J,JJ,JORD,Q0,QLEN,JDUM,JSP, & UP,LOW,IK INTEGER(8) :: K, KK, KK1, KK2, K0, K1, K2, ISP DOUBLE PRECISION :: CSP,DI,DMIN,DNEW,DQ0,VJ,RLX LOGICAL :: LORD DOUBLE PRECISION :: ZERO, ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) EXTERNAL DMUMPS_MTRANSD, DMUMPS_MTRANSE, & DMUMPS_MTRANSF, DMUMPS_MTRANSX RLX = U(1) RINF3 = U(2) LORD = (JPERM(1).EQ.6) NUM = 0 DO 10 I = 1,N JPERM(I) = 0_8 PR(I) = IP(I) D(I) = RINF 10 CONTINUE DO 15 I = 1,M U(I) = RINF3 IPERM(I) = 0 L(I) = 0_8 15 CONTINUE DO 30 J = 1,N IF (int(IP(J+1)-IP(J)) .GT. N/10 .AND. N.GT.50) GO TO 30 DO 20 K = IP(J),IP(J+1)-1 I = IRN(K) IF (A(K).GT.U(I)) GO TO 20 U(I) = A(K) IPERM(I) = J L(I) = K 20 CONTINUE 30 CONTINUE DO 40 I = 1,M J = IPERM(I) IF (J.EQ.0) GO TO 40 IF (JPERM(J).EQ.0_8) THEN JPERM(J) = L(I) D(J) = U(I) NUM = NUM + 1 ELSEIF (D(J).GT.U(I)) THEN K = JPERM(J) II = IRN(K) IPERM(II) = 0 JPERM(J) = L(I) D(J) = U(I) ELSE IPERM(I) = 0 ENDIF 40 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 45 I = 1,M D(I) = ZERO 45 CONTINUE DO 95 J = 1,N IF (JPERM(J).NE.0) GO TO 95 K1 = IP(J) K2 = IP(J+1) - 1_8 IF (K1.GT.K2) GO TO 95 VJ = RINF DO 50 K = K1,K2 I = IRN(K) DI = A(K) - U(I) IF (DI.GT.VJ) GO TO 50 IF (DI.LT.VJ .OR. DI.EQ.RINF) GO TO 55 IF (IPERM(I).NE.0 .OR. IPERM(I0).EQ.0) GO TO 50 55 VJ = DI I0 = I K0 = K 50 CONTINUE D(J) = VJ K = K0 I = I0 IF (IPERM(I).EQ.0) GO TO 90 DO 60 K = K0,K2 I = IRN(K) IF (A(K)-U(I).GT.VJ) GO TO 60 JJ = IPERM(I) KK1 = PR(JJ) KK2 = IP(JJ+1) - 1_8 IF (KK1.GT.KK2) GO TO 60 DO 70 KK = KK1,KK2 II = IRN(KK) IF (IPERM(II).GT.0) GO TO 70 IF (A(KK)-U(II).LE.D(JJ)) GO TO 80 70 CONTINUE PR(JJ) = KK2 + 1_8 60 CONTINUE GO TO 95 80 JPERM(JJ) = KK IPERM(II) = JJ PR(JJ) = KK + 1_8 90 NUM = NUM + 1 JPERM(J) = K IPERM(I) = J PR(J) = K + 1_8 95 CONTINUE IF (NUM.EQ.N) GO TO 1000 DO 99 I = 1,M D(I) = RINF Q(I) = 0 99 CONTINUE DO 100 JORD = 1,N IF (JPERM(JORD).NE.0) GO TO 100 DMIN = RINF QLEN = 0 LOW = M + 1 UP = M + 1 CSP = RINF J = JORD PR(J) = -1_8 DO 115 K = IP(J),IP(J+1)-1_8 I = IRN(K) DNEW = A(K) - U(I) IF (DNEW.GE.CSP) GO TO 115 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J ELSE IF (DNEW.LT.DMIN) DMIN = DNEW D(I) = DNEW QLEN = QLEN + 1 L(QLEN) = K ENDIF 115 CONTINUE Q0 = QLEN QLEN = 0 DO 120 IK = 1,Q0 K = L(IK) I = IRN(K) IF (CSP.LE.D(I)) THEN D(I) = RINF GO TO 120 ENDIF IF (D(I).LE.DMIN) THEN LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE QLEN = QLEN + 1 Q(I) = QLEN CALL DMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) 120 CONTINUE DO 150 JDUM = 1,NUM IF (LOW.EQ.UP) THEN IF (QLEN.EQ.0) GO TO 160 I = L32(1) IF (D(I).LT.RINF) DMIN = D(I)*(ONE+RLX) IF (DMIN.GE.CSP) GO TO 160 152 CALL DMUMPS_MTRANSE(QLEN,M,L32,D,Q,2) LOW = LOW - 1 L32(LOW) = I Q(I) = LOW IF (QLEN.EQ.0) GO TO 153 I = L32(1) IF (D(I).GT.DMIN) GO TO 153 GO TO 152 ENDIF 153 Q0 = L32(UP-1) DQ0 = D(Q0) IF (DQ0.GE.CSP) GO TO 160 IF (DMIN.GE.CSP) GO TO 160 UP = UP - 1 J = IPERM(Q0) VJ = DQ0 - A(JPERM(J)) + U(Q0) K1 = IP(J+1)-1_8 IF (LORD) THEN IF (CSP.NE.RINF) THEN DI = CSP - VJ IF (A(K1).GE.DI) THEN K0 = JPERM(J) IF (K0.GE.K1-6) GO TO 178 177 CONTINUE K = (K0+K1)/2 IF (A(K).GE.DI) THEN K1 = K ELSE K0 = K ENDIF IF (K0.GE.K1-6) GO TO 178 GO TO 177 178 DO 179 K = K0+1,K1 IF (A(K).LT.DI) GO TO 179 K1 = K - 1 GO TO 181 179 CONTINUE ENDIF ENDIF 181 IF (K1.EQ.JPERM(J)) K1 = K1 - 1 ENDIF K0 = IP(J) DI = CSP - VJ DO 155 K = K0,K1 I = IRN(K) IF (Q(I).GE.LOW) GO TO 155 DNEW = A(K) - U(I) IF (DNEW.GE.DI) GO TO 155 DNEW = DNEW + VJ IF (DNEW.GT.D(I)) GO TO 155 IF (IPERM(I).EQ.0) THEN CSP = DNEW ISP = K JSP = J DI = CSP - VJ ELSE IF (DNEW.GE.D(I)) GO TO 155 D(I) = DNEW IF (DNEW.LE.DMIN) THEN IF (Q(I).NE.0) THEN CALL DMUMPS_MTRANSF(Q(I),QLEN,M,L32,D,Q,2) ENDIF LOW = LOW - 1 L32(LOW) = I Q(I) = LOW ELSE IF (Q(I).EQ.0) THEN QLEN = QLEN + 1 Q(I) = QLEN ENDIF CALL DMUMPS_MTRANSD(I,M,L32,D,Q,2) ENDIF JJ = IPERM(I) OUT(JJ) = K PR(JJ) = int(J,8) ENDIF 155 CONTINUE 150 CONTINUE 160 IF (CSP.EQ.RINF) GO TO 190 NUM = NUM + 1 I = IRN(ISP) J = JSP IPERM(I) = J JPERM(J) = ISP DO 170 JDUM = 1,NUM JJ = int(PR(J)) IF (JJ.EQ.-1) GO TO 180 K = OUT(J) I = IRN(K) IPERM(I) = JJ JPERM(JJ) = K J = JJ 170 CONTINUE 180 DO 182 JJ = UP,M I = L32(JJ) U(I) = U(I) + D(I) - CSP 182 CONTINUE 190 DO 191 JJ = UP,M I = L32(JJ) D(I) = RINF Q(I) = 0 191 CONTINUE DO 192 JJ = LOW,UP-1 I = L32(JJ) D(I) = RINF Q(I) = 0 192 CONTINUE DO 193 JJ = 1,QLEN I = L32(JJ) D(I) = RINF Q(I) = 0 193 CONTINUE 100 CONTINUE 1000 CONTINUE DO 1200 J = 1,N K = JPERM(J) IF (K.NE.0) THEN D(J) = A(K) - U(IRN(K)) ELSE D(J) = ZERO ENDIF 1200 CONTINUE DO 1201 I = 1,M IF (IPERM(I).EQ.0) U(I) = ZERO 1201 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,Q,L32) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSW SUBROUTINE DMUMPS_MTRANSZ & (M,N,IRN,LIRN,IP,LENC,IPERM,NUM,PR,ARP,CV,OUT) IMPLICIT NONE INTEGER :: M,N,NUM INTEGER(8), INTENT(IN) :: LIRN INTEGER :: ARP(N),CV(M),IRN(LIRN),IPERM(M),LENC(N),OUT(N),PR(N) INTEGER(8), INTENT(IN) :: IP(N) C Local variables INTEGER :: I,J,J1,JORD,K,KK INTEGER(8) :: II, IN1, IN2 EXTERNAL DMUMPS_MTRANSX DO 10 I = 1,M CV(I) = 0 IPERM(I) = 0 10 CONTINUE DO 12 J = 1,N ARP(J) = LENC(J) - 1 12 CONTINUE NUM = 0 DO 1000 JORD = 1,N J = JORD PR(J) = -1 DO 70 K = 1,JORD IN1 = int(ARP(J),8) IF (IN1.LT.0_8) GO TO 30 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 20 II = IN1,IN2 I = IRN(II) IF (IPERM(I).EQ.0) GO TO 80 20 CONTINUE ARP(J) = -1 30 CONTINUE OUT(J) = LENC(J) - 1 DO 60 KK = 1,JORD IN1 = int(OUT(J),8) IF (IN1.LT.0_8) GO TO 50 IN2 = IP(J) + int(LENC(J) - 1,8) IN1 = IN2 - IN1 DO 40 II = IN1,IN2 I = IRN(II) IF (CV(I).EQ.JORD) GO TO 40 J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = int(IN2 - II - 1_8) GO TO 70 40 CONTINUE 50 CONTINUE J = PR(J) IF (J.EQ.-1) GO TO 1000 60 CONTINUE 70 CONTINUE 80 CONTINUE IPERM(I) = J ARP(J) = int(IN2 - II - 1_8) NUM = NUM + 1 DO 90 K = 1,JORD J = PR(J) IF (J.EQ.-1) GO TO 1000 II = IP(J) + int(LENC(J) - OUT(J) - 2,8) I = IRN(II) IPERM(I) = J 90 CONTINUE 1000 CONTINUE IF (M.EQ.N .and. NUM.EQ.N) GO TO 2000 CALL DMUMPS_MTRANSX(M,N,IPERM,CV,ARP) 2000 RETURN END SUBROUTINE DMUMPS_MTRANSZ SUBROUTINE DMUMPS_MTRANSX(M,N,IPERM,RW,CW) IMPLICIT NONE INTEGER M,N INTEGER RW(M),CW(N),IPERM(M) INTEGER I,J,K DO 10 J = 1,N CW(J) = 0 10 CONTINUE K = 0 DO 20 I = 1,M IF (IPERM(I).EQ.0) THEN K = K + 1 RW(K) = I ELSE J = IPERM(I) CW(J) = I ENDIF 20 CONTINUE K = 0 DO 30 J = 1,N IF (CW(J).NE.0) GO TO 30 K = K + 1 I = RW(K) IPERM(I) = -J 30 CONTINUE DO 40 J = N+1,M K = K + 1 I = RW(K) IPERM(I) = -J 40 CONTINUE RETURN END SUBROUTINE DMUMPS_MTRANSX MUMPS_5.4.1/src/zsol_c.F0000664000175000017500000023575114102210525015122 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SOL_C(root, N, A, LA, IW, LIW, W, LWC, & IWCB, LIWW, NRHS, NA, LNA, NE_STEPS, W2, MTYPE, ICNTL, FROM_PP, & STEP, FRERE, DAD, FILS, PTRIST, PTRFAC, IW1, LIW1, PTRACB, & LIWK_PTRACB, PROCNODE_STEPS, SLAVEF, INFO, KEEP,KEEP8, DKEEP, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IBEG_ROOT_DEF, IEND_ROOT_DEF, & IROOT_DEF_RHS_COL1, RHS_ROOT, LRHS_ROOT, SIZE_ROOT, MASTER_ROOT, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, POSINRHSCOMP_BWD, & NZ_RHS, NBCOL_INBLOC, NRHS_ORIG, JBEG_RHS, Step2node, LStep2node, & IRHS_SPARSE, IRHS_PTR, SIZE_PERM_RHS, PERM_RHS, & SIZE_UNS_PERM_INV, UNS_PERM_INV, NB_FS_IN_RHSCOMP_F, & NB_FS_IN_RHSCOMP_TOT, DO_NBSPARSE , RHS_BOUNDS, LRHS_BOUNDS & ) USE ZMUMPS_OOC USE ZMUMPS_SOL_ES USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC IMPLICIT NONE #if defined(V_T) INCLUDE 'VT.inc' #endif TYPE ( ZMUMPS_ROOT_STRUC ) :: root INTEGER(8) :: LA INTEGER(8) :: LWC INTEGER :: N,LIW,MTYPE,LIW1,LIWW,LNA INTEGER ICNTL(60),INFO(80), KEEP(500) DOUBLE PRECISION, intent(inout) :: DKEEP(230) INTEGER(8) KEEP8(150) INTEGER IW(LIW),IW1(LIW1),NA(LNA),NE_STEPS(KEEP(28)),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)), FILS(N), PTRIST(KEEP(28)), & DAD(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER :: LIWK_PTRACB INTEGER(8) :: PTRACB(LIWK_PTRACB) INTEGER NRHS, LRHSCOMP, NB_FS_IN_RHSCOMP_F, NB_FS_IN_RHSCOMP_TOT COMPLEX(kind=8) A(LA), W(LWC), & W2(KEEP(133)) COMPLEX(kind=8) :: RHSCOMP(LRHSCOMP,NRHS) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER PROCNODE_STEPS(KEEP(28)), POSINRHSCOMP_FWD(N), & POSINRHSCOMP_BWD(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IBEG_ROOT_DEF, IEND_ROOT_DEF, IROOT_DEF_RHS_COL1 INTEGER SIZE_ROOT, MASTER_ROOT INTEGER(8) :: LRHS_ROOT COMPLEX(kind=8) RHS_ROOT(LRHS_ROOT) LOGICAL, intent(in) :: FROM_PP INTEGER, intent(in) :: NZ_RHS, NBCOL_INBLOC, NRHS_ORIG INTEGER, intent(in) :: SIZE_UNS_PERM_INV INTEGER, intent(in) :: SIZE_PERM_RHS INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER, intent(in) :: LStep2node INTEGER, intent(in) :: Step2node(LStep2node) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(inout) :: RHS_BOUNDS (LRHS_BOUNDS) INTEGER MP, LP, LDIAG INTEGER K,I,II INTEGER allocok INTEGER LPOOL,MYLEAF,MYROOT,NBROOT,LPANEL_POS INTEGER NSTK_S,IPOOL,IPANEL_POS,PTRICB INTEGER MTYPE_LOC INTEGER MODE_RHS_BOUNDS INTEGER IERR INTEGER(8) :: IAPOS INTEGER IOLDPS, & LOCAL_M, & LOCAL_N #if defined(V_T) INTEGER soln_c_class, forw_soln, back_soln, root_soln #endif LOGICAL DOFORWARD, DOROOT, DOBACKWARD LOGICAL I_WORKED_ON_ROOT, SPECIAL_ROOT_REACHED INTEGER IROOT LOGICAL DOROOT_FWD_OOC, DOROOT_BWD_PANEL LOGICAL SWITCH_OFF_ES LOGICAL DUMMY_BOOL INTEGER :: IDUMMY COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0,0.0D0) INCLUDE 'mumps_headers.h' INTEGER, DIMENSION(:), ALLOCATABLE :: nodes_RHS INTEGER nb_nodes_RHS INTEGER nb_prun_leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_Leaves INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_List INTEGER nb_prun_nodes INTEGER nb_prun_roots, JAM1 INTEGER, DIMENSION(:), ALLOCATABLE :: Pruned_SONS, Pruned_Roots INTEGER :: SIZE_TO_PROCESS LOGICAL, DIMENSION(:), ALLOCATABLE :: TO_PROCESS INTEGER ISTEP, INODE_PRINC LOGICAL AM1, DO_PRUN LOGICAL Exploit_Sparsity LOGICAL DO_NBSPARSE_BWD, PRUN_BELOW_BWD INTEGER :: OOC_FCT_TYPE_TMP INTEGER :: MUMPS_OOC_GET_FCT_TYPE EXTERNAL :: MUMPS_OOC_GET_FCT_TYPE DOUBLE PRECISION TIME_FWD,TIME_BWD,TIME_SpecialRoot INTEGER :: nb_sparse INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: MUMPS_IN_OR_ROOT_SSARBR MYLEAF = -1 LP = ICNTL(1) MP = ICNTL(2) LDIAG = ICNTL(4) #if defined(V_T) CALL VTCLASSDEF( 'Soln_c',soln_c_class,ierr) CALL VTFUNCDEF( 'forw_soln',soln_c_class,forw_soln,ierr) CALL VTFUNCDEF( 'back_soln',soln_c_class,back_soln,ierr) CALL VTFUNCDEF( 'root_soln',soln_c_class,root_soln,ierr) #endif IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_FWD) ENDIF NSTK_S = 1 PTRICB = NSTK_S + KEEP(28) IPOOL = PTRICB + KEEP(28) LPOOL = NA(1) + 1 IPANEL_POS = IPOOL + LPOOL IF (KEEP(201).EQ.1) THEN LPANEL_POS = KEEP(228)+1 ELSE LPANEL_POS = 1 ENDIF IF (IPANEL_POS + LPANEL_POS -1 .ne. LIW1 ) THEN WRITE(*,*) MYID, ": Internal Error 1 in ZMUMPS_SOL_C", & IPANEL_POS, LPANEL_POS, LIW1 CALL MUMPS_ABORT() ENDIF DOFORWARD = .TRUE. DOBACKWARD= .TRUE. SPECIAL_ROOT_REACHED = .TRUE. SWITCH_OFF_ES = .FALSE. IF ( KEEP(111).NE.0 .OR. KEEP(252).NE.0 ) THEN DOFORWARD = .FALSE. ENDIF IF (KEEP(221).eq.1) DOBACKWARD = .FALSE. IF (KEEP(221).eq.2) DOFORWARD = .FALSE. IF ( KEEP(60).EQ.0 .AND. & ( & (KEEP(38).NE.0 .AND. root%yes) & .OR. & (KEEP(20).NE.0 .AND. MYID_NODES.EQ.MASTER_ROOT) & ) & .AND. KEEP(252).EQ.0 & ) &THEN DOROOT = .TRUE. ELSE DOROOT = .FALSE. ENDIF DOROOT_BWD_PANEL = DOROOT .AND. MTYPE.NE.1 .AND. KEEP(50).EQ.0 & .AND. KEEP(201).EQ.1 DOROOT_FWD_OOC = DOROOT .AND. .NOT.DOROOT_BWD_PANEL AM1 = (KEEP(237) .NE. 0) Exploit_Sparsity = (KEEP(235) .NE. 0) .AND. (.NOT. AM1) DO_PRUN = (Exploit_Sparsity.OR.AM1) IF (FROM_PP) THEN Exploit_Sparsity = .FALSE. DO_PRUN = .FALSE. IF ( AM1 ) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_SOL_C" CALL MUMPS_ABORT() ENDIF ENDIF IF ( DO_PRUN ) THEN ALLOCATE (Pruned_SONS(KEEP(28)), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ENDIF IF ( DO_PRUN & ) THEN SIZE_TO_PROCESS = KEEP(28) ELSE SIZE_TO_PROCESS = 1 ENDIF ALLOCATE (TO_PROCESS(SIZE_TO_PROCESS), stat=I) IF(I.GT.0) THEN INFO(1)=-13 INFO(2)=KEEP(28) END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 IF ( DOFORWARD .AND. DO_PRUN ) THEN nb_prun_nodes = 0 nb_prun_roots = 0 Pruned_SONS(:) = -1 IF ( Exploit_Sparsity ) THEN nb_nodes_RHS = 0 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NZ_RHS ISTEP = abs( STEP(IRHS_SPARSE(I)) ) INODE_PRINC = Step2node( ISTEP ) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ELSE IF ( AM1 ) THEN nb_nodes_RHS = 0 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_nodes_RHS END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 nb_nodes_RHS = 0 Pruned_SONS = -1 DO I = 1, NBCOL_INBLOC IF ( (IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF ( (KEEP(242) .NE. 0 ).OR. (KEEP(243).NE.0) ) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 ENDIF ISTEP = abs(STEP(JAM1)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF CALL ZMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) CALL ZMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF ( KEEP(201) .GT. 0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('F',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL ZMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), & KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE) THEN nb_sparse = max(1,KEEP(497)) MODE_RHS_BOUNDS = 0 IF (Exploit_Sparsity) MODE_RHS_BOUNDS = 2 CALL ZMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & MODE_RHS_BOUNDS) CALL ZMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,0, & KEEP(50), KEEP(38)) END IF SPECIAL_ROOT_REACHED = .FALSE. DO I= 1, nb_prun_roots IF ( (Pruned_Roots(I).EQ.KEEP(38)).OR. & (Pruned_Roots(I).EQ.KEEP(20)) ) THEN SPECIAL_ROOT_REACHED = .TRUE. EXIT ENDIF ENDDO DEALLOCATE(Pruned_List) ENDIF IF (KEEP(201).GT.0) THEN IF (DOFORWARD .OR. DOROOT_FWD_OOC) THEN CALL ZMUMPS_SOLVE_INIT_OOC_FWD(PTRFAC,KEEP(28),MTYPE, & A,LA,DOFORWARD,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF (DOFORWARD) THEN IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 1 ENDIF #if defined(V_T) CALL VTBEGIN(forw_soln,ierr) #endif IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, MYROOT, MYID_NODES, & SLAVEF, NA, LNA, KEEP, STEP, PROCNODE_STEPS) DO ISTEP =1, KEEP(28) IW1(NSTK_S+ISTEP-1) = NE_STEPS(ISTEP) ENDDO ELSE CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_roots, Pruned_Roots, & MYROOT, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) IF (AM1) THEN DEALLOCATE(Pruned_Roots) END IF IF ((Exploit_Sparsity).AND.(nb_prun_roots.EQ.NA(2))) THEN DEALLOCATE(Pruned_Roots) SWITCH_OFF_ES = .TRUE. ENDIF DO ISTEP = 1, KEEP(28) IW1(NSTK_S+ISTEP-1) = Pruned_SONS(ISTEP) ENDDO ENDIF IF ( DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NONA( N, MYLEAF, MYID_NODES, & nb_prun_leaves, Pruned_Leaves, KEEP, KEEP8, & STEP, PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 DEALLOCATE(Pruned_Leaves) ELSE CALL MUMPS_INIT_POOL_DIST( N, MYLEAF, MYID_NODES, & SLAVEF, NA, LNA, KEEP, KEEP8, STEP, & PROCNODE_STEPS, IW1(IPOOL), LPOOL ) MYLEAF = MYLEAF - 1 ENDIF CALL ZMUMPS_SOL_R(N, A(1), LA, IW(1), LIW, W(1), & LWC, NRHS, & IW1(PTRICB), IWCB, LIWW, & RHSCOMP,LRHSCOMP,POSINRHSCOMP_FWD, & STEP, FRERE,DAD,FILS, & IW1(NSTK_S),IW1(IPOOL),LPOOL,PTRIST,PTRFAC, & MYLEAF, MYROOT, INFO, & KEEP, KEEP8, DKEEP, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, & RHS_ROOT, LRHS_ROOT, MTYPE_LOC, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) IF (DO_PRUN) THEN MYLEAF = -1 ENDIF #if defined(V_T) CALL VTEND(forw_soln,ierr) #endif ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) THEN IF ( LP .GT. 0 ) THEN WRITE(LP,*) MYID, & ': ** ERROR RETURN FROM ZMUMPS_SOL_R,INFO(1:2)=', & INFO(1:2) END IF GOTO 500 END IF CALL MPI_BARRIER( COMM_NODES, IERR ) IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_FWD) DKEEP(117)=TIME_FWD + DKEEP(117) ENDIF IF (DO_PRUN.AND.SWITCH_OFF_ES) THEN DO_PRUN = .FALSE. Exploit_Sparsity = .FALSE. IF ( allocated(TO_PROCESS) .AND. SIZE_TO_PROCESS.NE.1 ) THEN DEALLOCATE (TO_PROCESS) SIZE_TO_PROCESS = 1 ALLOCATE(TO_PROCESS(SIZE_TO_PROCESS),stat=I) ENDIF ENDIF IF ( DOBACKWARD .AND. DO_PRUN ) THEN nb_prun_leaves = 0 IF ( Exploit_Sparsity .AND. (KEEP(111).EQ.0) ) THEN nb_nodes_RHS = nb_prun_roots ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nodes_RHS(1:nb_prun_roots)=Pruned_Roots(1:nb_prun_roots) DEALLOCATE(Pruned_Roots) ELSE nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ALLOCATE(nodes_RHS(nb_nodes_RHS), STAT = allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of nodes_RHS' INFO(1) = -13 INFO(2) = nb_nodes_RHS CALL MUMPS_ABORT() END IF nb_nodes_RHS = 0 Pruned_SONS(:) = -1 DO II = 1, NZ_RHS I = IRHS_SPARSE(II) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) ISTEP = abs(STEP(I)) INODE_PRINC = Step2node(ISTEP) IF ( Pruned_SONS(ISTEP) .eq. -1) THEN nb_nodes_RHS = nb_nodes_RHS +1 nodes_RHS(nb_nodes_RHS) = INODE_PRINC Pruned_SONS(ISTEP) = 0 ENDIF ENDDO ENDIF IF ( Exploit_Sparsity ) THEN CALL ZMUMPS_TREE_PRUN_NODES( & .FALSE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves & ) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_TREE_PRUN_NODES( & .TRUE., & DAD, NE_STEPS, FRERE, KEEP(28), & FILS, STEP, N, & nodes_RHS, nb_nodes_RHS, & TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves & ) CALL ZMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF(allocated(nodes_RHS)) DEALLOCATE(nodes_RHS) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL ZMUMPS_TREE_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), & KEEP8(31), & STEP, & Pruned_List, & nb_prun_nodes, OOC_FCT_TYPE_TMP) ENDIF ENDIF IF(KEEP(201).EQ.1.AND.DOROOT_BWD_PANEL) THEN I_WORKED_ON_ROOT = .FALSE. CALL ZMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) IF (IERR .LT. 0) THEN INFO(1) = -90 INFO(2) = IERR ENDIF ENDIF IF (KEEP(201).EQ.1) THEN CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 500 ENDIF IF (KEEP(60).NE.0 .AND. KEEP(221).EQ.0 & .AND. MYID_NODES .EQ. MASTER_ROOT) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (.NOT. FROM_PP) THEN CALL MUMPS_SECDEB(TIME_SpecialRoot) ENDIF IF ( ( KEEP( 38 ) .NE. 0 ).AND. SPECIAL_ROOT_REACHED ) THEN IF ( KEEP(60) .EQ. 0 .AND. KEEP(252) .EQ. 0 ) THEN IF ( root%yes ) THEN IF (KEEP(201).GT.0) THEN IF ( (Exploit_Sparsity.AND.(KEEP(111).NE.0)) .and. & (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) ) THEN GOTO 1010 ENDIF ENDIF IOLDPS = PTRIST(STEP(KEEP(38))) LOCAL_M = IW( IOLDPS + 2 + KEEP(IXSZ)) LOCAL_N = IW( IOLDPS + 1 + KEEP(IXSZ)) IF (KEEP(201).GT.0) THEN CALL ZMUMPS_SOLVE_GET_OOC_NODE( & KEEP(38),PTRFAC,KEEP,A,LA, & STEP,KEEP8,N,DUMMY_BOOL,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) '** ERROR after ZMUMPS_SOLVE_GET_OOC_NODE', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF IAPOS = PTRFAC(IW( IOLDPS + 4 + KEEP(IXSZ))) IF (LOCAL_M * LOCAL_N .EQ. 0) THEN IAPOS = min(IAPOS, LA) ENDIF #if defined(V_T) CALL VTBEGIN(root_soln,ierr) #endif CALL ZMUMPS_ROOT_SOLVE( NRHS, root%DESCRIPTOR(1), & root%CNTXT_BLACS, LOCAL_M, LOCAL_N, & root%MBLOCK, root%NBLOCK, & root%IPIV(1), root%LPIV, MASTER_ROOT, MYID_NODES, & COMM_NODES, & RHS_ROOT(1), & root%TOT_ROOT_SIZE, A( IAPOS ), & INFO(1), MTYPE, KEEP(50), FROM_PP) IF(KEEP(201).GT.0)THEN CALL ZMUMPS_FREE_FACTORS_FOR_SOLVE(KEEP(38), & PTRFAC,KEEP(28),A,LA,.FALSE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 WRITE(*,*) & '** ERROR after ZMUMPS_FREE_FACTORS_FOR_SOLVE ', & INFO(1) call MUMPS_ABORT() ENDIF ENDIF ENDIF ENDIF ELSE IF ( ( KEEP(20) .NE. 0) .AND. SPECIAL_ROOT_REACHED ) THEN IF ( MYID_NODES .eq. MASTER_ROOT ) THEN END IF END IF IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_SpecialRoot) DKEEP(119)=TIME_SpecialRoot + DKEEP(119) ENDIF #if defined(V_T) CALL VTEND(root_soln,ierr) #endif 1010 CONTINUE CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF ( INFO(1) .LT. 0 ) RETURN IF (DOBACKWARD) THEN IF ( KEEP(201).GT.0 .AND. .NOT. DOROOT_BWD_PANEL ) & THEN I_WORKED_ON_ROOT = DOROOT IF (KEEP(38).gt.0 ) THEN IF ( ( Exploit_Sparsity.AND.(KEEP(111).EQ.0) ) & .OR. AM1 ) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN OOC_STATE_NODE(STEP(KEEP(38)))=-4 ENDIF ENDIF IF (Exploit_Sparsity.AND.(KEEP(111).NE.0)) THEN IF (OOC_STATE_NODE(STEP(KEEP(38))).eq.-6) THEN I_WORKED_ON_ROOT = .FALSE. ENDIF ENDIF ENDIF ENDIF IF (.NOT.AM1) THEN DO_NBSPARSE_BWD = .FALSE. ELSE DO_NBSPARSE_BWD = DO_NBSPARSE ENDIF PRUN_BELOW_BWD = AM1 IF ( AM1 ) THEN CALL ZMUMPS_CHAIN_PRUN_NODES( & .FALSE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, & nb_prun_leaves) ALLOCATE(Pruned_List(nb_prun_nodes), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_nodes END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Roots(nb_prun_roots), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_roots END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 ALLOCATE(Pruned_Leaves(nb_prun_leaves), STAT=allocok) IF(allocok.GT.0) THEN INFO(1)=-13 INFO(2)=nb_prun_leaves END IF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) IF(INFO(1).LT.0) GOTO 500 CALL ZMUMPS_CHAIN_PRUN_NODES( & .TRUE., & DAD, KEEP(28), & STEP, N, & nodes_RHS, nb_nodes_RHS, & Pruned_SONS, TO_PROCESS, & nb_prun_nodes, nb_prun_roots, nb_prun_leaves, & Pruned_List, Pruned_Roots, Pruned_Leaves ) CALL ZMUMPS_OOC_SET_STATES_ES(N, & KEEP(201), Pruned_List, nb_prun_nodes, & STEP) IF (KEEP(201).GT.0) THEN OOC_FCT_TYPE_TMP=MUMPS_OOC_GET_FCT_TYPE & ('B',MTYPE,KEEP(201),KEEP(50)) ELSE OOC_FCT_TYPE_TMP = -5959 ENDIF CALL ZMUMPS_CHAIN_PRUN_NODES_STATS( & MYID_NODES, N, KEEP(28), KEEP(201), KEEP(485), KEEP8(31), & STEP, Pruned_List, nb_prun_nodes, OOC_FCT_TYPE_TMP & ) IF (DO_NBSPARSE_BWD) THEN nb_sparse = max(1,KEEP(497)) CALL ZMUMPS_INITIALIZE_RHS_BOUNDS( & STEP, N, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & JBEG_RHS, PERM_RHS, SIZE_PERM_RHS, KEEP(242), KEEP(243), & UNS_PERM_INV, SIZE_UNS_PERM_INV, KEEP(23), & RHS_BOUNDS, KEEP(28), & nb_sparse, MYID_NODES, & 1) CALL ZMUMPS_PROPAGATE_RHS_BOUNDS( & Pruned_Leaves, nb_prun_leaves, & STEP, N, Pruned_SONS, & DAD, RHS_BOUNDS, KEEP(28), & MYID_NODES, COMM_NODES, KEEP(485), & IW, LIW, PTRIST,KEEP(IXSZ),OOC_FCT_TYPE_TMP,1, & KEEP(50), KEEP(38)) END IF ENDIF IF ( KEEP(201).GT.0 ) THEN IROOT = max(KEEP(20),KEEP(38)) CALL ZMUMPS_SOLVE_INIT_OOC_BWD(PTRFAC,KEEP(28),MTYPE, & I_WORKED_ON_ROOT, IROOT, A, LA, IERR) ENDIF IF ( KEEP( 50 ) .eq. 0 ) THEN MTYPE_LOC = MTYPE ELSE MTYPE_LOC = 0 ENDIF #if defined(V_T) CALL VTBEGIN(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECDEB(TIME_BWD) ENDIF IF ( .NOT.SPECIAL_ROOT_REACHED ) THEN RHS_ROOT(1:NRHS*SIZE_ROOT) = ZERO ENDIF IF (AM1.AND.(NB_FS_IN_RHSCOMP_F.NE.NB_FS_IN_RHSCOMP_TOT)) THEN DO I =1, N II = POSINRHSCOMP_BWD(I) IF ((II.GT.0).AND.(II.GT.NB_FS_IN_RHSCOMP_F)) THEN DO K=1,NRHS RHSCOMP(II, K) = ZERO ENDDO ENDIF ENDDO ENDIF IF ( .NOT. DO_PRUN ) THEN CALL MUMPS_INIT_POOL_DIST_NA_BWD( N, MYROOT, MYID_NODES, & NA, LNA, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL ) IF (MYLEAF .EQ. -1) THEN CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & NA(1), & NA(3), & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF ELSE CALL MUMPS_INIT_POOL_DIST_BWD(N, nb_prun_roots, & Pruned_Roots, & MYROOT, MYID_NODES, KEEP, KEEP8, STEP, PROCNODE_STEPS, & IW1(IPOOL), LPOOL) CALL MUMPS_NBLOCAL_ROOTS_OR_LEAVES( N, & nb_prun_leaves, Pruned_Leaves, & MYLEAF, MYID_NODES, SLAVEF, KEEP, STEP, & PROCNODE_STEPS ) ENDIF IF (KEEP(31) .EQ. 1) THEN DO I = 1, KEEP(28) IF (MUMPS_PROCNODE(PROCNODE_STEPS(I),KEEP(199)) .EQ. & MYID_NODES) THEN IF ( .NOT. MUMPS_IN_OR_ROOT_SSARBR(PROCNODE_STEPS(I), & KEEP(199)) ) THEN IF ( DO_PRUN & ) THEN IF ( TO_PROCESS(I) ) THEN KEEP(31) = KEEP(31) + 1 ENDIF ELSE KEEP(31) = KEEP(31) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF CALL ZMUMPS_SOL_S( N, A, LA, IW, LIW, W(1), LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & IW1(PTRICB),PTRACB,IWCB,LIWW, W2, & NE_STEPS, & STEP, FRERE,DAD,FILS, & IW1(IPOOL),LPOOL,PTRIST,PTRFAC,MYLEAF,MYROOT,ICNTL,INFO, & PROCNODE_STEPS, SLAVEF, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, KEEP, KEEP8, DKEEP, & RHS_ROOT, LRHS_ROOT, & MTYPE_LOC, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, IW1(IPANEL_POS), & LPANEL_POS, PRUN_BELOW_BWD, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE_BWD & , FROM_PP & ) CALL ZMUMPS_CLEAN_PENDING( INFO(1), KEEP, & BUFR, LBUFR,LBUFR_BYTES, & COMM_NODES, IDUMMY, & SLAVEF, .TRUE., .FALSE. ) CALL MUMPS_PROPINFO(ICNTL, INFO, COMM_NODES, MYID ) #if defined(V_T) CALL VTEND(back_soln,ierr) #endif IF (.NOT.FROM_PP) THEN CALL MUMPS_SECFIN(TIME_BWD) DKEEP(118)=TIME_BWD+DKEEP(118) ENDIF ENDIF IF (LDIAG.GT.2 .AND. MP.GT.0) THEN IF (DOFORWARD) THEN K = min0(10,size(RHSCOMP,1)) IF (LDIAG.EQ.4) K = size(RHSCOMP,1) IF ( .NOT. FROM_PP) THEN WRITE (MP,99992) IF (size(RHSCOMP,1).GT.0) & WRITE (MP,99993) (RHSCOMP(I,1),I=1,K) IF (size(RHSCOMP,1).GT.0.and.NRHS>1) & WRITE (MP,99994) (RHSCOMP(I,2),I=1,K) ENDIF ENDIF ENDIF 500 CONTINUE IF ( allocated(TO_PROCESS)) DEALLOCATE (TO_PROCESS) IF (Exploit_Sparsity.OR.AM1.OR.SWITCH_OFF_ES) THEN IF ( allocated(nodes_RHS)) DEALLOCATE (nodes_RHS) IF ( allocated(Pruned_SONS)) DEALLOCATE (Pruned_SONS) IF ( allocated(Pruned_Roots)) DEALLOCATE (Pruned_Roots) IF ( allocated(Pruned_List)) DEALLOCATE (Pruned_List) IF ( allocated(Pruned_Leaves)) DEALLOCATE (Pruned_Leaves) ENDIF RETURN 99993 FORMAT (' RHS (internal, first column)'/(1X,1P,5D14.6)) 99994 FORMAT (' RHS (internal, 2 nd column)'/(1X,1P,5D14.6)) 99992 FORMAT (//' LEAVING SOLVE (ZMUMPS_SOL_C) WITH') END SUBROUTINE ZMUMPS_SOL_C SUBROUTINE ZMUMPS_GATHER_SOLUTION( NSLAVES, N, MYID, COMM, & NRHS, & MTYPE, RHS, LRHS, NCOL_RHS, JBEG_RHS, PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, CWORK, LCWORK, & LSCAL, SCALING, LSCALING, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP, LPOS_N, PERM_RHS, SIZE_PERM_RHS ) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE, NCOL_RHS INTEGER NRHS, LRHS, LCWORK, LPOS_N, NCOL_RHSCOMP COMPLEX(kind=8) RHS (LRHS, NCOL_RHS) INTEGER, INTENT(in) :: JBEG_RHS INTEGER KEEP(500) INTEGER(8) KEEP8(150) COMPLEX(kind=8) :: CWORK(LCWORK) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER SIZE_BUF, SIZE_BUF_BYTES INTEGER BUFFER(SIZE_BUF) INTEGER LRHSCOMP, POSINRHSCOMP(LPOS_N) COMPLEX(kind=8), intent(in) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS(SIZE_PERM_RHS) INTEGER I, II, J, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL, N2RECV INTEGER LIELL, IPOS, NPIV, MAXNPIV_estim, MAXSurf INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR, allocok PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND, IPOSINRHSCOMP INTEGER :: JCOL_RHS INTEGER :: K242 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: CHUNK, NOMP INTEGER, PARAMETER :: FIN = -1 COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER, ALLOCATABLE, DIMENSION(:) :: IROWlist(:) INCLUDE 'mumps_headers.h' INTEGER, EXTERNAL :: MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN IF (LSCAL) THEN IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (int(NRHS,8) * int(N,8) .GE. int(KEEP(363),8)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ELSE IF (KEEP(350).EQ.2) THEN K242 = KEEP(242) !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = max(N/2,1) !$ IF (NRHS * N .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK=int((int(N,8)*int(NRHS,8)+int(NOMP-1,8))/int(NOMP,8)) !$ CHUNK = min(CHUNK,(N+KEEP(362)-1)/KEEP(362)) !$ CHUNK = max(KEEP(363)/2,CHUNK) !$ ENDIF !$OMP PARALLEL FIRSTPRIVATE(JBEG_RHS,N,K242) !$OMP& PRIVATE(IPOSINRHSCOMP,I,JCOL_RHS) IF (OMP_FLAG) DO J=1, NRHS IF (K242.EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF !$OMP DO SCHEDULE(DYNAMIC,CHUNK) DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO !$OMP END DO NOWAIT ENDDO !$OMP END PARALLEL ELSE DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS = J+JBEG_RHS-1 ELSE JCOL_RHS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO I=1, N IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS(I,JCOL_RHS) = RHSCOMP(IPOSINRHSCOMP,J) ELSE RHS(I,JCOL_RHS) = ZERO ENDIF ENDDO ENDDO ENDIF ENDIF RETURN ENDIF MAXNPIV_estim = max(KEEP(246), KEEP(247)) MAXSurf = MAXNPIV_estim*NRHS IF (LCWORK .LT. MAXNPIV_estim) THEN WRITE(*,*) MYID, & ": Internal error 2 in ZMUMPS_GATHER_SOLUTION:", & TYPE_PARAL, LCWORK, KEEP(247), NRHS CALL MUMPS_ABORT() ENDIF IF (MYID.EQ.MASTER) THEN ALLOCATE(IROWlist(KEEP(247)),stat=allocok) IF(allocok.GT.0) THEN WRITE(*,*)'Problem with allocation of IROWlist' CALL MUMPS_ABORT() ENDIF ENDIF IF (NSLAVES .EQ. 1 .AND. TYPE_PARAL .EQ. 1) THEN CALL MUMPS_ABORT() ENDIF SIZE1=0 CALL MPI_PACK_SIZE(MAXNPIV_estim+2,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(MAXSurf,MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in ZMUMPS_GATHER_SOLUTION ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =N POS_BUF =0 IF (I_AM_SLAVE) THEN POS_BUF = 0 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-NPIV IF (NPIV.GT.0) & CALL ZMUMPS_NPIV_BLOCK_ADD ( .TRUE. ) ELSE IF (NPIV.GT.0) & CALL ZMUMPS_NPIV_BLOCK_ADD ( .FALSE.) ENDIF ENDIF ENDDO CALL ZMUMPS_NPIV_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) DO WHILE (NPIV.NE.FIN) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & IROWlist, NPIV, MPI_INTEGER, COMM, IERR) DO J=1, NRHS IF (KEEP(242).EQ.0) THEN JCOL_RHS=J+JBEG_RHS-1 ELSE JCOL_RHS=PERM_RHS(J+JBEG_RHS-1) ENDIF CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & CWORK, NPIV, MPI_DOUBLE_COMPLEX, & COMM, IERR) IF (LSCAL) THEN DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I)*SCALING(IROWlist(I)) ENDDO ELSE DO I=1,NPIV RHS(IROWlist(I),JCOL_RHS)=CWORK(I) ENDDO ENDIF ENDDO N2RECV=N2RECV-NPIV CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & NPIV, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO DEALLOCATE(IROWlist) ENDIF RETURN CONTAINS SUBROUTINE ZMUMPS_NPIV_BLOCK_ADD ( ON_MASTER ) LOGICAL, intent(in) :: ON_MASTER INTEGER :: JPOS, K242 LOGICAL :: LOCAL_LSCAL IF (ON_MASTER) THEN IF (KEEP(350).EQ.2 & .AND. (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN LOCAL_LSCAL = LSCAL K242 = KEEP(242) DO J=1, NRHS IF (K242.EQ.0) THEN JPOS = J+JBEG_RHS-1 ELSE JPOS = PERM_RHS(J+JBEG_RHS-1) ENDIF DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) IF (LOCAL_LSCAL) THEN RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ELSE RHS(I,JPOS) = RHSCOMP(IPOSINRHSCOMP,J) ENDIF ENDDO ENDDO ELSE IF (KEEP(242).EQ.0) THEN IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) DO J=1, NRHS RHS(I,J+JBEG_RHS-1) = RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ELSE IF (LSCAL) THEN DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J)*SCALING(I) ENDDO ENDDO ELSE DO II=1,NPIV I=IW(J1+II-1) IPOSINRHSCOMP= POSINRHSCOMP(I) !DIR$ NOVECTOR DO J=1, NRHS RHS(I,PERM_RHS(J+JBEG_RHS-1)) = & RHSCOMP(IPOSINRHSCOMP,J) ENDDO ENDDO ENDIF ENDIF ENDIF RETURN ENDIF CALL MPI_PACK(NPIV, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(IW(J1), NPIV, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) IPOSINRHSCOMP= POSINRHSCOMP(IW(J1)) DO J=1,NRHS CALL MPI_PACK(RHSCOMP(IPOSINRHSCOMP,J), NPIV, & MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) ENDDO N2SEND=N2SEND+NPIV IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL ZMUMPS_NPIV_BLOCK_SEND() END IF RETURN END SUBROUTINE ZMUMPS_NPIV_BLOCK_ADD SUBROUTINE ZMUMPS_NPIV_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE ZMUMPS_NPIV_BLOCK_SEND END SUBROUTINE ZMUMPS_GATHER_SOLUTION SUBROUTINE ZMUMPS_GATHER_SOLUTION_AM1(NSLAVES, N, MYID, COMM, & NRHS, RHSCOMP, LRHSCOMP, NRHSCOMP_COL, & KEEP, BUFFER, & SIZE_BUF, SIZE_BUF_BYTES, & LSCAL, SCALING, LSCALING, & IRHS_PTR_COPY, LIRHS_PTR_COPY, & IRHS_SPARSE_COPY, LIRHS_SPARSE_COPY, & RHS_SPARSE_COPY, LRHS_SPARSE_COPY, & UNS_PERM_INV, LUNS_PERM_INV, & POSINRHSCOMP, LPOS_ROW, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM INTEGER NRHS, LRHSCOMP, NRHSCOMP_COL COMPLEX(kind=8), intent(in) :: RHSCOMP (LRHSCOMP, NRHSCOMP_COL) INTEGER KEEP(500) INTEGER SIZE_BUF, SIZE_BUF_BYTES, LPOS_ROW INTEGER BUFFER(SIZE_BUF) INTEGER, intent(in) :: LIRHS_PTR_COPY, LIRHS_SPARSE_COPY, & LRHS_SPARSE_COPY, LUNS_PERM_INV, & NB_FS_IN_RHSCOMP INTEGER :: IRHS_SPARSE_COPY(LIRHS_SPARSE_COPY), & IRHS_PTR_COPY(LIRHS_PTR_COPY), & UNS_PERM_INV(LUNS_PERM_INV), & POSINRHSCOMP(LPOS_ROW) COMPLEX(kind=8) :: RHS_SPARSE_COPY(LRHS_SPARSE_COPY) LOGICAL, intent(in) :: LSCAL INTEGER, intent(in) :: LSCALING DOUBLE PRECISION, intent(in) :: SCALING(LSCALING) INTEGER COLSIZE, K, IZ, IPREV, NBCOL_INBLOC INTEGER I, II, J, MASTER, & TYPE_PARAL, N2RECV, IPOSINRHSCOMP INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE INTEGER RECORD_SIZE_P_1, SIZE1, SIZE2 INTEGER POS_BUF, N2SEND INTEGER, PARAMETER :: FIN = -1 INCLUDE 'mumps_headers.h' TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. MASTER .OR. TYPE_PARAL .eq. 1 NBCOL_INBLOC = size(IRHS_PTR_COPY)-1 IF (NSLAVES.EQ.1 .AND. TYPE_PARAL.EQ.1) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)= & RHSCOMP(IPOSINRHSCOMP,K)*SCALING(I) ELSE RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDIF ENDDO K = K + 1 ENDDO RETURN ENDIF IF (I_AM_SLAVE) THEN K=1 DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.EQ.0) CYCLE DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(I) IF (IPOSINRHSCOMP.GT.0) THEN RHS_SPARSE_COPY(IZ)=RHSCOMP(IPOSINRHSCOMP,K) ENDIF ENDDO K = K + 1 ENDDO ENDIF SIZE1=0 CALL MPI_PACK_SIZE(3,MPI_INTEGER, COMM, & SIZE1, IERR) SIZE2=0 CALL MPI_PACK_SIZE(1,MPI_DOUBLE_COMPLEX, COMM, & SIZE2, IERR) RECORD_SIZE_P_1= SIZE1+SIZE2 IF (RECORD_SIZE_P_1.GT.SIZE_BUF_BYTES) THEN write(6,*) MYID, & ' Internal error 3 in ZMUMPS_GATHER_SOLUTION_AM1 ' write(6,*) MYID, ' RECORD_SIZE_P_1, SIZE_BUF_BYTES=', & RECORD_SIZE_P_1, SIZE_BUF_BYTES CALL MUMPS_ABORT() ENDIF N2SEND =0 N2RECV =size(IRHS_SPARSE_COPY) POS_BUF =0 IF (I_AM_SLAVE) THEN DO J = 1, NBCOL_INBLOC COLSIZE = IRHS_PTR_COPY(J+1) - IRHS_PTR_COPY(J) IF (COLSIZE.LE.0) CYCLE K = 0 DO IZ=IRHS_PTR_COPY(J), IRHS_PTR_COPY(J+1)-1 I = IRHS_SPARSE_COPY(IZ) II = I IF (KEEP(23).NE.0) II = UNS_PERM_INV(I) IPOSINRHSCOMP = POSINRHSCOMP(II) IF (IPOSINRHSCOMP.GT.0) THEN IF (MYID .EQ. MASTER) THEN N2RECV=N2RECV-1 IF (LSCAL) & CALL ZMUMPS_AM1_BLOCK_ADD ( .TRUE. ) IRHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & I RHS_SPARSE_COPY( IRHS_PTR_COPY(J) + K) = & RHS_SPARSE_COPY(IZ) K = K+1 ELSE CALL ZMUMPS_AM1_BLOCK_ADD ( .FALSE. ) ENDIF ENDIF ENDDO IF (MYID.EQ.MASTER) & IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + K ENDDO CALL ZMUMPS_AM1_BLOCK_SEND() ENDIF IF ( MYID .EQ. MASTER ) THEN DO WHILE (N2RECV .NE. 0) CALL MPI_RECV( BUFFER, SIZE_BUF_BYTES, MPI_PACKED, & MPI_ANY_SOURCE, & GatherSol, COMM, STATUS, IERR ) POS_BUF = 0 CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) DO WHILE (J.NE.FIN) IZ = IRHS_PTR_COPY(J) CALL MPI_UNPACK( BUFFER,SIZE_BUF_BYTES, POS_BUF, & I, 1, MPI_INTEGER, COMM, IERR) IRHS_SPARSE_COPY(IZ) = I CALL MPI_UNPACK(BUFFER, SIZE_BUF_BYTES, POS_BUF, & RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_COMPLEX, & COMM, IERR) IF (LSCAL) THEN IF (KEEP(23).NE.0) I = UNS_PERM_INV(I) RHS_SPARSE_COPY(IZ) = RHS_SPARSE_COPY(IZ)*SCALING(I) ENDIF N2RECV=N2RECV-1 IRHS_PTR_COPY(J) = IRHS_PTR_COPY(J) + 1 CALL MPI_UNPACK( BUFFER, SIZE_BUF_BYTES, POS_BUF, & J, 1, MPI_INTEGER, COMM, IERR) ENDDO ENDDO IPREV = 1 DO J=1, size(IRHS_PTR_COPY)-1 I= IRHS_PTR_COPY(J) IRHS_PTR_COPY(J) = IPREV IPREV = I ENDDO ENDIF RETURN CONTAINS SUBROUTINE ZMUMPS_AM1_BLOCK_ADD ( SCALE_ONLY ) LOGICAL, intent(in) :: SCALE_ONLY INTEGER III IF (SCALE_ONLY) THEN III = I IF (KEEP(23).NE.0) III = UNS_PERM_INV(I) IF (LSCAL) THEN RHS_SPARSE_COPY(IZ)=RHS_SPARSE_COPY(IZ)*SCALING(III) ENDIF RETURN ENDIF CALL MPI_PACK(J, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(I, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_PACK(RHS_SPARSE_COPY(IZ), 1, MPI_DOUBLE_COMPLEX, & BUFFER, SIZE_BUF_BYTES, POS_BUF, COMM, & IERR) N2SEND=N2SEND+1 IF ( POS_BUF + RECORD_SIZE_P_1 > SIZE_BUF_BYTES ) THEN CALL ZMUMPS_AM1_BLOCK_SEND() END IF RETURN END SUBROUTINE ZMUMPS_AM1_BLOCK_ADD SUBROUTINE ZMUMPS_AM1_BLOCK_SEND() IF (N2SEND .NE. 0) THEN CALL MPI_PACK(FIN, 1, MPI_INTEGER, BUFFER, & SIZE_BUF_BYTES, POS_BUF, COMM, IERR ) CALL MPI_SEND(BUFFER, POS_BUF, MPI_PACKED, MASTER, & GatherSol, COMM, IERR) ENDIF POS_BUF=0 N2SEND=0 RETURN END SUBROUTINE ZMUMPS_AM1_BLOCK_SEND END SUBROUTINE ZMUMPS_GATHER_SOLUTION_AM1 SUBROUTINE ZMUMPS_DISTSOL_INDICES(MTYPE, ISOL_LOC, & PTRIST, KEEP,KEEP8, & IW, LIW_PASSED, MYID_NODES, N, STEP, & PROCNODE, NSLAVES, scaling_data, LSCAL & , IRHS_loc_MEANINGFUL, IRHS_loc, Nloc_RHS & ) IMPLICIT NONE INTEGER MTYPE, MYID_NODES, N, NSLAVES INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE(KEEP(28)) INTEGER ISOL_LOC(KEEP(89)) INTEGER LIW_PASSED INTEGER IW(LIW_PASSED) INTEGER STEP(N) LOGICAL LSCAL LOGICAL :: IRHS_loc_MEANINGFUL INTEGER :: Nloc_RHS INTEGER :: IRHS_loc(Nloc_RHS) type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t type (scaling_data_t) :: scaling_data INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER ISTEP, K INTEGER J1, IPOS, LIELL, NPIV, JJ LOGICAL :: CHECK_IRHS_loc INTEGER(8) :: DIFF_ADDR INCLUDE 'mumps_headers.h' CHECK_IRHS_loc=.FALSE. IF ( IRHS_loc_MEANINGFUL ) THEN IF (Nloc_RHS .GT. 0) THEN CALL MUMPS_SIZE_C( IRHS_loc(1), ISOL_loc(1), & DIFF_ADDR ) IF (DIFF_ADDR .EQ. 0_8) THEN CHECK_IRHS_loc=.TRUE. ENDIF ENDIF ENDIF K=0 DO ISTEP=1, KEEP(28) IF ( MYID_NODES == MUMPS_PROCNODE( PROCNODE(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW_PASSED, PTRIST, STEP, N) IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF DO JJ=J1,J1+NPIV-1 K=K+1 IF (CHECK_IRHS_loc) THEN IF (K.LE.Nloc_RHS) THEN IF ( IW(JJ) .NE.IRHS_LOC(K) ) THEN ENDIF ENDIF ENDIF ISOL_LOC(K)=IW(JJ) IF (LSCAL) THEN scaling_data%SCALING_LOC(K)= & scaling_data%SCALING(IW(JJ)) ENDIF ENDDO ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_DISTSOL_INDICES SUBROUTINE ZMUMPS_DISTRIBUTED_SOLUTION( & SLAVEF, N, MYID_NODES, & MTYPE, RHSCOMP, LRHSCOMP, NBRHS_EFF, & POSINRHSCOMP, & ISOL_LOC, & SOL_LOC, NRHS, BEG_RHS, LSOL_LOC, & PTRIST, & PROCNODE_STEPS, KEEP,KEEP8, IW, LIW, STEP, & scaling_data, LSCAL, NB_RHSSKIPPED, & PERM_RHS, SIZE_PERM_RHS) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' type scaling_data_t SEQUENCE DOUBLE PRECISION, dimension(:), pointer :: SCALING DOUBLE PRECISION, dimension(:), pointer :: SCALING_LOC end type scaling_data_t TYPE (scaling_data_t) :: scaling_data LOGICAL LSCAL INTEGER SLAVEF, N, MYID_NODES, LIW, MTYPE, NBRHS_EFF, LRHSCOMP INTEGER POSINRHSCOMP(N), NB_RHSSKIPPED INTEGER LSOL_LOC, BEG_RHS INTEGER ISOL_LOC(LSOL_LOC) INTEGER, INTENT(in) :: NRHS COMPLEX(kind=8) SOL_LOC( LSOL_LOC, NRHS ) COMPLEX(kind=8) RHSCOMP( LRHSCOMP, NBRHS_EFF ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER, INTENT(in) :: SIZE_PERM_RHS INTEGER, INTENT(in) :: PERM_RHS( SIZE_PERM_RHS ) INTEGER :: JJ, J1, ISTEP, K, KLOC, IPOSINRHSCOMP, JEMPTY INTEGER :: JCOL, JCOL_PERM INTEGER :: IPOS, LIELL, NPIV, JEND LOGICAL :: ROOT !$ LOGICAL :: OMP_FLAG COMPLEX(kind=8), PARAMETER :: ZERO = (0.0D0,0.0D0) INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE K=0 JEMPTY = BEG_RHS+NB_RHSSKIPPED-1 JEND = BEG_RHS+NB_RHSSKIPPED+NBRHS_EFF-1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN ROOT=.false. IF (KEEP(38).ne.0) ROOT = STEP(KEEP(38))==ISTEP IF (KEEP(20).ne.0) ROOT = STEP(KEEP(20))==ISTEP IF ( ROOT ) THEN IPOS = PTRIST(ISTEP) + KEEP(IXSZ) LIELL = IW(IPOS+3) NPIV = LIELL IPOS= PTRIST(ISTEP)+5+KEEP(IXSZ) ELSE IPOS = PTRIST(ISTEP) + 2 +KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) IPOS= IPOS+1 NPIV = IW(IPOS) IPOS= IPOS+1 IPOS= IPOS+1+IW( PTRIST(ISTEP) + 5 +KEEP(IXSZ)) END IF IF (MTYPE.eq.1 .AND. KEEP(50).EQ.0) THEN J1=IPOS+1+LIELL ELSE J1=IPOS+1 END IF IF (NB_RHSSKIPPED.GT.0) THEN DO JCOL = BEG_RHS, JEMPTY IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF KLOC=K DO JJ=J1,J1+NPIV-1 KLOC=KLOC+1 SOL_LOC(KLOC, JCOL_PERM) = ZERO ENDDO ENDDO ENDIF !$ OMP_FLAG = ( JEND-JEMPTY.GE.KEEP(362) .AND. !$ & (NPIV*(JEND-JEMPTY) .GE. KEEP(363)/2 ) ) !$OMP PARALLEL DO PRIVATE(JCOL,JCOL_PERM,KLOC,JJ,IPOSINRHSCOMP) !$OMP& IF(OMP_FLAG) DO JCOL = JEMPTY+1, JEND IF (KEEP(242) .NE. 0) THEN JCOL_PERM = PERM_RHS(JCOL) ELSE JCOL_PERM = JCOL ENDIF DO JJ=J1,J1+NPIV-1 KLOC=K + JJ-J1 + 1 IPOSINRHSCOMP = POSINRHSCOMP(IW(JJ)) IF (LSCAL) THEN SOL_LOC(KLOC,JCOL_PERM) = & scaling_data%SCALING_LOC(KLOC)* & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ELSE SOL_LOC(KLOC,JCOL_PERM) = & RHSCOMP(IPOSINRHSCOMP,JCOL-JEMPTY) ENDIF ENDDO ENDDO !$OMP END PARALLEL DO K=K+NPIV ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_DISTRIBUTED_SOLUTION SUBROUTINE ZMUMPS_SCATTER_RHS & (NSLAVES, N, MYID, COMM, & MTYPE, RHS, LRHS, NCOL_RHS, NRHS, & RHSCOMP, LRHSCOMP, NCOL_RHSCOMP, & POSINRHSCOMP_FWD, NB_FS_IN_RHSCOMP_F, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & ICNTL, INFO) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER NSLAVES, N, MYID, COMM, LIW, MTYPE INTEGER NRHS, LRHS, NCOL_RHS, LRHSCOMP, NCOL_RHSCOMP INTEGER ICNTL(60), INFO(80) COMPLEX(kind=8), intent(in) :: RHS (LRHS, NCOL_RHS) COMPLEX(kind=8), intent(out) :: RHSCOMP(LRHSCOMP, NCOL_RHSCOMP) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N), NB_FS_IN_RHSCOMP_F INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER IW(LIW), STEP(N) INTEGER BUF_MAXSIZE, BUF_MAXREF PARAMETER (BUF_MAXREF=200000) INTEGER, ALLOCATABLE, DIMENSION(:) :: BUF_INDX COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:,:) :: BUF_RHS COMPLEX(kind=8), ALLOCATABLE, DIMENSION(:) :: BUF_RHS_2 INTEGER ENTRIES_2_PROCESS, PROC_WHO_ASKS, BUF_EFFSIZE INTEGER INDX INTEGER allocok COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INTEGER I, J, K, JJ, J1, ISTEP, MASTER, & MYID_NODES, TYPE_PARAL INTEGER LIELL, IPOS, NPIV INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR PARAMETER(MASTER=0) LOGICAL I_AM_SLAVE !$ INTEGER :: CHUNK, NOMP !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE TYPE_PARAL = KEEP(46) I_AM_SLAVE = MYID .ne. 0 .OR. TYPE_PARAL .eq. 1 IF ( TYPE_PARAL == 1 ) THEN MYID_NODES = MYID ELSE MYID_NODES = MYID-1 ENDIF BUF_EFFSIZE = 0 BUF_MAXSIZE = max(min(BUF_MAXREF,int(2000000/NRHS)),2000) IF ( KEEP(350).EQ.2 ) THEN !$ NOMP = OMP_GET_MAX_THREADS() ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS_2(BUF_MAXSIZE*NRHS), & stat=allocok) ELSE ALLOCATE (BUF_INDX(BUF_MAXSIZE), & BUF_RHS(NRHS,BUF_MAXSIZE), & stat=allocok) END IF IF (allocok .GT. 0) THEN INFO(1)=-13 INFO(2)=BUF_MAXSIZE*(NRHS+1) ENDIF CALL MUMPS_PROPINFO(ICNTL, INFO, COMM, MYID ) IF (INFO(1).LT.0) RETURN IF (MYID.EQ.MASTER) THEN ENTRIES_2_PROCESS = N - KEEP(89) IF (TYPE_PARAL.EQ.1.AND.ENTRIES_2_PROCESS.NE.0) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF IF ( KEEP(350).EQ.2 ) THEN DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT(STATUS,MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) = RHS( INDX, K ) ENDDO ENDDO !$OMP END PARALLEL DO CALL MPI_SEND( BUF_RHS_2, & NRHS*BUF_EFFSIZE, & MPI_DOUBLE_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ELSE DO WHILE ( ENTRIES_2_PROCESS .NE. 0) CALL MPI_RECV( BUF_INDX, BUF_MAXSIZE, MPI_INTEGER, & MPI_ANY_SOURCE, & ScatterRhsI, COMM, STATUS, IERR ) CALL MPI_GET_COUNT( STATUS, MPI_INTEGER,BUF_EFFSIZE,IERR) PROC_WHO_ASKS = STATUS(MPI_SOURCE) DO I = 1, BUF_EFFSIZE INDX = BUF_INDX( I ) DO K = 1, NRHS BUF_RHS( K, I ) = RHS( INDX, K ) ENDDO ENDDO CALL MPI_SEND( BUF_RHS, NRHS*BUF_EFFSIZE, & MPI_DOUBLE_COMPLEX, PROC_WHO_ASKS, & ScatterRhsR, COMM, IERR) ENTRIES_2_PROCESS = ENTRIES_2_PROCESS - BUF_EFFSIZE ENDDO BUF_EFFSIZE= 0 ENDIF ENDIF IF (I_AM_SLAVE) THEN IF (MYID.NE.MASTER) THEN IF (NB_FS_IN_RHSCOMP_F.LT.LRHSCOMP) THEN DO K=1, NCOL_RHSCOMP DO I = NB_FS_IN_RHSCOMP_F +1, LRHSCOMP RHSCOMP (I, K) = ZERO ENDDO ENDDO ENDIF ENDIF DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF (MYID.EQ.MASTER) THEN INDX = POSINRHSCOMP_FWD(IW(J1)) IF (KEEP(350).EQ.2 .AND. & (NRHS.EQ.1.OR.((NPIV*NRHS*2*KEEP(16)).GE.KEEP(364)))) THEN !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (NPIV*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((NPIV*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(J,JJ) !$OMP& FIRSTPRIVATE(INDX) IF (OMP_FLAG) DO K = 1, NRHS DO JJ=J1,J1+NPIV-1 J=IW(JJ) RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE DO JJ=J1,J1+NPIV-1 J=IW(JJ) DO K = 1, NRHS RHSCOMP( INDX+JJ-J1, K ) = RHS( J, K ) ENDDO ENDDO END IF ELSE DO JJ=J1,J1+NPIV-1 BUF_EFFSIZE = BUF_EFFSIZE + 1 BUF_INDX(BUF_EFFSIZE) = IW(JJ) IF (BUF_EFFSIZE + 1 .GT. BUF_MAXSIZE) THEN CALL ZMUMPS_GET_BUF_INDX_RHS() ENDIF ENDDO ENDIF ENDIF ENDDO IF ( BUF_EFFSIZE .NE. 0 .AND. MYID.NE.MASTER ) & CALL ZMUMPS_GET_BUF_INDX_RHS() ENDIF IF (KEEP(350).EQ.2) THEN DEALLOCATE (BUF_INDX, BUF_RHS_2) ELSE DEALLOCATE (BUF_INDX, BUF_RHS) ENDIF RETURN CONTAINS SUBROUTINE ZMUMPS_GET_BUF_INDX_RHS() CALL MPI_SEND(BUF_INDX, BUF_EFFSIZE, MPI_INTEGER, & MASTER, ScatterRhsI, COMM, IERR ) IF (KEEP(350).EQ.2) THEN CALL MPI_RECV(BUF_RHS_2, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) !$ OMP_FLAG = .FALSE. !$ CHUNK = NRHS !$ IF (BUF_EFFSIZE*NRHS .GE. KEEP(363)) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max((BUF_EFFSIZE*NRHS+NOMP-1)/NOMP,KEEP(363)/2) !$ ENDIF !$OMP PARALLEL DO COLLAPSE(2) SCHEDULE(STATIC,CHUNK) PRIVATE(INDX) !$OMP& IF (OMP_FLAG) DO K = 1, NRHS DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) RHSCOMP( INDX, K ) = & BUF_RHS_2( I+(K-1)*BUF_EFFSIZE) ENDDO ENDDO !$OMP END PARALLEL DO ELSE CALL MPI_RECV(BUF_RHS, BUF_EFFSIZE*NRHS, & MPI_DOUBLE_COMPLEX, & MASTER, & ScatterRhsR, COMM, STATUS, IERR ) DO I = 1, BUF_EFFSIZE INDX = POSINRHSCOMP_FWD(BUF_INDX(I)) DO K = 1, NRHS RHSCOMP( INDX, K ) = BUF_RHS( K, I ) ENDDO ENDDO END IF BUF_EFFSIZE = 0 RETURN END SUBROUTINE ZMUMPS_GET_BUF_INDX_RHS END SUBROUTINE ZMUMPS_SCATTER_RHS SUBROUTINE ZMUMPS_BUILD_POSINRHSCOMP & (NSLAVES, N, MYID_NODES, & PTRIST, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & NBENT_RHSCOMP, NB_FS_IN_RHSCOMP ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP, NB_FS_IN_RHSCOMP INTEGER ISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL INTEGER IPOSINRHSCOMP, IPOSINRHSCOMP_COL INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP = 1 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, NPIV, LIELL, & IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) = IPOSINRHSCOMP+JJ-J1 ENDDO IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) = IPOSINRHSCOMP+JJ-JCOL ENDDO ENDIF IPOSINRHSCOMP = IPOSINRHSCOMP + NPIV ENDIF ENDDO NB_FS_IN_RHSCOMP = IPOSINRHSCOMP -1 IF (POSINRHSCOMP_COL_ALLOC) IPOSINRHSCOMP_COL=IPOSINRHSCOMP IF (IPOSINRHSCOMP.GT.N) GOTO 500 DO ISTEP = 1, KEEP(28) IF (MYID_NODES == MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP), & KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = NPIV, LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(J1+JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN POSINRHSCOMP_COL(IW(JCOL+JJ)) = - IPOSINRHSCOMP_COL IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 ENDIF ENDDO ELSE DO JJ = J1+NPIV, J1+LIELL-1-KEEP(253) IF (POSINRHSCOMP_ROW(IW(JJ)).EQ.0) THEN POSINRHSCOMP_ROW(IW(JJ)) = - IPOSINRHSCOMP IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDIF ENDDO ENDIF ENDIF ENDDO 500 NBENT_RHSCOMP = IPOSINRHSCOMP - 1 IF (POSINRHSCOMP_COL_ALLOC) & NBENT_RHSCOMP = max(NBENT_RHSCOMP, IPOSINRHSCOMP_COL-1) RETURN END SUBROUTINE ZMUMPS_BUILD_POSINRHSCOMP SUBROUTINE ZMUMPS_BUILD_POSINRHSCOMP_AM1 & (NSLAVES, N, MYID_NODES, & PTRIST, DAD, & KEEP,KEEP8, PROCNODE_STEPS, IW, LIW, STEP, & POSINRHSCOMP_ROW, POSINRHSCOMP_COL, & POSINRHSCOMP_COL_ALLOC, & MTYPE, & IRHS_PTR, NBCOL_INBLOC, IRHS_SPARSE, NZ_RHS, & PERM_RHS, SIZE_PERM_RHS, JBEG_RHS, & NBENT_RHSCOMP, & NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT, & UNS_PERM_INV, SIZE_UNS_PERM_INV & ) IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER, intent(in) :: NSLAVES, N, MYID_NODES, LIW, & SIZE_UNS_PERM_INV INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(in) :: PTRIST(KEEP(28)), PROCNODE_STEPS(KEEP(28)) INTEGER, intent(inout) :: DAD(KEEP(28)) INTEGER, intent(in) :: IW(LIW), STEP(N) INTEGER, intent(in) :: NBCOL_INBLOC, IRHS_PTR(NBCOL_INBLOC+1) INTEGER, intent(in) :: NZ_RHS, IRHS_SPARSE(NZ_RHS) INTEGER, intent(in) :: SIZE_PERM_RHS, PERM_RHS(SIZE_PERM_RHS) INTEGER, intent(in) :: JBEG_RHS INTEGER, intent(in) :: MTYPE LOGICAL, intent(in) :: POSINRHSCOMP_COL_ALLOC INTEGER, intent(out):: POSINRHSCOMP_ROW(N),POSINRHSCOMP_COL(N) INTEGER, intent(out):: NBENT_RHSCOMP INTEGER, intent(out):: NB_FS_IN_RHSCOMP_FWD, NB_FS_IN_RHSCOMP_TOT INTEGER, intent(in) :: UNS_PERM_INV(SIZE_UNS_PERM_INV) INTEGER I, JAM1 INTEGER ISTEP, OLDISTEP INTEGER NPIV INTEGER IPOS, LIELL INTEGER JJ, J1, JCOL, ABSJCOL INTEGER IPOSINRHSCOMP_ROW, IPOSINRHSCOMP_COL INTEGER NBENT_RHSCOMP_ROW, NBENT_RHSCOMP_COL LOGICAL GO_UP INCLUDE 'mumps_headers.h' INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE IF(KEEP(237).EQ.0) THEN WRITE(*,*)'BUILD_POSINRHSCOMP_SPARSE available for A-1 only !' CALL MUMPS_ABORT() END IF POSINRHSCOMP_ROW = 0 IF (POSINRHSCOMP_COL_ALLOC) POSINRHSCOMP_COL = 0 IPOSINRHSCOMP_ROW = 0 IPOSINRHSCOMP_COL = 0 DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_ROW(IW(J1)).EQ.0) THEN DO JJ = J1, J1+NPIV-1 POSINRHSCOMP_ROW(IW(JJ)) & = IPOSINRHSCOMP_ROW + JJ - J1 + 1 ENDDO IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + NPIV IF (POSINRHSCOMP_COL_ALLOC) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(IW(JJ)) & = - N - (IPOSINRHSCOMP_COL + JJ - JCOL + 1) ENDDO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ENDIF ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO NB_FS_IN_RHSCOMP_FWD = IPOSINRHSCOMP_ROW IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF ABSJCOL = abs(IW(JCOL)) IF(NPIV.GT.0) THEN IF(POSINRHSCOMP_COL(ABSJCOL).EQ.0) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ))) = & IPOSINRHSCOMP_COL+JJ-JCOL+1 END DO IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + NPIV ELSE IF (POSINRHSCOMP_COL(ABSJCOL).LT.-N) THEN DO JJ = JCOL, JCOL+NPIV-1 POSINRHSCOMP_COL(abs(IW(JJ)))= & -(N+POSINRHSCOMP_COL(abs(IW(JJ)))) END DO ELSE IF ((POSINRHSCOMP_COL(ABSJCOL).LT.0).AND. & (POSINRHSCOMP_COL(ABSJCOL).GE.-N))THEN WRITE(*,*)'Internal error 7 in BUILD...SPARSE' CALL MUMPS_ABORT() ELSE GO_UP = .FALSE. END IF END IF END IF IF(DAD(ISTEP).NE.0) THEN ISTEP = STEP(DAD(ISTEP)) ELSE GO_UP = .FALSE. END IF END DO END DO END IF NB_FS_IN_RHSCOMP_TOT = IPOSINRHSCOMP_COL IF (NSLAVES.NE.1) THEN DO I = 1, NBCOL_INBLOC IF ((IRHS_PTR(I+1)-IRHS_PTR(I)).EQ.0) CYCLE IF (KEEP(242).NE.0) THEN JAM1 = PERM_RHS(JBEG_RHS+I-1) ELSE JAM1 = JBEG_RHS+I-1 END IF ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_ROW(IW(J1+JJ)).EQ.0) THEN IPOSINRHSCOMP_ROW = IPOSINRHSCOMP_ROW + 1 POSINRHSCOMP_ROW(IW(JJ+J1)) & = -IPOSINRHSCOMP_ROW END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) IF(POSINRHSCOMP_COL_ALLOC) THEN DO I =1, NZ_RHS JAM1 = IRHS_SPARSE(I) IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) ISTEP = abs(STEP(JAM1)) GO_UP = .TRUE. DO WHILE(GO_UP) IF(MYID_NODES.EQ. & MUMPS_PROCNODE(PROCNODE_STEPS(ISTEP),KEEP(199))) THEN CALL MUMPS_SOL_GET_NPIV_LIELL_IPOS( ISTEP, KEEP, & NPIV, LIELL, IPOS, IW, LIW, PTRIST, STEP, N ) IF (MTYPE.eq.1 .OR. KEEP(50).NE.0) THEN J1=IPOS+1 ELSE J1=IPOS+1+LIELL END IF IF ( MTYPE .EQ. 1 .AND. KEEP(50).EQ.0 ) THEN JCOL = IPOS+1+LIELL ELSE JCOL = IPOS+1 ENDIF IF (KEEP(23).NE.0) JAM1 = UNS_PERM_INV(JAM1) DO JJ = NPIV, LIELL-1-KEEP(253) IF(POSINRHSCOMP_COL(IW(JCOL+JJ)).EQ.0) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = -IPOSINRHSCOMP_COL ELSE IF (POSINRHSCOMP_COL(IW(JCOL+JJ)).LT.-N) THEN IPOSINRHSCOMP_COL = IPOSINRHSCOMP_COL + 1 POSINRHSCOMP_COL(IW(JCOL+JJ)) & = POSINRHSCOMP_COL(IW(JCOL+JJ)) + N END IF END DO END IF IF(DAD(ISTEP).GT.0) THEN OLDISTEP=ISTEP ISTEP = STEP(DAD(ISTEP)) DAD(OLDISTEP)=-DAD(OLDISTEP) ELSE GO_UP = .FALSE. END IF END DO END DO DAD=ABS(DAD) END IF ENDIF NBENT_RHSCOMP_ROW = IPOSINRHSCOMP_ROW NBENT_RHSCOMP_COL = IPOSINRHSCOMP_COL NBENT_RHSCOMP = max(NBENT_RHSCOMP_ROW,NBENT_RHSCOMP_COL) RETURN END SUBROUTINE ZMUMPS_BUILD_POSINRHSCOMP_AM1 MUMPS_5.4.1/src/cfac_driver.F0000664000175000017500000043754714102210526016110 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_DRIVER( id) USE CMUMPS_BUF USE CMUMPS_LOAD USE CMUMPS_OOC USE CMUMPS_STRUC_DEF USE CMUMPS_LR_STATS USE CMUMPS_LR_DATA_M, only: CMUMPS_BLR_INIT_MODULE, & CMUMPS_BLR_END_MODULE & , CMUMPS_BLR_STRUC_TO_MOD & , CMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE CMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE CMUMPS_ANORMINF(id, ANORMINF, LSCAL) USE CMUMPS_STRUC_DEF TYPE (CMUMPS_STRUC), TARGET :: id REAL, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE CMUMPS_ANORMINF SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE CMUMPS_LR_DATA_M, only : CMUMPS_BLR_STRUC_TO_MOD, & CMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE CMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Parameters C ========== C TYPE(CMUMPS_STRUC), TARGET :: id C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: CMUMPS_LBUFR, CMUMPS_LBUFR_BYTES INTEGER(8) :: CMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: CMUMPS_LBUF, CMUMPS_LBUF_INT INTEGER(8) :: CMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, K28, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 REAL CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM C TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER MAXIS INTEGER(8) :: MAXS C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG COMPLEX, TARGET :: S_DUMMY_ARG(1) COMPLEX, POINTER, DIMENSION(:) :: S_PTR_ARG INTEGER NPIV_CRITICAL_PATH DOUBLE PRECISION TIME, TIMEET REAL ZERO, ONE, MONE PARAMETER( ZERO = 0.0E0, ONE = 1.0E0, MONE = -1.0E0) COMPLEX CZERO PARAMETER( CZERO = (0.0E0, 0.0E0) ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG REAL :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil REAL :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_LR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_DECOMP_ASM1 DOUBLE PRECISION :: TMP_TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TMP_TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2M C C Workspace. C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK COMPLEX, DIMENSION(:), ALLOCATABLE :: WK REAL, DIMENSION(:), ALLOCATABLE :: WK_REAL INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER BUREGISTRE(12) INTEGER BUINTSZ, BURESZ, BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS REAL SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C INTEGER, POINTER :: JOB * Control parameters: see description in CMUMPSID REAL,DIMENSION(:),POINTER::RINFO, RINFOG REAL,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER:: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: MYIRN_loc, MYJCN_loc COMPLEX, DIMENSION(:), POINTER :: MYA_loc INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) COMPLEX, TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH INTEGER(8) :: TOTAL_BYTES INTEGER(8) :: I8TMP, LWK_USER_SUM8 C C External references C =================== INTEGER numroc EXTERNAL numroc INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED C Fwd in facto: COMPLEX, DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM C C JOB=>id%JOB RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN MYIRN_loc=>id%IRN_loc MYJCN_loc=>id%JCN_loc MYA_loc=>id%A_loc ELSE MYIRN_loc=>DUMMYIRN_loc MYJCN_loc=>DUMMYJCN_loc MYA_loc=>DUMMYA_loc ENDIF N = id%N EPS = epsilon ( ZERO ) C TIMINGS: reset to 0 id%DKEEP(92)=0.0E0 id%DKEEP(93)=0.0E0 id%DKEEP(94)=0.0E0 id%DKEEP(97)=0.0E0 id%DKEEP(98)=0.0E0 id%DKEEP(56)=0.0E0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C MIN/MAX pivots reset to 0 id%DKEEP(19)=huge(0.0E0) id%DKEEP(20)=huge(0.0E0) id%DKEEP(21)=0.0E0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C Data from factorization is now freed asap C id%S, id%IS IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 NULLIFY(id%S) ENDIF ENDIF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C Free BLR factors, if any CALL CMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C IF (id%KEEP8(24).GT.0_8) THEN C We nullify S so that later when we test C if (associated(S) we can free space and reallocate it). NULLIFY(id%S) ENDIF C C -- KEEP8(24) can now then be reset safely WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user LWK_USER_SUM8 = 0_8 CALL MPI_REDUCE ( id%KEEP8(24), LWK_USER_SUM8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0E0 id%DKEEP(5)=-1.0E0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF C ---------------------- C Broadcast KEEP options C defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0E0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5E0) THEN CNTL1 = 0.5E0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_REAL, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 0 KEEP464COPY = 0 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF KEEP465COPY=0 IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF KEEP(489)=0 C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 50 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 50 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Ignore ICNTL(23) when WK_USER is provided c by resetting ITMP to zero on each proc where WK_USER is provided IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes IF ( PROKG ) THEN NWORKING = id%NSLAVES WRITE( MPG, 172 ) NWORKING, id%ICNTL(22), KEEP(486), & KEEP(12), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, LWK_USER_SUM8, CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL(id) END IF C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0E0 ! real part of the local determinant id%DKEEP(7) = 0.0E0 ! imaginary part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_REAL,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4*BUMAXMN ALLOCATE (IWK(LIWK),BURP(M),BUCP(N), & BURS(2* (id%NPROCS)),BUCS(2* (id%NPROCS)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL CMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL CMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N CXXXX IF(N > BUMAXMN) BUMAXMN = N LIWK = 1 ALLOCATE (IWK(LIWK),BURP(1),BUCP(1), & BURS(1),BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+1+1+1+1 ENDIF LWK_REAL = M + N ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (id%INFO(1) .LT. 0) GOTO 400 CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL CMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN ! internal error since LWK_REAL=BURESZ=M+N id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL CMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_REAL, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ---------------------------------- C Centralized scaling, options 1 to 6 C ---------------------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN C We have an explicit copy of the original C matrix in complex format which should probably C be avoided (but do we want to keep all C those old scaling options ?) LWK = id%KEEP8(28) ELSE LWK = 1_8 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL CMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF ! Scaling distributed matrices or centralized IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=real(TIMEET) C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8) & .AND. (K233+K231+K232).GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL CMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL CMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL CMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL CMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE C Fwd in facto: in case of repeated factorizations C with different Schur options we prefer to free C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF C Fwd in facto: allocate and broadcast RHS_MUMPS C to make it available on all processors. IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP(255) = N*id%KEEP(253) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(255) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_COMPLEX, MASTER,id%COMM,IERR) END DO ENDIF C Keep a copy of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 IF (KEEP(219).NE.0) THEN CALL CMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN C ------------------------ C Error allocating CMUMPS_BUF C ------------------------ id%INFO(1) = -13 id%INFO(2) = max(KEEP(108),1) END IF ENDIF C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_REAL, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_REAL, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN CALL CMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ELSE ANORMINF = ZERO ENDIF C C Set BLR threshold IF (id%DKEEP(8).LT.ZERO) THEN id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ENDIF IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A,1PD16.4)') & ' Effective value of CNTL(3) =',CNTL3 ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I10)') & 'ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for postponing =',SEUIL ENDIF !end KEEP(19) SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in CMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0E0 id%DKEEP(2) = ZERO ELSE C -- Null pivot is on IF (KEEP(19).NE.0) THEN C -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1E-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF ELSE C -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(REAL(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0E10*ANORMINF, & sqrt(huge(ANORMINF))/1.0E8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST in case of null pivot detection LPN_LIST = 1 IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = N ENDIF ALLOCATE( id%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_REAL, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN CALL CMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate id%S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL CMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1E6) C ------------------------- C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL CMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & ) ENDIF ! MEM_ALLOWED C ENDIF ! (.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (I_AM_SLAVE) THEN ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL CMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL CMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), id%DKEEP(15), KEEP(375), MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to CMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL CMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) C C Out-Of-Core (OOC) issues. Case where we ran one factorization OOC C and the second one is in-core: we try to free OOC C related data from previous factorization. C CALL CMUMPS_CLEAN_OOC_DATA(id, IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version I8TMP = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * id%KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL CMUMPS_OOC_INIT_FACTO(id,MAXS) ELSE WRITE(*,*) "Internal error in CMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL CMUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL CMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead C ====================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE C ---------------------------------------- C Allocate variable lists. Systematically. C ---------------------------------------- IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( id%INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) NULLIFY(id%INTARR) GOTO 100 END IF ELSE ALLOCATE( id%INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) GOTO 100 END IF END IF C ----------------------------- C Allocate real values. C On master, if hybrid host and C no scaling, avoid the copy. C ----------------------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C -------------------------- C Simple pointer association C -------------------------- id%DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- IF ( id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF C ----------------- C Also prepare some C data for the root C ----------------- IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL CMUMPS_INIT_ROOT_FAC( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF C C 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (CMUMPS_ANA_F and CMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(54) .eq. 0 ) THEN C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) write(6,*) ' PB2 ALLOC INTARR' CALL MUMPS_ABORT() ENDIF ENDIF NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL CMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP,id%KEEP8, & id%FILS(1), IWK(1), ! workspace of size N & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1)) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL CMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP(1),id%KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1) ) #endif DEALLOCATE(IWK) ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL CMUMPS_FACTO_RECV_ARROWHD2( id%N, & id%DBLARR(1), id%KEEP8(26), & id%INTARR(1), id%KEEP8(27), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), id%KEEP8(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & id%root, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%INFO(1), id%INFO(2) ) ENDIF ELSE C C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL CMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & id%DBLARR(1), id%KEEP8(26), id%INTARR(1), & id%KEEP8(27), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, id%root, id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C ENDIF ELSE C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL CMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL CMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, id%root ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = real(TIME) IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN CALL CMUMPS_BUF_INI_MYID(id%MYID_NODES) C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Reception buffer C ---------------- IF (KEEP(486).NE.0) THEN CMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP( 35 ),8) ELSE CMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- CMUMPS_LBUFR_BYTES8 = max( CMUMPS_LBUFR_BYTES8, & 100000_8 ) C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased by more than that. C This is why we use an extra factor 2 relaxation coefficient for the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for moste messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C CMUMPS_LBUFR_BYTES8 = CMUMPS_LBUFR_BYTES8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUFR_BYTES8)/100E0, 8) CMUMPS_LBUFR_BYTES8 = min(CMUMPS_LBUFR_BYTES8, & int(huge (KEEP(44))-100,8)) CMUMPS_LBUFR_BYTES = int( CMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( real(max(PERLU,MIN_PERLU))* & real(id%KEEP8(22))/100E0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(379)) * real(KEEP(35)), 8 ) ELSE CMUMPS_LBUF8 = int( real(KEEP(213)) / 100.0E0 * & real(KEEP(43)) * real(KEEP(35)), 8 ) ENDIF CMUMPS_LBUF8 = max( CMUMPS_LBUF8, 100000_8 ) CMUMPS_LBUF8 = CMUMPS_LBUF8 & + int( 2.0E0 * real(max(PERLU,MIN_PERLU))* & real(CMUMPS_LBUF8)/100E0, 8) C Make CMUMPS_LBUF8 small enough to be stored in a standard integer CMUMPS_LBUF8 = min(CMUMPS_LBUF8, int(huge (KEEP(43))-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: CMUMPS_LBUF8 = max(CMUMPS_LBUF8, CMUMPS_LBUFR_BYTES8+3*KEEP(34)) CMUMPS_LBUF = int(CMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN CMUMPS_LBUFR_BYTES=CMUMPS_LBUFR_BYTES*5 CMUMPS_LBUF=CMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C CMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN CMUMPS_LBUF_INT = CMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, CMUMPS_LBUFR_BYTES, CMUMPS_LBUF C and CMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) CMUMPS_LBUFR_BYTES, & CMUMPS_LBUF, CMUMPS_LBUF_INT END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I10, & /, & ' Size of async. emission buffer (bytes).. = ', I10,/, & ' Small emission buffer (bytes) .......... = ', I10) C -------------------------- C Allocate small send buffer C required for CMUMPS_FAC_B C -------------------------- CALL CMUMPS_BUF_ALLOC_SMALL_BUF( CMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= CMUMPS_LBUF_INT id%INFO(2)= (CMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in CMUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- CMUMPS_LBUFR = (CMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) ALLOCATE( BUFR( CMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = CMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', CMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C CMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, & MAXIS_ESTIM + 3 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine CMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in CMUMPS_LBUF module CALL CMUMPS_BUF_DIST_IRECV_SIZE( CMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, id%KEEP8(12), KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, CMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(real(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/real(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MPG,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to CMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during CMUMPS_FAC_B. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL CMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), & LDPTRAR,IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,CMUMPS_LBUFR & , CMUMPS_LBUFR_BYTES, CMUMPS_LBUF, id%INTARR(1),id%DBLARR(1), & id%root, NELT_arg, id%FRTPTR(1), id%FRTELT(1),id%COMM_LOAD, & id%ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, id%MEM_DIST(0), & id%DKEEP(1), id%PIVNUL_LIST(1), LPN_LIST, id%LRGROUPS(1) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : INTARR was not allocated C during factorization in the case C of an assembled matrix. C --------------------------------- IF ( KEEP(55) .eq. 0 ) THEN C C ---------------- C Assembled matrix C ---------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF C ELSE C C ---------------- C Elemental matrix C ---------------- IF (associated(id%INTARR)) THEN DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) ENDIF C ------------------------------------ C For the master from an hybrid host C execution without scaling, then real C values have not been copied ! C ------------------------------------- IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF C Memroy statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) ELSE IF ( id%MYID .EQ. 1 ) THEN CALL MPI_SEND( KEEP(17), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL CMUMPS_BUF_DEALL_SMALL_BUF( IERR ) C//PIV IF (KEEP(219).NE.0) THEN CALL CMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF C C Check for errors. C After CMUMPS_FAC_B every slave is aware of an error. C If master is included in computations, the call below should C not be necessary. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL CMUMPS_EXTRACT_SCHUR_REDRHS(id) IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN IF ( I_AM_SLAVE ) THEN CALL CMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN id%INFO(1)=IERR id%INFO(2)=0 ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C We want to collect statistics even in case of C error to understand if it is due to numerical C issues CC IF ( id%INFO(1) < 0 ) GOTO 500 END IF END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=real(TIME) ENDIF C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL CMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL CMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C FIXME Check if WK_USER used and indicate, total space to WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL CMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C C IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during CMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_REAL, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = real(id%KEEP8(6)*int(KEEP(35),8))/real(1E6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = real(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_FR, TMP_FLOP_SOLFWD_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_LR, TMP_FLOP_SOLFWD_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASM1, TMP_TIME_DECOMP_ASM1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_LOCASM2, TMP_TIME_DECOMP_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_MAPLIG1, TMP_TIME_DECOMP_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2S, TMP_TIME_DECOMP_ASMS2S & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2M, TMP_TIME_DECOMP_ASMS2M & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_SOLFWD_FR = TMP_FLOP_SOLFWD_FR FLOP_SOLFWD_LR = TMP_FLOP_SOLFWD_LR FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_DECOMP_ASM1 = TMP_TIME_DECOMP_ASM1 /id%NPROCS TIME_DECOMP_LOCASM2 = TMP_TIME_DECOMP_LOCASM2 /id%NPROCS TIME_DECOMP_MAPLIG1 = TMP_TIME_DECOMP_MAPLIG1 /id%NPROCS TIME_DECOMP_ASMS2S = TMP_TIME_DECOMP_ASMS2S /id%NPROCS TIME_DECOMP_ASMS2M = TMP_TIME_DECOMP_ASMS2M /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),id%RINFOG(3), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array IF (LPOK) THEN IF (CNTL(7) < 0.0E0) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(LP,'(/A/,A/,A/,A,A)') & ' WARNING in BLR input setting', & ' CNTL(7) < 0 is experimental: ', & ' RRQR precision = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the Users guide ' ENDIF ENDIF CALL SAVEandWRITE_GAINS(FRONTWISE, & KEEP(489), id%DKEEP, N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), KEEP(472), & KEEP(475), KEEP(478), KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0E00 ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56). INFOG(28)=KEEP(112)+KEEP(17) ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST(KEEP(109)+1:KEEP(109)+KEEP(17). C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND(id%PIVNUL_LIST(KEEP(109)+1), KEEP(17), & MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDDO ELSE CALL MPI_SEND( id%PIVNUL_LIST(1), KEEP(109), MPI_INTEGER, & MASTER,ZERO_PIV, id%COMM, IERR) CALL MPI_RECV( KEEP(220), 1, MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_REAL, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_REAL, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN DO I = 1, id%INFOG(28) CALL CMUMPS_UPDATEDETER( & cmplx(id%ROWSCA(id%PIVNUL_LIST(I)),0.0E0, & kind=kind(0.0E0)), & id%DKEEP(6), KEEP(259)) CALL CMUMPS_UPDATEDETER( & cmplx(id%COLSCA(id%PIVNUL_LIST(I)),0.0E0, & kind=kind(0.0E0)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) id%DKEEP(7)=-id%DKEEP(7) ENDIF C C 3/ Perform a reduction C CALL CMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL CMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, C id%STEP: used as workspace of size N still C allocated on master; restored on exit & id%STEP(1), & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see CMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN C ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) c IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99979) RINFOG(13) WRITE(MPG,99977) INFOG(34) ENDIF END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free DBLARR (as in end_driver.F) C in case an error occurred after allocating C DBLARR and before freeing it above. IF (id%KEEP(46).EQ.1 .AND. & id%KEEP(55).NE.0 .AND. & id%MYID.EQ.MASTER .AND. & id%KEEP(52) .EQ. 0) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL CMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL CMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in CMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL CMUMPS_OOC_END_FACTO(id,IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL CMUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO C 517 CONTINUE C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 160 FORMAT( & /' Elapsed time to reformat/distribute matrix =',F12.4) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' Memory allowed (MB -- 0: N/A ) =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =',F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =',F12.4) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =',I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =',F16.8) 99979 FORMAT( ' RINFOG(12) Determinant (imaginary part) =',F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =',I16) 99981 FORMAT( ' INFOG(14) Number of memory compress =',I16) 99982 FORMAT( ' INFOG(13) Number of delayed pivots =',I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =',I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) Estimated deficiency =',I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG(2) Operations in node assembly =',1PD10.3/ & ' ------(3) Operations in node elimination =',1PD10.3/ & ' ICNTL (8) Scaling effectively used =',I16/ & ' INFOG (9) Real space for factors =',I16/ & ' INFOG(10) Integer space for factors =',I16/ & ' INFOG(11) Maximum front size =',I16/ & ' INFOG(29) Number of entries in factors =',I16) 99985 FORMAT( ' INFOG(12) Number of off diagonal pivots =',I16) 99986 FORMAT( ' INFOG(25) Number of tiny pivots(static) =',I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =',I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =',I16) END SUBROUTINE CMUMPS_FAC_DRIVER C SUBROUTINE CMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE CMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE CMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER REAL LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = real(VAL)/real(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_REAL, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE CMUMPS_AVGMAX_STAT8 C SUBROUTINE CMUMPS_EXTRACT_SCHUR_REDRHS(id) USE CMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in root%RHS_CNTR_MASTER_ROOT. C TYPE(CMUMPS_STRUC) :: id C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ================================= C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from id%root%RHS_CNTR_MASTER_ROOT C ================================= IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL ccopy(SIZE_SCHUR, & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free root%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL CMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C ----------------------------------------- BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL ccopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL ccopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_COMPLEX, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_EXTRACT_SCHUR_REDRHS MUMPS_5.4.1/src/fac_asm_build_sort_index_ELT_m.F0000664000175000017500000003630314102210475021653 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_BUILD_SORT_INDEX_ELT_M CONTAINS SUBROUTINE MUMPS_ELT_BUILD_SORT( & NUMELT, LIST_ELT, & MYID, INODE, N, IOLDPS, & HF, NFRONT, NFRONT_EFF, PERM, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, NELT, & IW, LIW, & INTARR, LINTARR, ITLOC, & FILS, FRERE_STEPS, & KEEP, SON_LEVEL2, NIV1, IFLAG, & DAD, PROCNODE_STEPS, SLAVEF, & FRT_PTR, FRT_ELT, Pos_First_NUMORG, & SONROWS_PER_ROW, LSONROWS_PER_ROW & ) IMPLICIT NONE INTEGER NELT, INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IFSON, MYID, IFLAG, & NUMELT INTEGER KEEP(500) INTEGER LIST_ELT(*) INTEGER(8), INTENT(IN) :: PTRAIW(NELT+1) INTEGER STEP(N), PIMASTER(KEEP(28)), PTRIST(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), & PERM(N) INTEGER, TARGET :: IW(LIW) INTEGER, INTENT(IN), TARGET :: IWPOSCB INTEGER, INTENT(IN) :: IWPOS INTEGER(8), INTENT(IN) :: LINTARR INTEGER :: INTARR(LINTARR) LOGICAL, intent(in) :: NIV1 LOGICAL, intent(out) :: SON_LEVEL2 INTEGER, intent(out) :: NFRONT_EFF INTEGER, intent(in) :: DAD (KEEP(28)) INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(out) :: Pos_First_NUMORG INTEGER, intent(in) :: LSONROWS_PER_ROW INTEGER, intent(out) :: SONROWS_PER_ROW(LSONROWS_PER_ROW) INTEGER NEWEL, IOLDP2, INEW, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, IBROT, & I, ILOC, NEWEL_SAVE, NEWEL1_SAVE, & LAST_J_ASS, JMIN, MIN_PERM INTEGER :: K, K1, K2, K3, KK INTEGER(8) :: JJ8, J18, J28 LOGICAL LEVEL1_SON INTEGER INBPROCFILS_SON INTEGER TYPESPLIT INTEGER ELTI, NUMELT_IBROT INCLUDE 'mumps_headers.h' INTEGER, POINTER :: SON_IWPOSCB INTEGER, POINTER, DIMENSION(:) :: SON_IW INTEGER, POINTER, DIMENSION(:) :: PTTRI, PTLAST INTEGER :: LREQ, allocok INTEGER, ALLOCATABLE, TARGET :: TMP_ALLOC_ARRAY(:) INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE EXTERNAL MUMPS_TYPESPLIT, MUMPS_TYPENODE IW(IOLDPS+XXNBPR) = 0 Pos_First_NUMORG = 1 TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) SON_LEVEL2 = .FALSE. IOLDP2 = IOLDPS + HF - 1 ICT11 = IOLDP2 + NFRONT NFRONT_EFF = NASS1 NTOTFS = 0 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN K2 = PIMASTER(STEP(IFSON)) LSTK = IW(K2 +KEEP(IXSZ)) NELIM = IW(K2 + 1+KEEP(IXSZ)) NPIVS = IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_ELT_BUILD_SORT ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ENDIF I= MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFSON)),KEEP(199)) J= MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(IFSON)), & KEEP(199)) IF (LEVEL1_SON.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_ELT_BUILD_SORT ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ENDIF SON_IW => IW SON_IWPOSCB => IWPOSCB IF (K2 .GT. SON_IWPOSCB) THEN INBPROCFILS_SON = K2 + XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(IFSON))+XXNBPR ENDIF IW(IOLDPS+XXNBPR)=NSLSON SON_IW(INBPROCFILS_SON) = NSLSON SONROWS_PER_ROW(1:NFRONT-NASS1) = 1 IF ( K2.GT. IWPOSCB ) THEN NROWS = IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 IF (NELIM.GT.0) THEN DO KK=K1,K3 NTOTFS = NTOTFS + 1 JT1 = IW(KK) IW(ICT11 + NTOTFS) = JT1 IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(KK - ITRANS) ENDDO ENDIF DO KK =K3+1, K2 NTOTFS = NTOTFS + 1 JT1 = IW(KK) ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 DO JJ8=J18,J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDDO Pos_First_NUMORG = ITLOC(INODE) K1 = IOLDPS+HF DO KK=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(KK)) = 0 ENDDO RETURN ENDIF LREQ= 2*NUMSTK IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN ALLOCATE(TMP_ALLOC_ARRAY(LREQ), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF PTTRI => TMP_ALLOC_ARRAY(1:NUMSTK) PTLAST => TMP_ALLOC_ARRAY(NUMSTK+1:LREQ) ELSE PTTRI => IW(IWPOS:IWPOS+NUMSTK-1) PTLAST => IW(IWPOS+NUMSTK:IWPOS+LREQ) ENDIF IF (.NOT. NIV1) SONROWS_PER_ROW(1:NFRONT-NASS1) = 0 IN = INODE INEW = IOLDPS + HF INEW1 = 1 DO WHILE (IN.GT.0) ITLOC(IN) = INEW1 IW(INEW) = IN IW(INEW+NFRONT) = IN INEW1 = INEW1 + 1 INEW = INEW + 1 IN = FILS(IN) END DO NTOTFS = NUMORG IF (NUMSTK .NE. 0) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB LSTK = SON_IW(K2 +KEEP(IXSZ)) NELIM = SON_IW(K2 + 1+KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (K2 .GT. SON_IWPOSCB) THEN INBPROCFILS_SON = K2+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ENDIF IF (NIV1) THEN SON_IW(INBPROCFILS_SON) = NSLSON IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + NSLSON ELSE IF (LEVEL1_SON) THEN SON_IW(INBPROCFILS_SON) = 1 ELSE SON_IW(INBPROCFILS_SON) = NSLSON ENDIF IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + & SON_IW(INBPROCFILS_SON) ENDIF IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 - KEEP(253) K3 = K1 + NELIM - 1 IF (NELIM .NE. 0) THEN DO KK = K1, K3 NTOTFS = NTOTFS + 1 JT1 = SON_IW(KK) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS SON_IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = SON_IW(KK - ITRANS) ENDDO ENDIF PTTRI(IELL) = K2+1 PTLAST(IELL) = K2 K1 = K3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO KK = K1, K2 J = SON_IW(KK) IF (ITLOC(J) .EQ. 0) THEN PTTRI(IELL) = KK EXIT ENDIF ENDDO ELSE DO KK = K1, K2 SON_IW(KK) = ITLOC(SON_IW(KK)) ENDDO DO KK=K2+1, K2+KEEP(253) SON_IW(KK)=NFRONT-KEEP(253)+KK-K2 ENDDO ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF IF (NFRONT-KEEP(253).EQ.NASS1) GOTO 500 MIN_PERM = N + 1 JMIN = -1 DO IELL = 1, NUMSTK SON_IW => IW ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( SON_IW( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( ILOC ) MIN_PERM = PERM( JMIN ) END IF END IF END DO NEWEL = IOLDP2 + NASS1 + NFRONT DO WHILE ( MIN_PERM .NE. N + 1 ) NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = JMIN ITLOC( JMIN ) = NFRONT_EFF LAST_J_ASS = JMIN MIN_PERM = N + 1 DO IELL = 1, NUMSTK SON_IW => IW IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( SON_IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) & PTTRI( IELL ) = PTTRI( IELL ) + 1 ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( PERM(SON_IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( PTTRI( IELL ) ) MIN_PERM = PERM( JMIN ) END IF END IF END DO END DO NEWEL_SAVE = NEWEL NEWEL1_SAVE = NFRONT_EFF IF (NEWEL1_SAVE.LT.NFRONT - KEEP(253)) THEN DO IELL = 1,NUMELT ELTI = LIST_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 DO JJ8=J18,J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF ( (TYPESPLIT.EQ.4).AND. & (NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.6 & ) & ) IBROT = DAD(STEP(IBROT)) NUMELT_IBROT = FRT_PTR(IBROT+1) - FRT_PTR(IBROT) IF (NUMELT_IBROT.EQ.0) CYCLE DO IELL = FRT_PTR(IBROT), FRT_PTR(IBROT+1) ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1 DO JJ8 = J18, J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT ENDDO IF (NFRONT_EFF.NE.NFRONT-KEEP(253) .AND. & .NOT. (KEEP(376).EQ.1 .AND. KEEP(79) .GE.1)) THEN write(6,*) MYID, ': INODE', INODE, ' of type 4 ', & ' not yet fully assembled ', & ' NFRONT_EFF, NFRONT =', NFRONT_EFF, NFRONT CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN DO KK=NASS1+1, NFRONT_EFF IW( IOLDP2+KK ) = IW( ICT11+KK ) ENDDO ELSE CALL MUMPS_SORT( N, PERM, & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) CALL MUMPS_SORTED_MERGE( N, NASS1, PERM, ITLOC, & IW( NEWEL_SAVE + 1), NFRONT_EFF - NEWEL1_SAVE, & IW( ICT11 + NASS1 + 1 ), NEWEL1_SAVE - NASS1, & IW( IOLDP2 + NASS1 + 1 ), NFRONT_EFF - NASS1 ) DO KK = NASS1+1, NFRONT_EFF IW(ICT11 + KK) = IW(IOLDP2+KK) ENDDO END IF 500 CONTINUE IF ( KEEP(253).GT.0) THEN IP1 = IOLDPS + HF + NFRONT_EFF IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF DO I= 1, KEEP(253) IW(IP1+I-1) = N+I IW(IP2+I-1) = N+I ITLOC(N+I) = NFRONT_EFF + I ENDDO NFRONT_EFF = NFRONT_EFF + KEEP(253) ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN IP1 = IOLDPS + NFRONT + HF IP2 = IOLDPS + NFRONT_EFF + HF DO I=1, NFRONT_EFF IW(IP2+I-1)=IW(IP1+I-1) ENDDO ELSE IF (NFRONT .LT. NFRONT_EFF) THEN WRITE(*,*) "Internal error in MUMPS_ELT_BUILD_SORT", & NFRONT, NFRONT_EFF IFLAG = -53 GOTO 800 ENDIF IF ( (NUMSTK .NE.0) & .AND. (NFRONT-KEEP(253).GT.NASS1 ) & ) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB LSTK = SON_IW(K2+KEEP(IXSZ)) NELIM = SON_IW(K2 + 1 +KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3 +KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5 +KEEP(IXSZ)) LEVEL1_SON = (NSLSON .EQ. 0) NCOLS = NPIVS + LSTK NROWS = NCOLS IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ENDIF HS = NSLSON + 6 +KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 K1 = K3 + 1 IF (NFRONT-KEEP(253).GT.NASS1) THEN DO KK = K1, K2 J = SON_IW(KK) SON_IW(KK) = ITLOC(J) IF (NIV1 .AND. NSLSON.EQ.0) THEN ELSE IF (SON_IW(KK) .LE. NASS1 .OR. NIV1) THEN ELSE SONROWS_PER_ROW(SON_IW(KK)-NASS1) = & SONROWS_PER_ROW(SON_IW(KK)-NASS1) + 1 ENDIF ENDIF ENDDO ELSE IF (.not. NIV1) THEN WRITE(*,*) "Internal error 1 in MUMPS_ELT_BUILD_SORT" CALL MUMPS_ABORT() ENDIF IF (.not.LEVEL1_SON) THEN ENDIF ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF DO IELL=1,NUMELT ELTI = LIST_ELT(IELL) J18 = PTRAIW(ELTI) J28 = PTRAIW(ELTI+1)-1 DO JJ8=J18,J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDDO K1 = IOLDPS + HF + NUMORG K2 = K1 + NFRONT_EFF - 1 + NASS DO K = K1, K2 I = IW(K) ITLOC(I) = 0 ENDDO 800 CONTINUE IF (allocated(TMP_ALLOC_ARRAY)) DEALLOCATE(TMP_ALLOC_ARRAY) RETURN END SUBROUTINE MUMPS_ELT_BUILD_SORT END MODULE MUMPS_BUILD_SORT_INDEX_ELT_M MUMPS_5.4.1/src/somp_tps_m.F0000664000175000017500000000101714102210521015767 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE SMUMPS_TPS_M_RETURN MUMPS_5.4.1/src/zfac_front_aux.F0000664000175000017500000025064014102210525016633 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC_FRONT_AUX_M CONTAINS SUBROUTINE ZMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV,NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL,KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U,MAXFROMN,IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR &) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER NFRONT,NASS,LIW,INOPV INTEGER(8) :: LA INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION :: DKEEP(230) DOUBLE PRECISION UU, SEUIL COMPLEX(kind=8) A(LA) INTEGER IW(LIW) DOUBLE PRECISION, intent(in) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR DOUBLE PRECISION AMROW DOUBLE PRECISION RMAX COMPLEX(kind=8) SWOP INTEGER(8) :: APOS, POSELT INTEGER(8) :: J1, J2, J3_8, JJ, IDIAG INTEGER(8) :: J1_ini INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER NPIV,IPIV,IPIV_SHIFT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER J, J3 INTEGER NPIVP1,JMAX,ISW,ISWPS1 INTEGER ISWPS2,KSW,XSIZE INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER ISHIFT, K206 INTEGER ZMUMPS_IXAMAX INCLUDE 'mumps_headers.h' INTRINSIC max DOUBLE PRECISION, PARAMETER :: RZERO = 0.0D0 #if defined(_OPENMP) INTEGER :: NOMP, CHUNK, K360 K360 = KEEP(360) NOMP = OMP_GET_MAX_THREADS() #endif NFRONT8 = int(NFRONT,8) INOPV = 0 XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 K206 = KEEP(206) IF ((KEEP(50).NE.1).AND.OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE) & +KEEP(IXSZ), & IW, LIW) CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF ISHIFT = 0 IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.NASS) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMN_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*MAXFROMN .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX)) ) THEN ISHIFT = 0 ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMN_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT=NPIVP1+ISHIFT,NASS+ISHIFT IF (IPIV_SHIFT .LE. NASS) THEN IPIV=IPIV_SHIFT ELSE IPIV=IPIV_SHIFT-NASS-1+NPIVP1 ENDIF APOS = POSELT + NFRONT8*int(NPIV,8) + int(IPIV-1,8) JMAX = 1 AMROW = RZERO J1 = APOS J3 = NASS -NPIV JMAX = ZMUMPS_IXAMAX(J3,A(J1),NFRONT,KEEP(360)) JJ = J1 + int(JMAX-1,8)*NFRONT8 AMROW = abs(A(JJ)) RMAX = AMROW J1 = APOS + int(NASS-NPIV,8) * NFRONT8 J3 = NFRONT - NASS - KEEP(253)-NVSCHUR IF (IS_MAXFROMN_AVAIL) THEN RMAX = max(MAXFROMN,RMAX) IS_MAXFROMN_AVAIL = .FALSE. ELSE IF (J3.EQ.0) GOTO 370 IF (KEEP(351).EQ.1) THEN J1_ini = J1 !$ CHUNK = max(K360/2,(J3+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(J1_ini,NFRONT8,J3) !$OMP& REDUCTION(max:RMAX) IF (J3.GE.K360) DO J=1,J3 RMAX = max(abs(A(J1_ini + int(J-1,8) * NFRONT8)), & RMAX) END DO !$OMP END PARALLEL DO ELSE DO J=1,J3 RMAX = max(abs(A(J1)), RMAX) J1 = J1 + NFRONT8 END DO ENDIF END IF 370 IF (RMAX.LE.tiny(RMAX)) GO TO 460 IDIAG = APOS + int(IPIV - NPIVP1,8)*NFRONT8 IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS + int(JMAX - 1,8) * NFRONT8 )), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( & A(APOS + int(JMAX - 1,8) * NFRONT8 ), & DET_MANTW, DET_EXPW ) ENDIF IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ.0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8) J3_8 = POSELT + int(IPIV-1,8) DO J= 1,NFRONT SWOP = A(J1) A(J1) = A(J3_8) A(J3_8) = SWOP J1 = J1 + NFRONT8 J3_8 = J3_8 + NFRONT8 END DO ISWPS1 = IOLDPS + 5 + NPIVP1 + NFRONT + XSIZE ISWPS2 = IOLDPS + 5 + IPIV + NFRONT + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = -DET_SIGNW J1 = POSELT + int(NPIV,8) * NFRONT8 J2 = POSELT + int(NPIV + JMAX - 1,8) * NFRONT8 DO KSW=1,NFRONT SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + 1_8 J2 = J2 + 1_8 END DO ISWPS1 = IOLDPS + 5 + NPIV + 1 + XSIZE ISWPS2 = IOLDPS + 5 + NPIV + JMAX + XSIZE ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE INOPV = 1 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE IS_MAXFROMN_AVAIL = .FALSE. RETURN END SUBROUTINE ZMUMPS_FAC_H SUBROUTINE ZMUMPS_FAC_M(IBEG_BLOCK, & NFRONT,NASS,N,INODE,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,LKJIB,LKJIT,XSIZE) IMPLICIT NONE INTEGER NFRONT,NASS,N,LIW,INODE,IFINB,LKJIB,IBEG_BLOCK INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) COMPLEX(kind=8) VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS INTEGER LKJIT, XSIZE COMPLEX(kind=8) ONE, ALPHA INTEGER NPIV,JROW2 INTEGER NEL2,NPIVP1,KROW,NEL INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NFRONT8= int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 IFINB = 0 IF (IW(IOLDPS+3+XSIZE).LE.0) THEN IF (NASS.LT.LKJIT) THEN IW(IOLDPS+3+XSIZE) = NASS ELSE IW(IOLDPS+3+XSIZE) = min0(NASS,LKJIB) ENDIF ENDIF JROW2 = IW(IOLDPS+3+XSIZE) NEL2 = JROW2 - NPIVP1 IF (NEL2.EQ.0) THEN IF (JROW2.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 IW(IOLDPS+3+XSIZE) = min0(JROW2+LKJIB,NASS) IBEG_BLOCK = NPIVP1+1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 CALL zgeru(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_M SUBROUTINE ZMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP,MAXFROMN,IS_MAXFROMN_AVAIL,NVSCHUR) !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER NFRONT,NASS,LIW,IFINB INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) COMPLEX(kind=8) ALPHA,VALPIV INTEGER(8) :: APOS, POSELT, UUPOS, LPOS, IRWPOS INTEGER(8) :: NFRONT8 INTEGER IOLDPS,NPIV,XSIZE INTEGER, intent(in) :: KEEP(500) DOUBLE PRECISION, intent(inout) :: MAXFROMN LOGICAL, intent(inout) :: IS_MAXFROMN_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER NEL,IROW,NEL2,JCOL,NELMAXM INTEGER NPIVP1 COMPLEX(kind=8), PARAMETER :: ONE=(1.0D0,0.0D0) #if defined(_OPENMP) LOGICAL:: OMP_FLAG INTEGER:: NOMP, K360, CHUNK NOMP = OMP_GET_MAX_THREADS() K360 = KEEP(360) #endif NFRONT8=int(NFRONT,8) NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 NEL = NFRONT - NPIVP1 NELMAXM= NEL -KEEP(253)-NVSCHUR NEL2 = NASS - NPIVP1 IFINB = 0 IF (NPIVP1.EQ.NASS) IFINB = 1 APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) #if defined(_OPENMP) OMP_FLAG = .FALSE. CHUNK = max(NEL,1) IF (NOMP.GT.1) THEN IF (NEL.LT.K360) THEN IF (NEL*NEL2.GE.KEEP(361)) THEN OMP_FLAG = .TRUE. CHUNK = max(20, (NEL+NOMP-1)/NOMP) ENDIF ELSE OMP_FLAG = .TRUE. CHUNK = max(K360/2, (NEL+NOMP-1)/NOMP) ENDIF ENDIF #endif IF (KEEP(351).EQ.2) THEN MAXFROMN = 0.0D0 IF (NEL2 > 0) THEN IS_MAXFROMN_AVAIL = .TRUE. ENDIF !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& REDUCTION(max:MAXFROMN) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 IF (NEL2 > 0) THEN A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IF (IROW.LE.NELMAXM) & MAXFROMN=max(MAXFROMN, abs(A(IRWPOS))) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 DO JCOL = 2, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDIF END DO !$OMP END PARALLEL DO ELSE !$OMP PARALLEL DO schedule(static, CHUNK) !$OMP& FIRSTPRIVATE(APOS,NFRONT8,VALPIV,NEL,NEL2) !$OMP& PRIVATE(LPOS, UUPOS, IRWPOS, ALPHA, JCOL) IF(OMP_FLAG) DO IROW = 1, NEL LPOS = APOS + NFRONT8*int(IROW,8) A(LPOS) = A(LPOS)*VALPIV ALPHA = -A(LPOS) IRWPOS = LPOS + 1_8 UUPOS = APOS + 1_8 DO JCOL = 1, NEL2 A(IRWPOS) = A(IRWPOS) + ALPHA*A(UUPOS) IRWPOS = IRWPOS+1_8 UUPOS = UUPOS+1_8 ENDDO ENDDO !$OMP END PARALLEL DO ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_N SUBROUTINE ZMUMPS_FAC_PT_SETLOCK427( K427_OUT, K427, & K405, K222, NEL1, NASS ) INTEGER, INTENT(IN) :: K427, K405, K222, NEL1, NASS INTEGER, INTENT(OUT) :: K427_OUT K427_OUT = K427 IF ( K405 .EQ. 1 ) THEN IF ( K427_OUT .GT. 0 ) K427_OUT = 0 IF ( K427_OUT .LT. 0 ) K427_OUT = -1 ENDIF IF ( K427_OUT .GT. 99 ) K427_OUT = 0 IF ( K427_OUT .LT. -100 ) K427_OUT = -1 RETURN END SUBROUTINE ZMUMPS_FAC_PT_SETLOCK427 SUBROUTINE ZMUMPS_FAC_P(A,LA,NFRONT, & NPIV,NASS,POSELT,CALL_UTRSM, KEEP, INODE, & CALL_OOC, IWFAC, LIWFAC, LAFAC, MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG ) USE ZMUMPS_OOC, ONLY : IO_BLOCK, TYPEF_BOTH_LU, & ZMUMPS_OOC_IO_LU_PANEL USE MUMPS_OOC_COMMON, ONLY : STRAT_TRY_WRITE IMPLICIT NONE INTEGER(8) :: LA,POSELT,LAFAC COMPLEX(kind=8) A(LA) INTEGER NFRONT, NPIV, NASS LOGICAL, INTENT(IN) :: CALL_UTRSM INTEGER, INTENT(INOUT) :: IFLAG LOGICAL, INTENT(IN) :: CALL_OOC INTEGER LIWFAC, MYID, & LNextPiv2beWritten, UNextPiv2beWritten INTEGER IWFAC(LIWFAC) TYPE(IO_BLOCK) :: MonBloc INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS INTEGER NEL1, NEL11, IFLAG_OOC INTEGER :: INODE COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) INCLUDE 'mumps_headers.h' NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV LPOS2 = POSELT + int(NASS,8)*int(NFRONT,8) LPOS = LPOS2 + int(NPIV,8) LPOS1 = POSELT + int(NPIV,8) UPOS = POSELT + int(NASS,8) IF ( CALL_UTRSM ) THEN CALL ztrsm('R', 'U', 'N', 'U', NEL1, NPIV, ONE, & A(POSELT), NFRONT, A(UPOS), NFRONT) ENDIF CALL ztrsm('L','L','N','N',NPIV,NEL1,ONE,A(POSELT),NFRONT, & A(LPOS2),NFRONT) IF (CALL_OOC) THEN CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT_TRY_WRITE, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IWFAC, LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, & .FALSE. ) IF (IFLAG_OOC .LT. 0) THEN IFLAG = IFLAG_OOC GOTO 500 ENDIF ENDIF CALL zgemm('N','N',NEL11,NEL1,NPIV,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) IF ((CALL_UTRSM).AND.(NASS-NPIV.GT.0)) THEN LPOS2 = POSELT + int(NPIV,8)*int(NFRONT,8) LPOS = LPOS2 + int(NASS,8) CALL zgemm('N','N',NEL1,NASS-NPIV,NPIV,ALPHA,A(UPOS), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_P SUBROUTINE ZMUMPS_FAC_T(A,LA,NPIVB,NFRONT, & NPIV,NASS,POSELT) IMPLICIT NONE INTEGER NPIVB,NASS INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER(8) :: APOS, POSELT INTEGER NFRONT, NPIV, NASSL INTEGER(8) :: LPOS, LPOS1, LPOS2 INTEGER NEL1, NEL11, NPIVE COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NEL1 = NFRONT - NASS NEL11 = NFRONT - NPIV NPIVE = NPIV - NPIVB NASSL = NASS - NPIVB APOS = POSELT + int(NPIVB,8)*int(NFRONT,8) & + int(NPIVB,8) LPOS2 = APOS + int(NASSL,8) CALL ztrsm('R','U','N','U',NEL1,NPIVE,ONE,A(APOS),NFRONT, & A(LPOS2),NFRONT) LPOS = LPOS2 + int(NFRONT,8)*int(NPIVE,8) LPOS1 = APOS + int(NFRONT,8)*int(NPIVE,8) CALL zgemm('N','N',NEL1,NEL11,NPIVE,ALPHA,A(LPOS2), & NFRONT,A(LPOS1),NFRONT,ONE,A(LPOS),NFRONT) RETURN END SUBROUTINE ZMUMPS_FAC_T SUBROUTINE ZMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, NPIV, & NFRONT, LAST_ROW, LAST_COL, A, LA, POSELT, & FIRST_COL, CALL_LTRSM, CALL_UTRSM, CALL_GEMM, & WITH_COMM_THREAD, LR_ACTIVATED & ) !$ USE OMP_LIB #if defined(_OPENMP) USE ZMUMPS_BUF #endif IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: NPIV, NFRONT, LAST_ROW, LAST_COL INTEGER, intent(in) :: FIRST_COL INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: CALL_LTRSM, CALL_UTRSM, CALL_GEMM LOGICAL, intent(in) :: WITH_COMM_THREAD, LR_ACTIVATED INTEGER(8) :: NFRONT8, LPOSN, LPOS2N INTEGER(8) :: LPOS, LPOS1, LPOS2, UPOS, POSELT_LOCAL INTEGER :: NELIM, LKJIW, NEL1, NEL11, UTRSM_NCOLS COMPLEX(kind=8) ALPHA, ONE PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) !$ INTEGER :: NOMP !$ LOGICAL :: TRSM_GEMM_FINISHED !$ LOGICAL :: SAVE_NESTED, SAVE_DYNAMIC NFRONT8= int(NFRONT,8) NELIM = IEND_BLOCK - NPIV NEL1 = LAST_ROW - IEND_BLOCK IF ( NEL1 < 0 ) THEN WRITE(*,*) & "Internal error 1 in ZMUMPS_FAC_SQ,IEND_BLOCK>LAST_ROW", & IEND_BLOCK, LAST_ROW CALL MUMPS_ABORT() ENDIF LKJIW = NPIV - IBEG_BLOCK + 1 NEL11 = LAST_COL - NPIV LPOS2 = POSELT + int(IEND_BLOCK,8)*NFRONT8 + int(IBEG_BLOCK-1,8) UTRSM_NCOLS = LAST_COL - FIRST_COL UPOS = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 + int(FIRST_COL,8) POSELT_LOCAL = POSELT + int(IBEG_BLOCK-1,8)*NFRONT8 & + int(IBEG_BLOCK-1,8) IF ((NEL1.NE.0).AND.(LKJIW.NE.0)) THEN IF (WITH_COMM_THREAD .EQV. .FALSE.) THEN IF (CALL_LTRSM) THEN CALL ztrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ztrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL zgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL zgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) ENDIF ELSE !$ NOMP = OMP_GET_MAX_THREADS() !$ CALL OMP_SET_NUM_THREADS(2) !$ SAVE_NESTED = OMP_GET_NESTED() !$ SAVE_DYNAMIC = OMP_GET_DYNAMIC() !$ CALL OMP_SET_NESTED(.TRUE.) !$ CALL OMP_SET_DYNAMIC(.FALSE.) !$ TRSM_GEMM_FINISHED = .FALSE. !$OMP PARALLEL SHARED(TRSM_GEMM_FINISHED) !$ IF (OMP_GET_THREAD_NUM() .EQ. 1) THEN #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif IF (CALL_LTRSM) THEN CALL ztrsm('L','L','N','N',LKJIW,NEL1,ONE, & A(POSELT_LOCAL),NFRONT, & A(LPOS2),NFRONT) ENDIF IF (CALL_UTRSM) THEN CALL ztrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL zgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF IF (CALL_GEMM) THEN LPOS = LPOS2 + int(LKJIW,8) LPOS1 = POSELT_LOCAL + int(LKJIW,8) CALL zgemm('N','N',NEL11,NEL1,LKJIW,ALPHA,A(LPOS1), & NFRONT,A(LPOS2),NFRONT,ONE,A(LPOS),NFRONT) END IF !$ TRSM_GEMM_FINISHED = .TRUE. !$ ELSE !$ DO WHILE (.NOT. TRSM_GEMM_FINISHED) !$ CALL ZMUMPS_BUF_TEST() !$ CALL MUMPS_USLEEP(10000) !$ END DO !$ END IF !$OMP END PARALLEL !$ CALL OMP_SET_NESTED(SAVE_NESTED) !$ CALL OMP_SET_DYNAMIC(SAVE_DYNAMIC) #if defined(WORKAROUNDINTELILP64OPENMPLIMITATION) !$ CALL OMP_SET_NUM_THREADS(int(NOMP,4)) #else !$ CALL OMP_SET_NUM_THREADS(NOMP) #endif ENDIF ELSE IF (CALL_UTRSM.AND.UTRSM_NCOLS.NE.0) THEN CALL ztrsm('R','U','N','U',UTRSM_NCOLS,LKJIW,ONE, & A(POSELT_LOCAL),NFRONT, & A(UPOS),NFRONT) LPOS2N = POSELT + int(NPIV,8)*NFRONT8 + int(IBEG_BLOCK-1,8) LPOSN = POSELT + int(NPIV,8)*NFRONT8 + int(FIRST_COL,8) CALL zgemm('N','N',UTRSM_NCOLS,NELIM, & LKJIW,ALPHA,A(UPOS),NFRONT,A(LPOS2N), & NFRONT,ONE,A(LPOSN),NFRONT) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_SQ SUBROUTINE ZMUMPS_FAC_MQ(IBEG_BLOCK,IEND_BLOCK, & NFRONT, NASS, NPIV, LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK, NFRONT, & NASS, NPIV, LAST_COL INTEGER, intent(out) :: IFINB INTEGER(8), intent(in) :: LA, POSELT COMPLEX(kind=8), intent(inout) :: A(LA) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8) :: VALPIV INTEGER(8) :: APOS, UUPOS, LPOS INTEGER(8) :: NFRONT8 COMPLEX(kind=8) :: ONE, ALPHA INTEGER :: NEL2,NPIVP1,KROW,NEL PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) NFRONT8= int(NFRONT,8) NPIVP1 = NPIV + 1 NEL = LAST_COL - NPIVP1 IFINB = 0 NEL2 = IEND_BLOCK - NPIVP1 IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ELSE APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + NFRONT8 DO 541 KROW = 1,NEL2 A(LPOS) = A(LPOS)*VALPIV LPOS = LPOS + NFRONT8 541 CONTINUE LPOS = APOS + NFRONT8 UUPOS = APOS + 1_8 #if defined(MUMPS_USE_BLAS2) CALL zgeru(NEL,NEL2,ALPHA,A(UUPOS),1,A(LPOS),NFRONT, & A(LPOS+1_8),NFRONT) #else CALL zgemm('N','N',NEL,NEL2,1,ALPHA,A(UUPOS),NEL, & A(LPOS),NFRONT,ONE,A(LPOS+1_8),NFRONT) #endif ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ SUBROUTINE ZMUMPS_FAC_FR_UPDATE_CBROWS( INODE, NFRONT, NASS, & CALL_UTRSM, A, LA, LAFAC, POSELT, IW, LIW, IOLDPS, & MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR) USE ZMUMPS_OOC, ONLY: IO_BLOCK IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS, & LIW, MYID, XSIZE, IOLDPS, LIWFAC INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(inout) :: NOFFW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER, intent(inout) :: PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & IFLAG LOGICAL, intent(in) :: CALL_UTRSM INTEGER, intent(inout) :: IW(LIW) COMPLEX(kind=8), intent(inout) :: A(LA) DOUBLE PRECISION, intent(in) :: SEUIL, UU, DKEEP(230) INTEGER, intent(in) :: KEEP( 500 ) INTEGER(8), intent(inout) :: LAFAC INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NVSCHUR TYPE(IO_BLOCK), intent(inout) :: MonBloc LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER :: NPIV, NEL1, IBEG_BLOCK, IFINB, INOPV INTEGER Inextpiv DOUBLE PRECISION :: MAXFROMN LOGICAL :: IS_MAXFROMN_AVAIL NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF IF ((NPIV.GT.0).AND.(NEL1.GT.0)) THEN IF (OOC_EFFECTIVE_ON_FRONT) THEN MonBloc%LastPiv = NPIV ENDIF CALL ZMUMPS_FAC_P(A,LA,NFRONT, NPIV, NASS, POSELT, & CALL_UTRSM, KEEP, INODE, & OOC_EFFECTIVE_ON_FRONT, IW(IOLDPS), & LIWFAC, LAFAC, & MonBloc, MYID, KEEP8, & LNextPiv2beWritten, UNextPiv2beWritten, & IFLAG) ENDIF NPIV = IW(IOLDPS+1+XSIZE) IBEG_BLOCK = NPIV IF (NASS.EQ.NPIV) GOTO 500 IS_MAXFROMN_AVAIL = .FALSE. 120 CALL ZMUMPS_FAC_H(NFRONT,NASS,IW,LIW,A,LA, & INOPV, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IOLDPS,POSELT,UU,SEUIL, & KEEP, KEEP8, DKEEP, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, MAXFROMN, IS_MAXFROMN_AVAIL, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, NVSCHUR & ) IF (INOPV.NE.1) THEN CALL ZMUMPS_FAC_N(NFRONT,NASS,IW,LIW,A,LA, & IOLDPS,POSELT,IFINB,XSIZE, & KEEP, MAXFROMN, IS_MAXFROMN_AVAIL, & NVSCHUR) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) GOTO 120 ENDIF NPIV = IW(IOLDPS+1+XSIZE) NEL1 = NFRONT - NASS IF ((NPIV.LE.IBEG_BLOCK).OR.(NEL1.EQ.0)) GO TO 500 CALL ZMUMPS_FAC_T(A,LA,IBEG_BLOCK, & NFRONT,NPIV,NASS,POSELT) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_FR_UPDATE_CBROWS SUBROUTINE ZMUMPS_FAC_I(NFRONT,NASS,LAST_ROW, & IBEG_BLOCK, IEND_BLOCK, & N,INODE,IW,LIW,A,LA, & INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL,KEEP,KEEP8, & DKEEP,PIVNUL_LIST,LPN_LIST, & & PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR, PARPIV_T1, & TIPIV & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(inout), OPTIONAL :: TIPIV(:) INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: NFRONT,NASS,N,LIW,INODE,LAST_ROW INTEGER, intent(inout) :: IFLAG,INOPV,NOFFW, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW DOUBLE PRECISION, intent(in) :: UU, SEUIL INTEGER, intent(inout) :: IW(LIW) INTEGER, intent(in) :: IOLDPS INTEGER(8), intent(in) :: POSELT INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER, intent(in) :: LPN_LIST INTEGER, intent(inout) :: PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U INTEGER, intent(in) :: PIVOT_OPTION, IEND_BLR LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 INCLUDE 'mumps_headers.h' COMPLEX(kind=8) SWOP INTEGER XSIZE INTEGER(8) :: APOS, IDIAG INTEGER(8) :: J1, J2, JJ, J3 INTEGER(8) :: NFRONT8 INTEGER ILOC COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) DOUBLE PRECISION RZERO, RMAX, AMROW, MAX_PREV_in_PARPIV INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION :: RMAX_NORELAX DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL INTEGER NPIV,IPIV, LRLOC INTEGER NPIVP1,JMAX,J,ISW,ISWPS1 INTEGER ISWPS2,KSW, HF, IPIVNUL INTEGER ZMUMPS_IXAMAX INTEGER :: ISHIFT, K206 INTEGER :: IPIV_SHIFT,IPIV_END INTRINSIC max DATA RZERO /0.0D0/ #if defined(_OPENMP) INTEGER :: NOMP,CHUNK,K361 #endif INTEGER I_PIVRPTR_L, I_PIVR_L, NBPANELS_L INTEGER I_PIVRPTR_U, I_PIVR_U, NBPANELS_U #if defined(_OPENMP) NOMP = OMP_GET_MAX_THREADS() K361 = KEEP(361) #endif PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) XSIZE = KEEP(IXSZ) NPIV = IW(IOLDPS+1+XSIZE) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE NPIVP1 = NPIV + 1 APOSMAX = POSELT+NFRONT8*NFRONT8-1_8 IF (OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR_L, I_PIVR_L, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_U, NBPANELS_U, & I_PIVRPTR_U, I_PIVR_U, & IOLDPS+2*NFRONT+6+IW(IOLDPS+5+XSIZE)+XSIZE, & IW, LIW) ENDIF IF ( present(TIPIV) ) THEN ILOC = NPIVP1 - IBEG_BLOCK + 1 TIPIV(ILOC) = ILOC ENDIF IF (INOPV .EQ. -1) THEN APOS = POSELT + NFRONT8*int(NPIVP1-1,8) + int(NPIV,8) IDIAG = APOS CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF (dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + NFRONT8*int(IPIV-1,8) + int(NPIV,8) JMAX = 1 IF ((PIVOT_OPTION.EQ.0).OR.(UU.EQ.RZERO)) THEN IF (A(APOS).EQ.ZERO) GO TO 630 GO TO 380 ENDIF AMROW = RZERO J1 = APOS IF (PIVOT_OPTION.EQ.1 .OR. (LR_ACTIVATED .AND. & (KEEP(480).GE.2 & ))) THEN J = IEND_BLR - NPIV ELSE J = NASS - NPIV ENDIF J2 = J1 + J - 1_8 JMAX = ZMUMPS_IXAMAX(J,A(J1),1,KEEP(361)) JJ = J1 + int(JMAX - 1,8) AMROW = abs(A(JJ)) RMAX = AMROW IF (PIVOT_OPTION.GE.2) THEN J1 = J2 + 1_8 IF (PIVOT_OPTION.GE.3 & ) THEN J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253) - NVSCHUR,8) ELSE J2 = APOS +int(- NPIV + NASS - 1 ,8) ENDIF IF (J2.LT.J1) GO TO 370 IF (KEEP(351).EQ.1) THEN !$ CHUNK = max(K361/2,(int(J2-J1)+NOMP-1)/NOMP) !$OMP PARALLEL DO schedule(static, CHUNK) PRIVATE(JJ) !$OMP& FIRSTPRIVATE(J1,J2) !$OMP& REDUCTION(max:RMAX) IF ((J2-J1).GE.K361) DO JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) ENDDO !$OMP END PARALLEL DO ELSE DO 360 JJ=J1,J2 RMAX = max(abs(A(JJ)),RMAX) 360 CONTINUE ENDIF 370 CONTINUE ENDIF IDIAG = APOS + int(IPIV - NPIVP1,8) IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF ( RMAX .LE. PIVNUL ) THEN IF (LAST_ROW.EQ.NFRONT) THEN LRLOC = LAST_ROW -KEEP(253)-NVSCHUR ELSE LRLOC = LAST_ROW ENDIF IF (NFRONT - KEEP(253) .EQ. NASS) THEN IF (IEND_BLOCK.NE.NASS ) THEN GOTO 460 ENDIF J1=POSELT+int(IPIV-1,8)+int(NPIV,8)*NFRONT8 J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ELSE J1=POSELT+int(IPIV-1,8) J2=POSELT+int(IPIV-1,8)+int(LRLOC-1,8)*NFRONT8 ENDIF DO JJ=J1, J2, NFRONT8 IF ( abs(A(JJ)) .GT. PIVNUL ) THEN GOTO 460 END IF ENDDO IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) GOTO 460 ENDDO ENDIF ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(IDIAG)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109)+1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(dble(FIXA).GT.RZERO) THEN IF(dble(A(IDIAG)) .GE. RZERO) THEN A(IDIAG) = FIXA ELSE A(IDIAG) = -FIXA ENDIF ELSE J1 = APOS J2 = APOS + & int(- NPIV + NFRONT - 1 - KEEP(253),8) DO JJ=J1,J2 A(JJ) = ZERO ENDDO A(IDIAG) = -FIXA ENDIF JMAX = IPIV - NPIV GOTO 385 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF (abs(A(IDIAG)) .GE. UU*RMAX .AND. & abs(A(IDIAG)) .GT. max(SEUIL,tiny(RMAX))) THEN JMAX = IPIV - NPIV GO TO 380 ENDIF IF ( .NOT. (AMROW .GE. UU*RMAX .AND. & AMROW .GT. max(SEUIL,tiny(RMAX))) ) GO TO 460 NOFFW = NOFFW + 1 380 CONTINUE IF (K206.GE.1) THEN Inextpiv = IPIV + 1 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS+int(JMAX-1,8))), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( A(APOS+int(JMAX-1,8)), & DET_MANTW, & DET_EXPW ) ENDIF 385 CONTINUE IF (IPIV.EQ.NPIVP1) GO TO 400 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF IF (PARPIV_T1.NE.0) THEN SWOP = A(APOSMAX+int(NPIVP1,8)) A(APOSMAX+int(NPIVP1,8)) = A(APOSMAX+int(IPIV,8)) A(APOSMAX+int(IPIV,8)) = SWOP ENDIF DET_SIGNW = - DET_SIGNW J1 = POSELT + int(NPIV,8)*NFRONT8 J2 = J1 + NFRONT8 - 1_8 J3 = POSELT + int(IPIV-1,8)*NFRONT8 DO 390 JJ=J1,J2 SWOP = A(JJ) A(JJ) = A(J3) A(J3) = SWOP J3 = J3 + 1_8 390 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NPIVP1 ISWPS2 = IOLDPS + HF - 1 + IPIV ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW 400 IF (JMAX.EQ.1) GO TO 420 DET_SIGNW = - DET_SIGNW IF ( present(TIPIV) ) THEN TIPIV(ILOC) = ILOC + JMAX - 1 ENDIF J1 = POSELT + int(NPIV,8) J2 = POSELT + int(NPIV + JMAX - 1,8) DO 410 KSW=1,LAST_ROW SWOP = A(J1) A(J1) = A(J2) A(J2) = SWOP J1 = J1 + NFRONT8 J2 = J2 + NFRONT8 410 CONTINUE ISWPS1 = IOLDPS + HF - 1 + NFRONT + NPIV + 1 ISWPS2 = IOLDPS + HF - 1 + NFRONT + NPIV + JMAX ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW GO TO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 430 630 CONTINUE IFLAG = -10 GOTO 430 420 CONTINUE IF (OOC_EFFECTIVE_ON_FRONT) THEN IF (KEEP(251).EQ.0) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_L), & NBPANELS_L, & IW(I_PIVR_L), NASS, NPIVP1, IPIV, & PP_LastPanelonDisk_L, & PP_LastPIVRPTRFilled_L) ENDIF CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR_U), & NBPANELS_U, & IW(I_PIVR_U), NASS, NPIVP1, NPIV+JMAX, & PP_LastPanelonDisk_U, & PP_LastPIVRPTRFilled_U) ENDIF 430 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_I SUBROUTINE ZMUMPS_FAC_I_LDLT & ( NFRONT,NASS,INODE,IBEG_BLOCK,IEND_BLOCK, & IW,LIW, A,LA, INOPV, & NNEGW, NB22T1W, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU, SEUIL,KEEP,KEEP8,PIVSIZ, & DKEEP,PIVNUL_LIST,LPN_LIST, XSIZE, & PP_FIRST2SWAP_L, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled,MAXFROMM,IS_MAXFROMM_AVAIL, & PIVOT_OPTION, IEND_BLR, Inextpiv, & OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1, LR_ACTIVATED & ) !$ USE OMP_LIB USE MUMPS_OOC_COMMON IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER NFRONT,NASS,LIW,INODE,IFLAG,INOPV, & IOLDPS INTEGER, intent(inout) :: NNEGW, NB22T1W, NBTINYW INTEGER, intent(inout) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), intent(inout) :: DET_MANTW INTEGER, intent(in) :: IBEG_BLOCK, IEND_BLOCK INTEGER, intent(in) :: PIVOT_OPTION,IEND_BLR INTEGER, intent(inout) :: Inextpiv LOGICAL, intent(in) :: OOC_EFFECTIVE_ON_FRONT INTEGER PIVSIZ,LPIV, XSIZE COMPLEX(kind=8) A(LA) DOUBLE PRECISION UU, UULOC, SEUIL INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER PP_FIRST2SWAP_L, PP_LastPanelonDisk INTEGER PP_LastPIVRPTRIndexFilled DOUBLE PRECISION, intent(in) :: MAXFROMM LOGICAL, intent(inout) :: IS_MAXFROMM_AVAIL INTEGER, intent(in) :: NVSCHUR INTEGER, intent(in) :: PARPIV_T1 LOGICAL, intent(in) :: LR_ACTIVATED include 'mpif.h' INTEGER (8) :: POSPV1,POSPV2,OFFDAG,APOSJ INTEGER JMAX, LIM, LIM_SWAP DOUBLE PRECISION RMAX,AMAX,TMAX, MAX_PREV_in_PARPIV DOUBLE PRECISION RMAX_NORELAX, TMAX_NORELAX, UULOCM1 INTEGER(8) :: APOSMAX, APOSROW DOUBLE PRECISION MAXPIV DOUBLE PRECISION PIVNUL COMPLEX(kind=8) FIXA, CSEUIL COMPLEX(kind=8) PIVOT,DETPIV INCLUDE 'mumps_headers.h' INTEGER :: HF, IPIVNUL INTEGER :: J INTEGER(8) :: APOS, J1, J2, JJ, NFRONT8, KK, J1_ini, JJ_ini INTEGER :: LDA INTEGER(8) :: LDA8 INTEGER NPIV,IPIV INTEGER NPIVP1,K INTEGER :: ISHIFT, K206, IPIV_SHIFT, IPIV_END INTRINSIC max COMPLEX(kind=8) ZERO, ONE PARAMETER( ZERO = (0.0D0,0.0D0) ) PARAMETER( ONE = (1.0D0,1.0D0) ) DOUBLE PRECISION RZERO,RONE PARAMETER(RZERO=0.0D0, RONE=1.0D0) #if defined(_OPENMP) LOGICAL :: OMP_FLAG INTEGER :: NOMP, CHUNK, J1_end #endif INTEGER I_PIVRPTR, I_PIVR, NBPANELS_L !$ NOMP = OMP_GET_MAX_THREADS() PIVNUL = DKEEP(1) FIXA = cmplx(DKEEP(2),kind=kind(FIXA)) CSEUIL = cmplx(SEUIL,kind=kind(CSEUIL)) LDA = NFRONT LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) K206 = KEEP(206) UULOC = UU IF (UULOC.GT.RZERO) THEN UULOCM1 = RONE/UULOC ELSE UULOCM1 = RONE ENDIF HF = 6 + XSIZE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_GET_OOC_PERM_PTR(TYPEF_L, NBPANELS_L, & I_PIVRPTR, I_PIVR, IOLDPS+2*NFRONT+6+KEEP(IXSZ), & IW, LIW) ENDIF PIVSIZ = 1 NPIV = IW(IOLDPS+1+XSIZE) NPIVP1 = NPIV + 1 APOSMAX = POSELT+LDA8*LDA8-1_8 IF(INOPV .EQ. -1) THEN APOS = POSELT + (LDA8+1_8) * int(NPIV,8) POSPV1 = APOS CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), DKEEP, KEEP, .TRUE.) IF(abs(A(APOS)).LT.SEUIL) THEN IF(dble(A(APOS)) .GE. RZERO) THEN A(APOS) = CSEUIL ELSE A(APOS) = -CSEUIL ENDIF NBTINYW = NBTINYW + 1 ELSE IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER( A(APOS), DET_MANTW, DET_EXPW ) ENDIF IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, NPIVP1, & PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF GO TO 420 ENDIF INOPV = 0 ISHIFT = 0 IPIV_END = IEND_BLOCK IF (K206.GE.1) THEN IF (Inextpiv.GT.NPIVP1.AND.Inextpiv.LE.IEND_BLOCK) THEN ISHIFT = Inextpiv - NPIVP1 ENDIF IF ( K206.EQ.1 & .OR. (K206 .GT.1 .AND. IEND_BLOCK.EQ.IEND_BLR) ) THEN IPIV_END = IEND_BLOCK + ISHIFT ENDIF IF (ISHIFT.GT.0.AND.IS_MAXFROMM_AVAIL) THEN IPIV = NPIVP1 APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN ISHIFT = 0 ENDIF ENDIF ENDIF IF ( ISHIFT .GT. 0) THEN IS_MAXFROMM_AVAIL = .FALSE. ENDIF ENDIF DO 460 IPIV_SHIFT = NPIVP1+ISHIFT, IPIV_END IF (IPIV_SHIFT .LE. IEND_BLOCK) THEN IPIV=IPIV_SHIFT ELSE IPIV = IPIV_SHIFT-IEND_BLOCK-1+NPIVP1 IF (IBEG_BLOCK.EQ.NPIVP1) THEN EXIT ENDIF ENDIF APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIV,8) POSPV1 = APOS + int(IPIV - NPIVP1,8) PIVOT = A(POSPV1) IF (UULOC.EQ.RZERO.OR.PIVOT_OPTION.EQ.0) THEN IF (abs(A(APOS)).EQ.RZERO) GO TO 630 CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(APOS)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(A(APOS), DET_MANTW, DET_EXPW ) ENDIF GO TO 420 ENDIF IF ( IS_MAXFROMM_AVAIL ) THEN IF ( MAXFROMM .GT. PIVNUL ) THEN IF ( abs(PIVOT) .GE. UULOC*MAXFROMM & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(MAXFROMM)) ) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE. 0) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GOTO 415 ENDIF ENDIF IS_MAXFROMM_AVAIL = .FALSE. ENDIF AMAX = -RONE JMAX = 0 IF (PIVOT_OPTION.EQ.3 & ) THEN LIM = NFRONT - KEEP(253)-NVSCHUR ELSEIF (PIVOT_OPTION.GE.2 & ) THEN LIM = NASS ELSEIF (PIVOT_OPTION.GE.1) THEN LIM = IEND_BLR ELSE write(*,*) 'Internal error in FAC_I_LDLT 1x1:', & PIVOT_OPTION CALL MUMPS_ABORT() ENDIF J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(abs(A(JJ)) .GT. AMAX) THEN AMAX = abs(A(JJ)) JMAX = IPIV - int(POSPV1-JJ) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV IF(abs(A(J1)) .GT. AMAX) THEN AMAX = abs(A(J1)) JMAX = IPIV + J ENDIF J1 = J1 + LDA8 ENDDO RMAX = RZERO J1_ini = J1 #if defined(_OPENMP) J1_end = LIM - IEND_BLOCK CHUNK = max(J1_end,1) IF ( J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(J1) !$OMP& REDUCTION(max:RMAX) IF(OMP_FLAG) DO J=1, LIM - IEND_BLOCK J1 = J1_ini + int(J-1,8) * LDA8 RMAX = max(abs(A(J1)),RMAX) ENDDO !$OMP END PARALLEL DO IF (PARPIV_T1.NE.0) THEN RMAX_NORELAX = dble(A(APOSMAX+int(IPIV,8))) ELSE RMAX_NORELAX = RZERO ENDIF RMAX = max(RMAX,RMAX_NORELAX) IF (max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL) THEN IF ((PARPIV_T1.NE.0) & .AND.(PARPIV_T1.NE.-1) & .AND.(RMAX_NORELAX.LT.0) & .AND.(IPIV.GT.1)) THEN MAX_PREV_in_PARPIV = RZERO DO JJ=1,IPIV-1 MAX_PREV_in_PARPIV= max ( MAX_PREV_in_PARPIV, & dble(A(APOSMAX+int(JJ,8))) ) ENDDO IF (MAX_PREV_in_PARPIV.GT.PIVNUL) THEN APOSROW = POSELT + NFRONT8*int(IPIV-1,8) DO JJ=1,IPIV-1 IF (abs(A(APOSROW+JJ-1)).GT.PIVNUL) THEN GOTO 460 ENDIF ENDDO ENDIF ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(A(POSPV1)), DKEEP, KEEP, .TRUE.) !$OMP ATOMIC CAPTURE KEEP(109) = KEEP(109) + 1 IPIVNUL = KEEP(109) !$OMP END ATOMIC PIVNUL_LIST(IPIVNUL) = IW( IOLDPS+HF+NPIV+IPIV-NPIVP1 ) IF(dble(FIXA).GT.RZERO) THEN IF(dble(PIVOT) .GE. RZERO) THEN A(POSPV1) = FIXA ELSE A(POSPV1) = -FIXA ENDIF ELSE J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 A(JJ) = ZERO ENDDO J1 = POSPV1 + LDA8 DO J=1, IEND_BLOCK - IPIV A(J1) = ZERO J1 = J1 + LDA8 ENDDO DO J=1,LIM - IEND_BLOCK A(J1) = ZERO J1 = J1 + LDA8 ENDDO A(POSPV1) = ONE ENDIF PIVOT = A(POSPV1) GO TO 415 ENDIF RMAX = max(RMAX,abs(RMAX_NORELAX)) IF ( abs(PIVOT).GE.UULOC*max(RMAX,AMAX) & .AND. abs(PIVOT) .GT. max(SEUIL,tiny(RMAX)) ) THEN CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( abs(PIVOT), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(PIVOT, DET_MANTW, DET_EXPW ) ENDIF GO TO 415 END IF IF (NPIVP1.EQ.IEND_BLOCK) THEN GOTO 460 ELSE IF (JMAX.EQ.0) THEN GOTO 460 ENDIF IF (max(abs(PIVOT),RMAX,AMAX).LE.tiny(RMAX)) THEN GOTO 460 ENDIF IF ( & (KEEP(19).NE.0).AND.(max(AMAX,RMAX,abs(PIVOT)).LE.SEUIL) & ) & THEN GO TO 460 ENDIF IF (RMAX.LT.AMAX) THEN J1 = APOS J2 = POSPV1 - 1_8 DO JJ=J1,J2 IF(int(POSPV1-JJ) .NE. IPIV-JMAX) THEN RMAX = max(RMAX,abs(A(JJ))) ENDIF ENDDO J1 = POSPV1 + LDA8 DO J=1,IEND_BLOCK-IPIV IF(IPIV+J .NE. JMAX) THEN RMAX = max(abs(A(J1)),RMAX) ENDIF J1 = J1 + LDA8 ENDDO ENDIF APOSJ = POSELT + int(JMAX-1,8)*LDA8 + int(NPIV,8) POSPV2 = APOSJ + int(JMAX - NPIVP1,8) IF (IPIV.LT.JMAX) THEN OFFDAG = APOSJ + int(IPIV - NPIVP1,8) ELSE OFFDAG = APOS + int(JMAX - NPIVP1,8) END IF TMAX = RZERO #if defined(_OPENMP) J1_end = LIM-JMAX CHUNK = max(J1_end,1) IF (J1_end.GE.KEEP(360)) THEN OMP_FLAG = .TRUE. CHUNK = max(KEEP(360)/2,(J1_end+NOMP-1)/NOMP) ELSE OMP_FLAG = .FALSE. ENDIF #endif IF (JMAX .LT. IPIV) THEN JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) IF (OMP_FLAG) !$OMP& PRIVATE(JJ) REDUCTION(max:TMAX) DO K = 1, LIM - JMAX JJ = JJ_ini+ int(K,8)*NFRONT8 IF (JMAX+K.NE.IPIV) THEN TMAX=max(TMAX,abs(A(JJ))) ENDIF ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2-1_8 TMAX = max(TMAX,abs(A(KK))) ENDDO ELSE JJ_ini = POSPV2 !$OMP PARALLEL DO SCHEDULE(static, CHUNK) PRIVATE(JJ) !$OMP& REDUCTION(max:TMAX) IF(OMP_FLAG) DO K = 1, LIM-JMAX JJ = JJ_ini + int(K,8)*NFRONT8 TMAX=max(TMAX,abs(A(JJ))) ENDDO !$OMP END PARALLEL DO DO KK = APOSJ, POSPV2 - 1_8 IF (KK.NE.OFFDAG) THEN TMAX = max(TMAX,abs(A(KK))) ENDIF ENDDO ENDIF IF (PARPIV_T1.NE.0) THEN TMAX_NORELAX = max(SEUIL*UULOCM1, & abs(dble(A(APOSMAX+int(JMAX,8)))) & ) ELSE TMAX_NORELAX = SEUIL*UULOCM1 ENDIF TMAX = max (TMAX,TMAX_NORELAX) DETPIV = A(POSPV1)*A(POSPV2) - A(OFFDAG)**2 IF (SEUIL.GT.RZERO) THEN IF (sqrt(abs(DETPIV)) .LE. SEUIL ) THEN GOTO 460 ENDIF ENDIF MAXPIV = max(abs(A(POSPV1)),abs(A(POSPV2))) IF (MAXPIV.EQ.RZERO) MAXPIV = RONE IF ((abs(A(POSPV2))*RMAX+AMAX*TMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF IF ((abs(A(POSPV1))*TMAX+AMAX*RMAX)*UULOC.GT. & abs(DETPIV) .OR. abs(DETPIV) .EQ. RZERO) THEN GO TO 460 ENDIF CALL ZMUMPS_UPDATE_MINMAX_PIVOT & ( sqrt(abs(DETPIV)), & DKEEP, KEEP, .FALSE.) IF (KEEP(258) .NE.0 ) THEN CALL ZMUMPS_UPDATEDETER(DETPIV, DET_MANTW, DET_EXPW ) ENDIF PIVSIZ = 2 NB22T1W = NB22T1W + 1 415 CONTINUE IF (K206.GE.1) THEN Inextpiv = max(NPIVP1+PIVSIZ, IPIV+1) ENDIF DO K=1,PIVSIZ IF (PIVSIZ .EQ. 2) THEN IF (K==1) THEN LPIV = min(IPIV,JMAX) ELSE LPIV = max(IPIV,JMAX) ENDIF ELSE LPIV = IPIV ENDIF IF (LPIV.EQ.NPIVP1) GOTO 416 IF (KEEP(405) .EQ. 0) THEN KEEP8(80) = KEEP8(80)+1 ELSE !$OMP ATOMIC UPDATE KEEP8(80) = KEEP8(80)+1 !$OMP END ATOMIC ENDIF LIM_SWAP = NFRONT CALL ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, LPIV, POSELT, LIM_SWAP, & LDA, NFRONT, 1, PARPIV_T1, KEEP(50), & KEEP(IXSZ), -9999) 416 CONTINUE IF (KEEP(50).NE.1 .AND. OOC_EFFECTIVE_ON_FRONT) THEN CALL ZMUMPS_STORE_PERMINFO( IW(I_PIVRPTR), NBPANELS_L, & IW(I_PIVR), NASS, NPIVP1, LPIV, PP_LastPanelonDisk, & PP_LastPIVRPTRIndexFilled) ENDIF NPIVP1 = NPIVP1 + 1 ENDDO IF(PIVSIZ .EQ. 2) THEN A(POSELT+(LDA8+1_8)*int(NPIV,8)+1_8) = DETPIV ENDIF GOTO 420 460 CONTINUE IF (K206 .GE. 1) THEN Inextpiv=IEND_BLOCK+1 ENDIF IF (IEND_BLOCK.EQ.NASS) THEN INOPV = 1 ELSE INOPV = 2 ENDIF GO TO 420 630 CONTINUE PIVSIZ = 0 IFLAG = -10 420 CONTINUE IS_MAXFROMM_AVAIL = .FALSE. RETURN END SUBROUTINE ZMUMPS_FAC_I_LDLT SUBROUTINE ZMUMPS_FAC_MQ_LDLT(IEND_BLOCK, & NFRONT,NASS,NPIV,INODE, & A,LA,LDA, & POSELT,IFINB,PIVSIZ, & MAXFROMM, IS_MAXFROMM_AVAIL, IS_MAX_USEFUL, & PARPIV_T1, LAST_ROW, IEND_BLR, NVSCHUR_K253, & LR_ACTIVATED & ) IMPLICIT NONE INTEGER, intent(out):: IFINB INTEGER, intent(in) :: INODE, NFRONT, NASS, NPIV INTEGER, intent(in) :: IEND_BLOCK INTEGER, intent(in) :: LDA INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: LAST_ROW INTEGER, intent(in) :: IEND_BLR INTEGER(8) :: POSELT DOUBLE PRECISION, intent(out) :: MAXFROMM LOGICAL, intent(out) :: IS_MAXFROMM_AVAIL LOGICAL, intent(in) :: IS_MAX_USEFUL INTEGER, intent(in) :: PARPIV_T1 INTEGER, INTENT(in) :: NVSCHUR_K253 LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX(kind=8) VALPIV DOUBLE PRECISION :: MAXFROMMTMP INTEGER NCB1 INTEGER(8) :: NFRONT8 INTEGER(8) :: LDA8 INTEGER(8) :: K1POS INTEGER NEL2, NEL COMPLEX(kind=8) ONE, ZERO COMPLEX(kind=8) A11,A22,A12 INTEGER(8) :: APOS, LPOS, LPOS1, LPOS2 INTEGER(8) :: POSPV1, POSPV2 INTEGER PIVSIZ,NPIV_NEW,J2,I INTEGER(8) :: OFFDAG, OFFDAG_OLD, IBEG, IEND INTEGER(8) :: JJ, K1, K2, IROW INTEGER(8) :: ROW_SHIFT, JJ_LOC, IBEG_LOC, IEND_LOC COMPLEX(kind=8) SWOP,DETPIV,MULT1,MULT2 INTEGER(8) :: APOSMAX INCLUDE 'mumps_headers.h' PARAMETER(ONE = (1.0D0,0.0D0), & ZERO = (0.0D0,0.0D0)) LDA8 = int(LDA,8) NFRONT8 = int(NFRONT,8) NPIV_NEW = NPIV + PIVSIZ NEL = NFRONT - NPIV_NEW IFINB = 0 IS_MAXFROMM_AVAIL = .FALSE. NEL2 = IEND_BLOCK - NPIV_NEW IF (NEL2.EQ.0) THEN IF (IEND_BLOCK.EQ.NASS) THEN IFINB = -1 ELSE IFINB = 1 ENDIF ENDIF MAXFROMM = 0.0D0 IF(PIVSIZ .EQ. 1) THEN APOS = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) VALPIV = ONE/A(APOS) LPOS = APOS + LDA8 IF (NEL2 > 0) THEN IF (.NOT. IS_MAX_USEFUL) THEN DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ=1_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ELSE IS_MAXFROMM_AVAIL = .TRUE. DO I=1, NEL2 K1POS = LPOS + int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV A(K1POS+1_8)=A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMM=max( MAXFROMM,abs(A(K1POS+1_8)) ) DO JJ = 2_8, int(I,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO ENDIF ENDIF NCB1 = LAST_ROW - IEND_BLOCK IF (NCB1.GT.0) THEN IF (.NOT. IS_MAX_USEFUL) THEN !$OMP PARALLEL DO PRIVATE(JJ,K1POS) IF (NCB1 > 300) DO I=NEL2+1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO !$OMP END PARALLEL DO ELSE MAXFROMMTMP=0.0D0 !$OMP PARALLEL DO PRIVATE(JJ,K1POS) !$OMP& REDUCTION(max:MAXFROMMTMP) IF (NCB1-NVSCHUR_K253>300) DO I=NEL2+1, NEL2 + NCB1 - NVSCHUR_K253 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV IF (NEL2 > 0) THEN A(K1POS+1_8) = A(K1POS+1_8) - A(K1POS) * A(APOS+1_8) MAXFROMMTMP=max(MAXFROMMTMP, abs(A(K1POS+1_8))) DO JJ = 2_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDIF ENDDO !$OMP END PARALLEL DO DO I = NEL2 + NCB1 - NVSCHUR_K253 + 1, NEL2 + NCB1 K1POS = LPOS+ int(I-1,8)*LDA8 A(APOS+int(I,8))=A(K1POS) A(K1POS) = A(K1POS) * VALPIV DO JJ = 1_8, int(NEL2,8) A(K1POS+JJ)=A(K1POS+JJ) - A(K1POS) * A(APOS+JJ) ENDDO ENDDO MAXFROMM=max(MAXFROMM, MAXFROMMTMP) ENDIF ENDIF ELSE POSPV1 = POSELT + int(NPIV,8)*(NFRONT8 + 1_8) POSPV2 = POSPV1 + NFRONT8 + 1_8 OFFDAG_OLD = POSPV2 - 1_8 OFFDAG = POSPV1 + 1_8 SWOP = A(POSPV2) DETPIV = A(OFFDAG) A22 = A(POSPV1)/DETPIV A11 = SWOP/DETPIV A12 = -A(OFFDAG_OLD)/DETPIV A(OFFDAG) = A(OFFDAG_OLD) A(OFFDAG_OLD) = ZERO LPOS1 = POSPV2 + LDA8 - 1_8 LPOS2 = LPOS1 + 1_8 CALL zcopy(LAST_ROW-NPIV_NEW, A(LPOS1), LDA, A(POSPV1+2_8), 1) CALL zcopy(LAST_ROW-NPIV_NEW, A(LPOS2), LDA, A(POSPV2+1_8), 1) JJ = POSPV2 + NFRONT8-1_8 IBEG = JJ + 2_8 IEND = IBEG DO J2 = 1,NEL2 K1 = JJ K2 = JJ+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG, IEND A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ ) = -MULT1 A( JJ + 1_8 ) = -MULT2 IBEG = IBEG + NFRONT8 IEND = IEND + NFRONT8 + 1_8 JJ = JJ+NFRONT8 ENDDO IEND = IEND-1_8 !$OMP PARALLEL DO PRIVATE(J2, K1, K2, MULT1, MULT2, IROW, JJ_LOC, !$OMP& ROW_SHIFT, IBEG_LOC, IEND_LOC) IF (LAST_ROW-IEND_BLOCK>300) DO J2 = 1,LAST_ROW-IEND_BLOCK ROW_SHIFT = (J2-1_8)*NFRONT8 JJ_LOC = JJ + ROW_SHIFT IBEG_LOC = IBEG + ROW_SHIFT IEND_LOC = IEND + ROW_SHIFT K1 = JJ_LOC K2 = JJ_LOC+1_8 MULT1 = - (A11*A(K1)+A12*A(K2)) MULT2 = - (A12*A(K1)+A22*A(K2)) K1 = POSPV1 + 2_8 K2 = POSPV2 + 1_8 DO IROW = IBEG_LOC, IEND_LOC A(IROW) = A(IROW) + MULT1*A(K1) + MULT2*A(K2) K1 = K1 + 1_8 K2 = K2 + 1_8 ENDDO A( JJ_LOC ) = -MULT1 A( JJ_LOC + 1_8 ) = -MULT2 ENDDO !$OMP END PARALLEL DO ENDIF IF ((IS_MAXFROMM_AVAIL).AND.(NEL2.GT.0)) THEN IF (PARPIV_T1.NE.0) THEN APOSMAX = POSELT+LDA8*LDA8-1_8 + int(NPIV_NEW+1,8) MAXFROMM = max(MAXFROMM, & dble(A(APOSMAX)) & ) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_FAC_MQ_LDLT SUBROUTINE ZMUMPS_FAC_SQ_LDLT(IBEG_BLOCK,IEND_BLOCK,NPIV, & NFRONT,NASS,INODE,A,LA, & LDA, & POSELT, & KEEP,KEEP8, & FIRST_ROW_TRSM, LAST_ROW_TRSM, & LAST_COL_GEMM, LAST_ROW_GEMM, & CALL_TRSM, CALL_GEMM, LR_ACTIVATED, & IW, LIW, OFFSET_IW & ) IMPLICIT NONE INTEGER, intent(in) :: NPIV INTEGER, intent(in) :: NFRONT, NASS, IBEG_BLOCK, IEND_BLOCK INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER, intent(in) :: INODE INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: LDA INTEGER, intent(in) :: LAST_COL_GEMM INTEGER, intent(in) :: LAST_ROW_GEMM, LAST_ROW_TRSM, & FIRST_ROW_TRSM LOGICAL, intent(in) :: CALL_TRSM, CALL_GEMM, LR_ACTIVATED INTEGER :: OFFSET_IW, LIW INTEGER :: IW(LIW) INTEGER(8) :: LDA8 INTEGER NPIV_BLOCK, NEL1 INTEGER NRHS_TRSM INTEGER(8) :: LPOS, UPOS, APOS INTEGER IROW INTEGER Block INTEGER BLSIZE COMPLEX(kind=8) ONE, ALPHA INCLUDE 'mumps_headers.h' PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) LDA8 = int(LDA,8) NEL1 = LAST_COL_GEMM - IEND_BLOCK NRHS_TRSM = LAST_ROW_TRSM-FIRST_ROW_TRSM NPIV_BLOCK = NPIV - IBEG_BLOCK + 1 IF (NPIV_BLOCK.EQ.0) GO TO 500 IF (NEL1.NE.0) THEN IF (CALL_TRSM) THEN APOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IBEG_BLOCK-1,8) LPOS = POSELT + LDA8*int(FIRST_ROW_TRSM,8)+int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8)+int(FIRST_ROW_TRSM,8) CALL ztrsm('L', 'U', 'T', 'U', NPIV_BLOCK, NRHS_TRSM, & ONE, A(APOS), LDA, A(LPOS), LDA) CALL ZMUMPS_FAC_LDLT_COPY2U_SCALEL(NRHS_TRSM, 1, KEEP(424), & NFRONT, NPIV_BLOCK, LIW, IW, OFFSET_IW, LA, A, & POSELT, LPOS, UPOS, APOS, .NOT.LR_ACTIVATED) ENDIF IF (CALL_GEMM) THEN #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IBEG_BLOCK-1,8) UPOS = POSELT + LDA8*int(IBEG_BLOCK-1,8) + int(IEND_BLOCK,8) APOS = POSELT + LDA8*int(IEND_BLOCK,8) + int(IEND_BLOCK,8) CALL zgemmt( 'U','N','N', NEL1, & NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ELSE #endif IF ( LAST_COL_GEMM - IEND_BLOCK > KEEP(7) ) THEN BLSIZE = KEEP(8) ELSE BLSIZE = LAST_COL_GEMM - IEND_BLOCK END IF IF ( LAST_COL_GEMM - IEND_BLOCK .GT. 0 ) THEN #if defined(SAK_BYROW) DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int(IROW - 1,8) APOS = POSELT + int(IROW - 1,8) * LDA8 + & int(IEND_BLOCK,8) CALL zgemm( 'N','N', IROW + Block - IEND_BLOCK - 1, & Block, NPIV_BLOCK, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) ENDDO #else DO IROW = IEND_BLOCK+1, LAST_COL_GEMM, BLSIZE Block = min( BLSIZE, LAST_COL_GEMM - IROW + 1 ) LPOS = POSELT + int( IROW - 1,8) * LDA8 + & int(IBEG_BLOCK - 1,8) UPOS = POSELT + int(IBEG_BLOCK - 1,8) * LDA8 + & int( IROW - 1,8) APOS = POSELT + int( IROW - 1,8) * LDA8 + int( IROW - 1,8) CALL zgemm( 'N','N', Block, LAST_COL_GEMM - IROW + 1, & NPIV_BLOCK, ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, ONE, A( APOS ), LDA ) END DO #endif END IF #if defined(GEMMT_AVAILABLE) END IF #endif LPOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IBEG_BLOCK-1,8) UPOS = POSELT + int(IBEG_BLOCK-1,8) * LDA8 + & int(IEND_BLOCK,8) APOS = POSELT + int(LAST_COL_GEMM,8)*LDA8 + int(IEND_BLOCK,8) IF (LAST_ROW_GEMM .GT. LAST_COL_GEMM) THEN CALL zgemm('N', 'N', NEL1, LAST_ROW_GEMM-LAST_COL_GEMM, & NPIV_BLOCK, ALPHA, A(UPOS), LDA, A(LPOS), LDA, & ONE, A(APOS), LDA) ENDIF ENDIF ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_FAC_SQ_LDLT SUBROUTINE ZMUMPS_SWAP_LDLT( A, LA, IW, LIW, & IOLDPS, NPIVP1, IPIV, POSELT, LASTROW2SWAP, & LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE, & IBEG_BLOCK_TO_SEND ) IMPLICIT NONE INTEGER(8) :: POSELT, LA INTEGER LIW, IOLDPS, NPIVP1, IPIV INTEGER LDA, NFRONT, LEVEL, PARPIV, K50, XSIZE INTEGER LASTROW2SWAP COMPLEX(kind=8) A( LA ) INTEGER IW( LIW ) INTEGER, INTENT(IN) :: IBEG_BLOCK_TO_SEND INCLUDE 'mumps_headers.h' INTEGER :: IBEG INTEGER ISW, ISWPS1, ISWPS2, HF INTEGER(8) :: IDIAG, APOS INTEGER(8) :: LDA8 COMPLEX(kind=8) SWOP LDA8 = int(LDA,8) APOS = POSELT + LDA8*int(IPIV-1,8) + int(NPIVP1-1,8) IDIAG = APOS + int(IPIV - NPIVP1,8) HF = 6 + IW( IOLDPS + 5 + XSIZE) + XSIZE ISWPS1 = IOLDPS + HF + NPIVP1 - 1 ISWPS2 = IOLDPS + HF + IPIV - 1 ISW = IW(ISWPS1) IW(ISWPS1) = IW(ISWPS2) IW(ISWPS2) = ISW ISW = IW(ISWPS1+NFRONT) IW(ISWPS1+NFRONT) = IW(ISWPS2+NFRONT) IW(ISWPS2+NFRONT) = ISW IF ( LEVEL .eq. 2 ) THEN IBEG = IBEG_BLOCK_TO_SEND CALL zswap( NPIVP1 - 1 - IBEG + 1, & A( POSELT + int(NPIVP1-1,8) + & int(IBEG-1,8) * LDA8), LDA, & A( POSELT + int(IPIV-1,8) + & int(IBEG-1,8) * LDA8), LDA ) END IF CALL zswap( NPIVP1-1, & A( POSELT+int(NPIVP1-1,8) * LDA8 ), 1, & A( POSELT + int(IPIV-1,8) * LDA8 ), 1 ) CALL zswap( IPIV - NPIVP1 - 1, & A( POSELT+int(NPIVP1,8) * LDA8 + int(NPIVP1-1,8) ), & LDA, A( APOS + 1_8 ), 1 ) SWOP = A(IDIAG) A(IDIAG) = A( POSELT+int(NPIVP1-1,8)*LDA8+int(NPIVP1-1,8) ) A( POSELT + int(NPIVP1-1,8)*LDA8 + int(NPIVP1-1,8) ) = SWOP CALL zswap( LASTROW2SWAP - IPIV, & A( APOS + LDA8 ), LDA, & A( IDIAG + LDA8 ), LDA ) IF (PARPIV.NE.0 .AND.K50.EQ.2) THEN IF ( LEVEL .eq. 2 .OR. LEVEL.eq.1) THEN APOS = POSELT+LDA8*LDA8-1_8 SWOP = A(APOS+int(NPIVP1,8)) A(APOS+int(NPIVP1,8))= A(APOS+int(IPIV,8)) A(APOS+int(IPIV,8)) = SWOP ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SWAP_LDLT SUBROUTINE ZMUMPS_FAC_LDLT_COPY2U_SCALEL( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS, & COPY_NEEDED ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8), INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS LOGICAL, INTENT(IN) :: COPY_NEEDED INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX(kind=8) :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY COMPLEX(kind=8) :: ONE PARAMETER (ONE=(1.0D0,0.0D0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, A_DPOS) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = ONE/A(DPOS) LPOSI = LPOS+int(I-1,8) IF (COPY_NEEDED) THEN UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8) END DO ENDIF DO J = 1, Block2 A(LPOSI+int(J-1,8)*LDA8) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE IF (COPY_NEEDED) THEN CALL zcopy(Block2, A(LPOS+int(I-1,8)), & LDA, A(UPOS+int(I-1,8)*LDA8), 1) CALL zcopy(Block2, A(LPOS+int(I,8)), & LDA, A(UPOS+int(I,8)*LDA8), 1) ENDIF POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DETPIV = A11*A22 - A12**2 A22 = A11/DETPIV A11 = A(POSPV2)/DETPIV A12 = -A12/DETPIV DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) = MULT1 A(LPOS+int(J-1,8)*LDA8+int(I,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO END SUBROUTINE ZMUMPS_FAC_LDLT_COPY2U_SCALEL SUBROUTINE ZMUMPS_FAC_LDLT_COPYSCALE_U( IROWMAX, IROWMIN, & SIZECOPY, LDA, NCOLS, LIW, IW, OFFSET_IW, & LA, A, POSELT, A_LPOS, A_UPOS, A_DPOS ) !$ USE OMP_LIB INTEGER, INTENT(IN) :: IROWMAX, IROWMIN INTEGER, INTENT(IN) :: SIZECOPY INTEGER, INTENT(IN) :: LDA, NCOLS INTEGER, INTENT(IN) :: LIW INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(IN) :: OFFSET_IW INTEGER(8), INTENT(IN) :: LA COMPLEX(kind=8), INTENT(INOUT) :: A(LA) INTEGER(8), INTENT(IN) :: POSELT, A_LPOS, A_UPOS, A_DPOS INTEGER(8) :: LPOS, UPOS INTEGER(8) :: DPOS, POSPV1, POSPV2, OFFDAG INTEGER(8) :: LDA8 INTEGER :: IROWEND, IROW, Block2 INTEGER :: I, J COMPLEX(kind=8) :: MULT1, MULT2, A11, DETPIV, A22, A12 INTEGER :: BLSIZECOPY COMPLEX(kind=8) :: ONE PARAMETER (ONE=(1.0D0,0.0D0)) INTEGER(8) :: LPOSI, UPOSI LOGICAL :: PIVOT_2X2 !$ LOGICAL :: OMP_FLAG !$ INTEGER :: NOMP, CHUNK LDA8 = int(LDA,8) IF (SIZECOPY.NE.0) THEN BLSIZECOPY = SIZECOPY ELSE BLSIZECOPY = 250 ENDIF !$ NOMP = OMP_GET_MAX_THREADS() !$ OMP_FLAG = .FALSE. !$ CHUNK = (64/4) !$ IF (NOMP .GT. 1 .AND. NCOLS .GE. 4*CHUNK) THEN !$ OMP_FLAG = .TRUE. !$ CHUNK = max(2*CHUNK, NCOLS/NOMP) !$ ENDIF DO IROWEND = IROWMAX, IROWMIN, -BLSIZECOPY Block2 = min(BLSIZECOPY, IROWEND) IROW = IROWEND - Block2 + 1 LPOS = A_LPOS + int(IROW-1,8)*LDA8 UPOS = A_UPOS + int(IROW-1,8) !$OMP PARALLEL DO PRIVATE(PIVOT_2X2, A11, DPOS, !$OMP& POSPV1, POSPV2, OFFDAG, A22, A12, DETPIV, J, MULT1, MULT2 !$OMP& , LPOSI, UPOSI !$OMP& ) FIRSTPRIVATE(Block2, LDA, LDA8, LPOS, UPOS, POSELT) !$OMP& SCHEDULE(STATIC,CHUNK) IF(OMP_FLAG) DO I=1, NCOLS PIVOT_2X2 = .FALSE. IF(IW(OFFSET_IW+I-1) .LE. 0) THEN PIVOT_2X2 = .TRUE. ELSE IF (I .GT. 1) THEN IF (IW(OFFSET_IW+I-2) .LE. 0) THEN cycle ENDIF ENDIF ENDIF DPOS = A_DPOS + LDA8*int(I-1,8) + int(I-1,8) IF(.not. PIVOT_2X2) THEN A11 = A(DPOS) LPOSI = LPOS+int(I-1,8) UPOSI = UPOS+int(I-1,8)*LDA8 DO J = 1, Block2 A(UPOSI+int(J-1,8)) = A(LPOSI+int(J-1,8)*LDA8)*A11 END DO ELSE POSPV1 = DPOS POSPV2 = DPOS + int(LDA+1,8) OFFDAG = POSPV1+1_8 A11 = A(POSPV1) A22 = A(POSPV2) A12 = A(OFFDAG) DO J = 1,Block2 MULT1 = A11*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A12*A(LPOS+int(J-1,8)*LDA8+int(I,8)) MULT2 = A12*A(LPOS+int(J-1,8)*LDA8+int(I-1,8)) & + A22*A(LPOS+int(J-1,8)*LDA8+int(I,8)) A(UPOS+int(I-1,8)*LDA8+int(J-1,8)) = MULT1 A(UPOS+int(I,8)*LDA8+int(J-1,8)) = MULT2 ENDDO ENDIF ENDDO !$OMP END PARALLEL DO ENDDO RETURN END SUBROUTINE ZMUMPS_FAC_LDLT_COPYSCALE_U SUBROUTINE ZMUMPS_FAC_T_LDLT(NFRONT,NASS, & IW,LIW,A,LA, & LDA, & IOLDPS,POSELT,KEEP,KEEP8, & POSTPONE_COL_UPDATE, ETATASS, & TYPEFile, LAFAC, MonBloc, NextPiv2beWritten, & LIWFAC, MYID, IFLAG, OFFSET_IW, INODE ) USE ZMUMPS_OOC IMPLICIT NONE INTEGER NFRONT, NASS,LIW INTEGER(8) :: LA COMPLEX(kind=8) A(LA) INTEGER IW(LIW) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: POSELT INTEGER LDA INTEGER IOLDPS, ETATASS LOGICAL POSTPONE_COL_UPDATE INTEGER(8) :: LAFAC INTEGER TYPEFile, NextPiv2beWritten INTEGER LIWFAC, MYID, IFLAG TYPE(IO_BLOCK):: MonBloc INTEGER IDUMMY LOGICAL LAST_CALL INTEGER :: OFFSET_IW INTEGER, intent(in):: INODE INCLUDE 'mumps_headers.h' INTEGER(8) :: UPOS, APOS, LPOS INTEGER(8) :: LDA8 INTEGER BLSIZE, BLSIZE2, Block, IROW, NPIV, IROWEND INTEGER I2, I2END, Block2 COMPLEX(kind=8) ONE, ALPHA, BETA, ZERO PARAMETER (ONE=(1.0D0,0.0D0), ALPHA=(-1.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0)) LDA8 = int(LDA,8) IF (ETATASS.EQ.1) THEN BETA = ZERO ELSE BETA = ONE ENDIF IF ( NFRONT - NASS > KEEP(58) ) THEN IF ( NFRONT - NASS > KEEP(57) ) THEN BLSIZE = KEEP(58) ELSE BLSIZE = (NFRONT - NASS)/2 END IF ELSE BLSIZE = NFRONT - NASS END IF BLSIZE2 = KEEP(218) NPIV = IW( IOLDPS + 1 + KEEP(IXSZ)) IF ( NFRONT - NASS .GT. 0 ) THEN IF ( POSTPONE_COL_UPDATE ) THEN LPOS = POSELT + LDA8 * int(NASS,8) CALL ztrsm( 'L', 'U', 'T', 'U', & NPIV, NFRONT-NASS, ONE, & A( POSELT ), LDA, & A( LPOS ), LDA ) ENDIF #if defined(GEMMT_AVAILABLE) IF ( KEEP(421).EQ. -1) THEN LPOS = POSELT + int(NASS,8)*LDA8 UPOS = POSELT + int(NASS,8) APOS = POSELT + int(NASS,8)*LDA8 + int(NASS,8) IF (POSTPONE_COL_UPDATE) THEN CALL ZMUMPS_FAC_LDLT_COPY2U_SCALEL( NFRONT - NASS, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF CALL zgemmt('U', 'N', 'N', NFRONT-NASS, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS ), LDA, & BETA, & A( APOS ), LDA ) ELSE #endif DO IROWEND = NFRONT - NASS, 1, -BLSIZE Block = min( BLSIZE, IROWEND ) IROW = IROWEND - Block + 1 LPOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 APOS = POSELT + int(NASS,8)*LDA8 + int(IROW-1,8) * LDA8 + & int(NASS + IROW - 1,8) UPOS = POSELT + int(NASS,8) IF (.NOT. POSTPONE_COL_UPDATE) THEN UPOS = POSELT + int(NASS + IROW - 1,8) ENDIF IF (POSTPONE_COL_UPDATE) THEN CALL ZMUMPS_FAC_LDLT_COPY2U_SCALEL( Block, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, & POSELT, .TRUE. ) ENDIF DO I2END = Block, 1, -BLSIZE2 Block2 = min(BLSIZE2, I2END) I2 = I2END - Block2+1 CALL zgemm('N', 'N', Block2, Block-I2+1, NPIV, ALPHA, & A(UPOS+int(I2-1,8)), LDA, & A(LPOS+int(I2-1,8)*LDA8), LDA, & BETA, & A(APOS + int(I2-1,8) + int(I2-1,8)*LDA8), LDA) IF (KEEP(201).EQ.1) THEN IF (NextPiv2beWritten.LE.NPIV) THEN LAST_CALL=.FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL( & STRAT_TRY_WRITE, TYPEFile, & A(POSELT), LAFAC, MonBloc, & NextPiv2beWritten, IDUMMY, & IW(IOLDPS), LIWFAC, MYID, & KEEP8(31), & IFLAG,LAST_CALL ) IF (IFLAG .LT. 0 ) RETURN ENDIF ENDIF ENDDO IF ( NFRONT - NASS - IROW + 1 - Block > 0 ) THEN CALL zgemm( 'N', 'N', Block, NFRONT-NASS-Block-IROW+1, NPIV, & ALPHA, A( UPOS ), LDA, & A( LPOS + LDA8 * int(Block,8) ), LDA, & BETA, & A( APOS + LDA8 * int(Block,8) ), LDA ) ENDIF END DO #if defined(GEMMT_AVAILABLE) END IF #endif IF ( (POSTPONE_COL_UPDATE).AND.(NASS-NPIV.GT.0) ) THEN LPOS = POSELT + int(NPIV,8)*LDA8 UPOS = POSELT + int(NPIV,8) CALL ZMUMPS_FAC_LDLT_COPYSCALE_U( NASS-NPIV, 1, & KEEP(424), NFRONT, NPIV, & LIW, IW, OFFSET_IW, LA, A, POSELT, LPOS, UPOS, POSELT) LPOS = POSELT + LDA8 * int(NASS,8) CALL zgemm('N', 'N', NASS-NPIV, NFRONT-NASS, NPIV, ALPHA, & A( POSELT + int(NPIV,8)), LDA, & A( LPOS ), LDA, & BETA, & A( LPOS + int(NPIV,8) ), LDA) ENDIF END IF RETURN END SUBROUTINE ZMUMPS_FAC_T_LDLT SUBROUTINE ZMUMPS_STORE_PERMINFO( PIVRPTR, NBPANELS, PIVR, NASS, & K, P, LastPanelonDisk, & LastPIVRPTRIndexFilled ) IMPLICIT NONE INTEGER, intent(in) :: NBPANELS, NASS, K, P INTEGER, intent(inout) :: PIVRPTR(NBPANELS), PIVR(NASS) INTEGER LastPanelonDisk, LastPIVRPTRIndexFilled INTEGER I IF ( LastPanelonDisk+1 > NBPANELS ) THEN WRITE(*,*) "INTERNAL ERROR IN ZMUMPS_STORE_PERMINFO!" WRITE(*,*) "NASS=",NASS,"PIVRPTR=",PIVRPTR(1:NBPANELS) WRITE(*,*) "K=",K, "P=",P, "LastPanelonDisk=",LastPanelonDisk WRITE(*,*) "LastPIVRPTRIndexFilled=", LastPIVRPTRIndexFilled CALL MUMPS_ABORT() ENDIF PIVRPTR(LastPanelonDisk+1) = K + 1 IF (LastPanelonDisk.NE.0) THEN PIVR(K - PIVRPTR(1) + 1) = P DO I = LastPIVRPTRIndexFilled + 1, LastPanelonDisk PIVRPTR(I)=PIVRPTR(LastPIVRPTRIndexFilled) ENDDO ENDIF LastPIVRPTRIndexFilled = LastPanelonDisk + 1 RETURN END SUBROUTINE ZMUMPS_STORE_PERMINFO SUBROUTINE ZMUMPS_UPDATE_MINMAX_PIVOT & ( DIAG, DKEEP, KEEP, NULLPIVOT) !$ USE OMP_LIB IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: DIAG DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) LOGICAL, INTENT(IN) :: NULLPIVOT INTEGER, INTENT(IN) :: KEEP(500) IF (KEEP(405).EQ.0) THEN DKEEP(21) = max(DKEEP(21), DIAG) DKEEP(19) = min(DKEEP(19), DIAG) IF (.NOT.NULLPIVOT) THEN DKEEP(20) = min(DKEEP(20), DIAG) ENDIF ELSE !$OMP ATOMIC UPDATE DKEEP(21) = max(DKEEP(21), DIAG) !$OMP END ATOMIC !$OMP ATOMIC UPDATE DKEEP(19) = min(DKEEP(19), DIAG) !$OMP END ATOMIC IF (.NOT.NULLPIVOT) THEN !$OMP ATOMIC UPDATE DKEEP(20) = min(DKEEP(20), DIAG) !$OMP END ATOMIC ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_UPDATE_MINMAX_PIVOT SUBROUTINE ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, NCB, SIZE_SCHUR, ROW_INDICES, PERM, & NVSCHUR & ) IMPLICIT NONE INTEGER, intent(in) :: N, NCB, SIZE_SCHUR INTEGER, intent(in) :: ROW_INDICES(NCB), PERM(N) INTEGER, intent(out):: NVSCHUR INTEGER :: I, IPOS, IBEG_SCHUR IBEG_SCHUR = N - SIZE_SCHUR +1 NVSCHUR = 0 IPOS = NCB DO I= NCB,1,-1 IF (abs(ROW_INDICES(I)).LE.N) THEN IF (PERM(ROW_INDICES(I)).LT.IBEG_SCHUR) EXIT ENDIF IPOS = IPOS -1 ENDDO NVSCHUR = NCB-IPOS RETURN END SUBROUTINE ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT END MODULE ZMUMPS_FAC_FRONT_AUX_M MUMPS_5.4.1/src/cfac_asm.F0000664000175000017500000010067614102210523015360 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_ASM_SLAVE_MASTER(N, INODE, IW, LIW, A, LA, & ISON, NBROWS, NBCOLS, ROWLIST, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB, MYID, KEEP,KEEP8, IS_ofType5or6, & LDA_VALSON ) USE CMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON, IWPOSCB INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), STEP(N), PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)), ROWLIST(NBROWS) COMPLEX A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW LOGICAL, INTENT(IN) :: IS_ofType5or6 INTEGER(8) :: POSELT, POSEL1, APOS, JJ2 INTEGER HF,HS, NSLAVES, NFRONT, NASS1, & IOLDPS, ISTCHK, LSTK, NSLSON,NELIM, & NPIVS,NCOLS,J1,JJ,JJ1,NROWS, & LDAFS_PERE, IBEG, DIAG INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NASS1 = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) IF (KEEP(50).EQ.0) THEN LDAFS_PERE = NFRONT ELSE IF ( NSLAVES .eq. 0 ) THEN LDAFS_PERE = NFRONT ELSE LDAFS_PERE = NASS1 ENDIF ENDIF HF = 6 + NSLAVES + KEEP(IXSZ) POSEL1 = POSELT - int(LDAFS_PERE,8) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) OPASSW = OPASSW + dble(NBROWS*NBCOLS) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DO JJ = 1, NBROWS DO JJ1 = 1, NBCOLS JJ2 = APOS + int(JJ1-1,8) A(JJ2)=A(JJ2)+VALSON(JJ1,JJ) ENDDO APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO 170 JJ = 1, NBROWS APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO 160 JJ1 = 1, NBCOLS JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) 160 CONTINUE 170 CONTINUE ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(LDAFS_PERE,8) DIAG = ROWLIST(1) DO JJ = 1, NBROWS DO JJ1 = 1, DIAG JJ2 = APOS+int(JJ1-1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO DIAG = DIAG+1 APOS = APOS + int(LDAFS_PERE,8) ENDDO ELSE DO JJ = 1, NBROWS IF (ROWLIST(JJ).LE.NASS1.and..NOT.IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(JJ) - 1,8) DO JJ1 = 1, NELIM JJ2 = APOS + int(IW(J1+JJ1-1),8)*int(LDAFS_PERE,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO IBEG = NELIM+1 ELSE IBEG = 1 ENDIF APOS = POSEL1 + int(ROWLIST(JJ),8) * int(LDAFS_PERE,8) DO JJ1 = IBEG, NBCOLS IF (ROWLIST(JJ).LT.IW(J1 + JJ1 - 1)) EXIT JJ2 = APOS + int(IW(J1 + JJ1 - 1) - 1,8) A(JJ2) = A(JJ2) + VALSON(JJ1,JJ) ENDDO ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_MASTER SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_INIT & (N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, MYID, LRGROUPS) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(N), PTRAIW(N) COMPLEX :: RHS_MUMPS(KEEP(255)) COMPLEX :: A(LA) INTEGER :: INTARR(KEEP8(27)) COMPLEX :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT COMPLEX, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & KEEP8(27), KEEP8(26), & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_INIT SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_END & (N, INODE, IW, LIW, NBROWS, STEP, PTRIST, & ITLOC, RHS_MUMPS, KEEP,KEEP8) IMPLICIT NONE INTEGER N, LIW INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER INODE INTEGER NBROWS INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)) COMPLEX :: RHS_MUMPS(KEEP(255)) INCLUDE 'mumps_headers.h' INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J IOLDPS = PTRIST(STEP(INODE)) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE_END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE(N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, ROWLIST, COLLIST, VALSON, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, FILS, & ICNTL, KEEP,KEEP8, MYID, IS_ofType5or6, LDA_VALSON) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID LOGICAL, intent(in) :: IS_ofType5or6 INTEGER NBROWS, NBCOLS, LDA_VALSON INTEGER ROWLIST(NBROWS), COLLIST(NBCOLS) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: PTRAST(KEEP(28)) COMPLEX A(LA), VALSON(LDA_VALSON,NBROWS) DOUBLE PRECISION OPASSW, OPELIW INTEGER(8) :: POSEL1, POSELT, APOS, K8 INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & I,J,NASS,IDIAG COMPLEX, POINTER, DIMENSION(:) :: A_PTR INTEGER(8) :: LA_PTR INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL CMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) IF ( NBROWS .GT. NBROWF ) THEN WRITE(*,*) ' ERR: ERROR : NBROWS > NBROWF' WRITE(*,*) ' ERR: INODE =', INODE WRITE(*,*) ' ERR: NBROW=',NBROWS,'NBROWF=',NBROWF WRITE(*,*) ' ERR: ROW_LIST=', ROWLIST WRITE(*,*) ' ERR: NBCOLF/NASS=', NBCOLF, NASS CALL MUMPS_ABORT() END IF NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) IF (NBROWS.GT.0) THEN POSEL1 = POSELT - int(NBCOLF,8) IF (KEEP(50).EQ.0) THEN IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) DO I=1, NBROWS DO J = 1, NBCOLS A_PTR(APOS+int(J-1,8)) = A_PTR( APOS+int(J-1,8)) + & VALSON(J,I) ENDDO APOS = APOS + int(NBCOLF,8) END DO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ELSE IF (IS_ofType5or6) THEN APOS = POSEL1 + int(ROWLIST(1),8) * int(NBCOLF,8) & + int((NBROWS-1),8)*int(NBCOLF,8) IDIAG = 0 DO I=NBROWS,1,-1 A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8))= & A_PTR(APOS:APOS+int(NBCOLS-IDIAG-1,8)) + & VALSON(1:NBCOLS-IDIAG,I) APOS = APOS - int(NBCOLF,8) IDIAG = IDIAG + 1 ENDDO ELSE DO I=1,NBROWS APOS = POSEL1 + int(ROWLIST(I),8) * int(NBCOLF,8) DO J=1,NBCOLS IF (ITLOC(COLLIST(J)) .EQ. 0) THEN EXIT ENDIF K8 = APOS + int(ITLOC(COLLIST(J)),8) - 1_8 A_PTR(K8) = A_PTR(K8) + VALSON(J,I) ENDDO ENDDO ENDIF ENDIF OPASSW = OPASSW + dble(NBROWS*NBCOLS) ENDIF RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_TO_SLAVE SUBROUTINE CMUMPS_LDLT_ASM_NIV12_IP( A, LA, & IAFATH, NFRONT, NASS1, & IACB, NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX A( LA ) INTEGER(8) :: IAFATH, IACB INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB, IBEGCBROW, IENDFRONT LOGICAL RESET_TO_ZERO, RISK_OF_SAME_POS, & RISK_OF_SAME_POS_THIS_LINE IENDFRONT = IAFATH+int(NFRONT,8)*int(NFRONT,8)-1_8 IPOSCB=1_8 RESET_TO_ZERO = IACB .LT. IENDFRONT + 1_8 RISK_OF_SAME_POS = IACB + LCB .EQ. IENDFRONT + 1_8 RISK_OF_SAME_POS_THIS_LINE = .FALSE. DO I=1, NROWS POSELT = int(IW(I)-1,8) * int(NFRONT,8) IF (.NOT. CB_IS_COMPRESSED ) THEN IPOSCB = 1_8 + int(I - 1,8) * int(NCOLS,8) IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDIF IF ( RISK_OF_SAME_POS ) THEN IF (I.EQ.NROWS .OR. .NOT. CB_IS_COMPRESSED) THEN IF ( IAFATH + POSELT + int(IW(I)-1,8) .EQ. & IACB+IPOSCB+int(I-1-1,8)) THEN RISK_OF_SAME_POS_THIS_LINE = .TRUE. ENDIF ENDIF ENDIF IF (RESET_TO_ZERO) THEN IF ( RISK_OF_SAME_POS_THIS_LINE ) THEN DO J=1, I APOS = POSELT + int(IW( J ),8) IF (IAFATH + APOS - 1_8.NE. IACB+IPOSCB-1_8) THEN A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO ENDIF IPOSCB = IPOSCB + 1_8 ENDDO ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) A(IACB+IPOSCB-1_8) = ZERO IPOSCB = IPOSCB + 1_8 ENDDO ENDIF ELSE DO J=1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IACB+IPOSCB-1_8) IPOSCB = IPOSCB + 1_8 ENDDO ENDIF IF (.NOT. CB_IS_COMPRESSED ) THEN IBEGCBROW = IACB+IPOSCB-1_8 IF ( IBEGCBROW .LE. IENDFRONT ) THEN A(IBEGCBROW:IBEGCBROW+int(NCOLS-I,8)-1_8)=ZERO ENDIF ENDIF IF (IACB+IPOSCB-1_8 .GE. IENDFRONT + 1_8) THEN RESET_TO_ZERO = .FALSE. ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_LDLT_ASM_NIV12_IP SUBROUTINE CMUMPS_LDLT_ASM_NIV12( A, LA, SON_A, & IAFATH, NFRONT, NASS1, & NCOLS, LCB, & IW, NROWS, NELIM, ETATASS, & CB_IS_COMPRESSED !$ & , K360 & ) IMPLICIT NONE INTEGER NFRONT, NASS1 INTEGER(8) :: LA INTEGER NCOLS, NROWS, NELIM INTEGER(8) :: LCB COMPLEX A( LA ) COMPLEX SON_A( LCB ) INTEGER(8) :: IAFATH INTEGER IW( NCOLS ) INTEGER ETATASS LOGICAL CB_IS_COMPRESSED !$ INTEGER, INTENT(in):: K360 COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) INTEGER I, J INTEGER(8) :: APOS, POSELT INTEGER(8) :: IPOSCB !$ LOGICAL :: OMP_FLAG IF ((ETATASS.EQ.0) .OR. (ETATASS.EQ.1)) THEN IPOSCB = 1_8 DO I = 1, NELIM POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) IF (.NOT. CB_IS_COMPRESSED) THEN IPOSCB = 1_8 + int( I - 1, 8 ) * int(NCOLS,8) ENDIF DO J = 1, I APOS = POSELT + int(IW( J ),8) A(IAFATH+ APOS -1_8) = A(IAFATH+ APOS -1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO END DO ENDIF IF ((ETATASS.EQ.0).OR.(ETATASS.EQ.1)) THEN !$ OMP_FLAG = (NROWS-NELIM).GE.K360 !$OMP PARALLEL DO PRIVATE(IPOSCB, POSELT, J, APOS) IF (OMP_FLAG) DO I = NELIM + 1, NROWS IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8) * int(I-1,8)) / 2_8 + 1_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + 1_8 ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE. int(NASS1,8)) THEN DO J = 1, NELIM APOS = POSELT + int( IW( J ) - 1, 8 ) * int(NFRONT,8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) + & SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = 1, NELIM APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF IF (ETATASS.EQ.1) THEN POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I IF (IW(J).GT.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB +1_8 END DO ELSE POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J = NELIM + 1, I APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB + 1_8 END DO ENDIF END DO !$OMP END PARALLEL DO ELSE DO I= NROWS, NELIM+1, -1 IF (CB_IS_COMPRESSED) THEN IPOSCB = (int(I,8)*int(I+1,8))/2_8 ELSE IPOSCB = int(I-1,8) * int(NCOLS,8) + int(I,8) ENDIF POSELT = int(IW( I ),8) IF (POSELT.LE.int(NASS1,8)) EXIT POSELT = int( IW( I ) - 1, 8 ) * int(NFRONT, 8) DO J=I,NELIM+1, -1 IF (IW(J).LE.NASS1) EXIT APOS = POSELT + int(IW( J ), 8) A(IAFATH+APOS-1_8) = A(IAFATH+APOS-1_8) & + SON_A(IPOSCB) IPOSCB = IPOSCB - 1_8 ENDDO ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_LDLT_ASM_NIV12 SUBROUTINE CMUMPS_RESTORE_INDICES(N, ISON, INODE, IWPOSCB, & PIMASTER, PTLUST_S, IW, LIW, STEP, KEEP,KEEP8) IMPLICIT NONE INTEGER N, ISON, INODE, IWPOSCB INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER PIMASTER(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER LIW INTEGER IW(LIW) INTEGER ISTCHK, LSTK, NSLSON, HS, NROWS, NCOLS, NPIVS, NELIM INTEGER IOLDPS, NFRONT, NSLAVES, ICT11, HF INTEGER J1, J2, J3, JJ, JPOS LOGICAL SAME_PROC INCLUDE 'mumps_headers.h' ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK+KEEP(IXSZ)) NSLSON = IW(ISTCHK+5+KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1+KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3+KEEP(IXSZ)) NCOLS = NPIVS + LSTK IF ( NPIVS < 0 ) NPIVS = 0 SAME_PROC = ISTCHK < IWPOSCB IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2+KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS IF (KEEP(50).NE.0) THEN J2 = J1 + LSTK - 1 DO JJ = J1, J2 IW(JJ) = IW(JJ - NROWS) ENDDO ELSE J2 = J1 + LSTK - 1 J3 = J1 + NELIM DO JJ = J3, J2 IW(JJ) = IW(JJ - NROWS) ENDDO IF (NELIM .NE. 0) THEN IOLDPS = PTLUST_S(STEP(INODE)) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES+KEEP(IXSZ) ICT11 = IOLDPS + HF - 1 + NFRONT J3 = J3 - 1 DO 190 JJ = J1, J3 JPOS = IW(JJ) + ICT11 IW(JJ) = IW(JPOS) 190 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_RESTORE_INDICES SUBROUTINE CMUMPS_ASM_MAX( & N, INODE, IW, LIW, A, LA, & ISON, NBCOLS, & VALSON, PTLUST_S, PTRAST, STEP, PIMASTER, & OPASSW, IWPOSCB,MYID, KEEP,KEEP8 ) USE CMUMPS_LOAD IMPLICIT NONE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8) :: LA INTEGER N,LIW,MYID INTEGER INODE,ISON,IWPOSCB INTEGER NBCOLS INTEGER IW(LIW), STEP(N), & PIMASTER(KEEP(28)), & PTLUST_S(KEEP(28)) INTEGER(8) PTRAST(KEEP(28)) COMPLEX A(LA) REAL VALSON(NBCOLS) DOUBLE PRECISION OPASSW INTEGER HF,HS, NSLAVES, NASS1, & IOLDPS, ISTCHK, & LSTK, NSLSON,NELIM,NPIVS,NCOLS, J1, & JJ1,NROWS INTEGER(8) POSELT, APOS, JJ2 INCLUDE 'mumps_headers.h' LOGICAL SAME_PROC INTRINSIC real IOLDPS = PTLUST_S(STEP(INODE)) POSELT = PTRAST(STEP(INODE)) NASS1 = iabs(IW(IOLDPS + 2 + KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) ISTCHK = PIMASTER(STEP(ISON)) LSTK = IW(ISTCHK + KEEP(IXSZ)) NSLSON = IW(ISTCHK + 5 + KEEP(IXSZ)) HS = 6 + NSLSON + KEEP(IXSZ) NELIM = IW(ISTCHK + 1 + KEEP(IXSZ)) NPIVS = IW(ISTCHK + 3 + KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NCOLS = NPIVS + LSTK SAME_PROC = (ISTCHK.LT.IWPOSCB) IF (SAME_PROC) THEN NROWS = NCOLS ELSE NROWS = IW(ISTCHK+2 + KEEP(IXSZ)) ENDIF J1 = ISTCHK + NROWS + HS + NPIVS APOS = POSELT + int(NASS1,8)*int(NASS1,8) - 1_8 DO JJ1 = 1, NBCOLS JJ2 = APOS+int(IW(J1 + JJ1 - 1),8) IF(real(A(JJ2)) .LT. VALSON(JJ1)) THEN A(JJ2) = cmplx(VALSON(JJ1),kind=kind(A)) ENDIF ENDDO RETURN END SUBROUTINE CMUMPS_ASM_MAX SUBROUTINE CMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, IOLDPS, & A, LA, POSELT, KEEP, KEEP8, & ITLOC, FILS, PTRAIW, PTRARW, INTARR, DBLARR, & LINTARR, LDBLARR, RHS_MUMPS, LRGROUPS) !$ USE OMP_LIB USE CMUMPS_ANA_LR, ONLY : GET_CUT USE CMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT INTEGER(8), intent(in) :: LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX, intent(inout) :: A(LA) COMPLEX, intent(in) :: RHS_MUMPS(KEEP(255)) COMPLEX, intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: INTARR(LINTARR) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(N), PTRARW(N) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, J, K, K1, K2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: J18, J28, JJ8, JK8 INTEGER(8) :: APOS, ICT12 INTEGER(8) :: AINPUT8 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NASS - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) ILOC = ITLOC(J) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF IN = INODE DO WHILE (IN.GT.0) AINPUT8 = PTRARW(IN) JK8 = PTRAIW(IN) JJ8 = JK8 + 1_8 J18 = JJ8 + 1_8 J28 = J18 + INTARR(JK8) IJROW = -ITLOC(INTARR(J18)) ICT12 = POSELT +int(- NBCOLF + IJROW - 1,8) DO JJ8= J18,J28 ILOC = ITLOC(INTARR(JJ8)) IF (ILOC.GT.0) THEN APOS = ICT12 + int(ILOC,8)*int(NBCOLF,8) A(APOS) = A(APOS) + DBLARR(AINPUT8) ENDIF AINPUT8 = AINPUT8 + 1_8 ENDDO IN = FILS(IN) ENDDO K1 = IOLDPS + HF K2 = K1 + NBROWF + NASS - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 ENDDO RETURN END SUBROUTINE CMUMPS_ASM_SLAVE_ARROWHEADS SUBROUTINE CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) IMPLICIT NONE INTEGER, intent(in) :: INODE, NFRONT, NASS1, KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(out) :: PARPIV_T1 INTEGER :: NCB LOGICAL, EXTERNAL :: CMUMPS_IS_TRSM_LARGE_ENOUGH, & CMUMPS_IS_GEMM_LARGE_ENOUGH PARPIV_T1 = KEEP(269) IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.0) RETURN IF ( (PARPIV_T1.EQ.-2).AND.LR_ACTIVATED ) THEN PARPIV_T1 = 1 ENDIF NCB = NFRONT-NASS1 IF (PARPIV_T1.EQ.-2) THEN IF ( & ( CMUMPS_IS_TRSM_LARGE_ENOUGH ( NASS1, NCB & ) & ) & .OR. & ( CMUMPS_IS_GEMM_LARGE_ENOUGH ( NCB, NCB, NASS1 & ) & ) & ) THEN PARPIV_T1 = 1 ELSE PARPIV_T1 = 0 ENDIF ENDIF IF (NCB.EQ.KEEP(253)) THEN PARPIV_T1 = 0 ENDIF RETURN END SUBROUTINE CMUMPS_SET_PARPIVT1 LOGICAL FUNCTION CMUMPS_IS_TRSM_LARGE_ENOUGH & ( M, N & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(M)*dble(N) ) / & ( dble(M)/dble(2) + dble(2)*dble(N) ) CMUMPS_IS_TRSM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION CMUMPS_IS_TRSM_LARGE_ENOUGH LOGICAL FUNCTION CMUMPS_IS_GEMM_LARGE_ENOUGH & ( M, N, K & ) IMPLICIT NONE INTEGER, INTENT(in) :: M, N, K DOUBLE PRECISION :: AI INTEGER, PARAMETER :: THRES_AI = 400 AI = ( dble(2)*dble(M)*dble(N)*dble(K) ) / & ( dble(M)*dble(N) + dble(M)*dble(K) + dble(K)*dble(N) ) CMUMPS_IS_GEMM_LARGE_ENOUGH = (AI.GE.dble(THRES_AI)) RETURN END FUNCTION CMUMPS_IS_GEMM_LARGE_ENOUGH SUBROUTINE CMUMPS_PARPIVT1_SET_MAX ( INODE, & A, LAELL8, KEEP, NFRONT, & NASS1, NVSCHUR_K253 ) & IMPLICIT NONE INTEGER(8), intent(in) :: LAELL8 INTEGER, intent(in) :: INODE INTEGER, intent(in) :: KEEP(500), NFRONT, NASS1, & NVSCHUR_K253 COMPLEX, intent(inout) :: A(LAELL8) INTEGER(8) :: APOSMAX, APOS, NASS1_8, NFRONT_8 INTEGER :: I, J, NCB COMPLEX :: ZERO REAL :: RMAX PARAMETER( ZERO = (0.0E0,0.0E0) ) NASS1_8 = int(NASS1, 8) NFRONT_8 = int(NFRONT, 8) NCB = NFRONT-NASS1-NVSCHUR_K253 IF ((NCB.EQ.0).AND.(NVSCHUR_K253.EQ.0)) CALL MUMPS_ABORT() APOSMAX = LAELL8 - NASS1_8 + 1_8 A(APOSMAX:APOSMAX+NASS1_8-1_8)= ZERO IF (NCB.EQ.0) RETURN IF (KEEP(50).EQ.2) THEN APOS = 1_8 + (NASS1_8*NFRONT_8) DO I = 1, NCB DO J = 1, NASS1 RMAX = real(A(APOSMAX+int(J,8)-1_8)) RMAX = max(RMAX, abs(A(APOS+int(J,8)-1_8))) A(APOSMAX+int(J,8)-1_8) = cmplx(RMAX,kind=kind(A)) ENDDO APOS = APOS+NFRONT_8 ENDDO ELSE APOS = 1_8 + NASS1_8 DO I = 1, NASS1 RMAX = real(A(APOSMAX+int(I,8)-1_8)) DO J = 1, NCB RMAX = max(RMAX, abs(A(APOS+int(J,8)-1))) ENDDO A(APOSMAX+int(I,8)-1_8) = cmplx(RMAX,kind=kind(A)) APOS = APOS+NFRONT_8 ENDDO ENDIF CALL CMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, A(APOSMAX), NASS1) RETURN END SUBROUTINE CMUMPS_PARPIVT1_SET_MAX SUBROUTINE CMUMPS_UPDATE_PARPIV_ENTRIES ( INODE, & KEEP, PARPIV, LPARPIV) IMPLICIT NONE INTEGER, intent(in) :: INODE, LPARPIV, KEEP(500) COMPLEX, intent(inout):: PARPIV(LPARPIV) INTEGER :: I REAL :: EPS, RMIN, RZERO, RTMP LOGICAL :: UPDATE_PARPIV PARAMETER( RZERO = 0.0E0 ) UPDATE_PARPIV=.FALSE. RMIN = huge(RZERO) DO I = 1, LPARPIV RTMP = real(PARPIV(I)) IF (RTMP.GT.RZERO) THEN RMIN = min(RMIN, RTMP) ELSE UPDATE_PARPIV=.TRUE. ENDIF ENDDO IF (UPDATE_PARPIV) THEN IF (RMIN.LT.huge(RMIN)) THEN EPS = sqrt(epsilon(RZERO)) RMIN = min(RMIN, EPS) DO I = 1, LPARPIV RTMP = real(PARPIV(I)) IF (real(PARPIV(I)).EQ.RZERO) THEN PARPIV(I) = cmplx(-RMIN, kind=kind(PARPIV)) ENDIF ENDDO ENDIF ENDIF RETURN END SUBROUTINE CMUMPS_UPDATE_PARPIV_ENTRIES SUBROUTINE CMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX & (N, INODE, IW, LIW, A, LA, KEEP, PERM, & IOLDPS, POSELT, & NFRONT, NASS1, LR_ACTIVATED, PARPIV_T1) USE CMUMPS_FAC_FRONT_AUX_M, & ONLY: CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT IMPLICIT NONE INTEGER, intent(in) :: N, INODE, LIW, IOLDPS, & NFRONT, NASS1 INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: IW (LIW), PERM(N), KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED COMPLEX, intent(inout) :: A(LA) INTEGER, intent(inout) :: PARPIV_T1 INTEGER :: NVSCHUR_K253, IROW_L INTEGER(8) :: LAELL8, NFRONT8 INCLUDE 'mumps_headers.h' IF (PARPIV_T1.EQ.-999) THEN CALL CMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS1, KEEP, & LR_ACTIVATED, PARPIV_T1) ELSE IF ((PARPIV_T1.NE.0.AND.PARPIV_T1.NE.1)) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.NE.0) THEN IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) ) THEN IROW_L = IOLDPS+6+KEEP(IXSZ)+NASS1 CALL CMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS1, & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR_K253 ) ELSE NVSCHUR_K253 = KEEP(253) ENDIF NFRONT8 = int(NFRONT,8) LAELL8 = NFRONT8 * NFRONT8 + int(NASS1,8) CALL CMUMPS_PARPIVT1_SET_MAX ( INODE, & A(POSELT), LAELL8, KEEP, & NFRONT, NASS1, NVSCHUR_K253 ) ENDIF RETURN END SUBROUTINE CMUMPS_PARPIVT1_SET_NVSCHUR_and_MAX MUMPS_5.4.1/src/sfac_process_blfac_slave.F0000664000175000017500000005206014102210521020606 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE SMUMPS_PROCESS_BLFAC_SLAVE( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL,KEEP,KEEP8,DKEEP,IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_LR_CORE USE SMUMPS_LR_TYPE USE SMUMPS_FAC_LR USE SMUMPS_LR_DATA_M USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC USE SMUMPS_DYNAMIC_MEMORY_M, ONLY : SMUMPS_DM_SET_DYNPTR USE SMUMPS_FAC_FRONT_AUX_M, & ONLY : SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT #if defined(BLR_MT) !$ USE OMP_LIB #endif IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: POSFAC, IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER PERM(N), STEP(N), PIMASTER(KEEP(28)) INTEGER IW( LIW ) REAL A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER NELT, LPTRAR INTEGER FRTPTR( N + 1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER COMM, MYID INTEGER PTLUST_S(KEEP(28)) INTEGER ITLOC( N + KEEP(253)), FILS( N ), DAD( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER ND( KEEP(28) ), FRERE_STEPS( KEEP(28) ) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 REAL DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INCLUDE 'mumps_headers.h' INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER INODE, IPOSK, JPOSK, NCOLU, NPIV, POSITION, IERR INTEGER(8) POSELT, POSBLOCFACTO INTEGER(8) LAELL INTEGER(8) :: LA_PTR REAL, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NROW1, NCOL1, NPIV1 INTEGER NSLAVES_TOT, HS, DEST, NSLAVES_FOLLOW INTEGER FPERE INTEGER(8) CPOS, LPOS LOGICAL DYNAMIC LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED INTEGER allocok INTEGER LR_ACTIVATED_INT LOGICAL LR_ACTIVATED, COMPRESS_CB INTEGER NB_BLR_U, CURRENT_BLR_U TYPE (LRB_TYPE), DIMENSION(:), ALLOCATABLE :: BLR_U INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_U TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS, BEGS_BLR_COL INTEGER :: NB_BLR_LS, IPANEL, & MAXI_CLUSTER_LS, MAXI_CLUSTER, & NB_BLR_COL, MAXI_CLUSTER_COL, NPARTSASS_MASTER REAL, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT REAL, ALLOCATABLE, DIMENSION(:,:) :: BLOCKLR REAL,ALLOCATABLE,DIMENSION(:) :: RWORK INTEGER :: OMP_NUM, LWORK INTEGER :: II,JJ INTEGER :: NFS4FATHER, NASS1, NELIM, INFO_TMP(2) INTEGER :: NVSCHUR_K253, NSLAVES_L, IROW_L INTEGER :: NBROWSinF REAL, ALLOCATABLE, DIMENSION(:) :: M_ARRAY REAL, ALLOCATABLE, DIMENSION(:) :: UDYNAMIC REAL ONE,ALPHA PARAMETER (ONE = 1.0E0, ALPHA=-1.0E0) DYNAMIC = .FALSE. POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, JPOSK, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) IF ( NPIV .LE. 0 ) THEN NPIV = - NPIV WRITE(*,*) MYID,':error, received negative NPIV in BLFAC' CALL MUMPS_ABORT() END IF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOLU, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LR_ACTIVATED_INT, 1, & MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IPANEL, 1, & MPI_INTEGER, COMM, IERR ) IF (LR_ACTIVATED) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) CURRENT_BLR_U = 1 ALLOCATE(BLR_U(max(NB_BLR_U,1)), & BEGS_BLR_U(NB_BLR_U+2), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) + NB_BLR_U+2 GOTO 700 endif CALL SMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, JPOSK-1, 0, 'V', & BLR_U, NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE LAELL = int(NPIV,8) * int(NCOLU,8) CALL SMUMPS_GET_SIZE_NEEDED( & 0, LAELL, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID, SLAVEF, & PROCNODE_STEPS, DAD, & IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LAELL LRLUS = LRLUS - LAELL KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LAELL KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LAELL CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8, LAELL,KEEP,KEEP8,LRLUS) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOLU, & MPI_REAL, & COMM, IERR ) ENDIF IF (PTRIST(STEP( INODE )) .EQ. 0) DYNAMIC = .TRUE. IF ( (PTRIST(STEP( INODE )).NE.0) .AND. & (IPOSK + NPIV -1 .GT. & IW(PTRIST(STEP(INODE))+3+KEEP(IXSZ))) )THEN DYNAMIC = .TRUE. ENDIF IF (LR_ACTIVATED) THEN DYNAMIC = .FALSE. ENDIF IF (DYNAMIC) THEN ALLOCATE(UDYNAMIC(LAELL), stat=allocok) if (allocok .GT. 0) THEN IFLAG = -13 CALL MUMPS_SET_IERROR(LAELL,IERROR) GOTO 700 endif UDYNAMIC(1_8:LAELL) = A(POSBLOCFACTO:POSBLOCFACTO+LAELL-1_8) LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN CALL SMUMPS_TREAT_DESCBAND(INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, & IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF DO WHILE ( IPOSK + NPIV -1 .GT. & IW( PTRIST(STEP( INODE )) + 3 +KEEP(IXSZ)) ) MSGSOU = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), & KEEP(199) ) SET_IRECV = .FALSE. BLOCKING = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MSGSOU, BLOC_FACTO_SYM, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP( INODE )) CALL SMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ) ) NROW1 = IW( IOLDPS + 2 + KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NSLAVES_TOT = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAVES_TOT + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (LR_ACTIVATED) THEN CALL SMUMPS_BLR_DEC_AND_RETRIEVE_L (IW(IOLDPS+XXF), IPANEL, & BEGS_BLR_LS, BLR_LS) NB_BLR_LS = size(BEGS_BLR_LS)-2 #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_BLR_UPDATE_TRAILING_I ( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_U(1), size(BEGS_BLR_U), & CURRENT_BLR_U, & BLR_LS(1), NB_BLR_LS+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & 0, & 2, & 1, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR_U, KEEP8) IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) IF (IFLAG.LT.0) GOTO 700 IF (KEEP(486).EQ.3) THEN CALL SMUMPS_BLR_TRY_FREE_PANEL(IW(IOLDPS+XXF), IPANEL, & KEEP8) ENDIF ELSE CPOS = POSELT + int(JPOSK - 1,8) LPOS = POSELT + int(IPOSK - 1,8) IF ( NPIV .GT. 0 ) THEN IF (DYNAMIC) THEN CALL sgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & UDYNAMIC(1), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ELSE CALL sgemm( 'T', 'N', NCOLU, NROW1, NPIV, ALPHA, & A( POSBLOCFACTO ), NPIV, & A_PTR( LPOS ), NCOL1, ONE, & A_PTR( CPOS ), NCOL1 ) ENDIF ENDIF ENDIF IF (NPIV .GT. 0) THEN FLOP1 = dble(NCOLU*NPIV)*dble(2*NROW1) FLOP1 = -FLOP1 CALL SMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8 ) ENDIF IF ( IW(IOLDPS+6+KEEP(IXSZ)).EQ. & huge(IW(IOLDPS+6+KEEP(IXSZ))) ) THEN IW(IOLDPS+6+KEEP(IXSZ)) = 1 ENDIF IW(IOLDPS+6+KEEP(IXSZ)) = & IW(IOLDPS+6+KEEP(IXSZ)) + 1 IF (.NOT.LR_ACTIVATED) THEN IF (DYNAMIC) THEN DEALLOCATE(UDYNAMIC) ELSE LRLU = LRLU + LAELL LRLUS = LRLUS + LAELL KEEP8(69) = KEEP8(69) - LAELL POSFAC = POSFAC - LAELL CALL SMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LAELL,KEEP,KEEP8,LRLUS) ENDIF ENDIF NSLAVES_FOLLOW = IW( IOLDPS + 5 +KEEP(IXSZ) ) - XTRA_SLAVES_SYM IF ( IW( IOLDPS + 6 +KEEP(IXSZ)) .eq. 0 .and. & KEEP(50) .ne. 0 .and. NSLAVES_FOLLOW .eq. 0 ) & THEN DEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)), KEEP(199) ) CALL SMUMPS_BUF_SEND_1INT( INODE, DEST, END_NIV2_LDLT, & COMM, KEEP, IERR ) IF ( IERR .LT. 0 ) THEN write(*,*) ' Internal error in PROCESS_BLFAC_SLAVE.' IFLAG = -99 GOTO 700 END IF END IF IF (IW(PTRIST(STEP(INODE)) + 6+KEEP(IXSZ) ) .eq. 0) THEN NPIV1 = IW( IOLDPS + 3 + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 4 + KEEP(IXSZ)) NELIM = NASS1 - NPIV1 COMPRESS_CB= .FALSE. IF (LR_ACTIVATED) THEN COMPRESS_CB = ((IW(PTRIST(STEP(INODE))+XXLR).EQ.1).OR. & (IW(PTRIST(STEP(INODE))+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (COMPRESS_CB) THEN CALL SMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER) NB_BLR_COL = size(BEGS_BLR_COL) - 1 allocate(CB_LRB(NB_BLR_LS,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_LS*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF DO II=1,NB_BLR_LS DO JJ=1,NB_BLR_COL-NPARTSASS_MASTER NULLIFY(CB_LRB(II,JJ)%Q) NULLIFY(CB_LRB(II,JJ)%R) CB_LRB(II,JJ)%ISLR = .FALSE. ENDDO ENDDO CALL SMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER_LS) CALL MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) MAXI_CLUSTER = max(MAXI_CLUSTER_LS, & MAXI_CLUSTER_COL+NELIM,NPIV) LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCKLR(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 700 ENDIF NFS4FATHER = -9999 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2) ) THEN CALL SMUMPS_BLR_RETRIEVE_NFS4FATHER ( IW(IOLDPS+XXF), & NFS4FATHER ) NFS4FATHER = max(NFS4FATHER,0) + NELIM ENDIF ALLOCATE(M_ARRAY(max(NFS4FATHER,1)), stat=allocok) IF (allocok.gt.0) THEN IFLAG = -13 IERROR = max(NFS4FATHER,1) GOTO 700 ENDIF BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NBROWSinF = 0 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN CALL SMUMPS_COMPUTE_NBROWSinF ( & N, INODE, FPERE, KEEP, & IOLDPS, HS, & IW, LIW, & NROW1, NCOL1, NPIV1, & NELIM, NFS4FATHER, & NBROWSinF & ) ENDIF IF ((KEEP(114).EQ.1) .AND. (KEEP(116).GT.0) & .AND. (KEEP(50).EQ.2) & ) THEN NSLAVES_L = IW(PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IROW_L = PTRIST(STEP(INODE)) + 6 + NSLAVES_L + & KEEP(IXSZ) CALL SMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NROW1, & KEEP(116), & IW(IROW_L), & PERM, NVSCHUR_K253 ) ELSE NVSCHUR_K253 = 0 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL SMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_LS(1), size(BEGS_BLR_LS), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_LS, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1, INODE, & IW(IOLDPS+XXF), 1, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCKLR, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV1, NVSCHUR_K253, KEEP(1), & M_ARRAY, & NELIM, NBROWSinF ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 650 IF ( (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND. & NFS4FATHER.GT.0 ) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL SMUMPS_BLR_SAVE_M_ARRAY( IW(IOLDPS+XXF), & M_ARRAY, INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) ENDIF 650 CONTINUE IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF CALL SMUMPS_END_FACTO_SLAVE( COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND,FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF RETURN 700 CONTINUE CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 600 CONTINUE IF (allocated(BLR_U)) DEALLOCATE(BLR_U) IF (COMPRESS_CB) THEN IF (allocated(BLOCKLR)) DEALLOCATE(BLOCKLR) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(WORK)) DEALLOCATE(WORK) ENDIF IF (allocated(M_ARRAY)) DEALLOCATE(M_ARRAY) IF (DYNAMIC) THEN IF (allocated(UDYNAMIC)) DEALLOCATE(UDYNAMIC) ENDIF RETURN END SUBROUTINE SMUMPS_PROCESS_BLFAC_SLAVE MUMPS_5.4.1/src/ana_AMDMF.F0000664000175000017500000005475714102210475015305 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE MUMPS_SYMQAMD_NEW & ( JOB, THRESH, NDENSE, & N, IWLEN, PE, PFREE, LEN, IW, NV, & ELEN, LAST, NCMPA, DEGREE, HEAD, NEXT, W, & PERM, COMPLEM_LIST, SIZE_COMPLEM_LIST, & AGG6 ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, SIZE_COMPLEM_LIST INTEGER(8), INTENT(IN) :: IWLEN INTEGER, INTENT(IN) :: THRESH LOGICAL, INTENT(IN) :: AGG6 INTEGER, INTENT (IN) :: COMPLEM_LIST(max(1,SIZE_COMPLEM_LIST)) INTEGER, INTENT(INOUT) :: JOB INTEGER, INTENT(INOUT) :: LEN(N), IW(IWLEN) INTEGER(8), INTENT(INOUT) :: PFREE INTEGER(8), INTENT(INOUT) :: PE(N) INTEGER, INTENT(INOUT) :: PERM(N) INTEGER, INTENT(OUT) :: NCMPA INTEGER, INTENT(OUT) :: NV(N), LAST(N) INTEGER, INTENT(INOUT) :: ELEN(N) INTEGER, INTENT(OUT) :: NDENSE(N), DEGREE(N), & HEAD(N), NEXT(N), W(N) INTEGER THRESM, NDME, PERMeqN INTEGER NBD,NBED, NBDM, LASTD, NELME LOGICAL IDENSE INTEGER :: FDEG, ThresMin, ThresPrev, IBEGSchur, & ThresMinINIT LOGICAL :: AGG6_loc INTEGER :: THD_AGG LOGICAL :: SchurON INTEGER :: DEG, DEGME, DEXT, DMAX, E, ELENME, ELN, I, & ILAST, INEXT, J, JLAST, JNEXT, K, KNT1, KNT2, KNT3, & LENJ, LN, ME, MINDEG, NEL, & NLEFT, NVI, NVJ, NVPIV, SLENME, WE, WFLG, WNVI, X INTEGER KNT1_UPDATED, KNT2_UPDATED INTEGER(8) MAXMEM, MEM, NEWMEM INTEGER :: MAXINT_N INTEGER(8) :: HASH, HMOD INTEGER(8) :: P, P1, P2, P3, PDST, PEND, PJ, PME, PME1, PME2, & PN, PSRC, PLN, PELN INTRINSIC max, min, mod IF (N.EQ.1) THEN ELEN(1) = 1 LAST(1) = 1 PE(1) = 0_8 NV(1) = 1 RETURN ENDIF AGG6_loc = AGG6 THD_AGG = max(128, min(N/2048, 1024)) IF ( SIZE_COMPLEM_LIST < 0 .OR. SIZE_COMPLEM_LIST > N ) THEN WRITE(*,*) "Internal MUMPS_SYMQAMD_NEW", SIZE_COMPLEM_LIST,N CALL MUMPS_ABORT() ENDIF IF (JOB.EQ.2) THEN SchurON = .FALSE. ENDIF THRESM = THRESH IF (JOB.NE.2) THEN SchurON = (SIZE_COMPLEM_LIST > 0) IF ((JOB.EQ.1) .AND. (.NOT.SchurON) .AND. (N .GT. 0)) THEN ENDIF IBEGSchur = N-SIZE_COMPLEM_LIST+1 IF (THRESM.GT.N) THRESM = N IF (THRESM.LT.0) THRESM = 0 IF ( SchurON ) THEN DO I= 1, N IF ( PERM(I) .GE. IBEGSchur) THEN PERM(I) = N + 1 IF (LEN(I) .EQ.0) THEN PE(I) = 0_8 ENDIF ENDIF ENDDO ENDIF ENDIF IF (SchurON) THEN THRESM = N ThresMin = N ThresPrev = N ELSE THRESM = max(int(31*N/32),THRESM) THRESM = max(THRESM,1) ThresMin = max( 3*THRESM / 4, 1) ThresPrev = THRESM ENDIF ThresMinINIT = ThresMin/4 IF (THRESM.GT.0) THEN IF ((THRESM.GT.N).OR.(THRESM.LT.2)) THEN THRESM = N ENDIF ENDIF IF (JOB.EQ.2) THEN ENDIF PERMeqN = 0 LASTD = 0 NBD = 0 NBED = 0 NBDM = 0 NEL = 0 WFLG = 2 MAXINT_N=huge(WFLG)-N MINDEG = 1 NCMPA = 0 HMOD = int(max (1, N-1),kind=8) DMAX = 0 MEM = PFREE - 1 MAXMEM = MEM DO 10 I = 1, N NDENSE(I)= 0 LAST (I) = 0 HEAD (I) = 0 NEXT (I) = 0 NV (I) = 1 W (I) = 1 10 CONTINUE IF (JOB.EQ.2) THEN DO I = 1,SIZE_COMPLEM_LIST X = COMPLEM_LIST(I) ELEN(X) = -I NV(X) = LEN(X)+1 DMAX = max(DMAX, LEN(X)) ENDDO NEL = NEL + SIZE_COMPLEM_LIST DO I=1,N DEGREE (I) = LEN (I) ENDDO ELSE DO I=1, N ELEN (I) = 0 DEGREE (I) = LEN (I) ENDDO ENDIF DO 20 I = 1, N IF (ELEN(I).LT.0) CYCLE DEG = DEGREE (I) IF (PERM(I).EQ.N) THEN PERMeqN = I PERM(I) = N-1 ENDIF FDEG = PERM(I) IF ( (DEG .GT. 0).OR.(PERM(I).EQ.N+1) ) THEN IF ( (THRESM.GT.0) .AND. & (FDEG .GT.THRESM) ) THEN NBD = NBD+1 IF (FDEG.NE.N+1) THEN DEGREE(I) = DEGREE(I)+N+2 DEG = N INEXT = HEAD (DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ELSE NBED = NBED+1 DEGREE(I) = N+1 DEG = N IF (LASTD.EQ.0) THEN LASTD = I HEAD(DEG) = I NEXT(I) = 0 LAST(I) = 0 ELSE NEXT(LASTD) = I LAST(I) = LASTD LASTD = I NEXT(I) = 0 ENDIF ENDIF ELSE INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (FDEG) = I ENDIF ELSE NEL = NEL + 1 ELEN (I) = -NEL PE (I) = 0_8 W (I) = 0 ENDIF 20 CONTINUE IF ((NBD.EQ.0).AND.(THRESM.GT.0)) THRESM = N 30 IF (NEL .LT. N) THEN DO 40 DEG = MINDEG, N ME = HEAD (DEG) IF (ME .GT. 0) GO TO 50 40 CONTINUE 50 MINDEG = DEG IF ( (DEG.NE.N) .AND. & (DEG.GT.THRESM+1) .AND. (NBD.GT.0) ) THEN MINDEG = N GOTO 30 ENDIF IF (DEGREE(ME).LE.N) THEN INEXT = NEXT (ME) IF (INEXT .NE. 0) LAST (INEXT) = 0 HEAD (DEG) = INEXT ELSE MINDEG = 1 NBDM = max(NBDM,NBD) IF (DEGREE(ME).GT.N+1) THEN IF (WFLG .GT. MAXINT_N) THEN DO 52 X = 1, N IF (W (X) .NE. 0) W (X) = 1 52 CONTINUE WFLG = 2 ENDIF WFLG = WFLG + 1 51 CONTINUE INEXT = NEXT (ME) IF (INEXT .NE. 0) THEN LAST (INEXT) = 0 ELSE LASTD = 0 ENDIF NDENSE(ME) = 0 W(ME) = WFLG P1 = PE(ME) P2 = P1 + int(LEN(ME) -1,8) PLN = P1 PELN = P1 DO 55 P=P1,P2 E= IW(P) IF (W(E).EQ.WFLG) GOTO 55 W(E) = WFLG IF (PE(E).LT.0_8) THEN X = E 53 X = int(-PE(X)) IF (W(X) .EQ.WFLG) GOTO 55 W(X) = WFLG IF ( PE(X) .LT. 0 ) GOTO 53 E = X ENDIF IF (ELEN(E).LT.0) THEN NDENSE(E) = NDENSE(E) - NV(ME) IW(PLN) = IW(PELN) IW(PELN) = E PLN = PLN + 1_8 PELN = PELN + 1_8 PME1 = PE(E) DO 54 PME = PME1, PME1+LEN(E)-1 X = IW(PME) IF ((ELEN(X).GE.0).AND.(W(X).NE.WFLG)) THEN NDENSE(ME) = NDENSE(ME) + NV(X) W(X) = WFLG ENDIF 54 CONTINUE ELSE NDENSE(ME) = NDENSE(ME) + NV(E) IW(PLN)=E PLN = PLN+1_8 ENDIF 55 CONTINUE WFLG = WFLG + 1 LEN(ME) = int(PLN-P1) ELEN(ME) = int(PELN-P1) NDME = NDENSE(ME)+NV(ME) IF (NDENSE(ME).EQ.0) NDENSE(ME) =1 DEGREE(ME) = NDENSE(ME) DEG = PERM(ME) MINDEG = min(DEG,MINDEG) JNEXT = HEAD(DEG) IF (JNEXT.NE. 0) LAST (JNEXT) = ME NEXT(ME) = JNEXT HEAD(DEG) = ME ME = INEXT IF (ME.NE.0) THEN IF (DEGREE(ME).GT.(N+1) ) GOTO 51 ENDIF HEAD (N) = ME IF (THRESM.LT.N) THEN ThresMin = max(THRESM+ThresMin,ThresPrev+ThresMin/2+1) ThresMin = min(ThresMin, N) ThresPrev = ThresPrev+(N-ThresPrev)/2+ThresMinINIT THRESM = max( & THRESM + int(sqrt(dble(ThresMin)))+ ThresMinINIT , & ThresPrev) THRESM = min(THRESM,N) ThresMin = min(THRESM, ThresMin) ThresPrev = THRESM ENDIF NBD = NBED GOTO 30 ENDIF IF (DEGREE(ME).EQ.N+1) THEN IF (NBD.NE.NBED) THEN write(6,*) ' ERROR in MUMPS_SYMQAMD_NEW ', & ' quasi dense rows remains' CALL MUMPS_ABORT() ENDIF IF (JOB.EQ.1) THEN DO I = 1,SIZE_COMPLEM_LIST X = COMPLEM_LIST(I) ELEN(X) = -(N-SIZE_COMPLEM_LIST+I) NV(X) = 1 PE(X) = 0_8 ENDDO GOTO 265 ENDIF NELME = -(NEL+1) DO 59 X=1,N IF ((PE(X).GT.0_8) .AND. (ELEN(X).LT.0)) THEN PE(X) = int(-COMPLEM_LIST(1),8) ELSEIF (DEGREE(X).EQ.N+1) THEN NEL = NEL + NV(X) PE(X) = int(-ME,8) ELEN(X) = 0 NV(X) = 0 ENDIF 59 CONTINUE ELEN(ME) = NELME NV(ME) = NBD PE(ME) = 0_8 IF (NEL.NE.N) THEN write(6,*) 'Internal ERROR 2 detected in QAMD' write(6,*) ' NEL not equal to N: N, NEL =',N,NEL CALL MUMPS_ABORT() ENDIF IF (ME.NE. COMPLEM_LIST(1)) THEN DO I=1, SIZE_COMPLEM_LIST PE(COMPLEM_LIST(I)) = int(-COMPLEM_LIST(1),8) ENDDO PE(COMPLEM_LIST(1)) = 0_8 NV( COMPLEM_LIST(1))= NV(ME) NV(ME) = 0 ELEN( COMPLEM_LIST(1)) = ELEN(ME) ELEN(ME) = 0 ENDIF GOTO 265 ENDIF ENDIF ELENME = ELEN (ME) ELEN (ME) = - (NEL + 1) NVPIV = NV (ME) NEL = NEL + NVPIV NDENSE(ME) = 0 NV (ME) = -NVPIV DEGME = 0 IF (ELENME .EQ. 0) THEN PME1 = PE (ME) PME2 = PME1 - 1 DO 60 P = PME1, PME1 + int(LEN (ME) - 1,8) I = IW (P) NVI = NV (I) IF (NVI .GT. 0) THEN DEGME = DEGME + NVI NV (I) = -NVI PME2 = PME2 + 1 IW (PME2) = I IF (DEGREE(I).LE.N) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 60 CONTINUE NEWMEM = 0 ELSE P = PE (ME) PME1 = PFREE SLENME = LEN (ME) - ELENME KNT1_UPDATED = 0 DO 120 KNT1 = 1, ELENME + 1 KNT1_UPDATED = KNT1_UPDATED +1 IF (KNT1 .GT. ELENME) THEN E = ME PJ = P LN = SLENME ELSE E = IW (P) P = P + 1 PJ = PE (E) LN = LEN (E) ENDIF KNT2_UPDATED = 0 DO 110 KNT2 = 1, LN KNT2_UPDATED = KNT2_UPDATED+1 I = IW (PJ) PJ = PJ + 1 NVI = NV (I) IF (NVI .GT. 0) THEN IF (PFREE .GT. IWLEN) THEN PE (ME) = P LEN (ME) = LEN (ME) - KNT1_UPDATED KNT1_UPDATED = 0 IF (LEN (ME) .EQ. 0) PE (ME) = 0_8 PE (E) = PJ LEN (E) = LN - KNT2_UPDATED KNT2_UPDATED = 0 IF (LEN (E) .EQ. 0) PE (E) = 0_8 NCMPA = NCMPA + 1 DO 70 J = 1, N PN = PE (J) IF (PN .GT. 0) THEN PE (J) = int(IW (PN),8) IW (PN) = -J ENDIF 70 CONTINUE PDST = 1 PSRC = 1 PEND = PME1 - 1 80 CONTINUE IF (PSRC .LE. PEND) THEN J = -IW (PSRC) PSRC = PSRC + 1 IF (J .GT. 0) THEN IW (PDST) = int(PE (J)) PE (J) = PDST PDST = PDST + 1_8 LENJ = LEN (J) DO 90 KNT3 = 0, LENJ - 2 IW (PDST + KNT3) = IW (PSRC + KNT3) 90 CONTINUE PDST = PDST + int(LENJ - 1,8) PSRC = PSRC + int(LENJ - 1,8) ENDIF GO TO 80 ENDIF P1 = PDST DO 100 PSRC = PME1, PFREE - 1 IW (PDST) = IW (PSRC) PDST = PDST + 1 100 CONTINUE PME1 = P1 PFREE = PDST PJ = PE (E) P = PE (ME) ENDIF DEGME = DEGME + NVI NV (I) = -NVI IW (PFREE) = I PFREE = PFREE + 1 IF (DEGREE(I).LE.N) THEN ILAST = LAST (I) INEXT = NEXT (I) IF (INEXT .NE. 0) LAST (INEXT) = ILAST IF (ILAST .NE. 0) THEN NEXT (ILAST) = INEXT ELSE HEAD (PERM(I)) = INEXT ENDIF ELSE NDENSE(ME) = NDENSE(ME) + NVI ENDIF ENDIF 110 CONTINUE IF (E .NE. ME) THEN PE (E) = int(-ME,8) W (E) = 0 ENDIF 120 CONTINUE PME2 = PFREE - 1 NEWMEM = PFREE - PME1 MEM = MEM + NEWMEM MAXMEM = max (MAXMEM, MEM) ENDIF DEGREE (ME) = DEGME PE (ME) = PME1 LEN (ME) = int(PME2 - PME1 + 1_8) IF (WFLG .GT. MAXINT_N) THEN DO 130 X = 1, N IF (W (X) .NE. 0) W (X) = 1 130 CONTINUE WFLG = 2 ENDIF DO 150 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.N) GOTO 150 ELN = ELEN (I) IF (ELN .GT. 0) THEN NVI = -NV (I) WNVI = WFLG - NVI DO 140 P = PE (I), PE (I) + int(ELN - 1,8) E = IW (P) WE = W (E) IF (WE .GE. WFLG) THEN WE = WE - NVI ELSE IF (WE .NE. 0) THEN WE = DEGREE (E) + WNVI - NDENSE(E) ENDIF W (E) = WE 140 CONTINUE ENDIF 150 CONTINUE AGG6_loc = (AGG6 .OR. (DEGREE(ME) .LT. THD_AGG)) DO 180 PME = PME1, PME2 I = IW (PME) IF (DEGREE(I).GT.N) GOTO 180 P1 = PE (I) P2 = P1 + ELEN (I) - 1 PN = P1 HASH = 0_8 DEG = 0 DO 160 P = P1, P2 E = IW (P) DEXT = W (E) - WFLG IF (DEXT .GT. 0) THEN DEG = DEG + DEXT IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (.NOT. AGG6_loc .AND. DEXT .EQ. 0) THEN IW (PN) = E PN = PN + 1 HASH = HASH + int(E,kind=8) ELSE IF (AGG6_loc .AND. (DEXT .EQ. 0) .AND. & ((NDENSE(ME).EQ.NBD).OR.(NDENSE(E).EQ.0))) THEN PE (E) = int(-ME,8) W (E) = 0 ELSE IF (AGG6_loc .AND. DEXT.EQ.0) THEN IW(PN) = E PN = PN+1 HASH = HASH + int(E,kind=8) ENDIF 160 CONTINUE ELEN (I) = int(PN - P1 + 1_8) P3 = PN DO 170 P = P2 + 1, P1 + LEN (I) - 1 J = IW (P) NVJ = NV (J) IF (NVJ .GT. 0) THEN IF (DEGREE(J).LE.N) DEG=DEG+NVJ IW (PN) = J PN = PN + 1 HASH = HASH + int(J,kind=8) ENDIF 170 CONTINUE IF (((ELEN(I).EQ.1).AND.(P3.EQ.PN)) & .OR. & (AGG6_loc.AND.(DEG .EQ. 0).AND.(NDENSE(ME).EQ.NBD)) & ) & THEN PE (I) = int(-ME, 8) NVI = -NV (I) DEGME = DEGME - NVI NVPIV = NVPIV + NVI NEL = NEL + NVI NV (I) = 0 ELEN (I) = 0 ELSE DEGREE(I) = min (DEG+NBD-NDENSE(ME), & DEGREE(I)) IW (PN) = IW (P3) IW (P3) = IW (P1) IW (P1) = ME LEN (I) = int(PN - P1 + 1) HASH = mod (HASH, HMOD) + 1_8 J = HEAD (HASH) IF (J .LE. 0) THEN NEXT (I) = -J HEAD (HASH) = -I ELSE NEXT (I) = LAST (J) LAST (J) = I ENDIF LAST (I) = int(HASH,kind=kind(LAST)) ENDIF 180 CONTINUE DEGREE (ME) = DEGME DMAX = max (DMAX, DEGME) WFLG = WFLG + DMAX IF (WFLG .GT. MAXINT_N) THEN DO 190 X = 1, N IF (W (X) .NE. 0) W (X) = 1 190 CONTINUE WFLG = 2 ENDIF DO 250 PME = PME1, PME2 I = IW (PME) IF ( (NV(I).LT.0) .AND. (DEGREE(I).LE.N) ) THEN HASH = int(LAST (I),kind=8) J = HEAD (HASH) IF (J .EQ. 0) GO TO 250 IF (J .LT. 0) THEN I = -J HEAD (HASH) = 0 ELSE I = LAST (J) LAST (J) = 0 ENDIF IF (I .EQ. 0) GO TO 250 200 CONTINUE IF (NEXT (I) .NE. 0) THEN X = I LN = LEN (I) ELN = ELEN (I) DO 210 P = PE (I) + 1, PE (I) + int(LN - 1,8) W (IW (P)) = WFLG 210 CONTINUE JLAST = I J = NEXT (I) 220 CONTINUE IF (J .NE. 0) THEN IF (LEN (J) .NE. LN) GO TO 240 IF (ELEN (J) .NE. ELN) GO TO 240 DO 230 P = PE (J) + 1, PE (J) + int(LN - 1,8) IF (W (IW (P)) .NE. WFLG) GO TO 240 230 CONTINUE IF (PERM(J).GT.PERM(X)) THEN PE (J) = int(-X,8) NV (X) = NV (X) + NV (J) NV (J) = 0 ELEN (J) = 0 ELSE PE (X) = int(-J,8) NV (J) = NV (X) + NV (J) NV (X) = 0 ELEN (X) = 0 X = J ENDIF J = NEXT (J) NEXT (JLAST) = J GO TO 220 240 CONTINUE JLAST = J J = NEXT (J) GO TO 220 ENDIF WFLG = WFLG + 1 I = NEXT (I) IF (I .NE. 0) GO TO 200 ENDIF ENDIF 250 CONTINUE IF ( (THRESM .GT. 0).AND.(THRESM.LT.N) ) THEN THRESM = max(ThresMin, THRESM-NVPIV) ENDIF P = PME1 NLEFT = N - NEL DO 260 PME = PME1, PME2 I = IW (PME) NVI = -NV (I) IF (NVI .GT. 0) THEN NV (I) = NVI IF (DEGREE(I).LE.N) THEN DEG = min (DEGREE (I)+ DEGME - NVI, NLEFT - NVI) DEGREE (I) = DEG IDENSE = .FALSE. IF (THRESM.GT.0) THEN IF (PERM(I) .GT. THRESM) THEN IDENSE = .TRUE. DEGREE(I) = DEGREE(I)+N+2 ENDIF IF (IDENSE) THEN P1 = PE(I) P2 = P1 + int(ELEN(I) - 1, 8) IF (P2.GE.P1) THEN DO 264 PJ=P1,P2 E= IW(PJ) NDENSE (E) = NDENSE(E) + NVI 264 CONTINUE ENDIF NBD = NBD+NVI FDEG = N DEG = N INEXT = HEAD(DEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT HEAD (DEG) = I LAST(I) = 0 IF (LASTD.EQ.0) LASTD=I ENDIF ENDIF IF (.NOT.IDENSE) THEN FDEG = PERM(I) INEXT = HEAD (FDEG) IF (INEXT .NE. 0) LAST (INEXT) = I NEXT (I) = INEXT LAST (I) = 0 HEAD (FDEG) = I ENDIF MINDEG = min (MINDEG, FDEG) ENDIF IW (P) = I P = P + 1 ENDIF 260 CONTINUE NV (ME) = NVPIV + DEGME LEN (ME) = int(P - PME1) IF (LEN (ME) .EQ. 0) THEN PE (ME) = 0_8 W (ME) = 0 ENDIF IF (NEWMEM .NE. 0) THEN PFREE = P MEM = MEM - NEWMEM + int(LEN (ME),8) ENDIF GO TO 30 ENDIF 265 CONTINUE DO 290 I = 1, N IF (ELEN (I) .EQ. 0) THEN J = int(-PE (I)) 270 CONTINUE IF (ELEN (J) .GE. 0) THEN J = int(-PE (J)) GO TO 270 ENDIF E = J K = -ELEN (E) J = I 280 CONTINUE IF (ELEN (J) .GE. 0) THEN JNEXT = int(-PE (J)) PE (J)= int(-E,8) IF (ELEN (J) .EQ. 0) THEN ELEN (J) = K K = K + 1 ENDIF J = JNEXT GO TO 280 ENDIF ELEN (E) = -K ENDIF 290 CONTINUE DO 300 I = 1, N K = abs (ELEN (I)) LAST (K) = I ELEN (I) = K 300 CONTINUE IF (.NOT.SchurON) THEN IF (PERMeqN.GT.0) PERM(PERMeqN) = N ENDIF PFREE = MAXMEM RETURN END SUBROUTINE MUMPS_SYMQAMD_NEW MUMPS_5.4.1/src/zfac_driver.F0000664000175000017500000044037014102210526016123 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FAC_DRIVER( id) USE ZMUMPS_BUF USE ZMUMPS_LOAD USE ZMUMPS_OOC USE ZMUMPS_STRUC_DEF USE ZMUMPS_LR_STATS USE ZMUMPS_LR_DATA_M, only: ZMUMPS_BLR_INIT_MODULE, & ZMUMPS_BLR_END_MODULE & , ZMUMPS_BLR_STRUC_TO_MOD & , ZMUMPS_BLR_MOD_TO_STRUC USE MUMPS_FRONT_DATA_MGT_M #if ! defined(NO_FDM_DESCBAND) USE MUMPS_FAC_DESCBAND_DATA_M #endif #if ! defined(NO_FDM_MAPROW) USE MUMPS_FAC_MAPROW_DATA_M #endif !$ USE OMP_LIB C Derived datatype to pass pointers with implicit interfaces USE ZMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T IMPLICIT NONE C C Purpose C ======= C C Performs scaling, sorting in arrowhead, then C distributes the matrix, and perform C factorization. C C INTERFACE SUBROUTINE ZMUMPS_ANORMINF(id, ANORMINF, LSCAL) USE ZMUMPS_STRUC_DEF TYPE (ZMUMPS_STRUC), TARGET :: id DOUBLE PRECISION, INTENT(OUT) :: ANORMINF LOGICAL :: LSCAL END SUBROUTINE ZMUMPS_ANORMINF SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES(id_FDM_F_ENCODING, & id_BLRARRAY_ENCODING, KEEP8) USE MUMPS_FRONT_DATA_MGT_M, only : MUMPS_FDM_STRUC_TO_MOD, & MUMPS_FDM_END USE ZMUMPS_LR_DATA_M, only : ZMUMPS_BLR_STRUC_TO_MOD, & ZMUMPS_BLR_END_MODULE # if defined(MUMPS_F2003) CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER, intent(inout) :: & id_FDM_F_ENCODING # else CHARACTER, DIMENSION(:), POINTER :: id_BLRARRAY_ENCODING CHARACTER, DIMENSION(:), POINTER :: id_FDM_F_ENCODING # endif INTEGER(8), intent(inout) :: KEEP8(150) END SUBROUTINE ZMUMPS_FREE_ID_DATA_MODULES END INTERFACE C C Parameters C ========== C TYPE(ZMUMPS_STRUC), TARGET :: id C C MPI C === C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 C C Local variables C =============== C INCLUDE 'mumps_headers.h' INTEGER(8) :: NSEND8, NSEND_TOT8 INTEGER(8) :: NLOCAL8, NLOCAL_TOT8 INTEGER :: LDPTRAR, NELT_arg, NBRECORDS INTEGER :: ITMP INTEGER :: KEEP464COPY, KEEP465COPY INTEGER(8) :: KEEP826_SAVE INTEGER(8) :: K67, K68, K70, K74, K75 INTEGER(8) ITMP8 INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INTEGER MP, LP, MPG, allocok LOGICAL PROK, PROKG, LSCAL, LPOK, COMPUTE_ANORMINF C Reception buffer INTEGER :: ZMUMPS_LBUFR, ZMUMPS_LBUFR_BYTES INTEGER(8) :: ZMUMPS_LBUFR_BYTES8 ! for intermediate computation INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFR C Size of send buffers (in bytes) INTEGER :: ZMUMPS_LBUF, ZMUMPS_LBUF_INT INTEGER(8) :: ZMUMPS_LBUF8 ! for intermediate computation C INTEGER PTRIST, PTRWB, MAXELT_SIZE, & ITLOC, IPOOL, K28, LPOOL INTEGER IRANK, ID_ROOT INTEGER KKKK INTEGER(8) :: NZ_locMAX8 INTEGER(8) MEMORY_MD_ARG INTEGER(8) MAXS_BASE8, MAXS_BASE_RELAXED8 DOUBLE PRECISION CNTL4, AVG_FLOPS INTEGER MIN_PERLU, MAXIS_ESTIM C TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS INTEGER MAXIS INTEGER(8) :: MAXS C For S argument to arrowhead routines: INTEGER(8) :: MAXS_ARG COMPLEX(kind=8), TARGET :: S_DUMMY_ARG(1) COMPLEX(kind=8), POINTER, DIMENSION(:) :: S_PTR_ARG INTEGER NPIV_CRITICAL_PATH DOUBLE PRECISION TIME, TIMEET DOUBLE PRECISION ZERO, ONE, MONE PARAMETER( ZERO = 0.0D0, ONE = 1.0D0, MONE = -1.0D0) COMPLEX(kind=8) CZERO PARAMETER( CZERO = (0.0D0, 0.0D0) ) INTEGER PERLU, TOTAL_MBYTES, K231, K232, K233, BLR_STRAT INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. INTEGER COLOUR, COMM_FOR_SCALING ! For Simultaneous scaling INTEGER LIWK, LWK_REAL INTEGER(8) :: LWK C I_AM_SLAVE: used to determine if proc has the role of a slave C WK_USER_PROVIDED is set to true when WK_USER is provided by user LOGICAL I_AM_SLAVE, PERLU_ON, WK_USER_PROVIDED, EARLYT3ROOTINS LOGICAL PRINT_MAXAVG DOUBLE PRECISION :: ANORMINF, SEUIL, SEUIL_LDLT_NIV2, Thresh_Seuil DOUBLE PRECISION :: CNTL1, CNTL3, CNTL5, CNTL6, EPS INTEGER N, LPN_LIST,POSBUF INTEGER, DIMENSION (:), ALLOCATABLE :: ITMP2 INTEGER I,K INTEGER(8) :: ITEMP8 INTEGER :: PARPIV_T1 INTEGER FRONTWISE C temporary variables for collecting stats from all processors DOUBLE PRECISION :: TMP_MRY_LU_FR DOUBLE PRECISION :: TMP_MRY_LU_LRGAIN DOUBLE PRECISION :: TMP_MRY_CB_FR DOUBLE PRECISION :: TMP_MRY_CB_LRGAIN DOUBLE PRECISION :: TMP_FLOP_LRGAIN DOUBLE PRECISION :: TMP_FLOP_TRSM DOUBLE PRECISION :: TMP_FLOP_PANEL DOUBLE PRECISION :: TMP_FLOP_FRFRONTS DOUBLE PRECISION :: TMP_FLOP_TRSM_FR DOUBLE PRECISION :: TMP_FLOP_TRSM_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_FR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LR DOUBLE PRECISION :: TMP_FLOP_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_FLOP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_FLOP_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_FLOP_ACCUM_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_COMPRESS DOUBLE PRECISION :: TMP_FLOP_CB_DECOMPRESS DOUBLE PRECISION :: TMP_FLOP_FACTO_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_FR DOUBLE PRECISION :: TMP_FLOP_SOLFWD_LR INTEGER :: TMP_CNT_NODES DOUBLE PRECISION :: TMP_TIME_UPDATE DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR1 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR2 DOUBLE PRECISION :: TMP_TIME_UPDATE_LRLR3 DOUBLE PRECISION :: TMP_TIME_UPDATE_FRLR DOUBLE PRECISION :: TMP_TIME_UPDATE_FRFR DOUBLE PRECISION :: TMP_TIME_COMPRESS DOUBLE PRECISION :: TMP_TIME_MIDBLK_COMPRESS DOUBLE PRECISION :: TMP_TIME_FRSWAP_COMPRESS DOUBLE PRECISION :: TMP_TIME_CB_COMPRESS DOUBLE PRECISION :: TMP_TIME_PANEL DOUBLE PRECISION :: TMP_TIME_FAC_I DOUBLE PRECISION :: TMP_TIME_FAC_MQ DOUBLE PRECISION :: TMP_TIME_FAC_SQ DOUBLE PRECISION :: TMP_TIME_LRTRSM DOUBLE PRECISION :: TMP_TIME_FRTRSM DOUBLE PRECISION :: TMP_TIME_FRFRONTS DOUBLE PRECISION :: TMP_TIME_LR_MODULE DOUBLE PRECISION :: TMP_TIME_DIAGCOPY DOUBLE PRECISION :: TMP_TIME_DECOMP DOUBLE PRECISION :: TMP_TIME_DECOMP_UCFS DOUBLE PRECISION :: TMP_TIME_DECOMP_ASM1 DOUBLE PRECISION :: TMP_TIME_DECOMP_LOCASM2 DOUBLE PRECISION :: TMP_TIME_DECOMP_MAPLIG1 DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2S DOUBLE PRECISION :: TMP_TIME_DECOMP_ASMS2M C C Workspace. C INTEGER, DIMENSION(:), ALLOCATABLE :: IWK COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: WK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: WK_REAL INTEGER(8), DIMENSION(:), ALLOCATABLE :: IWK8 INTEGER, DIMENSION(:), ALLOCATABLE :: BURP INTEGER, DIMENSION(:), ALLOCATABLE :: BUCP INTEGER, DIMENSION(:), ALLOCATABLE :: BURS INTEGER, DIMENSION(:), ALLOCATABLE :: BUCS INTEGER BUREGISTRE(12) INTEGER BUINTSZ, BURESZ, BUJOB INTEGER BUMAXMN, M, SCMYID, SCNPROCS DOUBLE PRECISION SCONEERR, SCINFERR C C Parameters arising from the structure C ===================================== C INTEGER, POINTER :: JOB * Control parameters: see description in ZMUMPSID DOUBLE PRECISION,DIMENSION(:),POINTER::RINFO, RINFOG DOUBLE PRECISION,DIMENSION(:),POINTER:: CNTL INTEGER,DIMENSION(:),POINTER:: INFOG, KEEP INTEGER, DIMENSION(:), POINTER :: MYIRN_loc, MYJCN_loc COMPLEX(kind=8), DIMENSION(:), POINTER :: MYA_loc INTEGER, TARGET :: DUMMYIRN_loc(1), DUMMYJCN_loc(1) COMPLEX(kind=8), TARGET :: DUMMYA_loc(1) INTEGER,DIMENSION(:),POINTER::ICNTL EXTERNAL MUMPS_GET_POOL_LENGTH INTEGER MUMPS_GET_POOL_LENGTH INTEGER(8) :: TOTAL_BYTES INTEGER(8) :: I8TMP, LWK_USER_SUM8 C C External references C =================== INTEGER numroc EXTERNAL numroc INTEGER:: NWORKING LOGICAL:: MEM_EFF_ALLOCATED C Fwd in facto: COMPLEX(kind=8), DIMENSION(:), POINTER :: RHS_MUMPS LOGICAL :: RHS_MUMPS_ALLOCATED INTEGER :: NB_ACTIVE_FRONTS_ESTIM INTEGER :: NB_FRONTS_F_ESTIM C C JOB=>id%JOB RINFO=>id%RINFO RINFOG=>id%RINFOG CNTL=>id%CNTL INFOG=>id%INFOG KEEP=>id%KEEP ICNTL=>id%ICNTL IF (id%KEEP8(29) .NE. 0) THEN MYIRN_loc=>id%IRN_loc MYJCN_loc=>id%JCN_loc MYA_loc=>id%A_loc ELSE MYIRN_loc=>DUMMYIRN_loc MYJCN_loc=>DUMMYJCN_loc MYA_loc=>DUMMYA_loc ENDIF N = id%N EPS = epsilon ( ZERO ) C TIMINGS: reset to 0 id%DKEEP(92)=0.0D0 id%DKEEP(93)=0.0D0 id%DKEEP(94)=0.0D0 id%DKEEP(97)=0.0D0 id%DKEEP(98)=0.0D0 id%DKEEP(56)=0.0D0 C Count of MPI messages: reset to 0 id%KEEP(266)=0 id%KEEP(267)=0 C MIN/MAX pivots reset to 0 id%DKEEP(19)=huge(0.0D0) id%DKEEP(20)=huge(0.0D0) id%DKEEP(21)=0.0D0 C Number of symmetric swaps id%KEEP8(80)=0_8 C Largest increase of internal panel size id%KEEP(425) =0 C PRINT_MAXAVG = .NOT.(id%NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) C C BEGIN CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C Data from factorization is now freed asap C id%S, id%IS IF (id%KEEP8(24).EQ.0_8) THEN C -- deallocate only when not provided/allocated by the user IF (associated(id%S)) THEN DEALLOCATE(id%S) id%KEEP8(23)=0_8 NULLIFY(id%S) ENDIF ENDIF IF (associated(id%IS)) THEN DEALLOCATE(id%IS) NULLIFY(id%IS) ENDIF C Free BLR factors, if any CALL ZMUMPS_FREE_ID_DATA_MODULES(id%FDM_F_ENCODING, & id%BLRARRAY_ENCODING, id%KEEP8(1)) IF (associated(id%root%RG2L_ROW))THEN DEALLOCATE(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_ROW) ENDIF IF (associated(id%root%RG2L_COL))THEN DEALLOCATE(id%root%RG2L_COL) NULLIFY(id%root%RG2L_COL) ENDIF IF (associated( id%PTLUST_S )) THEN DEALLOCATE(id%PTLUST_S) NULLIFY(id%PTLUST_S) ENDIF IF (associated(id%PTRFAC)) THEN DEALLOCATE(id%PTRFAC) NULLIFY(id%PTRFAC) END IF IF (associated(id%RHSCOMP)) THEN DEALLOCATE(id%RHSCOMP) NULLIFY(id%RHSCOMP) id%KEEP8(25)=0_8 ENDIF IF (associated(id%POSINRHSCOMP_ROW)) THEN DEALLOCATE(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_ROW) ENDIF IF (id%POSINRHSCOMP_COL_ALLOC) THEN DEALLOCATE(id%POSINRHSCOMP_COL) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. ENDIF C C END CASE OF ALLOCATED DATA FROM PREVIOUS CALLS C C Related to forward in facto functionality (referred to as "Fwd in facto") NULLIFY(RHS_MUMPS) RHS_MUMPS_ALLOCATED = .FALSE. C ----------------------------------------------------------------------- C Set WK_USER_PROVIDED to true when workspace WK_USER is provided by user C We can accept WK_USER to be provided on only one proc and C different values of WK_USER per processor C IF (id%KEEP8(24).GT.0_8) THEN C We nullify S so that later when we test C if (associated(S) we can free space and reallocate it). NULLIFY(id%S) ENDIF C C -- KEEP8(24) can now then be reset safely WK_USER_PROVIDED = (id%LWK_USER.NE.0) IF (WK_USER_PROVIDED) THEN IF (id%LWK_USER.GT.0) THEN id%KEEP8(24) = int(id%LWK_USER,8) ELSE id%KEEP8(24) = -int(id%LWK_USER,8)* 1000000_8 ENDIF ELSE id%KEEP8(24) = 0_8 ENDIF C Compute sum of LWK_USER provided by user LWK_USER_SUM8 = 0_8 CALL MPI_REDUCE ( id%KEEP8(24), LWK_USER_SUM8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) C C KEEP8(26) might be modified C (element entry format) C but need be restore for C future factorisation C with different scaling option C KEEP826_SAVE = id%KEEP8(26) C In case of loop on factorization with C different scaling options, initialize C DKEEP(4:5) to 0. id%DKEEP(4)=-1.0D0 id%DKEEP(5)=-1.0D0 C Mapping information used during solve. In case of several facto+solve C it has to be recomputed. In case of several solves with the same C facto, it is not recomputed. IF (associated(id%IPTR_WORKING)) THEN DEALLOCATE(id%IPTR_WORKING) NULLIFY(id%IPTR_WORKING) END IF IF (associated(id%WORKING)) THEN DEALLOCATE(id%WORKING) NULLIFY(id%WORKING) END IF C C Units for printing C MP: diagnostics C LP: errors C LP = ICNTL( 1 ) MP = ICNTL( 2 ) MPG = ICNTL( 3 ) LPOK = ((LP.GT.0).AND.(id%ICNTL(4).GE.1)) PROK = ((MP.GT.0).AND.(id%ICNTL(4).GE.2)) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. MASTER ) PROKG = (PROKG.AND.(id%ICNTL(4).GE.2)) IF ( PROK ) WRITE( MP, 130 ) IF ( PROKG ) WRITE( MPG, 130 ) C ------------------------------------- C Depending on the type of parallelism, C the master can now (soon) potentially C have the role of a slave C ------------------------------------- I_AM_SLAVE = ( id%MYID .ne. MASTER .OR. & ( id%MYID .eq. MASTER .AND. & KEEP(46) .eq. 1 ) ) C C Prepare work for out-of-core C IF (id%MYID .EQ. MASTER .AND. KEEP(201) .NE. -1) THEN C Note that if KEEP(201)=-1, then we have decided C at analysis phase that factors will not be stored C (neither in memory nor on disk). In that case, C ICNTL(22) is ignored. C -- ICNTL(22) must be set before facto phase C (=1 OOC on; =0 OOC off) C and cannot be changed for subsequent solve phases. KEEP(201)=id%ICNTL(22) IF (KEEP(201) .NE. 0) THEN # if defined(OLD_OOC_NOPANEL) KEEP(201)=2 # else KEEP(201)=1 # endif ENDIF ENDIF C ---------------------- C Broadcast KEEP options C defined for facto: C ---------------------- CALL MPI_BCAST( KEEP(12), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(19), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(21), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(201), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) PERLU = KEEP(12) IF (id%MYID.EQ.MASTER) THEN C KEEP(50) case C ============== C C KEEP(50) = 0 : matrix is unsymmetric C KEEP(50) /= 0 : matrix is symmetric C KEEP(50) = 1 : Ask L L^T on the root. Matrix is PSD. C KEEP(50) = 2 : Ask for L U on the root C KEEP(50) = 3 ... L D L^T ?? C CNTL1 = id%CNTL(1) C --------------------------------------- C For symmetric (non general) matrices C set (directly) CNTL1 = 0.0 C --------------------------------------- KEEP(17)=0 IF ( KEEP(50) .eq. 1 ) THEN IF (CNTL1 .ne. ZERO ) THEN IF ( PROKG ) THEN WRITE(MPG,'(A)') & '** Warning : SPD solver called, resetting CNTL(1) to 0.0D0' END IF END IF CNTL1 = ZERO END IF C CNTL1 threshold value must be between C 0.0 and 1.0 (for SYM=0) and 0.5 (for SYM=1,2) IF (CNTL1.GT.ONE) CNTL1=ONE IF (CNTL1.LT.ZERO) CNTL1=ZERO IF (KEEP(50).NE.0.AND.CNTL1.GT.0.5D0) THEN CNTL1 = 0.5D0 ENDIF PARPIV_T1 = id%KEEP(268) IF (PARPIV_T1.EQ.77) THEN PARPIV_T1 = 0 ENDIF IF (PARPIV_T1.EQ.-3) THEN PARPIV_T1 = 0 ENDIF IF ((PARPIV_T1.LT.-3).OR.(PARPIV_T1.GT.1)) THEN C out of range values PARPIV_T1 =0 ENDIF C note that KEEP(50).EQ.1 => CNTL1=0.0 IF (CNTL1.EQ.0.0.OR.(KEEP(50).eq.1)) PARPIV_T1 = 0 C IF (PARPIV_T1.EQ.-2) THEN IF (KEEP(19).NE.0) THEN C switch off PARPIV_T1 if RR activated C but do NOT switch off PARPIV_1 with null pivot detection PARPIV_T1 = 0 ENDIF ENDIF id%KEEP(269) = PARPIV_T1 ENDIF CALL MPI_BCAST(CNTL1, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) CALL MPI_BCAST( KEEP(269), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (id%MYID.EQ.MASTER) THEN C ----------------------------------------------------- C Decoding of ICNTL(35) for factorization: same as C at analysis except that we store a copy of ICNTL(35) C in KEEP(486) instead of KEEP(494) and need to check C compatibility of KEEP(486) and KEEP(494): If LR was C not activated during analysis, it cannot be activated C at factorization. C ------------------------------------------------------ id%KEEP(486) = id%ICNTL(35) IF (id%KEEP(486).EQ.1) THEN C -- Automatic BLR option setting id%KEEP(486)= 2 ENDIF IF ( id%KEEP(486).EQ.4) id%KEEP(486)=0 IF ((id%KEEP(486).LT.0).OR.(id%KEEP(486).GT.4)) THEN C Out of range values treated as 0 id%KEEP(486) = 0 ENDIF IF ((KEEP(486).NE.0).AND.(KEEP(494).EQ.0)) THEN C To activate BLR during factorization, C ICNTL(35) must have been set at analysis. IF (LPOK) THEN WRITE(LP,'(A)') & " *** Error with BLR setting " WRITE(LP,'(A)') " *** BLR was not activated during ", & " analysis but is requested during factorization." ENDIF id%INFO(1)=-54 id%INFO(2)=0 GOTO 105 ENDIF KEEP464COPY = id%ICNTL(38) IF (KEEP464COPY.LT.0.OR.KEEP464COPY.GT.1000) THEN C Out of range values treated as 0 KEEP464COPY = 0 ENDIF IF (id%KEEP(461).LT.1) THEN id%KEEP(461) = 10 ENDIF KEEP465COPY=0 IF (id%ICNTL(36).EQ.1.OR.id%ICNTL(36).EQ.3) THEN IF (CNTL1.EQ.ZERO .OR. KEEP(468).LE.1) THEN KEEP(475) = 3 ELSE IF ( (KEEP(269).GT.0).OR. (KEEP(269).EQ.-2)) THEN KEEP(475) = 2 ELSE IF (KEEP(468).EQ.2) THEN KEEP(475) = 2 ELSE KEEP(475) = 1 ENDIF ELSE KEEP(475) = 0 ENDIF KEEP(481)=0 IF (id%ICNTL(36).LT.0 .OR. id%ICNTL(36).GE.2) THEN C Only options 1 and 2 are allowed KEEP(475) = 0 ENDIF C K489 is set according to ICNTL(37) IF (id%ICNTL(37).EQ.0.OR.id%ICNTL(37).EQ.1) THEN KEEP(489) = id%ICNTL(37) ELSE C Other values treated as zero KEEP(489) = 0 ENDIF IF (KEEP(79).GE.1) THEN C CompressCB incompatible with type4,5,6 nodes KEEP(489)=0 ENDIF KEEP(489)=0 C id%KEEP(476) \in [1,100] IF ((id%KEEP(476).GT.100).OR.(id%KEEP(476).LT.1)) THEN id%KEEP(476)= 50 ENDIF C id%KEEP(477) \in [1,100] IF ((id%KEEP(477).GT.100).OR.(id%KEEP(477).LT.1)) THEN id%KEEP(477)= 100 ENDIF C id%KEEP(483) \in [1,100] IF ((id%KEEP(483).GT.100).OR.(id%KEEP(483).LT.1)) THEN id%KEEP(483)= 50 ENDIF C id%KEEP(484) \in [1,100] IF ((id%KEEP(484).GT.100).OR.(id%KEEP(484).LT.1)) THEN id%KEEP(484)= 50 ENDIF C id%KEEP(480)=0,2,3,4,5,6 IF ((id%KEEP(480).GT.6).OR.(id%KEEP(480).LT.0) & .OR.(id%KEEP(480).EQ.1)) THEN id%KEEP(480)=0 ENDIF C id%KEEP(473)=0 or 1 IF ((id%KEEP(473).NE.0).AND.(id%KEEP(473).NE.1)) THEN id%KEEP(473)=0 ENDIF C id%KEEP(474)=0,1,2,3 IF ((id%KEEP(474).GT.3).OR.(id%KEEP(474).LT.0)) THEN id%KEEP(474)=0 ENDIF C id%KEEP(479)>0 IF (id%KEEP(479).LE.0) THEN id%KEEP(479)=1 ENDIF IF (id%KEEP(474).NE.0.AND.id%KEEP(480).EQ.0) THEN id%KEEP(474) = 0 ENDIF IF (id%KEEP(478).NE.0.AND.id%KEEP(480).LT.4) THEN id%KEEP(478) = 0 ENDIF IF (id%KEEP(480).GE.5 .OR. & (id%KEEP(480).NE.0.AND.id%KEEP(474).EQ.3)) THEN IF (id%KEEP(475).LT.2) THEN C Reset to 3 if 5 or to 4 if 6 id%KEEP(480) = id%KEEP(480) - 2 write(*,*) ' Resetting KEEP(480) to ', id%KEEP(480) ENDIF ENDIF 105 CONTINUE ENDIF ! id%MYID .EQ. MASTER CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 CALL MPI_BCAST( KEEP(473), 14, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(486).NE.0) THEN CALL MPI_BCAST( KEEP(489), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP464COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP465COPY, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF IF (id%MYID.EQ.MASTER) THEN IF (KEEP(217).GT.2.OR.KEEP(217).LT.0) THEN KEEP(217)=0 ENDIF KEEP(214)=KEEP(217) IF (KEEP(214).EQ.0) THEN IF (KEEP(201).NE.0) THEN ! OOC or no factors KEEP(214)=1 ELSE KEEP(214)=2 ENDIF IF (KEEP(486).EQ.2) THEN KEEP(214)=1 ENDIF ENDIF ENDIF CALL MPI_BCAST( KEEP(214), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) IF (KEEP(201).NE.0) THEN C -- Low Level I/O strategy CALL MPI_BCAST( KEEP(99), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(205), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) CALL MPI_BCAST( KEEP(211), 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) ENDIF C Fwd in facto: explicitly forbid C sparse RHS and A-1 computation IF (id%KEEP(252).EQ.1 .AND. id%MYID.EQ.MASTER) THEN IF (id%ICNTL(20).EQ.1) THEN ! out-of-range => 0 C NB: in doc ICNTL(20) only accessed during solve C In practice, will have failed earlier if RHS not allocated. C Still it looks safer to keep this test. id%INFO(1)=-43 id%INFO(2)=20 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Sparse RHS is incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(30).NE.0) THEN ! out-of-range => 1 id%INFO(1)=-43 id%INFO(2)=30 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: A-1 functionality incompatible with forward', & ' performed during factorization (ICNTL(32)=1)' ELSE IF (id%ICNTL(9) .NE. 1) THEN id%INFO(1)=-43 id%INFO(2)=9 IF (LPOK) WRITE(LP,'(A)') & ' ERROR: Transpose system (ICNTL(9).NE.0) not ', & ' compatible with forward performed during', & ' factorization (ICNTL(32)=1)' ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C IF (id%INFO(1).LT.0) GOTO 530 C C The memory allowed is given by ICNTL(23) in Mbytes C 0 means that nothing is provided. C Save memory available, ICNTL(23) in KEEP8(4) C IF ( id%MYID.EQ.MASTER ) THEN ITMP = ICNTL(23) END IF CALL MPI_BCAST( ITMP, 1, MPI_INTEGER, & MASTER, id%COMM, IERR ) C C Ignore ICNTL(23) when WK_USER is provided c by resetting ITMP to zero on each proc where WK_USER is provided IF (WK_USER_PROVIDED) ITMP = 0 ITMP8 = int(ITMP, 8) id%KEEP8(4) = ITMP8 * 1000000_8 ! convert to nb of bytes IF ( PROKG ) THEN NWORKING = id%NSLAVES WRITE( MPG, 172 ) NWORKING, id%ICNTL(22), KEEP(486), & KEEP(12), & id%KEEP8(111), KEEP(126), KEEP(127), KEEP(28), & id%KEEP8(4)/1000000_8, LWK_USER_SUM8, CNTL1 IF (KEEP(252).GT.0) & WRITE(MPG,173) KEEP(253) IF (KEEP(269).NE.0) & WRITE(MPG,174) KEEP(269) ENDIF IF (KEEP(201).LE.0) THEN C In-core version or no factors KEEP(IXSZ)=XSIZE_IC ELSE IF (KEEP(201).EQ.2) THEN C OOC version, no panels KEEP(IXSZ)=XSIZE_OOC_NOPANEL ELSE IF (KEEP(201).EQ.1) THEN C Panel versions: IF (KEEP(50).EQ.0) THEN KEEP(IXSZ)=XSIZE_OOC_UNSYM ELSE KEEP(IXSZ)=XSIZE_OOC_SYM ENDIF ENDIF IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Stats initialization for LR CALL INIT_STATS_GLOBAL(id) END IF C * ********************************** * Begin intializations regarding the * computation of the determinant * ********************************** IF (id%MYID.EQ.MASTER) KEEP(258)=ICNTL(33) CALL MPI_BCAST(KEEP(258), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF (KEEP(258) .NE. 0) THEN KEEP(259) = 0 ! Initial exponent of the local determinant KEEP(260) = 1 ! Number of permutations id%DKEEP(6) = 1.0D0 ! real part of the local determinant id%DKEEP(7) = 0.0D0 ! imaginary part of the local determinant ENDIF * ******************************** * End intializations regarding the * computation of the determinant * ******************************** C * ********************** * Begin of Scaling phase * ********************** C C SCALING MANAGEMENT C * Options 1, 3, 4 centralized only C C * Options 7, 8 : also works for distributed matrix C C At this point, we have the scaling arrays allocated C on the master. They have been allocated on the master C inside the main MUMPS driver. C CALL MPI_BCAST(KEEP(52), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) LSCAL = ((KEEP(52) .GT. 0) .AND. (KEEP(52) .LE. 8)) IF (LSCAL) THEN C IF ( id%MYID.EQ.MASTER ) THEN CALL MUMPS_SECDEB(TIMEET) ENDIF C ----------------------- C Retrieve parameters for C simultaneous scaling C ----------------------- IF (KEEP(52) .EQ. 7) THEN C -- Cheap setting of SIMSCALING (it is the default in 4.8.4) K231= KEEP(231) K232= KEEP(232) K233= KEEP(233) ELSEIF (KEEP(52) .EQ. 8) THEN C -- More expensive setting of SIMSCALING (it was the default in 4.8.1,2,3) K231= KEEP(239) K232= KEEP(240) K233= KEEP(241) ENDIF CALL MPI_BCAST(id%DKEEP(3),1,MPI_DOUBLE_PRECISION,MASTER, & id%COMM,IERR) C IF ( ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) .AND. & KEEP(54).NE.0 ) THEN C ------------------------------ C Scaling for distributed matrix C We need to allocate scaling C arrays on all processors, not C only the master. C ------------------------------ IF ( id%MYID .NE. MASTER ) THEN IF ( associated(id%COLSCA)) & DEALLOCATE( id%COLSCA ) IF ( associated(id%ROWSCA)) & DEALLOCATE( id%ROWSCA ) ALLOCATE( id%COLSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ALLOCATE( id%ROWSCA(N), stat=IERR) IF (IERR .GT.0) THEN id%INFO(1)=-13 id%INFO(2)=N ENDIF ENDIF M = N BUMAXMN=M IF(N > BUMAXMN) BUMAXMN = N LIWK = 4*BUMAXMN ALLOCATE (IWK(LIWK),BURP(M),BUCP(N), & BURS(2* (id%NPROCS)),BUCS(2* (id%NPROCS)), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+M+N+4* (id%NPROCS) ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 1 C -- LWK not used LWK_REAL = 1 ALLOCATE(WK_REAL(LWK_REAL), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 CALL ZMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LIWK < BUINTSZ) THEN DEALLOCATE(IWK) LIWK = BUINTSZ ALLOCATE(IWK(LIWK), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK ENDIF ENDIF LWK_REAL = BURESZ DEALLOCATE(WK_REAL) ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LWK_REAL ENDIF C --- Propagate enventual error CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 517 C -- estimation of memory and construction of partvecs BUJOB = 2 CALL ZMUMPS_SIMSCALEABS( & MYIRN_loc(1), MYJCN_loc(1), MYA_loc(1), & id%KEEP8(29), & M, N, id%NPROCS, id%MYID, id%COMM, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(IWK, WK_REAL,BURP,BUCP,BURS, BUCS) ELSE IF ( KEEP(54) .EQ. 0 ) THEN C ------------------ C Centralized matrix C ------------------ IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN C ------------------------------- C Create a communicator of size 1 C ------------------------------- IF (id%MYID.EQ.MASTER) THEN COLOUR = 0 ELSE COLOUR = MPI_UNDEFINED ENDIF CALL MPI_COMM_SPLIT( id%COMM, COLOUR, 0, & COMM_FOR_SCALING, IERR ) IF (id%MYID.EQ.MASTER) THEN M = N BUMAXMN=N CXXXX IF(N > BUMAXMN) BUMAXMN = N LIWK = 1 ALLOCATE (IWK(LIWK),BURP(1),BUCP(1), & BURS(1),BUCS(1), & stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=LIWK+1+1+1+1 ENDIF LWK_REAL = M + N ALLOCATE (WK_REAL(LWK_REAL), stat=allocok) IF (allocok > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 ENDIF IF (id%INFO(1) .LT. 0) GOTO 400 CALL MPI_COMM_RANK(COMM_FOR_SCALING, SCMYID, IERR) CALL MPI_COMM_SIZE(COMM_FOR_SCALING, SCNPROCS, IERR) BUJOB = 1 CALL ZMUMPS_SIMSCALEABS( & id%IRN(1), id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) IF(LWK_REAL < BURESZ) THEN ! internal error since LWK_REAL=BURESZ=M+N id%INFO(1) = -136 GOTO 400 ENDIF BUJOB = 2 CALL ZMUMPS_SIMSCALEABS(id%IRN(1), & id%JCN(1), id%A(1), & id%KEEP8(28), & M, N, SCNPROCS, SCMYID, COMM_FOR_SCALING, & BURP, BUCP, & BURS, BUCS, BUREGISTRE, & IWK, LIWK, & BUINTSZ, BURESZ, BUJOB, & id%ROWSCA(1), id%COLSCA(1), WK_REAL, LWK_REAL, & id%KEEP(50), & K231, K232, K233, & id%DKEEP(3), & SCONEERR, SCINFERR) id%DKEEP(4) = SCONEERR id%DKEEP(5) = SCINFERR CXXXX DEALLOCATE(WK_REAL) DEALLOCATE (IWK,BURP,BUCP, & BURS,BUCS) ENDIF C Centralized matrix: make DKEEP(4:5) available to all processors CALL MPI_BCAST( id%DKEEP(4),2,MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) 400 CONTINUE IF (id%MYID.EQ.MASTER) THEN C Communicator should only be C freed on the master process CALL MPI_COMM_FREE(COMM_FOR_SCALING, IERR) ENDIF CALL MUMPS_PROPINFO(ICNTL(1), id%INFO(1), & id%COMM, id%MYID) IF (id%INFO(1).LT.0) GOTO 517 ELSE IF (id%MYID.EQ.MASTER) THEN C ---------------------------------- C Centralized scaling, options 1 to 6 C ---------------------------------- IF (KEEP(52).GT.0 .AND. KEEP(52).LE.6) THEN C --------------------- C Allocate temporary C workspace for scaling C --------------------- IF ( KEEP(52) .eq. 5 .or. & KEEP(52) .eq. 6 ) THEN C We have an explicit copy of the original C matrix in complex format which should probably C be avoided (but do we want to keep all C those old scaling options ?) LWK = id%KEEP8(28) ELSE LWK = 1_8 END IF LWK_REAL = 5 * N ALLOCATE( WK_REAL( LWK_REAL ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = LWK_REAL GOTO 137 END IF ALLOCATE( WK( LWK ), stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) GOTO 137 END IF CALL ZMUMPS_FAC_A(N, id%KEEP8(28), KEEP(52), id%A(1), & id%IRN(1), id%JCN(1), & id%COLSCA(1), id%ROWSCA(1), & WK, LWK, WK_REAL, LWK_REAL, ICNTL(1), id%INFO(1) ) DEALLOCATE( WK_REAL ) DEALLOCATE( WK ) ENDIF ENDIF ENDIF ! Scaling distributed matrices or centralized IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIMEET) id%DKEEP(92)=TIMEET C Print inf-norm after last KEEP(233) iterations of C scaling option KEEP(52)=7 or 8 (SimScale) C IF (PROKG.AND.(KEEP(52).EQ.7.OR.KEEP(52).EQ.8) & .AND. (K233+K231+K232).GT.0) THEN IF (K232.GT.0) WRITE(MPG, 166) id%DKEEP(4) ENDIF ENDIF ENDIF ! LSCAL C C scaling might also be provided by the user LSCAL = (LSCAL .OR. (KEEP(52) .EQ. -1) .OR. KEEP(52) .EQ. -2) IF (LSCAL .AND. KEEP(258).NE.0 .AND. id%MYID .EQ. MASTER) THEN DO I = 1, id%N CALL ZMUMPS_UPDATEDETER_SCALING(id%ROWSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO IF (KEEP(50) .EQ. 0) THEN ! unsymmetric DO I = 1, id%N CALL ZMUMPS_UPDATEDETER_SCALING(id%COLSCA(I), & id%DKEEP(6), ! determinant & KEEP(259)) ! exponent of the determinant ENDDO ELSE C ----------------------------------------- C In this case COLSCA = ROWSCA C Since determinant was initialized to 1, C compute square of the current determinant C rather than going through COLSCA. C ----------------------------------------- CALL ZMUMPS_DETER_SQUARE(id%DKEEP(6), KEEP(259)) ENDIF C Now we should have taken the C inverse of the scaling vectors CALL ZMUMPS_DETER_SCALING_INVERSE(id%DKEEP(6), KEEP(259)) ENDIF C C ******************** C End of Scaling phase C At this point: either (matrix is distributed and KEEP(52)=7 or 8) C in which case scaling arrays are allocated on all processors, C or scaling arrays are only on the host processor. C In case of distributed matrix input, we will free the scaling C arrays on procs with MYID .NE. 0 after the all-to-all distribution C of the original matrix. C ******************** C 137 CONTINUE C Fwd in facto: in case of repeated factorizations C with different Schur options we prefer to free C systematically this array now than waiting for C the root node. We rely on the fact that it is C allocated or not during the solve phase so if C it was allocated in a 1st call to facto and not C in a second, we don't want the solve to think C it was allocated in the second call. IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN DEALLOCATE (id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF C Fwd in facto: check that id%NRHS has not changed IF ( id%MYID.EQ.MASTER.AND. KEEP(252).EQ.1 .AND. & id%NRHS .NE. id%KEEP(253) ) THEN C Error: NRHS should not have C changed since the analysis id%INFO(1)=-42 id%INFO(2)=id%KEEP(253) ENDIF C Fwd in facto: allocate and broadcast RHS_MUMPS C to make it available on all processors. IF (id%KEEP(252) .EQ. 1) THEN IF ( id%MYID.NE.MASTER ) THEN id%KEEP(254) = N ! Leading dimension id%KEEP(255) = N*id%KEEP(253) ! Tot size ALLOCATE(RHS_MUMPS(id%KEEP(255)),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(255) IF (LPOK) & WRITE(LP,*) 'ERROR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ELSE C Case of non working master id%KEEP(254)=id%LRHS ! Leading dimension id%KEEP(255)=id%LRHS*(id%KEEP(253)-1)+id%N ! Tot size RHS_MUMPS=>id%RHS RHS_MUMPS_ALLOCATED = .FALSE. IF (LSCAL) THEN C Scale before broadcast: apply row C scaling (remark that we assume no C transpose). DO K=1, id%KEEP(253) DO I=1, N RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & = RHS_MUMPS( id%KEEP(254) * (K-1) + I ) & * id%ROWSCA(I) ENDDO ENDDO ENDIF ENDIF ELSE id%KEEP(255)=1 ALLOCATE(RHS_MUMPS(1),stat=IERR) IF (IERR > 0) THEN id%INFO(1)=-13 id%INFO(2)=1 IF (LPOK) & WRITE(LP,*) 'ERREUR while allocating RHS on a slave' NULLIFY(RHS_MUMPS) ENDIF RHS_MUMPS_ALLOCATED = .TRUE. ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 IF (KEEP(252) .EQ. 1) THEN C C Broadcast the columns of the right-hand side C one by one. Leading dimension is keep(254)=N C on procs with MYID > 0 but may be larger on C the master processor. DO I= 1, id%KEEP(253) CALL MPI_BCAST(RHS_MUMPS((I-1)*id%KEEP(254)+1), N, & MPI_DOUBLE_COMPLEX, MASTER,id%COMM,IERR) END DO ENDIF C Keep a copy of ICNTL(24) and make it C available on all working processors. KEEP(110)=id%ICNTL(24) CALL MPI_BCAST(KEEP(110), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) C KEEP(110) defaults to 0 for out of range values IF (KEEP(110).NE.1) KEEP(110)=0 IF (KEEP(219).NE.0) THEN CALL ZMUMPS_BUF_MAX_ARRAY_MINSIZE(max(KEEP(108),1),IERR) IF (IERR .NE. 0) THEN C ------------------------ C Error allocating ZMUMPS_BUF C ------------------------ id%INFO(1) = -13 id%INFO(2) = max(KEEP(108),1) END IF ENDIF C ----------------------------------------------- C Depending on the option used for C -detecting null pivots (ICNTL(24)/KEEP(110)) C CNTL(3) is used to set DKEEP(1) C ( A row is considered as null if ||row|| < DKEEP(1) ) C CNTL(5) is then used to define if a large C value is set on the diagonal or if a 1 is set C and other values in the row are reset to zeros. C SEUIL* corresponds to the minimum required C absolute value of pivot. C SEUIL_LDLT_NIV2 is used only in the C case of SYM=2 within a niv2 node for which C we have only a partial view of the fully summed rows. IF (id%MYID .EQ. MASTER) CNTL3 = id%CNTL(3) CALL MPI_BCAST(CNTL3, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL5 = id%CNTL(5) CALL MPI_BCAST(CNTL5, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) CNTL6 = id%CNTL(6) CALL MPI_BCAST(CNTL6, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) IF (id%MYID .EQ. MASTER) id%DKEEP(8) = id%CNTL(7) CALL MPI_BCAST(id%DKEEP(8), 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR) id%DKEEP(11) = id%DKEEP(8)/id%KEEP(461) id%DKEEP(12) = id%DKEEP(8)/id%KEEP(462) IF (KEEP(486).EQ.0) id%DKEEP(8) = ZERO COMPUTE_ANORMINF = .FALSE. IF ( (KEEP(486) .NE. 0).AND. (id%DKEEP(8).LT.ZERO)) THEN COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(19).NE.0) THEN C Rank revealing factorisation COMPUTE_ANORMINF = .TRUE. ENDIF IF (KEEP(110).NE.0) THEN C Null pivot detection COMPUTE_ANORMINF = .TRUE. ENDIF C ------------------------------------------------------- C We compute ANORMINF, when needed, based on C the infinite norm of Rowsca *A*Colsca C and make it available on all working processes. IF (COMPUTE_ANORMINF) THEN CALL ZMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ELSE ANORMINF = ZERO ENDIF C C Set BLR threshold IF (id%DKEEP(8).LT.ZERO) THEN id%DKEEP(8) = abs(id%DKEEP(8))*ANORMINF ENDIF IF ((KEEP(19).NE.0).OR.(KEEP(110).NE.0)) THEN IF (PROKG) THEN WRITE(MPG,'(A,1PD16.4)') & ' Effective value of CNTL(3) =',CNTL3 ENDIF ENDIF IF (KEEP(19).EQ.0) THEN C -- RR is off SEUIL = ZERO id%DKEEP(9) = ZERO ELSE C -- RR is on C C CNTL(3) is the threshold used in the following to compute C DKEEP(9) the threshold under which the sing val. are considered C as null and from which we start to look for a gap between two C sing val. IF (CNTL3 .LT. ZERO) THEN id%DKEEP(9) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(9) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN ENDIF IF (PROKG) THEN WRITE(MPG, '(A,I10)') & 'ICNTL(56) rank revealing effective value =',KEEP(19) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for singularities on the root =',id%DKEEP(9) ENDIF C RR postponing considers that pivot rows with norm smaller C than SEUIL should be postponed. C SEUIL should be bigger than DKEEP(9), this means that C DKEEP(13) should be bigger than 1. Thresh_Seuil = id%DKEEP(13) IF (id%DKEEP(13).LT.1) Thresh_Seuil = 10 SEUIL = id%DKEEP(9)*Thresh_Seuil IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Threshold for postponing =',SEUIL ENDIF !end KEEP(19) SEUIL_LDLT_NIV2 = SEUIL C ------------------------------- C -- Null pivot row detection C ------------------------------- IF (KEEP(110).EQ.0) THEN C -- Null pivot is off C Initialize DKEEP(1) to a negative value C in order to avoid detection of null pivots C (test max(AMAX,RMAX,abs(PIVOT)).LE.PIVNUL C in ZMUMPS_FAC_I, where PIVNUL=DKEEP(1)) id%DKEEP(1) = -1.0D0 id%DKEEP(2) = ZERO ELSE C -- Null pivot is on IF (KEEP(19).NE.0) THEN C -- RR is on C RR postponing considers that pivot rows of norm smaller that SEUIL C should be postponed, but pivot rows smaller than DKEEP(1) are C directly added to null space and thus considered as null pivot rows. IF ((id%DKEEP(10).LE.0).OR.(id%DKEEP(10).GT.1)) THEN C DKEEP(10) is out of range, set to the default value 10-1 id%DKEEP(1) = id%DKEEP(9)*1D-1 ELSE id%DKEEP(1) = id%DKEEP(9)*id%DKEEP(10) ENDIF ELSE C -- RR is off C -- only Null pivot detection C We keep strategy currently used in MUMPS 4.10.0 IF (CNTL3 .LT. ZERO) THEN id%DKEEP(1) = abs(CNTL(3)) ELSE IF (CNTL3 .GT. ZERO) THEN id%DKEEP(1) = CNTL3*ANORMINF ELSE ! (CNTL(3) .EQ. ZERO) THEN c id%DKEEP(1) = NPIV_CRITICAL_PATH*EPS*ANORMINF CALL MUMPS_NPIV_CRITICAL_PATH( & N, KEEP(28), id%STEP(1), id%FRERE_STEPS(1), id%FILS(1), & id%NA(1), id%LNA, id%NE_STEPS(1), NPIV_CRITICAL_PATH ) id%DKEEP(1) = sqrt(dble(NPIV_CRITICAL_PATH))*EPS*ANORMINF ENDIF ENDIF ! fin rank revealing IF ((KEEP(110).NE.0).AND.(PROKG)) THEN WRITE(MPG, '(A,I16)') & ' ICNTL(24) null pivot rows detection =',KEEP(110) WRITE(MPG,'(A,1PD16.4)') & ' ...Zero pivot detection threshold =',id%DKEEP(1) ENDIF IF (CNTL5.GT.ZERO) THEN id%DKEEP(2) = CNTL5 * ANORMINF IF (PROKG) WRITE(MPG,'(A,1PD10.3)') & ' ...Fixation for null pivots =',id%DKEEP(2) ELSE IF (PROKG) WRITE(MPG,*) '...Infinite fixation ' IF (id%KEEP(50).EQ.0) THEN C Unsym ! the user let us choose a fixation. set in NEGATIVE ! to detect during facto when to set row to zero ! id%DKEEP(2) = -max(1.0D10*ANORMINF, & sqrt(huge(ANORMINF))/1.0D8) ELSE C Sym id%DKEEP(2) = ZERO ENDIF ENDIF ENDIF ! fin null pivot detection. C Find id of root node if RR is on IF (KEEP(53).NE.0) THEN ID_ROOT =MUMPS_PROCNODE(id%PROCNODE_STEPS(id%STEP(KEEP(20))), & id%KEEP(199)) IF ( KEEP( 46 ) .NE. 1 ) THEN ID_ROOT = ID_ROOT + 1 END IF ENDIF C Second pass: set parameters for null pivot detection C Allocate PIVNUL_LIST in case of null pivot detection LPN_LIST = 1 IF ( associated( id%PIVNUL_LIST) ) DEALLOCATE(id%PIVNUL_LIST) IF(KEEP(110) .EQ. 1) THEN LPN_LIST = N ENDIF IF (KEEP(19).NE.0 .AND. & (ID_ROOT.EQ.id%MYID .OR. id%MYID.EQ.MASTER)) THEN LPN_LIST = N ENDIF ALLOCATE( id%PIVNUL_LIST(LPN_LIST),stat = IERR ) IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=LPN_LIST END IF id%PIVNUL_LIST(1:LPN_LIST) = 0 KEEP(109) = 0 C end set parameter for null pivot detection CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).lt.0 ) GOTO 517 C -------------------------------------------------------------- C STATIC PIVOTING C -- Static pivoting only when RR and Null pivot detection OFF C -------------------------------------------------------------- IF ((KEEP(19).EQ.0).AND.(KEEP(110).EQ.0)) THEN IF (id%MYID .EQ. MASTER) CNTL4 = id%CNTL(4) CALL MPI_BCAST( CNTL4, 1, MPI_DOUBLE_PRECISION, & MASTER, id%COMM, IERR ) C IF ( CNTL4 .GE. ZERO ) THEN KEEP(97) = 1 IF ( CNTL4 .EQ. ZERO ) THEN C -- set seuil to sqrt(eps)*||A|| IF(ANORMINF .EQ. ZERO) THEN CALL ZMUMPS_ANORMINF( id , ANORMINF, LSCAL ) ENDIF SEUIL = sqrt(EPS) * ANORMINF ELSE SEUIL = CNTL4 ENDIF SEUIL_LDLT_NIV2 = SEUIL C ELSE SEUIL = ZERO ENDIF ENDIF C set number of tiny pivots / 2x2 pivots in types 1 / C 2x2 pivots in types 2, to zero. This is because the C user can call the factorization step several times. KEEP(98) = 0 KEEP(103) = 0 KEEP(105) = 0 MAXS = 1_8 * * Start allocations * ***************** * C C The slaves can now perform the factorization C C C Allocate id%S on all nodes C or point to user provided data WK_USER when LWK_USER>0 C ======================= C C Compute BLR_STRAT and a first estimation C of MAXS, the size of id%S CALL ZMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & id%KEEP(1), id%KEEP8(1)) C MAXS = MAXS_BASE_RELAXED8 IF (WK_USER_PROVIDED) THEN C -- Set MAXS to size of WK_USER_ MAXS = id%KEEP8(24) ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF C id%KEEP8(75) = huge(id%KEEP8(75)) id%KEEP8(76) = huge(id%KEEP8(76)) IF ((.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (id%KEEP8(4) .NE. 0_8) THEN C ------------------------- C WE TRY TO USE MEM_ALLOWED (KEEP8(4)/1D6) C ------------------------- C Set MAXS given BLR_STRAT, KEEP(201) and MAXS_BASE_RELAXED8 CALL ZMUMPS_MEM_ALLOWED_SET_MAXS ( & MAXS, & BLR_STRAT, id%KEEP(201), MAXS_BASE_RELAXED8, & id%KEEP(1), id%KEEP8(1), id%MYID, id%N, id%NELT, & id%NA(1), id%LNA, id%NSLAVES, & KEEP464COPY, KEEP465COPY, & id%INFO(1), id%INFO(2) & ) ENDIF ! MEM_ALLOWED C ENDIF ! (.NOT.WK_USER_PROVIDED).AND.(I_AM_SLAVE)) THEN C IF (I_AM_SLAVE) THEN ENDIF ! I_AM_SLAVE) C CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) .LT. 0) THEN GOTO 517 ENDIF CALL MUMPS_SETI8TOI4(MAXS, id%INFO(39)) CALL ZMUMPS_AVGMAX_STAT8(PROKG, MPG, MAXS, id%NSLAVES, & PRINT_MAXAVG, & id%COMM, " Effective size of S (based on INFO(39))= ") C IF ( I_AM_SLAVE ) THEN C ------------------ C Dynamic scheduling C ------------------ CALL ZMUMPS_LOAD_SET_INICOST( dble(id%COST_SUBTREES), & KEEP(64), id%DKEEP(15), KEEP(375), MAXS ) K28=KEEP(28) MEMORY_MD_ARG = min(int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8 ), C Restrict freedom from dynamic scheduler when C MEM_ALLOWED=ICNTL(23) is small (case where KEEP8(4)-MAXS_BASE8 C is negative after call to ZMUMPS_MAX_MEM) & max(0_8, MAXS-MAXS_BASE8)) CALL ZMUMPS_LOAD_INIT( id, MEMORY_MD_ARG, MAXS ) C C Out-Of-Core (OOC) issues. Case where we ran one factorization OOC C and the second one is in-core: we try to free OOC C related data from previous factorization. C CALL ZMUMPS_CLEAN_OOC_DATA(id, IERR) IF (IERR < 0) THEN id%INFO(1) = -90 id%INFO(2) = 0 GOTO 112 ENDIF IF (KEEP(201) .GT. 0) THEN C ------------------- C OOC initializations C ------------------- IF (KEEP(201).EQ.1 !PANEL Version & .AND.KEEP(50).EQ.0 ! Unsymmetric & .AND.KEEP(251).NE.2 ! Store L to disk & ) THEN id%OOC_NB_FILE_TYPE=2 ! declared in MUMPS_OOC_COMMON ELSE id%OOC_NB_FILE_TYPE=1 ! declared in MUMPS_OOC_COMMON ENDIF C ------------------------------ C Dimension IO buffer, KEEP(100) C ------------------------------ IF (KEEP(205) .GT. 0) THEN KEEP(100) = KEEP(205) ELSE IF (KEEP(201).EQ.1) THEN ! PANEL version I8TMP = int(id%OOC_NB_FILE_TYPE,8) * & 2_8 * int(KEEP(226),8) ELSE I8TMP = 2_8 * id%KEEP8(119) ENDIF I8TMP = I8TMP + int(max(KEEP(12),0),8) * & (I8TMP/100_8+1_8) C we want to avoid too large IO buffers. C 12M corresponds to 100Mbytes given to buffers. I8TMP = min(I8TMP, 12000000_8) KEEP(100)=int(I8TMP) ENDIF IF (KEEP(201).EQ.1) THEN C Panel version. Force the use of a buffer. IF ( KEEP(99) < 3 ) THEN KEEP(99) = KEEP(99) + 3 ENDIF ENDIF C -------------------------- C Reset KEEP(100) to 0 if no C buffer is used for OOC. C -------------------------- IF (KEEP(99) .LT.3) KEEP(100)=0 IF((dble(KEEP(100))*dble(KEEP(35))/dble(2)).GT. & (dble(1999999999)))THEN IF (PROKG) THEN WRITE(MPG,*)id%MYID,': Warning: DIM_BUF_IO might be & too big for Filesystem' ENDIF ENDIF ALLOCATE (id%OOC_INODE_SEQUENCE(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_INODE_SEQUENCE) GOTO 112 ENDIF ALLOCATE (id%OOC_TOTAL_NB_NODES(id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE NULLIFY(id%OOC_TOTAL_NB_NODES) GOTO 112 ENDIF ALLOCATE (id%OOC_SIZE_OF_BLOCK(KEEP(28), & id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_SIZE_OF_BLOCK) GOTO 112 ENDIF ALLOCATE (id%OOC_VADDR(KEEP(28),id%OOC_NB_FILE_TYPE), & stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = id%OOC_NB_FILE_TYPE*KEEP(28) NULLIFY(id%OOC_VADDR) GOTO 112 ENDIF ENDIF ENDIF 112 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1) < 0) THEN C LOAD_END must be done but not OOC_END_FACTO GOTO 513 ENDIF IF (I_AM_SLAVE) THEN IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL ZMUMPS_OOC_INIT_FACTO(id,MAXS) ELSE WRITE(*,*) "Internal error in ZMUMPS_FAC_DRIVER" CALL MUMPS_ABORT() ENDIF IF(id%INFO(1).LT.0)THEN GOTO 111 ENDIF ENDIF C First increment corresponds to the number of C floating-point operations for subtrees allocated C to the local processor. CALL ZMUMPS_LOAD_UPDATE(0,.FALSE.,dble(id%COST_SUBTREES), & id%KEEP(1),id%KEEP8(1)) IF (id%INFO(1).LT.0) GOTO 111 END IF C ----------------------- C Manage main workarray S C ----------------------- EARLYT3ROOTINS = KEEP(200) .EQ.0 #if defined (LARGEMATRICES) IF ( id%MYID .ne. MASTER ) THEN #endif IF (.NOT.WK_USER_PROVIDED) THEN IF ( EARLYT3ROOTINS ) THEN C Standard allocation strategy ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(MAXS, id%INFO(2)) C On some platforms (IBM for example), an C allocation failure returns a non-null pointer. C Therefore we nullify S NULLIFY(id%S) id%KEEP8(23)=0_8 ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) id%KEEP8(23) = 0_8 ENDIF #if defined (LARGEMATRICES) END IF #endif C 111 CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 514 C -------------------------- C Initialization of modules C related to data management C -------------------------- NB_ACTIVE_FRONTS_ESTIM = 3 IF (I_AM_SLAVE) THEN C CALL MUMPS_FDM_INIT('A',NB_ACTIVE_FRONTS_ESTIM, id%INFO) C IF ( (KEEP(486).EQ.2) & .OR. ((KEEP(489).NE.0).AND.(KEEP(400).GT.1)) & ) THEN C In case of LRSOLVE or CompressCB, C initialize nb of handlers to nb of BLR C nodes estimated at analysis NB_FRONTS_F_ESTIM = KEEP(470) ELSE IF (KEEP(489).NE.0) THEN C Compress CB and no L0 OMP (or 1 thread under L0): C NB_ACTIVE_FRONTS_ESTIM is too small, C to limit nb of reallocations make it twice larger NB_FRONTS_F_ESTIM = 2*NB_ACTIVE_FRONTS_ESTIM ELSE NB_FRONTS_F_ESTIM = NB_ACTIVE_FRONTS_ESTIM ENDIF ENDIF CALL MUMPS_FDM_INIT('F',NB_FRONTS_F_ESTIM, id%INFO ) IF (id%INFO(1) .LT. 0 ) GOTO 114 #if ! defined(NO_FDM_DESCBAND) C Storage of DESCBAND information CALL MUMPS_FDBD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif #if ! defined(NO_FDM_MAPROW) C Storage of MAPROW and ROOT2SON information CALL MUMPS_FMRD_INIT( NB_ACTIVE_FRONTS_ESTIM, id%INFO ) #endif CALL ZMUMPS_BLR_INIT_MODULE( NB_FRONTS_F_ESTIM, id%INFO ) 114 CONTINUE ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C GOTO 500: one of the above module initializations failed IF ( id%INFO(1).LT.0 ) GOTO 500 C C C Allocate space for matrix in arrowhead C ====================================== C C CASE 1 : Matrix is assembled C CASE 2 : Matrix is elemental C IF ( KEEP(55) .eq. 0 ) THEN C ------------------------------------ C Space has been allocated already for C the integer part during analysis C Only slaves need the arrowheads. C ------------------------------------ IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE .and. id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = IERR ) ELSE ALLOCATE( id%DBLARR( 1 ), stat =IERR ) END IF IF ( IERR .NE. 0 ) THEN IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for DBLARR(',id%KEEP8(26),')' ENDIF id%INFO(1)=-13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE C ---------------------------------------- C Allocate variable lists. Systematically. C ---------------------------------------- IF ( associated( id%INTARR ) ) THEN DEALLOCATE( id%INTARR ) NULLIFY( id%INTARR ) END IF IF ( I_AM_SLAVE .and. id%KEEP8(27) .ne. 0_8 ) THEN ALLOCATE( id%INTARR( id%KEEP8(27) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(27), id%INFO(2)) NULLIFY(id%INTARR) GOTO 100 END IF ELSE ALLOCATE( id%INTARR(1),stat=allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) GOTO 100 END IF END IF C ----------------------------- C Allocate real values. C On master, if hybrid host and C no scaling, avoid the copy. C ----------------------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF IF ( I_AM_SLAVE ) THEN IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN C -------------------------- C Simple pointer association C -------------------------- id%DBLARR => id%A_ELT ELSE C ---------- C Allocation C ---------- IF ( id%KEEP8(26) .ne. 0_8 ) THEN ALLOCATE( id%DBLARR( id%KEEP8(26) ), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(id%KEEP8(26), id%INFO(2)) NULLIFY(id%DBLARR) GOTO 100 END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF ELSE ALLOCATE( id%DBLARR(1), stat = allocok ) IF ( allocok .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%DBLARR) GOTO 100 END IF END IF END IF C ----------------- C Also prepare some C data for the root C ----------------- IF ( KEEP(38).NE.0 .AND. I_AM_SLAVE ) THEN CALL ZMUMPS_INIT_ROOT_FAC( id%N, & id%root, id%FILS(1), KEEP(38), id%KEEP(1), id%INFO(1) ) END IF C C 100 CONTINUE C ---------------- C Check for errors C ---------------- CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C C ----------------------------------- C C DISTRIBUTION OF THE ORIGINAL MATRIX C C ----------------------------------- C C TIMINGS: computed (and printed) on the host C Next line: global time for distrib(arrowheads,elts) C on the host. Synchronization has been performed. IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C ------------------------------------------- C S_PTR_ARG / MAXS_ARG will be used for id%S C argument to arrowhead/element distribution C routines: if id%S is not allocated, we pass C S_DUMMY_ARG instead, which is not accessed. C ------------------------------------------- IF (EARLYT3ROOTINS) THEN S_PTR_ARG => id%S MAXS_ARG = MAXS ELSE S_PTR_ARG => S_DUMMY_ARG MAXS_ARG = 1 ENDIF C IF ( KEEP( 55 ) .eq. 0 ) THEN C ---------------------------- C Original matrix is assembled C Arrowhead format to be used. C ---------------------------- C KEEP8(26) and KEEP8(27) hold the number of entries for real/integer C for the matrix in arrowhead format. They have been set by the C analysis phase (ZMUMPS_ANA_F and ZMUMPS_ANA_G) C C ------------------------------------------------------------------ C Blocking is used for sending arrowhead records (I,J,VAL) C buffer(1) is used to store number of bytes already packed C buffer(2) number of records already packed C KEEP(39) : Number of records (blocking factor) C ------------------------------------------------------------------ C C --------------------------------------------- C In case of parallel root compute minimum C size of workspace to receive arrowheads C of root node. Will be used to check that C MAXS is large enough for arrowheads (case C of EARLYT3ROOTINS (KEEP(200)=0); if .NOT. C EARLYT3ROOTINS (KEEP(200)=1), root will C be assembled into id%S later and size of C id%S will be checked later) C --------------------------------------------- IF (EARLYT3ROOTINS .AND. KEEP(38).NE.0 .AND. & KEEP(60) .EQ.0 .AND. I_AM_SLAVE) THEN LWK = int(numroc( id%root%ROOT_SIZE, id%root%MBLOCK, & id%root%MYROW, 0, id%root%NPROW ),8) LWK = max( 1_8, LWK ) LWK = LWK* & int(numroc( id%root%ROOT_SIZE, id%root%NBLOCK, & id%root%MYCOL, 0, id%root%NPCOL ),8) LWK = max( 1_8, LWK ) ELSE LWK = 1_8 ENDIF C MAXS must be at least 1, and in case of C parallel root, large enough to receive C arrowheads of root. IF (MAXS .LT. int(LWK,8)) THEN id%INFO(1) = -9 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 C IF ( KEEP(54) .eq. 0 ) THEN C ================================================ C FIRST CASE : MATRIX IS NOT INITIALLY DISTRIBUTED C ================================================ C A small integer workspace is needed to C send the arrowheads. IF ( id%MYID .eq. MASTER ) THEN ALLOCATE(IWK(id%N), stat=allocok) IF ( allocok .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%N END IF #if defined(LARGEMATRICES) ALLOCATE (WK(LWK),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 CALL MUMPS_SET_IERROR(LWK, id%INFO(2)) write(6,*) ' PB1 ALLOC LARGEMAT' ENDIF #endif ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1).LT.0 ) GOTO 500 IF ( id%MYID .eq. MASTER ) THEN C C -------------------------------- C MASTER sends arowheads using the C global communicator with ranks C also in global communicator C IWK is used as temporary C workspace of size N. C -------------------------------- IF ( .not. associated( id%INTARR ) ) THEN ALLOCATE( id%INTARR( 1 ),stat=IERR) IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = 1 NULLIFY(id%INTARR) write(6,*) ' PB2 ALLOC INTARR' CALL MUMPS_ABORT() ENDIF ENDIF NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF #if defined(LARGEMATRICES) CALL ZMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP,id%KEEP8, & id%FILS(1), IWK(1), ! workspace of size N & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), WK(1), LWK, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1)) C write(6,*) '!!! A,IRN,JCN are freed during factorization ' DEALLOCATE (id%A) NULLIFY(id%A) DEALLOCATE (id%IRN) NULLIFY (id%IRN) DEALLOCATE (id%JCN) NULLIFY (id%JCN) IF (.NOT.WK_USER_PROVIDED) THEN IF (EARLYT3ROOTINS) THEN ALLOCATE (id%S(MAXS),stat=IERR) id%KEEP8(23) = MAXS IF ( IERR .GT. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = MAXS NULLIFY(id%S) id%KEEP8(23)=0_8 write(6,*) ' PB2 ALLOC LARGEMAT',MAXS CALL MUMPS_ABORT() ENDIF ENDIF ENDIF ELSE id%S => id%WK_USER(1:id%KEEP8(24)) ENDIF IF (EARLYT3ROOTINS) THEN id%S(MAXS-LWK+1_8:MAXS) = WK(1_8:LWK) ENDIF DEALLOCATE (WK) #else CALL ZMUMPS_FACTO_SEND_ARROWHEADS(id%N, id%KEEP8(28), id%A(1), & id%IRN(1), id%JCN(1), id%SYM_PERM(1), & LSCAL, id%COLSCA(1), id%ROWSCA(1), & id%MYID, id%NSLAVES, id%PROCNODE_STEPS(1), & NBRECORDS, & LP, id%COMM, id%root, KEEP(1),id%KEEP8(1), & id%FILS(1), IWK(1), & & id%INTARR(1), id%KEEP8(27), id%DBLARR(1), id%KEEP8(26), & id%PTRAR(1), id%PTRAR(id%N+1), & id%FRERE_STEPS(1), id%STEP(1), S_PTR_ARG(1), MAXS_ARG, & id%ISTEP_TO_INIV2(1), id%I_AM_CAND(1), & id%CANDIDATES(1,1) ) #endif DEALLOCATE(IWK) ELSE NBRECORDS = KEEP(39) IF (id%KEEP8(28) .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(id%KEEP8(28)) ENDIF CALL ZMUMPS_FACTO_RECV_ARROWHD2( id%N, & id%DBLARR(1), id%KEEP8(26), & id%INTARR(1), id%KEEP8(27), & id%PTRAR( 1 ), & id%PTRAR(id%N+1), & KEEP( 1 ), id%KEEP8(1), id%MYID, id%COMM, & NBRECORDS, & & S_PTR_ARG(1), MAXS_ARG, & id%root, & id%PROCNODE_STEPS(1), id%NSLAVES, & id%SYM_PERM(1), id%FRERE_STEPS(1), id%STEP(1), & id%INFO(1), id%INFO(2) ) ENDIF ELSE C C ============================================= C SECOND CASE : MATRIX IS INITIALLY DISTRIBUTED C ============================================= C Timing on master. IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECDEB(TIME) END IF IF ( I_AM_SLAVE ) THEN C --------------------------------------------------- C In order to have possibly IRN_loc/JCN_loc/A_loc C of size 0, avoid to pass them inside REDISTRIBUTION C and pass id instead C NZ_locMAX8 gives as a maximum buffer size (send/recv) used C an upper bound to limit buffers on small matrices C --------------------------------------------------- CALL MPI_ALLREDUCE(id%KEEP8(29), NZ_locMAX8, 1, MPI_INTEGER8, & MPI_MAX, id%COMM_NODES, IERR) NBRECORDS = KEEP(39) IF (NZ_locMAX8 .LT. int(NBRECORDS,8)) THEN NBRECORDS = int(NZ_locMAX8) ENDIF CALL ZMUMPS_REDISTRIBUTION( id%N, & id%KEEP8(29), & id, & id%DBLARR(1), id%KEEP8(26), id%INTARR(1), & id%KEEP8(27), id%PTRAR(1), id%PTRAR(id%N+1), & KEEP(1), id%KEEP8(1), id%MYID_NODES, & id%COMM_NODES, NBRECORDS, & S_PTR_ARG(1), MAXS_ARG, id%root, id%PROCNODE_STEPS(1), & id%NSLAVES, id%SYM_PERM(1), id%STEP(1), & id%ICNTL(1), id%INFO(1), NSEND8, NLOCAL8, & id%ISTEP_TO_INIV2(1), & id%CANDIDATES(1,1) ) IF ( ( KEEP(52).EQ.7 ).OR. (KEEP(52).EQ.8) ) THEN C ------------------------------------------------- C In that case, scaling arrays have been allocated C on all processors. They were useful for matrix C distribution. But we now really only need them C on the host. In case of distributed solution, we C will have to broadcast either ROWSCA or COLSCA C (depending on MTYPE) but this is done later. C C In other words, on exit from the factorization, C we want to have scaling arrays available only C on the host. C ------------------------------------------------- IF ( id%MYID > 0 ) THEN IF (associated(id%ROWSCA)) THEN DEALLOCATE(id%ROWSCA) NULLIFY(id%ROWSCA) ENDIF IF (associated(id%COLSCA)) THEN DEALLOCATE(id%COLSCA) NULLIFY(id%COLSCA) ENDIF ENDIF ENDIF #if defined(LARGEMATRICES) C deallocate id%IRN_loc, id%JCN(loc) to free extra space C Note that in this case IRN_loc cannot be used C anymore during the solve phase for IR and Error analysis. IF (associated(id%IRN_loc)) THEN DEALLOCATE(id%IRN_loc) NULLIFY(id%IRN_loc) ENDIF IF (associated(id%JCN_loc)) THEN DEALLOCATE(id%JCN_loc) NULLIFY(id%JCN_loc) ENDIF IF (associated(id%A_loc)) THEN DEALLOCATE(id%A_loc) NULLIFY(id%A_loc) ENDIF write(6,*) ' Warning :', & ' id%A_loc, IRN_loc, JCN_loc deallocated !!! ' #endif IF (PROK) THEN WRITE(MP,120) NLOCAL8, NSEND8 END IF END IF IF ( KEEP(46) .eq. 0 .AND. id%MYID.eq.MASTER ) THEN C ------------------------------ C The host is not working -> had C no data from initial matrix C ------------------------------ NSEND8 = 0_8 NLOCAL8 = 0_8 END IF C -------------------------- C Put into some info/infog ? C -------------------------- CALL MPI_REDUCE( NSEND8, NSEND_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( NLOCAL8, NLOCAL_TOT8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF ( PROKG ) THEN WRITE(MPG,125) NLOCAL_TOT8, NSEND_TOT8 END IF C C ------------------------- C Check for possible errors C ------------------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C ENDIF ELSE C ------------------- C Matrix is elemental, C provided on the C master only C ------------------- IF ( id%MYID.eq.MASTER) & CALL ZMUMPS_MAXELT_SIZE( id%ELTPTR(1), & id%NELT, & MAXELT_SIZE ) C C Perform the distribution of the elements. C A this point, C PTRAIW/PTRARW have been computed. C INTARR/DBLARR have been allocated C ELTPROC gives the mapping of elements C CALL ZMUMPS_ELT_DISTRIB( id%N, id%NELT, id%KEEP8(30), & id%COMM, id%MYID, & id%NSLAVES, id%PTRAR(1), & id%PTRAR(id%NELT+2), & id%INTARR(1), id%DBLARR(1), id%KEEP8(27), id%KEEP8(26), & id%KEEP(1), id%KEEP8(1), MAXELT_SIZE, & id%FRTPTR(1), id%FRTELT(1), & S_PTR_ARG(1), MAXS_ARG, id%FILS(1), & id, id%root ) C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 END IF ! Element entry C ------------------------ C Time the redistribution: C ------------------------ IF ( id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(93) = TIME IF (PROKG) WRITE(MPG,160) id%DKEEP(93) END IF C C TIMINGS: C Next line: elapsed time for factorization IF (id%MYID.EQ.MASTER) CALL MUMPS_SECDEB(TIME) C C Allocate buffers on the workers C =============================== C IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_BUF_INI_MYID(id%MYID_NODES) C C Some buffers are required to pack/unpack data and for C receiving MPI messages. C For packing/unpacking : the buffer must be large C enough to send several messages while receives might not C be posted yet. C It is assumed that the size of an integer is held in KEEP(34) C while the size of a complex is held in KEEP(35). C BUFR and LBUFR are declared of type integer, since byte is not C a standard datatype. C We now use KEEP(43) or KEEP(379) and KEEP(44) or KEEP(380) C as estimated at analysis to allocate appropriate buffer sizes C C Reception buffer C ---------------- IF (KEEP(486).NE.0) THEN ZMUMPS_LBUFR_BYTES8 = int(KEEP( 380 ),8) * int(KEEP( 35 ),8) ELSE ZMUMPS_LBUFR_BYTES8 = int(KEEP( 44 ),8) * int(KEEP( 35 ),8) ENDIF C --------------------------------------- C Ensure a reasonable minimal buffer size C --------------------------------------- ZMUMPS_LBUFR_BYTES8 = max( ZMUMPS_LBUFR_BYTES8, & 100000_8 ) C C If there is pivoting, size of the message might still increase. C We use a relaxation (so called PERLU) to increase the estimate. C C Note: PERLU is a global estimate for pivoting. C It may happen that one large contribution block size is increased by more than that. C This is why we use an extra factor 2 relaxation coefficient for the relaxation of C the reception buffer in the case where pivoting is allowed. C A more dynamic strategy could be applied: if message to C be received is larger than expected, reallocate a larger C buffer. (But this won't work with IRECV.) C Finally, one may want (as we are currently doing it for moste messages) C to cut large messages into a series of smaller ones. C IF (KEEP(48).EQ.5) THEN MIN_PERLU = 2 ELSE MIN_PERLU = 0 ENDIF C ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0, 8) ZMUMPS_LBUFR_BYTES8 = min(ZMUMPS_LBUFR_BYTES8, & int(huge (KEEP(44))-100,8)) ZMUMPS_LBUFR_BYTES = int( ZMUMPS_LBUFR_BYTES8 ) IF (KEEP(48)==5) THEN C Since the buffer is going to be allocated, use C it as the constraint for memory/granularity C in hybrid scheduler C id%KEEP8(21) = id%KEEP8(22) + & int( dble(max(PERLU,MIN_PERLU))* & dble(id%KEEP8(22))/100D0,8) ENDIF C C Now estimate the size for the buffer for asynchronous C sends of contribution blocks (so called CB). We want to be able to send at C least KEEP(213)/100 (two in general) messages at the C same time. C C Send buffer C ----------- IF (KEEP(486).NE.0) THEN ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(379)) * dble(KEEP(35)), 8 ) ELSE ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 * & dble(KEEP(43)) * dble(KEEP(35)), 8 ) ENDIF ZMUMPS_LBUF8 = max( ZMUMPS_LBUF8, 100000_8 ) ZMUMPS_LBUF8 = ZMUMPS_LBUF8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUF8)/100D0, 8) C Make ZMUMPS_LBUF8 small enough to be stored in a standard integer ZMUMPS_LBUF8 = min(ZMUMPS_LBUF8, int(huge (KEEP(43))-100,8)) C C No reason to have send buffer smaller than receive buffer. C This should never occur with the formulas above but just C in case: ZMUMPS_LBUF8 = max(ZMUMPS_LBUF8, ZMUMPS_LBUFR_BYTES8+3*KEEP(34)) ZMUMPS_LBUF = int(ZMUMPS_LBUF8) IF(id%KEEP(48).EQ.4)THEN ZMUMPS_LBUFR_BYTES=ZMUMPS_LBUFR_BYTES*5 ZMUMPS_LBUF=ZMUMPS_LBUF*5 ENDIF C C Estimate size of buffer for small messages C Each node can send ( NSLAVES - 1 ) messages to (NSLAVES-1) nodes C C KEEP(56) is the number of nodes of level II. C Messages will be sent for the symmetric case C for synchronisation issues. C C We take an upperbound C ZMUMPS_LBUF_INT = ( KEEP(56) + id%NSLAVES * id%NSLAVES ) * 5 & * KEEP(34) IF ( KEEP( 38 ) .NE. 0 ) THEN C C KKKK = MUMPS_PROCNODE( id%PROCNODE_STEPS(id%STEP(KEEP(38))), & id%KEEP(199) ) IF ( KKKK .EQ. id%MYID_NODES ) THEN ZMUMPS_LBUF_INT = ZMUMPS_LBUF_INT + 4 * KEEP(34) * & ( id%NSLAVES + id%NE_STEPS(id%STEP(KEEP(38))) & + min(KEEP(56), id%NE_STEPS(id%STEP(KEEP(38)))) * id%NSLAVES & ) END IF END IF C At this point, ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF C and ZMUMPS_LBUF_INT have been computed (all C are in numbers of bytes). IF ( PROK ) THEN WRITE( MP, 9999 ) ZMUMPS_LBUFR_BYTES, & ZMUMPS_LBUF, ZMUMPS_LBUF_INT END IF 9999 FORMAT( /,' Allocated buffers',/,' ------------------',/, & ' Size of reception buffer in bytes ...... = ', I10, & /, & ' Size of async. emission buffer (bytes).. = ', I10,/, & ' Small emission buffer (bytes) .......... = ', I10) C -------------------------- C Allocate small send buffer C required for ZMUMPS_FAC_B C -------------------------- CALL ZMUMPS_BUF_ALLOC_SMALL_BUF( ZMUMPS_LBUF_INT, IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)= -13 C convert to size in integer id%INFO(2)= ZMUMPS_LBUF_INT id%INFO(2)= (ZMUMPS_LBUF_INT+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ':Allocation error in ZMUMPS_BUF_ALLOC_SMALL_BUF' & ,id%INFO(2) ENDIF GO TO 110 END IF C C -------------------------------------- C Allocate reception buffer on all procs C This is done now. C -------------------------------------- ZMUMPS_LBUFR = (ZMUMPS_LBUFR_BYTES+KEEP(34)-1)/KEEP(34) ALLOCATE( BUFR( ZMUMPS_LBUFR ),stat=IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1) = -13 id%INFO(2) = ZMUMPS_LBUFR IF (LPOK) THEN WRITE(LP,*) & ': Allocation error for BUFR(', ZMUMPS_LBUFR, & ') on MPI process',id%MYID ENDIF GO TO 110 END IF C ----------------------------------------- C Estimate MAXIS. IS will be allocated in C ZMUMPS_FAC_B. It will contain factors and C contribution blocks integer information C ----------------------------------------- C Relax integer workspace based on PERLU PERLU = KEEP( 12 ) IF (KEEP(201).GT.0) THEN C OOC panel or non panel (note that C KEEP(15)=KEEP(225) if non panel) MAXIS_ESTIM = KEEP(225) ELSE C In-core or reals for factors not stored MAXIS_ESTIM = KEEP(15) ENDIF MAXIS = max( 1, & MAXIS_ESTIM + 3 * max(PERLU,10) * & ( MAXIS_ESTIM / 100 + 1 ) & ) C ---------------------------- C Allocate PTLUST_S and PTRFAC C They will be used to access C factors in the solve phase. C ---------------------------- ALLOCATE( id%PTLUST_S( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTLUST_S(', id%KEEP(28),')' ENDIF NULLIFY(id%PTLUST_S) GOTO 110 END IF ALLOCATE( id%PTRFAC( id%KEEP(28) ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%KEEP(28) NULLIFY(id%PTRFAC) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for id%PTRFAC(', id%KEEP(28),')' ENDIF GOTO 110 END IF C ----------------------------- C Reserve temporary workspace : C IPOOL, PTRWB, ITLOC, PTRIST C PTRWB will be subdivided again C in routine ZMUMPS_FAC_B C ----------------------------- PTRIST = 1 PTRWB = PTRIST + id%KEEP(28) ITLOC = PTRWB + 2 * id%KEEP(28) C Fwd in facto: ITLOC of size id%N + id%KEEP(253) IPOOL = ITLOC + id%N + id%KEEP(253) C C -------------------------------- C NA(1) is an upperbound for LPOOL C -------------------------------- C Structure of the pool: C ____________________________________________________ C | Subtrees | | Top nodes | 1 2 3 | C ---------------------------------------------------- LPOOL = MUMPS_GET_POOL_LENGTH(id%NA(1), id%KEEP(1),id%KEEP8(1)) ALLOCATE( IWK( IPOOL + LPOOL - 1 ), stat = IERR ) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=IPOOL + LPOOL - 1 IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWK(',IPOOL+LPOOL-1,')' ENDIF GOTO 110 END IF ALLOCATE(IWK8( 2 * id%KEEP(28)), stat = IERR) IF ( IERR .NE. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=2 * id%KEEP(28) IF (LPOK) THEN WRITE(LP,*) id%MYID, & ': Allocation error for IWKB(', 2*id%KEEP(28),')' ENDIF GOTO 110 END IF C C Return to SPMD C ENDIF C 110 CONTINUE C ---------------- C Broadcast errors C ---------------- CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO( 1 ) .LT. 0 ) GOTO 500 C IF ( I_AM_SLAVE ) THEN C Store size of receive buffers in ZMUMPS_LBUF module CALL ZMUMPS_BUF_DIST_IRECV_SIZE( ZMUMPS_LBUFR_BYTES ) IF (PROK) THEN WRITE( MP, 170 ) MAXS, MAXIS, id%KEEP8(12), KEEP(15), & id%KEEP8(26), id%KEEP8(27), id%KEEP8(11), KEEP(26), KEEP(27) ENDIF END IF C =============================================================== C Before calling the main driver, ZMUMPS_FAC_B, C some statistics should be initialized to 0, C even on the host node because they will be C used in REDUCE operations afterwards. C -------------------------------------------- C Size of factors written. It will be set to POSFAC in C IC, otherwise we accumulate written factors in it. id%KEEP8(31)= 0_8 C Size of factors under L0 will be returned C in id%KEEP8(64), not included in KEEP8(31)) C Number of entries in factors id%KEEP8(10) = 0_8 C KEEP8(8) will hold the volume of extra copies due to C in-place stacking in fac_mem_stack.F id%KEEP8(8)=0_8 id%INFO(9:14)=0 RINFO(2:3)=ZERO IF ( I_AM_SLAVE ) THEN C ------------------------------------ C Call effective factorization routine C ------------------------------------ IF ( KEEP(55) .eq. 0 ) THEN LDPTRAR = id%N ELSE LDPTRAR = id%NELT + 1 END IF IF ( id%KEEP(55) .NE. 0 ) THEN NELT_arg = id%NELT ELSE C ------------------------------ C Use size 1 to avoid complaints C when using check bound options C ------------------------------ NELT_arg = 1 END IF ENDIF C Compute DKEEP(17) AVG_FLOPS = RINFOG(1)/(dble(id%NSLAVES)) id%DKEEP(17) = max ( id%DKEEP(18), AVG_FLOPS/dble(50) ) & IF (PROK.AND.id%MYID.EQ.MASTER) THEN IF (id%NSLAVES.LE.1) THEN WRITE(MPG,'(/A,A,1PD10.3)') &' Start factorization with total', &' estimated flops (RINFOG(1)) = ', & RINFOG(1) ELSE WRITE(MP,'(/A,A,1PD10.3,A,1PD10.3)') &' Start factorization with total', &' estimated flops RINFOG(1) / Average per MPI proc = ', & RINFOG(1), ' / ', AVG_FLOPS ENDIF ENDIF IF (I_AM_SLAVE) THEN C IS/S pointers passed to ZMUMPS_FAC_B with C implicit interface through intermediate C structure S_IS_POINTERS. IS will be allocated C during ZMUMPS_FAC_B. S_IS_POINTERS%IW => id%IS; NULLIFY(id%IS) S_IS_POINTERS%A => id%S ; NULLIFY(id%S) CALL ZMUMPS_FAC_B(id%N,S_IS_POINTERS,MAXS,MAXIS,id%SYM_PERM(1), & id%NA(1),id%LNA,id%NE_STEPS(1),id%ND_STEPS(1), id%FILS(1), & id%STEP(1),id%FRERE_STEPS(1),id%DAD_STEPS(1),id%CANDIDATES(1,1), & id%ISTEP_TO_INIV2(1),id%TAB_POS_IN_PERE(1,1), id%PTRAR(1), & LDPTRAR,IWK(PTRIST),id%PTLUST_S(1),id%PTRFAC(1),IWK(PTRWB),IWK8, & IWK(ITLOC),RHS_MUMPS(1),IWK(IPOOL),LPOOL,CNTL1,ICNTL(1), & id%INFO(1), RINFO(1),KEEP(1),id%KEEP8(1),id%PROCNODE_STEPS(1), & id%NSLAVES,id%COMM_NODES,id%MYID,id%MYID_NODES,BUFR,ZMUMPS_LBUFR & , ZMUMPS_LBUFR_BYTES, ZMUMPS_LBUF, id%INTARR(1),id%DBLARR(1), & id%root, NELT_arg, id%FRTPTR(1), id%FRTELT(1),id%COMM_LOAD, & id%ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, id%MEM_DIST(0), & id%DKEEP(1), id%PIVNUL_LIST(1), LPN_LIST, id%LRGROUPS(1) & ) id%IS => S_IS_POINTERS%IW; NULLIFY(S_IS_POINTERS%IW) id%S => S_IS_POINTERS%A ; NULLIFY(S_IS_POINTERS%A) C C ------------------------------ C Deallocate temporary workspace C ------------------------------ DEALLOCATE( IWK ) DEALLOCATE( IWK8 ) ENDIF C --------------------------------- C Free some workspace corresponding C to the original matrix in C arrowhead or elemental format. C ----- C Note : INTARR was not allocated C during factorization in the case C of an assembled matrix. C --------------------------------- IF ( KEEP(55) .eq. 0 ) THEN C C ---------------- C Assembled matrix C ---------------- IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF C ELSE C C ---------------- C Elemental matrix C ---------------- IF (associated(id%INTARR)) THEN DEALLOCATE( id%INTARR) NULLIFY( id%INTARR ) ENDIF C ------------------------------------ C For the master from an hybrid host C execution without scaling, then real C values have not been copied ! C ------------------------------------- IF ( id%MYID_NODES .eq. MASTER & .AND. KEEP(46) .eq. 1 & .AND. KEEP(52) .eq. 0 ) THEN NULLIFY( id%DBLARR ) ELSE IF (associated( id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF END IF END IF C Memroy statistics C ----------------------------------- C If QR (Keep(19)) is not zero, and if C the host does not have the information C (ie is not slave), send information C computed on the slaves during facto C to the host. C ----------------------------------- IF ( KEEP(19) .NE. 0 ) THEN IF ( KEEP(46) .NE. 1 ) THEN C Host was not working during facto_root C Send him the information IF ( id%MYID .eq. MASTER ) THEN CALL MPI_RECV( KEEP(17), 1, MPI_INTEGER, 1, DEFIC_TAG, & id%COMM, STATUS, IERR ) ELSE IF ( id%MYID .EQ. 1 ) THEN CALL MPI_SEND( KEEP(17), 1, MPI_INTEGER, 0, DEFIC_TAG, & id%COMM, IERR ) END IF END IF END IF C -------------------------------- C Deallocate communication buffers C They will be reallocated C in the solve. C -------------------------------- IF (allocated(BUFR)) DEALLOCATE(BUFR) CALL ZMUMPS_BUF_DEALL_SMALL_BUF( IERR ) C//PIV IF (KEEP(219).NE.0) THEN CALL ZMUMPS_BUF_DEALL_MAX_ARRAY() ENDIF C C Check for errors. C After ZMUMPS_FAC_B every slave is aware of an error. C If master is included in computations, the call below should C not be necessary. CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C CALL ZMUMPS_EXTRACT_SCHUR_REDRHS(id) IF (KEEP(201) .GT. 0) THEN IF ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.2)) THEN IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_OOC_CLEAN_PENDING(IERR) IF(IERR.LT.0)THEN id%INFO(1)=IERR id%INFO(2)=0 ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C We want to collect statistics even in case of C error to understand if it is due to numerical C issues CC IF ( id%INFO(1) < 0 ) GOTO 500 END IF END IF IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SECFIN(TIME) id%DKEEP(94)=TIME ENDIF C ===================================================================== C COMPUTE MEMORY ALLOCATED BY MUMPS, INFO(16) C --------------------------------------------- MEM_EFF_ALLOCATED = .TRUE. CALL ZMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, .TRUE., TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) IF (id%KEEP8(24).NE.0) THEN C WK_USER is not part of memory allocated by MUMPS C and is not counted, id%KEEP8(23) should be zero id%INFO(16) = TOTAL_MBYTES ELSE C Note that even for the case of ICNTL(23)>0 C we report here the memory effectively allocated C that can be smaller than ICNTL(23) ! id%INFO(16) = TOTAL_MBYTES ENDIF C ---------------------------------------------------- C Centralize memory statistics on the host C id%INFOG(18) = size of mem in Mbytes for facto, C for the processor using largest memory C id%INFOG(19) = size of mem in Mbytes for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(16), id%INFOG(18), IRANK ) CALL ZMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, id%INFO(16), id%INFOG(18), id%INFOG(19), & id%NSLAVES, IRANK, & id%KEEP(1) ) C FIXME Check if WK_USER used and indicate, total space to WK_USER IF (PROK ) THEN WRITE(MP,'(A,I12) ') & ' ** Eff. min. Space MBYTES for facto (INFO(16)):', & TOTAL_MBYTES ENDIF C ========================(INFO(16) RELATED)====================== C --------------------------------------- C COMPUTE EFFECTIVE MEMORY USED INFO(22) C --------------------------------------- PERLU_ON = .TRUE. MEM_EFF_ALLOCATED = .FALSE. CALL ZMUMPS_MAX_MEM( id%KEEP(1),id%KEEP8(1), & id%MYID, N, id%NELT, id%NA(1), id%LNA, id%KEEP8(28), & id%KEEP8(30), & id%NSLAVES, TOTAL_MBYTES, .TRUE., id%KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY, MEM_EFF_ALLOCATED & , .FALSE. ! UNDER_L0_OMP & ) C -- TOTAL_BYTES and TOTAL_MBYTES includes both static C -- (MAXS) and BLR structures computed as the SUM of the PEAKS C -- (KEEP8(67) + KEEP8(70)) id%KEEP8(7) = TOTAL_BYTES C -- INFO(22) holds the effective space (in Mbytes) used by MUMPS C -- (it includes part of WK_USER used if provided by user) id%INFO(22) = TOTAL_MBYTES C ---------------------------------------------------- C Centralize memory statistics on the host C INFOG(21) = size of effective mem (Mbytes) for facto, C for the processor using largest memory C INFOG(22) = size of effective mem (Mbytes) for facto, C sum over all processors C ---------------------------------------------------- CALL MUMPS_MEM_CENTRALIZE( id%MYID, id%COMM, & id%INFO(22), id%INFOG(21), IRANK ) IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, max in Mbytes (INFOG(21)):', & id%INFOG(21) ENDIF WRITE( MPG,'(A,I12) ') & ' ** Memory effectively used, total in Mbytes (INFOG(22)):', & id%INFOG(22) END IF C IF (I_AM_SLAVE) THEN K67 = id%KEEP8(67) K68 = id%KEEP8(68) K70 = id%KEEP8(70) K74 = id%KEEP8(74) K75 = id%KEEP8(75) ELSE K67 = 0_8 K68 = 0_8 K70 = 0_8 K74 = 0_8 K75 = 0_8 ENDIF C -- Save the number of entries effectively used C in main working array S CALL MUMPS_SETI8TOI4(K67,id%INFO(21)) C C IF ( PROKG ) THEN IF (id%INFO(1) .GE.0) THEN WRITE(MPG,180) id%DKEEP(94) ELSE WRITE(MPG,185) id%DKEEP(94) ENDIF ENDIF C C Sum RINFO(2) : total number of flops for assemblies C Sum RINFO(3) : total number of flops for eliminations C Initialize RINFO(4) in case BLR was not activated RINFO(4) = RINFO(3) C C Should work even if the master does some work C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) C Reduce needed to dimension small working array C on all procs during ZMUMPS_GATHER_SOLUTION KEEP(247) = 0 CALL MPI_REDUCE( KEEP(246), KEEP(247), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR) C C Reduce compression times: get max compression times CALL MPI_REDUCE( id%DKEEP(97), id%DKEEP(98), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) C CALL MPI_REDUCE( RINFO(2), RINFOG(2), 2, & MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MUMPS_REDUCEI8( id%KEEP8(31)+id%KEEP8(64),id%KEEP8(6), & MPI_SUM, MASTER, id%COMM ) C IF (id%MYID.EQ.0) THEN C In MegaBytes RINFOG(16) = dble(id%KEEP8(6)*int(KEEP(35),8))/dble(1D6) IF (KEEP(201).LE.0) THEN RINFOG(16) = ZERO ENDIF ENDIF CALL MUMPS_REDUCEI8( id%KEEP8(48),id%KEEP8(148), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(148), INFOG(9)) C CALL MPI_REDUCE( int(id%INFO(10),8), id%KEEP8(128), & 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN CALL MUMPS_SETI8TOI4(id%KEEP8(128), id%INFOG(10)) ENDIF C Use MPI_MAX for this one to get largest front size CALL MPI_ALLREDUCE( id%INFO(11), INFOG(11), 1, MPI_INTEGER, & MPI_MAX, id%COMM, IERR) C make maximum effective frontal size available on all procs C for solve phase C (Note that INFO(11) includes root size on root master) KEEP(133) = INFOG(11) CALL MPI_REDUCE( id%INFO(12), INFOG(12), 3, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( KEEP(103), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(229) = INFOG(25) CALL MPI_REDUCE( KEEP(105), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) KEEP(230) = INFOG(25) C id%INFO(25) = KEEP(98) CALL MPI_ALLREDUCE( id%INFO(25), INFOG(25), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) C Extra copies due to in-place stacking CALL MUMPS_REDUCEI8( id%KEEP8(8), id%KEEP8(108), MPI_SUM, & MASTER, id%COMM ) C Entries in factors CALL MUMPS_SETI8TOI4(id%KEEP8(10), id%INFO(27)) CALL MUMPS_REDUCEI8( id%KEEP8(10),id%KEEP8(110), MPI_SUM, & MASTER, id%COMM ) CALL MUMPS_SETI8TOI4(id%KEEP8(110), INFOG(29)) C Initialize INFO(28)/INFOG(35) in case BLR not activated id%INFO(28) = id%INFO(27) INFOG(35) = INFOG(29) C ============================== C LOW-RANK C ============================== IF ( KEEP(486) .NE. 0 ) THEN !LR is activated C Compute and Save local amount of flops in case of BLR RINFO(4) = dble(FLOP_FRFRONTS + FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS) C C Compute and Save local number of entries in compressed factors C ITMP8 = id%KEEP8(10) - int(MRY_LU_LRGAIN,8) CALL MUMPS_SETI8TOI4( ITMP8, id%INFO(28)) C CALL MPI_REDUCE( MRY_LU_LRGAIN, TMP_MRY_LU_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_LU_FR, TMP_MRY_LU_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_FR, TMP_MRY_CB_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( MRY_CB_LRGAIN, TMP_MRY_CB_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_LRGAIN, TMP_FLOP_LRGAIN & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_FR, TMP_FLOP_TRSM_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM_LR, TMP_FLOP_TRSM_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_FR, TMP_FLOP_UPDATE_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LR, TMP_FLOP_UPDATE_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRSWAP_COMPRESS, & TMP_FLOP_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_MIDBLK_COMPRESS, & TMP_FLOP_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_UPDATE_LRLR3, TMP_FLOP_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(FLOP_ACCUM_COMPRESS, TMP_FLOP_ACCUM_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_TRSM, TMP_FLOP_TRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_PANEL, TMP_FLOP_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FRFRONTS, TMP_FLOP_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_COMPRESS, TMP_FLOP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_DECOMPRESS, TMP_FLOP_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_COMPRESS, TMP_FLOP_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_CB_DECOMPRESS,TMP_FLOP_CB_DECOMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_FR, TMP_FLOP_FACTO_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_FR, TMP_FLOP_SOLFWD_FR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_SOLFWD_LR, TMP_FLOP_SOLFWD_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( CNT_NODES,TMP_CNT_NODES & , 1, MPI_INTEGER, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%NPROCS.GT.1) THEN FLOP_FACTO_LR = FLOP_FACTO_FR - FLOP_LRGAIN & + FLOP_COMPRESS + FLOP_FRFRONTS CALL MPI_REDUCE( FLOP_FACTO_LR, AVG_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN AVG_FLOP_FACTO_LR = AVG_FLOP_FACTO_LR/id%NPROCS ENDIF CALL MPI_REDUCE( FLOP_FACTO_LR, MIN_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR) CALL MPI_REDUCE( FLOP_FACTO_LR, MAX_FLOP_FACTO_LR & , 1, MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR) ENDIF ! NPROCS > 1 CALL MPI_REDUCE( TIME_UPDATE, TMP_TIME_UPDATE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR1, TMP_TIME_UPDATE_LRLR1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR2, TMP_TIME_UPDATE_LRLR2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_LRLR3, TMP_TIME_UPDATE_LRLR3 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRLR, TMP_TIME_UPDATE_FRLR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_UPDATE_FRFR, TMP_TIME_UPDATE_FRFR & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DIAGCOPY, TMP_TIME_DIAGCOPY & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_COMPRESS,TMP_TIME_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_MIDBLK_COMPRESS, & TMP_TIME_MIDBLK_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRSWAP_COMPRESS, & TMP_TIME_FRSWAP_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_CB_COMPRESS, TMP_TIME_CB_COMPRESS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP, TMP_TIME_DECOMP & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_UCFS, TMP_TIME_DECOMP_UCFS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASM1, TMP_TIME_DECOMP_ASM1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_LOCASM2, TMP_TIME_DECOMP_LOCASM2 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE(TIME_DECOMP_MAPLIG1, TMP_TIME_DECOMP_MAPLIG1 & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2S, TMP_TIME_DECOMP_ASMS2S & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_DECOMP_ASMS2M, TMP_TIME_DECOMP_ASMS2M & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_PANEL, TMP_TIME_PANEL & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_I, TMP_TIME_FAC_I & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_MQ, TMP_TIME_FAC_MQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FAC_SQ, TMP_TIME_FAC_SQ & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LRTRSM, TMP_TIME_LRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRTRSM, TMP_TIME_FRTRSM & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_FRFRONTS, TMP_TIME_FRFRONTS & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) CALL MPI_REDUCE( TIME_LR_MODULE, TMP_TIME_LR_MODULE & , 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, id%COMM, IERR) IF (id%MYID.EQ.MASTER) THEN IF (id%NPROCS.GT.1) THEN C rename the stat variable so that COMPUTE_GLOBAL_GAINS can work for any C number of procs MRY_LU_FR = TMP_MRY_LU_FR MRY_LU_LRGAIN = TMP_MRY_LU_LRGAIN MRY_CB_FR = TMP_MRY_CB_FR MRY_CB_LRGAIN = TMP_MRY_CB_LRGAIN FLOP_LRGAIN = TMP_FLOP_LRGAIN FLOP_PANEL = TMP_FLOP_PANEL FLOP_TRSM = TMP_FLOP_TRSM FLOP_TRSM_FR = TMP_FLOP_TRSM_FR FLOP_TRSM_LR = TMP_FLOP_TRSM_LR FLOP_UPDATE_FR = TMP_FLOP_UPDATE_FR FLOP_UPDATE_LR = TMP_FLOP_UPDATE_LR FLOP_UPDATE_LRLR3 = TMP_FLOP_UPDATE_LRLR3 FLOP_COMPRESS = TMP_FLOP_COMPRESS FLOP_MIDBLK_COMPRESS = TMP_FLOP_MIDBLK_COMPRESS FLOP_FRSWAP_COMPRESS = TMP_FLOP_FRSWAP_COMPRESS FLOP_ACCUM_COMPRESS = TMP_FLOP_ACCUM_COMPRESS FLOP_CB_COMPRESS = TMP_FLOP_CB_COMPRESS FLOP_DECOMPRESS = TMP_FLOP_DECOMPRESS FLOP_CB_DECOMPRESS = TMP_FLOP_CB_DECOMPRESS FLOP_FRFRONTS = TMP_FLOP_FRFRONTS FLOP_SOLFWD_FR = TMP_FLOP_SOLFWD_FR FLOP_SOLFWD_LR = TMP_FLOP_SOLFWD_LR FLOP_FACTO_FR = TMP_FLOP_FACTO_FR CNT_NODES = TMP_CNT_NODES TIME_UPDATE = TMP_TIME_UPDATE /id%NPROCS TIME_UPDATE_LRLR1 = TMP_TIME_UPDATE_LRLR1 /id%NPROCS TIME_UPDATE_LRLR2 = TMP_TIME_UPDATE_LRLR2 /id%NPROCS TIME_UPDATE_LRLR3 = TMP_TIME_UPDATE_LRLR3 /id%NPROCS TIME_UPDATE_FRLR = TMP_TIME_UPDATE_FRLR /id%NPROCS TIME_UPDATE_FRFR = TMP_TIME_UPDATE_FRFR /id%NPROCS TIME_COMPRESS = TMP_TIME_COMPRESS /id%NPROCS TIME_MIDBLK_COMPRESS = TMP_TIME_MIDBLK_COMPRESS/id%NPROCS TIME_FRSWAP_COMPRESS = TMP_TIME_FRSWAP_COMPRESS/id%NPROCS TIME_DIAGCOPY = TMP_TIME_DIAGCOPY /id%NPROCS TIME_CB_COMPRESS = TMP_TIME_CB_COMPRESS /id%NPROCS TIME_PANEL = TMP_TIME_PANEL /id%NPROCS TIME_FAC_I = TMP_TIME_FAC_I /id%NPROCS TIME_FAC_MQ = TMP_TIME_FAC_MQ /id%NPROCS TIME_FAC_SQ = TMP_TIME_FAC_SQ /id%NPROCS TIME_LRTRSM = TMP_TIME_LRTRSM /id%NPROCS TIME_FRTRSM = TMP_TIME_FRTRSM /id%NPROCS TIME_FRFRONTS = TMP_TIME_FRFRONTS /id%NPROCS TIME_LR_MODULE = TMP_TIME_LR_MODULE /id%NPROCS TIME_DECOMP = TMP_TIME_DECOMP /id%NPROCS TIME_DECOMP_UCFS = TMP_TIME_DECOMP_UCFS /id%NPROCS TIME_DECOMP_ASM1 = TMP_TIME_DECOMP_ASM1 /id%NPROCS TIME_DECOMP_LOCASM2 = TMP_TIME_DECOMP_LOCASM2 /id%NPROCS TIME_DECOMP_MAPLIG1 = TMP_TIME_DECOMP_MAPLIG1 /id%NPROCS TIME_DECOMP_ASMS2S = TMP_TIME_DECOMP_ASMS2S /id%NPROCS TIME_DECOMP_ASMS2M = TMP_TIME_DECOMP_ASMS2M /id%NPROCS ENDIF CALL COMPUTE_GLOBAL_GAINS(id%KEEP8(110),id%RINFOG(3), & id%KEEP8(49), PROKG, MPG) C Number of entries in factor INFOG(35) in C compressed form is updated as long as C BLR is activated, this independently of the C fact that factors are saved in LR. CALL MUMPS_SETI8TOI4(id%KEEP8(49), id%INFOG(35)) FRONTWISE = 0 C WRITE gains also compute stats stored in DKEEP array IF (LPOK) THEN IF (CNTL(7) < 0.0D0) THEN C Warning : using negative values is an experimental and C non recommended setting. WRITE(LP,'(/A/,A/,A/,A,A)') & ' WARNING in BLR input setting', & ' CNTL(7) < 0 is experimental: ', & ' RRQR precision = |CNTL(7| x ||A_pre||, ', & ' where A_pre is the preprocessed matrix as defined', & ' in the Users guide ' ENDIF ENDIF CALL SAVEandWRITE_GAINS(FRONTWISE, & KEEP(489), id%DKEEP, N, id%ICNTL(36), & KEEP(487), KEEP(488), KEEP(490), & KEEP(491), KEEP(50), KEEP(486), KEEP(472), & KEEP(475), KEEP(478), KEEP(480), KEEP(481), & KEEP(483), KEEP(484), & id%KEEP8(110), id%KEEP8(49), & KEEP(28), id%NPROCS, MPG, PROKG) C flops when BLR activated RINFOG(14) = id%DKEEP(56) ELSE RINFOG(14) = 0.0D00 ENDIF ENDIF C ============================== C NULL PIVOTS AND RANK-REVEALING C ============================== IF(KEEP(110) .EQ. 1) THEN C -- make available to users the local number of null pivots detected C -- with ICNTL(24) = 1. id%INFO(18) = KEEP(109) CALL MPI_ALLREDUCE( KEEP(109), KEEP(112), 1, MPI_INTEGER, & MPI_SUM, id%COMM, IERR) ELSE id%INFO(18) = 0 KEEP(109) = 0 KEEP(112) = 0 ENDIF IF (id%MYID.EQ.MASTER) THEN C INFOG(28) deficiency resulting from ICNTL(24) and ICNTL(56). INFOG(28)=KEEP(112)+KEEP(17) ENDIF C ======================================== C We now provide to the host the part of C PIVNUL_LIST resulting from the processing C of the root node and we update id%INFO(18) C on the processor holding the root to C include null pivots relative to the root C ======================================== IF (KEEP(17) .NE. 0) THEN IF (id%MYID .EQ. ID_ROOT) THEN C Include in id%INFO(18) null pivots resulting C from deficiency on the root. In this way, C the sum of all id%INFO(18) is equal to INFOG(28). id%INFO(18)=id%INFO(18)+KEEP(17) ENDIF IF (ID_ROOT .EQ. MASTER) THEN IF (id%MYID.EQ.MASTER) THEN C -------------------------------------------------- C Null pivots of root have been stored in C PIVNUL_LIST(KEEP(109)+1:KEEP(109)+KEEP(17). C Shift them at the end of the list because: C * this is what we need to build the null space C * we would otherwise overwrite them on the host C when gathering null pivots from other processors C -------------------------------------------------- DO I=1, KEEP(17) id%PIVNUL_LIST(KEEP(112)+I)=id%PIVNUL_LIST(KEEP(109)+I) ENDDO ENDIF ELSE C --------------------------------- C Null pivots of root must be sent C from the processor responsible of C the root to the host (or MASTER). C --------------------------------- IF (id%MYID .EQ. ID_ROOT) THEN CALL MPI_SEND(id%PIVNUL_LIST(KEEP(109)+1), KEEP(17), & MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, IERR) ELSE IF (id%MYID .EQ. MASTER) THEN CALL MPI_RECV(id%PIVNUL_LIST(KEEP(112)+1), KEEP(17), & MPI_INTEGER, ID_ROOT, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDIF C =========================== C gather zero pivots indices C on the host node C =========================== C In case of non working host, the following code also C works considering that KEEP(109) is equal to 0 on C the non-working host IF(KEEP(110) .EQ. 1) THEN ALLOCATE(ITMP2(id%NPROCS),stat = IERR ) ! deallocated in 490 IF ( IERR .GT. 0 ) THEN id%INFO(1)=-13 id%INFO(2)=id%NPROCS END IF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF (id%INFO(1).LT.0) GOTO 490 CALL MPI_GATHER ( KEEP(109),1, MPI_INTEGER, & ITMP2(1), 1, MPI_INTEGER, & MASTER, id%COMM, IERR) IF(id%MYID .EQ. MASTER) THEN POSBUF = ITMP2(1)+1 C First null pivot of master is in C position 1 of global list KEEP(220)=1 DO I = 1,id%NPROCS-1 CALL MPI_RECV(id%PIVNUL_LIST(POSBUF), ITMP2(I+1), & MPI_INTEGER,I, & ZERO_PIV, id%COMM, STATUS, IERR) C Send position POSBUF of first null pivot of proc I C in global list. Will allow to quickly identify during C the solve step if one is concerned by a global position C K, 0 <= K <= INFOG(28). CALL MPI_SEND(POSBUF, 1, MPI_INTEGER, I, ZERO_PIV, & id%COMM, IERR) POSBUF = POSBUF + ITMP2(I+1) ENDDO ELSE CALL MPI_SEND( id%PIVNUL_LIST(1), KEEP(109), MPI_INTEGER, & MASTER,ZERO_PIV, id%COMM, IERR) CALL MPI_RECV( KEEP(220), 1, MPI_INTEGER, MASTER, ZERO_PIV, & id%COMM, STATUS, IERR ) ENDIF ENDIF C ===================================== C Statistics relative to min/max pivots C ===================================== CALL MPI_REDUCE( id%DKEEP(19), RINFOG(19), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(20), RINFOG(20), 1, & MPI_DOUBLE_PRECISION, & MPI_MIN, MASTER, id%COMM, IERR ) CALL MPI_REDUCE( id%DKEEP(21), RINFOG(21), 1, & MPI_DOUBLE_PRECISION, & MPI_MAX, MASTER, id%COMM, IERR ) C ========================================= C Centralized number of swaps for pivoting C ========================================= CALL MPI_REDUCE( id%KEEP8(80), ITEMP8, 1, MPI_INTEGER8, & MPI_SUM, MASTER, id%COMM, IERR ) IF (id%MYID .EQ. MASTER) THEN CALL MUMPS_SETI8TOI4(ITEMP8,id%INFOG(48)) ENDIF C ========================================== C Centralized largest increase of panel size C ========================================== CALL MPI_REDUCE( id%KEEP(425), id%INFOG(49), 1, MPI_INTEGER, & MPI_MAX, MASTER, id%COMM, IERR ) C ===================================== C Statistics concerning the determinant C ===================================== C C 1/ on the host better take into account null pivots if scaling: C C Since null pivots are excluded from the computation C of the determinant, we also exclude the corresponding C scaling entries. Since those entries have already been C taken into account before the factorization, we multiply C the determinant on the host by the scaling values corresponding C to pivots in PIVNUL_LIST. IF (id%MYID.EQ.MASTER .AND. LSCAL. AND. KEEP(258).NE.0) THEN DO I = 1, id%INFOG(28) CALL ZMUMPS_UPDATEDETER( & cmplx(id%ROWSCA(id%PIVNUL_LIST(I)),0.0D0, & kind=kind(0.0D0)), & id%DKEEP(6), KEEP(259)) CALL ZMUMPS_UPDATEDETER( & cmplx(id%COLSCA(id%PIVNUL_LIST(I)),0.0D0, & kind=kind(0.0D0)), & id%DKEEP(6), KEEP(259)) ENDDO ENDIF C C 2/ Swap signs depending on pivoting on each proc C IF (KEEP(258).NE.0) THEN C Return the determinant in INFOG(34) and RINFOG(12/13) IF (KEEP(260).EQ.-1) THEN ! Local to each processor id%DKEEP(6)=-id%DKEEP(6) id%DKEEP(7)=-id%DKEEP(7) ENDIF C C 3/ Perform a reduction C CALL ZMUMPS_DETER_REDUCTION( & id%COMM, id%DKEEP(6), KEEP(259), & RINFOG(12), INFOG(34), id%NPROCS) C C 4/ Swap sign if needed C IF (id%KEEP(50).EQ.0 .AND. id%MYID.EQ. MASTER) THEN C Modify sign of determinant according C to unsymmetric permutation (max-trans C of max-weighted matching) IF (id%KEEP(23).NE.0) THEN CALL ZMUMPS_DETER_SIGN_PERM( & RINFOG(12), id%N, C id%STEP: used as workspace of size N still C allocated on master; restored on exit & id%STEP(1), & id%UNS_PERM(1) ) C Remark that RINFOG(12/13) are modified only C on the host but will be broadcast on exit C from MUMPS (see ZMUMPS_DRIVER) ENDIF ENDIF ENDIF 490 IF (allocated(ITMP2)) DEALLOCATE(ITMP2) IF ( PROKG ) THEN C ----------------------------- C PRINT STATISTICS (on master) C ----------------------------- WRITE(MPG,99984) RINFOG(2),RINFOG(3),KEEP(52), & id%KEEP8(148), & id%KEEP8(128), INFOG(11), id%KEEP8(110) IF (id%KEEP(50) == 0) THEN ! off diag pivots WRITE(MPG, 99985) INFOG(12) END IF IF (id%KEEP(50) .NE. 1) THEN ! delayed pivots WRITE(MPG, 99982) INFOG(13) END IF IF (KEEP(97) .NE. 0) THEN ! tiny pivots WRITE(MPG, 99986) INFOG(25) ENDIF IF (id%KEEP(50) == 2) THEN !number of 2x2 pivots in type 1 nodes WRITE(MPG, 99988) KEEP(229) !number of 2x2 pivots in type 2 nodes WRITE(MPG, 99989) KEEP(230) ENDIF !number of zero pivots IF (KEEP(110) .NE.0) THEN WRITE(MPG, 99991) KEEP(112) ENDIF !Deficiency on root IF ( KEEP(19) .ne. 0 ) c IF ( KEEP(17) .ne. 0 ) & WRITE(MPG, 99983) KEEP(17) !Total deficiency IF (KEEP(110).NE.0.OR.KEEP(19).NE.0) c IF (KEEP(110).NE.0.OR.KEEP(17).NE.0) & WRITE(MPG, 99992) KEEP(17)+KEEP(112) ! Memory compress WRITE(MPG, 99981) INFOG(14) ! Extra copies due to ip stack in unsym case ! in core case (or OLD_OOC_PANEL) IF (id%KEEP8(108) .GT. 0_8) THEN WRITE(MPG, 99980) id%KEEP8(108) ENDIF IF ((KEEP(60).NE.0) .AND. INFOG(25).GT.0) THEN ! Schur on and tiny pivots set in last level ! before the Schur if KEEP(114)=0 WRITE(MPG, '(A)') & " ** Warning Static pivoting was necessary" WRITE(MPG, '(A)') & " ** to factor interior variables with Schur ON" ENDIF IF (KEEP(258).NE.0) THEN WRITE(MPG,99978) RINFOG(12) WRITE(MPG,99979) RINFOG(13) WRITE(MPG,99977) INFOG(34) ENDIF END IF * ========================================== * * End of Factorization Phase * * ========================================== C C Goto 500 is done when C LOAD_INIT C OOC_INIT_FACTO C MUMPS_FDM_INIT #if ! defined(NO_FDM_DESCBAND) C MUMPS_FDBD_INIT #endif #if ! defined(NO_FDM_MAPROW) C MUMPS_FMRD_INIT #endif C are all called. C 500 CONTINUE C Redo free DBLARR (as in end_driver.F) C in case an error occurred after allocating C DBLARR and before freeing it above. IF (id%KEEP(46).EQ.1 .AND. & id%KEEP(55).NE.0 .AND. & id%MYID.EQ.MASTER .AND. & id%KEEP(52) .EQ. 0) THEN NULLIFY(id%DBLARR) ELSE IF (associated(id%DBLARR)) THEN DEALLOCATE(id%DBLARR) NULLIFY(id%DBLARR) ENDIF ENDIF #if ! defined(NO_FDM_DESCBAND) IF (I_AM_SLAVE) THEN CALL MUMPS_FDBD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif #if ! defined(NO_FDM_MAPROW) IF (I_AM_SLAVE) THEN CALL MUMPS_FMRD_END(id%INFO(1)) ! INFO(1): input only ENDIF #endif IF (I_AM_SLAVE) THEN C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN C Store pointer to BLR_ARRAY in MUMPS structure C (requires successful factorization otherwise module is freed) CALL ZMUMPS_BLR_MOD_TO_STRUC(id%BLRARRAY_ENCODING) ELSE C INFO(1) positive or negative CALL ZMUMPS_BLR_END_MODULE(id%INFO(1), id%KEEP8) ENDIF ENDIF IF (I_AM_SLAVE) THEN CALL MUMPS_FDM_END('A') C Terminate BLR module except if it is still needed for solve IF ( & ( & (KEEP(486).EQ.2) & ) & .AND. id%INFO(1).GE.0 & ) THEN CALL MUMPS_FDM_MOD_TO_STRUC('F', id%FDM_F_ENCODING, & id%INFO(1)) IF (.NOT. associated(id%FDM_F_ENCODING)) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_FAC_DRIVER" ENDIF ELSE CALL MUMPS_FDM_END('F') ENDIF ENDIF C C Goto 514 is done when an C error occurred in MUMPS_FDM_INIT C or (after FDM_INIT but before C OOC_INIT) C 514 CONTINUE IF ( I_AM_SLAVE ) THEN IF ((KEEP(201).EQ.1).OR.(KEEP(201).EQ.2)) THEN CALL ZMUMPS_OOC_END_FACTO(id,IERR) IF (id%ASSOCIATED_OOC_FILES) THEN id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (KEEP(201).NE.0) THEN C ---------------------------------------- C In OOC or if KEEP(201).EQ.-1 we always C free S at end of factorization. As id%S C may be unassociated in case of error C during or before the allocation of id%S, C we only free S when it was associated. C ---------------------------------------- IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 ENDIF ELSE ! host not working IF (WK_USER_PROVIDED) THEN C at the end of a phase S is always freed when WK_USER provided NULLIFY(id%S) ELSE IF (associated(id%S)) DEALLOCATE(id%S) NULLIFY(id%S) ! in all cases id%KEEP8(23)=0_8 END IF END IF C C Goto 513 is done in case of error where LOAD_INIT was C called but not OOC_INIT_FACTO. 513 CONTINUE IF ( I_AM_SLAVE ) THEN CALL ZMUMPS_LOAD_END( id%INFO(1), id%NSLAVES, IERR ) IF (IERR.LT.0 .AND. id%INFO(1) .GE. 0) id%INFO(1) = IERR ENDIF CALL MUMPS_PROPINFO( ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) C C Goto 517 is done when an error occurs when GPU initialization C has been performed but not LOAD_INIT or OOC_INIT_FACTO C 517 CONTINUE C C Goto 530 is done when an error occurs before C the calls to GPU_INIT, LOAD_INIT and OOC_INIT_FACTO 530 CONTINUE C Fwd in facto: free RHS_MUMPS in case C it was allocated. IF (RHS_MUMPS_ALLOCATED) DEALLOCATE(RHS_MUMPS) NULLIFY(RHS_MUMPS) C id%KEEP8(26) = KEEP826_SAVE RETURN 120 FORMAT(/' Local redistrib: data local/sent =',I16,I16) 125 FORMAT(/' Redistrib: total data local/sent =',I16,I16) 130 FORMAT(//'****** FACTORIZATION STEP ********'/) 160 FORMAT( & /' Elapsed time to reformat/distribute matrix =',F12.4) 166 FORMAT(' Max difference from 1 after scaling the entries', & ' for ONE-NORM (option 7/8) =',D9.2) 170 FORMAT(' STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Size of internal working array S =',I16/ & ' Size of internal working array IS =',I16/ & ' Minimum (ICNTL(14)=0) size of S =',I16/ & ' Minimum (ICNTL(14)=0) size of IS =',I16/ & ' Real space for original matrix =',I16/ & ' Integer space for original matrix =',I16/ & ' INFO(3) Real space for factors (estimated) =',I16/ & ' INFO(4) Integer space for factors (estim.) =',I16/ & ' Maximum frontal size (estimated) =',I16) 172 FORMAT(' GLOBAL STATISTICS PRIOR NUMERICAL FACTORIZATION ...'/ & ' Number of working processes =',I16/ & ' ICNTL(22) Out-of-core option =',I16/ & ' ICNTL(35) BLR activation (eff. choice) =',I16/ & ' ICNTL(14) Memory relaxation =',I16/ & ' INFOG(3) Real space for factors (estimated)=',I16/ & ' INFOG(4) Integer space for factors (estim.)=',I16/ & ' Maximum frontal size (estimated) =',I16/ & ' Number of nodes in the tree =',I16/ & ' Memory allowed (MB -- 0: N/A ) =',I16/ & ' Memory provided by user, sum of LWK_USER =',I16/ & ' Effective threshold for pivoting, CNTL(1) =',D16.4) 173 FORMAT( ' Perform forward during facto, NRHS =',I16) 174 FORMAT( ' KEEP(268) Relaxed pivoting effective value =',I16) 180 FORMAT(/' Elapsed time for factorization =',F12.4) 185 FORMAT(/' Elapsed time for (failed) factorization =',F12.4) 99977 FORMAT( ' INFOG(34) Determinant (base 2 exponent) =',I16) 99978 FORMAT( ' RINFOG(12) Determinant (real part) =',F16.8) 99979 FORMAT( ' RINFOG(12) Determinant (imaginary part) =',F16.8) 99980 FORMAT( ' Extra copies due to In-Place stacking =',I16) 99981 FORMAT( ' INFOG(14) Number of memory compress =',I16) 99982 FORMAT( ' INFOG(13) Number of delayed pivots =',I16) 99983 FORMAT( ' Nb of singularities detected by ICNTL(56) =',I16) 99991 FORMAT( ' Nb of null pivots detected by ICNTL(24) =',I16) 99992 FORMAT( ' INFOG(28) Estimated deficiency =',I16) 99984 FORMAT(/'Leaving factorization with ...'/ & ' RINFOG(2) Operations in node assembly =',1PD10.3/ & ' ------(3) Operations in node elimination =',1PD10.3/ & ' ICNTL (8) Scaling effectively used =',I16/ & ' INFOG (9) Real space for factors =',I16/ & ' INFOG(10) Integer space for factors =',I16/ & ' INFOG(11) Maximum front size =',I16/ & ' INFOG(29) Number of entries in factors =',I16) 99985 FORMAT( ' INFOG(12) Number of off diagonal pivots =',I16) 99986 FORMAT( ' INFOG(25) Number of tiny pivots(static) =',I16) 99988 FORMAT( ' Number of 2x2 pivots in type 1 nodes =',I16) 99989 FORMAT( ' Number of 2x2 pivots in type 2 nodes =',I16) END SUBROUTINE ZMUMPS_FAC_DRIVER C SUBROUTINE ZMUMPS_PRINT_ALLOCATED_MEM( PROK, PROKG, PRINT_MAXAVG, & MP, MPG, INFO16, INFOG18, INFOG19, NSLAVES, IRANK, KEEP ) IMPLICIT NONE C C Purpose: C ======= C Print memory allocated during factorization C - called at beginning of factorization in full-rank C - called at end of factorization in low-rank (because C of dynamic allocations) C LOGICAL, INTENT(IN) :: PROK, PROKG, PRINT_MAXAVG INTEGER, INTENT(IN) :: MP, MPG, INFO16, INFOG18, INFOG19 INTEGER, INTENT(IN) :: IRANK, NSLAVES INTEGER, INTENT(IN) :: KEEP(500) C IF ( PROKG ) THEN IF (PRINT_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' ** Memory allocated, max in Mbytes (INFOG(18)):', & INFOG18 ENDIF WRITE( MPG,'(/A,I12) ') & ' ** Memory allocated, total in Mbytes (INFOG(19)):', & INFOG19 END IF RETURN END SUBROUTINE ZMUMPS_PRINT_ALLOCATED_MEM SUBROUTINE ZMUMPS_AVGMAX_STAT8(PROKG, MPG, VAL, NSLAVES, & PRINT_MAXAVG, COMM, MSG) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL, intent(in) :: PROKG INTEGER, intent(in) :: MPG INTEGER(8), intent(in) :: VAL INTEGER, intent(in) :: NSLAVES LOGICAL, intent(in) :: PRINT_MAXAVG INTEGER, intent(in) :: COMM CHARACTER*48 MSG C Local INTEGER(8) MAX_VAL INTEGER IERR, MASTER DOUBLE PRECISION LOC_VAL, AVG_VAL PARAMETER(MASTER=0) C CALL MUMPS_REDUCEI8( VAL, MAX_VAL, MPI_MAX, MASTER, COMM) LOC_VAL = dble(VAL)/dble(NSLAVES) CALL MPI_REDUCE( LOC_VAL, AVG_VAL, 1, MPI_DOUBLE_PRECISION, & MPI_SUM, MASTER, COMM, IERR ) IF (PROKG) THEN IF (PRINT_MAXAVG) THEN WRITE(MPG,100) " Average", MSG, int(AVG_VAL,8) ELSE WRITE(MPG,110) MSG, MAX_VAL ENDIF ENDIF RETURN 100 FORMAT(A8,A48,I18) 110 FORMAT(A48,I18) END SUBROUTINE ZMUMPS_AVGMAX_STAT8 C SUBROUTINE ZMUMPS_EXTRACT_SCHUR_REDRHS(id) USE ZMUMPS_STRUC_DEF IMPLICIT NONE C C Purpose C ======= C C Extract the Schur and possibly also the reduced right-hand side C (if Fwd in facto) from the processor working on Schur and copy C it into the user datastructures id%SCHUR and id%REDRHS on the host. C This routine assumes that the integer list of the Schur has not C been permuted and still corresponds to LISTVAR_SCHUR. C C If the Schur is centralized, the master of the Schur holds the C Schur and possibly also the reduced right-hand side. C If the Schur is distribued (already built in user's datastructure), C then the master of the Schur may hold the reduced right-hand side, C in which case it is available in root%RHS_CNTR_MASTER_ROOT. C TYPE(ZMUMPS_STRUC) :: id C C Local variables C =============== C INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INCLUDE 'mumps_headers.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER :: IERR INTEGER, PARAMETER :: MASTER = 0 INTEGER :: ID_SCHUR, SIZE_SCHUR, LD_SCHUR, IB, BL4 INTEGER :: ROW_LENGTH, I INTEGER(8) :: SURFSCHUR8, BL8, SHIFT8 INTEGER(8) :: ISCHUR_SRC, ISCHUR_DEST, ISCHUR_SYM, ISCHUR_UNS C C External functions C ================== C INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE C Quick return in case factorization did not terminate correctly IF (id%INFO(1) .LT. 0) RETURN C Quick return if Schur option off IF (id%KEEP(60) .EQ. 0) RETURN C Get Schur id ID_SCHUR =MUMPS_PROCNODE( & id%PROCNODE_STEPS(id%STEP(max(id%KEEP(20),id%KEEP(38)))), & id%KEEP(199)) IF ( id%KEEP( 46 ) .NE. 1 ) THEN ID_SCHUR = ID_SCHUR + 1 END IF C Get size of Schur IF (id%MYID.EQ.ID_SCHUR) THEN IF (id%KEEP(60).EQ.1) THEN C Sequential Schur LD_SCHUR = & id%IS(id%PTLUST_S(id%STEP(id%KEEP(20)))+2+id%KEEP(IXSZ)) SIZE_SCHUR = LD_SCHUR - id%KEEP(253) ELSE C Parallel Schur LD_SCHUR = -999999 ! not used SIZE_SCHUR = id%root%TOT_ROOT_SIZE ENDIF ELSE IF (id%MYID .EQ. MASTER) THEN SIZE_SCHUR = id%KEEP(116) LD_SCHUR = -44444 ! Not used ELSE C Proc is not concerned with Schur, return RETURN ENDIF SURFSCHUR8 = int(SIZE_SCHUR,8)*int(SIZE_SCHUR,8) C ================================= C Case of parallel Schur: if REDRHS C was requested, obtain it directly C from id%root%RHS_CNTR_MASTER_ROOT C ================================= IF (id%KEEP(60) .GT. 1) THEN IF (id%KEEP(221).EQ.1 .AND. id%KEEP(252).GT.0) THEN DO I = 1, id%KEEP(253) IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL zcopy(SIZE_SCHUR, & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), 1, & id%REDRHS((I-1)*id%LREDRHS+1), 1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( & id%root%RHS_CNTR_MASTER_ROOT((I-1)*SIZE_SCHUR+1), & SIZE_SCHUR, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE ! MYID.EQ.MASTER C Receive CALL MPI_RECV( id%REDRHS((I-1)*id%LREDRHS+1), & SIZE_SCHUR, & MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ENDDO C ------------------------------ C In case of parallel Schur, we C free root%RHS_CNTR_MASTER_ROOT C ------------------------------ IF (id%MYID.EQ.ID_SCHUR) THEN DEALLOCATE(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY (id%root%RHS_CNTR_MASTER_ROOT) ENDIF ENDIF C return because this is all we need to do C in case of parallel Schur complement RETURN ENDIF C ============================ C Centralized Schur complement C ============================ C PTRAST has been freed at the moment of calling this C routine. Schur is available through C PTRFAC(IW( PTLUST_S( STEP(KEEP(20)) ) + 4 +KEEP(IXSZ) )) IF (id%KEEP(252).EQ.0) THEN C CASE 1 (ORIGINAL CODE): C Schur is contiguous on ID_SCHUR IF ( ID_SCHUR .EQ. MASTER ) THEN ! Necessarily equals id%MYID C --------------------- C Copy Schur complement C --------------------- CALL ZMUMPS_COPYI8SIZE( SURFSCHUR8, & id%S(id%PTRFAC(id%STEP(id%KEEP(20)))), & id%SCHUR(1) ) ELSE C ----------------------------------------- C The processor responsible of the Schur C complement sends it to the host processor C ----------------------------------------- BL8=int(huge(BL4)/id%KEEP(35)/10,8) DO IB=1, int((SURFSCHUR8+BL8-1_8) / BL8) SHIFT8 = int(IB-1,8) * BL8 ! Where to send BL4 = int(min(BL8,SURFSCHUR8-SHIFT8)) ! Size of block IF ( id%MYID .eq. ID_SCHUR ) THEN C Send Schur complement CALL MPI_SEND( id%S( SHIFT8 + & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ)))), & BL4, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE IF ( id%MYID .eq. MASTER ) THEN C Receive Schur complement CALL MPI_RECV( id%SCHUR(1_8 + SHIFT8), & BL4, & MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) END IF ENDDO END IF ELSE C CASE 2 (Fwd in facto): Schur is not contiguous on ID_SCHUR, C process it row by row. C C 2.1: We first centralize Schur complement into id%SCHUR ISCHUR_SRC = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) ISCHUR_DEST= 1_8 DO I=1, SIZE_SCHUR ROW_LENGTH = SIZE_SCHUR IF (ID_SCHUR.EQ.MASTER) THEN ! Necessarily = id%MYID CALL zcopy(ROW_LENGTH, id%S(ISCHUR_SRC), 1, & id%SCHUR(ISCHUR_DEST),1) ELSE IF (id%MYID.EQ.ID_SCHUR) THEN C Send CALL MPI_SEND( id%S(ISCHUR_SRC), ROW_LENGTH, & MPI_DOUBLE_COMPLEX, & MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE C Recv CALL MPI_RECV( id%SCHUR(ISCHUR_DEST), & ROW_LENGTH, & MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF ISCHUR_SRC = ISCHUR_SRC+int(LD_SCHUR,8) ISCHUR_DEST= ISCHUR_DEST+int(SIZE_SCHUR,8) ENDDO C 2.2: Get REDRHS on host C 2.2.1: Symmetric => REDRHS is available in last KEEP(253) C rows of Schur structure on ID_SCHUR C 2.2.2: Unsymmetric => REDRHS corresponds to last KEEP(253) C columns. However it must be transposed. IF (id%KEEP(221).EQ.1) THEN ! Implies Fwd in facto ISCHUR_SYM = id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) * & int(LD_SCHUR,8) ISCHUR_UNS = & id%PTRFAC(id%IS(id%PTLUST_S(id%STEP(id%KEEP(20))) & +4+id%KEEP(IXSZ))) + int(SIZE_SCHUR,8) ISCHUR_DEST = 1_8 DO I = 1, id%KEEP(253) IF (ID_SCHUR .EQ. MASTER) THEN ! necessarily = id%MYID IF (id%KEEP(50) .EQ. 0) THEN CALL zcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%REDRHS(ISCHUR_DEST), 1) ELSE CALL zcopy(SIZE_SCHUR, id%S(ISCHUR_SYM), 1, & id%REDRHS(ISCHUR_DEST), 1) ENDIF ELSE IF (id%MYID .NE. MASTER) THEN IF (id%KEEP(50) .EQ. 0) THEN C Use id%S(ISCHUR_SYM) as temporary contig. workspace C of size SIZE_SCHUR. CALL zcopy(SIZE_SCHUR, id%S(ISCHUR_UNS), LD_SCHUR, & id%S(ISCHUR_SYM), 1) ENDIF CALL MPI_SEND(id%S(ISCHUR_SYM), SIZE_SCHUR, & MPI_DOUBLE_COMPLEX, MASTER, TAG_SCHUR, & id%COMM, IERR ) ELSE CALL MPI_RECV(id%REDRHS(ISCHUR_DEST), & SIZE_SCHUR, MPI_DOUBLE_COMPLEX, ID_SCHUR, TAG_SCHUR, & id%COMM, STATUS, IERR ) ENDIF ENDIF IF (id%KEEP(50).EQ.0) THEN ISCHUR_UNS = ISCHUR_UNS + int(LD_SCHUR,8) ELSE ISCHUR_SYM = ISCHUR_SYM + int(LD_SCHUR,8) ENDIF ISCHUR_DEST = ISCHUR_DEST + int(id%LREDRHS,8) ENDDO ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_EXTRACT_SCHUR_REDRHS MUMPS_5.4.1/src/zfac_mem_compress_cb.F0000664000175000017500000005056614102210524017767 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_SIZEFREEINREC(IW,LREC,SIZE_FREE,XSIZE) IMPLICIT NONE INTEGER, intent(in) :: LREC, XSIZE INTEGER, intent(in) :: IW(LREC) INTEGER(8), intent(out):: SIZE_FREE INTEGER(8) :: SIZE_STA, SIZE_DYN INCLUDE 'mumps_headers.h' CALL MUMPS_GETI8( SIZE_STA,IW(1+XXR) ) CALL MUMPS_GETI8( SIZE_DYN,IW(1+XXD) ) IF ( SIZE_DYN .GT. 0) THEN SIZE_FREE = SIZE_STA ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE+3),8) ELSE IF (IW(1+XXS).EQ.S_NOLCBCONTIG38 .OR. & IW(1+XXS).EQ.S_NOLCBNOCONTIG38) THEN SIZE_FREE=int(IW(1+XSIZE+2),8)*int(IW(1+XSIZE)+ & IW(1+XSIZE + 3) - & ( IW(1+XSIZE + 4) & - IW(1+XSIZE + 3) ), 8) ELSE IF (IW(1+XXS).EQ.S_NOLNOCB) THEN SIZE_FREE = SIZE_STA ELSE SIZE_FREE=0_8 ENDIF RETURN END SUBROUTINE ZMUMPS_SIZEFREEINREC SUBROUTINE ZMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW, XSIZE, KEEP216) IMPLICIT NONE LOGICAL, INTENT(out) :: RECORD_CAN_BE_COMPRESSED INTEGER, INTENT(in) :: XSIZE, KEEP216 INTEGER, INTENT(in) :: IW(XSIZE) INCLUDE 'mumps_headers.h' INTEGER(8) :: SIZE_DYN, SIZE_STA CALL MUMPS_GETI8( SIZE_STA, IW(1+XXR)) CALL MUMPS_GETI8( SIZE_DYN, IW(1+XXD)) IF (IW(1+XXS) .EQ. S_FREE) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( SIZE_DYN .GT. 0_8 .AND. SIZE_STA .GT. 0_8) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE IF ( IW(1+XXS) .EQ. S_NOLNOCB) THEN RECORD_CAN_BE_COMPRESSED = .TRUE. ELSE RECORD_CAN_BE_COMPRESSED = & ( IW(1+XXS) .EQ. S_NOLCBNOCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG .OR. & IW(1+XXS) .EQ. S_NOLCBNOCONTIG38 .OR. & IW(1+XXS) .EQ. S_NOLCBCONTIG38 ) & .AND. KEEP216.NE.3 ENDIF RETURN END SUBROUTINE ZMUMPS_CAN_RECORD_BE_COMPRESSED SUBROUTINE ZMUMPS_MOVETONEXTRECORD &(IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER(8) :: RCURRENT INTEGER LIW,IXXP,ICURRENT,NEXT,ISIZE2SHIFT INTEGER IW(LIW) INTEGER(8) :: RSIZE ICURRENT=NEXT CALL MUMPS_GETI8( RSIZE, IW(ICURRENT + XXR) ) RCURRENT = RCURRENT - RSIZE NEXT=IW(ICURRENT+XXP) IW(IXXP)=ICURRENT+ISIZE2SHIFT IXXP=ICURRENT+XXP RETURN END SUBROUTINE ZMUMPS_MOVETONEXTRECORD SUBROUTINE ZMUMPS_ISHIFT(IW,LIW,BEG2SHIFT,END2SHIFT,ISIZE2SHIFT) IMPLICIT NONE INTEGER LIW, BEG2SHIFT, END2SHIFT, ISIZE2SHIFT INTEGER IW(LIW) INTEGER I IF (ISIZE2SHIFT.GT.0) THEN DO I=END2SHIFT,BEG2SHIFT,-1 IW(I+ISIZE2SHIFT)=IW(I) ENDDO ELSE IF (ISIZE2SHIFT.LT.0) THEN DO I=BEG2SHIFT,END2SHIFT IW(I+ISIZE2SHIFT)=IW(I) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ISHIFT SUBROUTINE ZMUMPS_RSHIFT(A, LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT) IMPLICIT NONE INTEGER(8) :: LA, BEG2SHIFT, END2SHIFT, RSIZE2SHIFT COMPLEX(kind=8) A(LA) INTEGER(8) :: I IF (RSIZE2SHIFT.GT.0_8) THEN DO I=END2SHIFT,BEG2SHIFT,-1_8 A(I+RSIZE2SHIFT)=A(I) ENDDO ELSE IF (RSIZE2SHIFT.LT.0_8) THEN DO I=BEG2SHIFT,END2SHIFT A(I+RSIZE2SHIFT)=A(I) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_RSHIFT SUBROUTINE ZMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP199, PROCNODE_STEPS, DAD) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_PAMASTERORPTRAST IMPLICIT NONE INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF, KEEP199 INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) COMPLEX(kind=8), INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(in) :: MYID INCLUDE 'mumps_headers.h' INTEGER ICURRENT, NEXT, STATE_NEXT INTEGER(8) :: RCURRENT INTEGER ISIZE2SHIFT INTEGER(8) :: RSIZE2SHIFT INTEGER IBEGCONTIG INTEGER(8) :: RBEGCONTIG INTEGER(8) :: RBEG2SHIFT, REND2SHIFT INTEGER INODE LOGICAL :: IS_PAMASTER, IS_PTRAST INTEGER(8) :: FREE_IN_REC INTEGER(8) :: RCURRENT_SIZE, DYN_SIZE LOGICAL :: RECORD_CAN_BE_COMPRESSED INTEGER IXXP INTEGER, EXTERNAL :: MUMPS_TYPENODE INTEGER, EXTERNAL :: MUMPS_PROCNODE LOGICAL, EXTERNAL :: ZMUMPS_ISBAND EXTERNAL MPI_WTIME DOUBLE PRECISION MPI_WTIME DOUBLE PRECISION TIME_REF, TIME_COMP TIME_REF = MPI_WTIME() ISIZE2SHIFT=0 RSIZE2SHIFT=0_8 ICURRENT = LIW-XSIZE+1 RCURRENT = LA+1_8 IBEGCONTIG = -999999 RBEGCONTIG = -999999_8 NEXT = IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) GOTO 120 COMP=COMP+1 STATE_NEXT = IW(NEXT+XXS) IXXP = ICURRENT+XXP 10 CONTINUE CALL ZMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, & IW(NEXT), XSIZE, KEEP216) IF ( .NOT. RECORD_CAN_BE_COMPRESSED ) THEN CALL ZMUMPS_MOVETONEXTRECORD(IW,LIW, & IXXP, ICURRENT, NEXT, RCURRENT, ISIZE2SHIFT) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) IF (IBEGCONTIG < 0) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF IF (RBEGCONTIG < 0_8) THEN RBEGCONTIG=RCURRENT+RCURRENT_SIZE-1_8 ENDIF INODE=IW(ICURRENT+XXN) IF ( DYN_SIZE .EQ. 0_8 ) THEN IF (RSIZE2SHIFT .NE. 0_8) THEN CALL ZMUMPS_DM_PAMASTERORPTRAST( N, SLAVEF, MYID, & KEEP28, KEEP199, & INODE, IW(ICURRENT+XXS), & IW(ICURRENT+XXD:ICURRENT+XXD+1), STEP, & DAD, PROCNODE_STEPS, RCURRENT, PAMASTER, PTRAST, & IS_PAMASTER, IS_PTRAST ) IF (IS_PTRAST) THEN PTRAST(STEP(INODE))= & PTRAST(STEP(INODE))+RSIZE2SHIFT ELSE IF (IS_PAMASTER) THEN PAMASTER(STEP(INODE))= & PAMASTER(STEP(INODE))+RSIZE2SHIFT ENDIF ENDIF ENDIF IF (ISIZE2SHIFT .NE. 0) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ENDIF IF (NEXT .NE. TOP_OF_STACK) THEN STATE_NEXT=IW(NEXT+XXS) GOTO 10 ENDIF ENDIF 20 CONTINUE IF (IBEGCONTIG.NE.0 .AND. ISIZE2SHIFT .NE. 0) THEN CALL ZMUMPS_ISHIFT(IW,LIW,ICURRENT,IBEGCONTIG,ISIZE2SHIFT) IF (IXXP .LE.IBEGCONTIG) THEN IXXP=IXXP+ISIZE2SHIFT ENDIF ENDIF IBEGCONTIG=-9999 25 CONTINUE IF (RBEGCONTIG .GT.0_8 .AND. RSIZE2SHIFT .NE. 0_8) THEN CALL ZMUMPS_RSHIFT(A,LA,RCURRENT,RBEGCONTIG,RSIZE2SHIFT) ENDIF RBEGCONTIG=-99999_8 30 CONTINUE IF (NEXT.EQ. TOP_OF_STACK) GOTO 100 CALL ZMUMPS_CAN_RECORD_BE_COMPRESSED( & RECORD_CAN_BE_COMPRESSED, IW(NEXT), XSIZE, KEEP216) IF ( STATE_NEXT .NE. S_FREE .AND. & RECORD_CAN_BE_COMPRESSED ) THEN IF (RBEGCONTIG > 0_8) GOTO 25 CALL ZMUMPS_MOVETONEXTRECORD & (IW,LIW,IXXP,ICURRENT,NEXT, RCURRENT,ISIZE2SHIFT) IF (IBEGCONTIG < 0 ) THEN IBEGCONTIG=ICURRENT+IW(ICURRENT+XXI)-1 ENDIF CALL ZMUMPS_SIZEFREEINREC(IW(ICURRENT), & LIW-ICURRENT+1, & FREE_IN_REC, & XSIZE) CALL MUMPS_GETI8(DYN_SIZE, IW(ICURRENT+XXD)) IF (DYN_SIZE .GT. 0_8) THEN ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), 0, & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBNOCONTIG38) THEN CALL ZMUMPS_MAKECBCONTIG(A,LA,RCURRENT, & IW(ICURRENT+XSIZE+2), & IW(ICURRENT+XSIZE), & IW(ICURRENT+XSIZE)+IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XSIZE+4)-IW(ICURRENT+XSIZE+3), & IW(ICURRENT+XXS),RSIZE2SHIFT) IW(ICURRENT+XXS) = S_NOLCLEANED38 ELSE IF (STATE_NEXT.EQ.S_NOLNOCB) THEN IW(ICURRENT+XXS) = S_NOLNOCBCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IF (STATE_NEXT .EQ. S_NOLCBCONTIG) THEN IW(ICURRENT+XXS) = S_NOLCLEANED ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG38) THEN IW(ICURRENT+XXS) = S_NOLCLEANED38 ENDIF IF (RSIZE2SHIFT .GT.0_8) THEN RBEG2SHIFT = RCURRENT + FREE_IN_REC CALL MUMPS_GETI8(RCURRENT_SIZE, IW(ICURRENT+XXR)) REND2SHIFT = RCURRENT + RCURRENT_SIZE - 1_8 CALL ZMUMPS_RSHIFT(A, LA, & RBEG2SHIFT, REND2SHIFT, & RSIZE2SHIFT) ENDIF ELSE WRITE(*,*) "Internal error 3 in ZMUMPS_COMPRE_NEW", & STATE_NEXT, DYN_SIZE, FREE_IN_REC CALL MUMPS_ABORT() ENDIF INODE = IW(ICURRENT+XXN) IF ( DYN_SIZE .GT. 0_8 ) THEN IF (PTRIST(STEP(INODE)).EQ.ICURRENT) & PTRIST(STEP(INODE))= & PTRIST(STEP(INODE))+ISIZE2SHIFT IF (PIMASTER(STEP(INODE)).EQ.ICURRENT) & PIMASTER(STEP(INODE))= & PIMASTER(STEP(INODE))+ISIZE2SHIFT ELSE IF (STATE_NEXT .EQ. S_NOLCBCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG .OR. & STATE_NEXT .EQ. S_NOLCBCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLCBNOCONTIG38 .OR. & STATE_NEXT .EQ. S_NOLNOCB ) THEN IF (ISIZE2SHIFT.NE.0) THEN PTRIST(STEP(INODE))=PTRIST(STEP(INODE))+ISIZE2SHIFT ENDIF PTRAST(STEP(INODE))=PTRAST(STEP(INODE))+RSIZE2SHIFT+ & FREE_IN_REC ELSE WRITE(*,*) "Internal error 4 in ZMUMPS_COMPRE_NEW", & STATE_NEXT CALL MUMPS_ABORT() ENDIF CALL MUMPS_SUBTRI8TOARRAY(IW(ICURRENT+XXR),FREE_IN_REC) RSIZE2SHIFT=RSIZE2SHIFT+FREE_IN_REC RBEGCONTIG=-9999_8 IF (NEXT.EQ.TOP_OF_STACK) THEN GOTO 20 ELSE STATE_NEXT=IW(NEXT+XXS) ENDIF GOTO 30 ENDIF IF (IBEGCONTIG.GT.0) THEN GOTO 20 ENDIF 40 CONTINUE IF (STATE_NEXT == S_FREE) THEN ICURRENT = NEXT CALL MUMPS_GETI8( RCURRENT_SIZE, IW(ICURRENT + XXR) ) ISIZE2SHIFT = ISIZE2SHIFT + IW(ICURRENT+XXI) RSIZE2SHIFT = RSIZE2SHIFT + RCURRENT_SIZE RCURRENT = RCURRENT - RCURRENT_SIZE NEXT=IW(ICURRENT+XXP) IF (NEXT.EQ.TOP_OF_STACK) THEN WRITE(*,*) "Internal error 1 in ZMUMPS_COMPRE_NEW" CALL MUMPS_ABORT() ENDIF STATE_NEXT = IW(NEXT+XXS) GOTO 40 ENDIF GOTO 10 100 CONTINUE IWPOSCB = IWPOSCB + ISIZE2SHIFT LRLU = LRLU + RSIZE2SHIFT IPTRLU = IPTRLU + RSIZE2SHIFT 120 CONTINUE TIME_COMP = MPI_WTIME() - TIME_REF ACC_TIME = ACC_TIME + TIME_COMP RETURN END SUBROUTINE ZMUMPS_COMPRE_NEW SUBROUTINE ZMUMPS_GET_SIZEHOLE(IREC, IW, LIW, & ISIZEHOLE, RSIZEHOLE) IMPLICIT NONE INTEGER, intent(in) :: IREC, LIW INTEGER, intent(in) :: IW(LIW) INTEGER, intent(out):: ISIZEHOLE INTEGER(8), intent(out) :: RSIZEHOLE INTEGER IRECLOC INTEGER(8) :: RECLOC_SIZE INCLUDE 'mumps_headers.h' ISIZEHOLE=0 RSIZEHOLE=0_8 IRECLOC = IREC + IW( IREC+XXI ) 10 CONTINUE CALL MUMPS_GETI8(RECLOC_SIZE, IW(IRECLOC+XXR)) IF (IW(IRECLOC+XXS).EQ.S_FREE) THEN ISIZEHOLE=ISIZEHOLE+IW(IRECLOC+XXI) RSIZEHOLE=RSIZEHOLE+RECLOC_SIZE IRECLOC=IRECLOC+IW(IRECLOC+XXI) GOTO 10 ENDIF RETURN END SUBROUTINE ZMUMPS_GET_SIZEHOLE SUBROUTINE ZMUMPS_MAKECBCONTIG(A, LA, RCURRENT, & NROW, NCB, LD, NELIM, NODESTATE, ISHIFT) IMPLICIT NONE INCLUDE 'mumps_headers.h' INTEGER LD, NROW, NCB, NELIM, NODESTATE INTEGER(8) :: ISHIFT INTEGER(8) :: LA, RCURRENT COMPLEX(kind=8) A(LA) INTEGER I,J INTEGER(8) :: IOLD,INEW LOGICAL NELIM_ROOT NELIM_ROOT=.TRUE. IF (NODESTATE.EQ. S_NOLCBNOCONTIG) THEN NELIM_ROOT=.FALSE. IF (NELIM.NE.0) THEN WRITE(*,*) "Internal error 1 IN ZMUMPS_MAKECBCONTIG" CALL MUMPS_ABORT() ENDIF ELSE IF (NODESTATE .NE. S_NOLCBNOCONTIG38) THEN WRITE(*,*) "Internal error 2 in ZMUMPS_MAKECBCONTIG" & ,NODESTATE CALL MUMPS_ABORT() ENDIF IF (ISHIFT .LT.0_8) THEN WRITE(*,*) "Internal error 3 in ZMUMPS_MAKECBCONTIG",ISHIFT CALL MUMPS_ABORT() ENDIF IF (NELIM_ROOT) THEN IOLD=RCURRENT+int(LD,8)*int(NROW,8)+int(NELIM-1-NCB,8) ELSE IOLD = RCURRENT+int(LD,8)*int(NROW,8)-1_8 ENDIF INEW = RCURRENT+int(LD,8)*int(NROW,8)+ISHIFT-1_8 DO I = NROW, 1, -1 IF (I.EQ.NROW .AND. ISHIFT.EQ.0_8.AND. & .NOT. NELIM_ROOT) THEN IOLD=IOLD-int(LD,8) INEW=INEW-int(NCB,8) CYCLE ENDIF IF (NELIM_ROOT) THEN DO J=1,NELIM A( INEW ) = A( IOLD + int(- J + 1,8)) INEW = INEW - 1_8 ENDDO ELSE DO J=1, NCB A( INEW ) = A( IOLD + int(- J + 1, 8)) INEW = INEW - 1_8 ENDDO ENDIF IOLD = IOLD - int(LD,8) ENDDO IF (NELIM_ROOT) THEN NODESTATE=S_NOLCBCONTIG38 ELSE NODESTATE=S_NOLCBCONTIG ENDIF RETURN END SUBROUTINE ZMUMPS_MAKECBCONTIG SUBROUTINE ZMUMPS_GET_SIZE_NEEDED( & SIZEI_NEEDED, SIZER_NEEDED, SKIP_TOP_STACK, & KEEP, KEEP8, & N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, PROCNODE_STEPS, DAD, & IFLAG, IERROR & ) #if ! defined(NODYNAMICCB) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY: ZMUMPS_DM_CBSTATIC2DYNAMIC #endif IMPLICIT NONE INTEGER, INTENT(in) :: SIZEI_NEEDED INTEGER(8), INTENT(in) :: SIZER_NEEDED LOGICAL, INTENT(in) :: SKIP_TOP_STACK INTEGER, INTENT(in) :: KEEP(500) INTEGER(8), INTENT(inout):: KEEP8(150) INTEGER, INTENT(in) :: N, LIW, KEEP28, KEEP216, XSIZE INTEGER(8), INTENT(in) :: LA INTEGER(8), INTENT(inout):: LRLU, IPTRLU, LRLUS INTEGER, INTENT(inout) :: IWPOSCB INTEGER, INTENT(inout) :: IWPOS INTEGER(8), INTENT(inout) :: PTRAST(KEEP28), PAMASTER(KEEP28) INTEGER, INTENT(inout) :: IW(LIW),PTRIST(KEEP28), & PIMASTER(KEEP28) INTEGER, INTENT(in) :: STEP(N), SLAVEF INTEGER, INTENT(in) :: PROCNODE_STEPS(KEEP28), DAD(KEEP28) COMPLEX(kind=8), INTENT(inout) :: A(LA) INTEGER, INTENT(inout) :: COMP DOUBLE PRECISION, INTENT(inout) :: ACC_TIME INTEGER, INTENT(iN) :: MYID INTEGER, INTENT(inout) :: IFLAG, IERROR LOGICAL ZMUMPS_COMPRE_NEW_CALLED ZMUMPS_COMPRE_NEW_CALLED = .FALSE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 1 in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ZMUMPS_COMPRE_NEW_CALLED = .TRUE. IF (IWPOSCB-IWPOS+1 .LT. SIZEI_NEEDED) THEN IFLAG = -8 IERROR = SIZEI_NEEDED GOTO 500 ENDIF ENDIF IF ( .NOT.ZMUMPS_COMPRE_NEW_CALLED.AND. & (LRLU.LT.SIZER_NEEDED).AND. & (LRLUS.GE.SIZER_NEEDED).AND. & (LRLU.NE.LRLUS) & ) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) ZMUMPS_COMPRE_NEW_CALLED = .TRUE. IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF IF (LRLUS.LT.SIZER_NEEDED) THEN #if ! defined(NODYNAMICCB) IF (.NOT. ZMUMPS_COMPRE_NEW_CALLED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 2 ', & 'in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF CALL ZMUMPS_DM_CBSTATIC2DYNAMIC(KEEP(141), & SIZER_NEEDED, SKIP_TOP_STACK, & MYID, N, SLAVEF, & KEEP, KEEP8, & IW, LIW, IWPOSCB, IWPOS, & A, LA, LRLU, IPTRLU, LRLUS, & STEP, PTRAST, PAMASTER, & PROCNODE_STEPS, DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 500 IF (LRLU.LT.SIZER_NEEDED) THEN CALL ZMUMPS_COMPRE_NEW(N,KEEP28,IW,LIW,A,LA, & LRLU,IPTRLU,IWPOS, & IWPOSCB,PTRIST,PTRAST,STEP,PIMASTER,PAMASTER, & KEEP216,LRLUS,XSIZE, COMP, ACC_TIME, MYID, & SLAVEF, KEEP(199), PROCNODE_STEPS, DAD) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'Internal error 4 ', & 'in ZMUMPS_GET_SIZE_NEEDED ', & 'PB compress... ZMUMPS_ALLOC_CB ', & 'LRLU,LRLUS=',LRLU,LRLUS IFLAG = -9 GOTO 500 END IF ENDIF #else IFLAG = -9 CALL MUMPS_SET_IERROR(SIZER_NEEDED-LRLUS, IERROR) GOTO 500 #endif ENDIF 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_GET_SIZE_NEEDED MUMPS_5.4.1/src/cfac_process_master2.F0000664000175000017500000001630114102210523017702 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_PROCESS_MASTER2(MYID,BUFR, LBUFR, & LBUFR_BYTES, & PROCNODE_STEPS, SLAVEF, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, & N, IW, LIW, A, LA, & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & COMP, & IFLAG, IERROR, COMM, COMM_LOAD, & IPOOL, LPOOL, LEAF, KEEP, KEEP8, DKEEP, & ND, FILS, DAD, FRERE, ITLOC, RHS_MUMPS, & ISTEP_TO_INIV2, TAB_POS_IN_PERE ) USE CMUMPS_LOAD USE CMUMPS_DYNAMIC_MEMORY_M, ONLY : CMUMPS_DM_SET_PTR IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR INTEGER MYID INTEGER KEEP(500) INTEGER(8) KEEP8(150) REAL DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER SLAVEF INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER IWPOS, IWPOSCB INTEGER N, LIW INTEGER IW( LIW ) COMPLEX A( LA ) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), PIMASTER(KEEP(28)) INTEGER PROCNODE_STEPS( KEEP(28) ), ITLOC( N +KEEP(253) ) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER COMP INTEGER NSTK_S( KEEP(28) ) INTEGER IFLAG, IERROR, COMM, COMM_LOAD INTEGER LPOOL, LEAF INTEGER IPOOL( LPOOL ) INTEGER ND(KEEP(28)), FILS( N ), DAD(KEEP(28)), FRERE(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSITION, IFATH, ISON, NROW, NCOL, NELIM, & NSLAVES INTEGER(8) :: NOREAL INTEGER NOINT, INIV2, NCOL_EFF DOUBLE PRECISION FLOP1 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET INTEGER NOREAL_PACKET LOGICAL PERETYPE2 INCLUDE 'mumps_headers.h' COMPLEX, POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: DYN_SIZE INTEGER MUMPS_TYPENODE EXTERNAL MUMPS_TYPENODE POSITION = 0 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IFATH, 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & ISON , 1, MPI_INTEGER, & COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NSLAVES, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NROW , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NCOL , 1, MPI_INTEGER & , COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_ALREADY_SENT, 1, & MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & NBROWS_PACKET, 1, & MPI_INTEGER, COMM, IERR) IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN NCOL_EFF = NROW ELSE NCOL_EFF = NCOL ENDIF NOREAL_PACKET = NBROWS_PACKET * NCOL_EFF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN NOINT = 6 + NROW + NCOL + NSLAVES + KEEP(IXSZ) NOREAL= int(NROW,8) * int(NCOL_EFF,8) CALL CMUMPS_ALLOC_CB(.FALSE.,0_8,.FALSE.,.FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW,LIW,A,LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, & NOINT, NOREAL, ISON, S_NOTFREE, .TRUE., & COMP, LRLUS, KEEP8(67), IFLAG, IERROR & ) IF ( IFLAG .LT. 0 ) THEN RETURN ENDIF PIMASTER(STEP( ISON )) = IWPOSCB + 1 PAMASTER(STEP( ISON )) = IPTRLU + 1_8 IW( IWPOSCB + 1 + XXNBPR ) = 0 IW( IWPOSCB + 1 + KEEP(IXSZ) ) = NCOL NELIM = NROW IW( IWPOSCB + 2 + KEEP(IXSZ) ) = NELIM IW( IWPOSCB + 3 + KEEP(IXSZ) ) = NROW IF ( NSLAVES .NE. 0 .and. KEEP(50).ne.0 ) THEN IW( IWPOSCB + 4 + KEEP(IXSZ) ) = NROW - NCOL IF ( NROW - NCOL .GE. 0 ) THEN WRITE(*,*) 'Error in PROCESS_MAITRE2:',NROW,NCOL CALL MUMPS_ABORT() END IF ELSE IW( IWPOSCB + 4 + KEEP(IXSZ) ) = 0 END IF IW( IWPOSCB + 5 + KEEP(IXSZ) ) = 1 IW( IWPOSCB + 6 + KEEP(IXSZ) ) = NSLAVES IF (NSLAVES.GT.0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IWPOSCB + 7 + KEEP(IXSZ) ), & NSLAVES, MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NSLAVES), & NROW, MPI_INTEGER, COMM, IERR) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & IW(IWPOSCB + 7 + KEEP(IXSZ) + NROW + NSLAVES), & NCOL, MPI_INTEGER, COMM, IERR) IF ( NSLAVES .GT. 0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(ISON) ) CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, & TAB_POS_IN_PERE(1,INIV2), & NSLAVES+1, MPI_INTEGER, COMM, IERR) TAB_POS_IN_PERE(SLAVEF+2,INIV2) = NSLAVES ENDIF ENDIF IF (NOREAL_PACKET.GT.0) THEN CALL MUMPS_GETI8(DYN_SIZE, IW(PIMASTER(STEP(ISON))+XXD)) IF ( DYN_SIZE .GT. 0_8 ) THEN CALL CMUMPS_DM_SET_PTR( PAMASTER(STEP(ISON)), & DYN_SIZE, SON_A ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & SON_A( 1_8 + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_COMPLEX, COMM, IERR ) ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A( PAMASTER(STEP(ISON)) + & int(NBROWS_ALREADY_SENT,8) * int(NCOL_EFF,8) ), & NOREAL_PACKET, MPI_COMPLEX, COMM, IERR ) ENDIF ENDIF IF ( NBROWS_ALREADY_SENT + NBROWS_PACKET .EQ. NROW ) THEN PERETYPE2 = ( MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFATH)), & KEEP(199)) .EQ. 2 ) NSTK_S( STEP(IFATH )) = NSTK_S( STEP(IFATH) ) - 1 IF ( NSTK_S( STEP(IFATH)) .EQ. 0 ) THEN CALL CMUMPS_INSERT_POOL_N(N, IPOOL, LPOOL, PROCNODE_STEPS, & SLAVEF, KEEP(199), & KEEP(28), KEEP(76), KEEP(80), KEEP(47), & STEP, IFATH ) IF (KEEP(47) .GE. 3) THEN CALL CMUMPS_LOAD_POOL_UPD_NEW_POOL( & IPOOL, LPOOL, & PROCNODE_STEPS, KEEP,KEEP8, SLAVEF, COMM_LOAD, & MYID, STEP, N, ND, FILS ) ENDIF CALL MUMPS_ESTIM_FLOPS( IFATH, N, PROCNODE_STEPS, & KEEP(199), ND, & FILS,FRERE, STEP, PIMASTER, & KEEP(28), KEEP(50), KEEP(253), & FLOP1,IW, LIW, KEEP(IXSZ) ) IF (IFATH.NE.KEEP(20)) & CALL CMUMPS_LOAD_UPDATE(1, .FALSE., FLOP1, KEEP,KEEP8) END IF ENDIF RETURN END SUBROUTINE CMUMPS_PROCESS_MASTER2 MUMPS_5.4.1/src/cfac_sol_l0omp_m.F0000664000175000017500000003332614102210524017016 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: CMUMPS_INIT_L0_OMP_FACTORS & , CMUMPS_FREE_L0_OMP_FACTORS & , CMUMPS_SAVE_RESTORE_L0FACARRAY CONTAINS SUBROUTINE CMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE CMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE CMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE CMUMPS_FREE_L0_OMP_FACTORS SUBROUTINE CMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE CMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (CMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (trim(mode) .EQ. "memory_save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (trim(mode) .EQ. "save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (trim(mode) .EQ. "restore") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if !defined(MUMPS_F2003) IF (trim(mode).EQ."memory_save") THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."save") THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."restore") THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE CMUMPS_SAVE_RESTORE_L0FAC END MODULE CMUMPS_FACSOL_L0OMP_M MUMPS_5.4.1/src/cfac_b.F0000664000175000017500000003704614102210523015021 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_FAC_B( N, S_IS_POINTERS, LA, LIW, SYM_PERM, & NA, LNA, NE_STEPS, NFSIZ, FILS, STEP, FRERE, DAD, CAND, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PTRAR, LDPTRAR, PTRIST, & PTLUST_S, PTRFAC, IW1, IW2, ITLOC, RHS_MUMPS, POOL, LPOOL, & CNTL1, ICNTL, INFO, RINFO, KEEP, KEEP8, PROCNODE_STEPS, SLAVEF, & COMM_NODES, MYID, MYID_NODES, BUFR, LBUFR, LBUFR_BYTES, & CMUMPS_LBUF, INTARR, DBLARR, root, NELT, FRTPTR, FRTELT, & COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, & DKEEP, PIVNUL_LIST, LPN_LIST, LRGROUPS & ) USE CMUMPS_DYNAMIC_MEMORY_M, ONLY: CMUMPS_DM_FAC_UPD_DYN_MEMCNTS USE CMUMPS_LOAD USE CMUMPS_BUF, ONLY : CMUMPS_BUF_ALLOC_CB, CMUMPS_BUF_DEALL_CB USE CMUMPS_FAC_S_IS_POINTERS_M, ONLY : S_IS_POINTERS_T USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC IMPLICIT NONE INCLUDE 'mpif.h' TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER(8) :: LA INTEGER N,LIW,LPOOL,SLAVEF,COMM_NODES INTEGER MYID, MYID_NODES,LNA TYPE (S_IS_POINTERS_T) :: S_IS_POINTERS REAL RINFO(40) INTEGER, INTENT( IN ) :: LBUFR, LBUFR_BYTES INTEGER :: BUFR( LBUFR ) INTEGER, INTENT( IN ) :: CMUMPS_LBUF INTEGER, DIMENSION(0:SLAVEF - 1) :: MEM_DISTRIB INTEGER NELT, LDPTRAR INTEGER FRTPTR(*), FRTELT(*) INTEGER LRGROUPS(N) REAL CNTL1 INTEGER ICNTL(60) INTEGER INFO(80), KEEP(500) INTEGER(8) KEEP8(150) INTEGER SYM_PERM(N), NA(LNA), & NE_STEPS(KEEP(28)), FILS(N), & FRERE(KEEP(28)), NFSIZ(KEEP(28)), & DAD(KEEP(28)) INTEGER CAND(SLAVEF+1, max(1,KEEP(56))) INTEGER STEP(N) INTEGER(8), INTENT(IN) :: PTRAR(LDPTRAR,2) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER IW1(2*KEEP(28)), ITLOC(N+KEEP(253)), POOL(LPOOL) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER(8) :: IW2(2*KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER COMM_LOAD, ASS_IRECV INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) COMPLEX DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) REAL SEUIL, SEUIL_LDLT_NIV2 INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER, EXTERNAL :: MUMPS_PROCNODE INTEGER allocok REAL UULOC INTEGER IERR INTEGER LP, MPRINT LOGICAL LPOK INTEGER NSTK,PTRAST INTEGER PIMASTER, PAMASTER LOGICAL PROK REAL ZERO, ONE DATA ZERO /0.0E0/ DATA ONE /1.0E0/ INTEGER :: NSTEPSDONE DOUBLE PRECISION :: OPASS, OPELI INTEGER :: NELVA, COMP INTEGER :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER :: NB22T1, NB22T2, NBTINY, DET_EXP, DET_SIGN COMPLEX :: DET_MANT INTEGER :: NTOTPVTOT INTEGER(8) :: POSFAC, LRLU, IPTRLU, LRLUS INTEGER IWPOS, LEAF, NBROOT, NROOT INTEGER :: LIW_ARG_FAC_PAR INTEGER(8) :: LA_ARG_FAC_PAR COMPLEX, TARGET:: CDUMMY(1) INTEGER, TARGET :: IDUMMY(1) LOGICAL :: IW_DUMMY, A_DUMMY KEEP(41)=0 KEEP(42)=0 LP = ICNTL(1) LPOK = (LP.GT.0) .AND. (ICNTL(4).GE.1) MPRINT = ICNTL(2) PROK = (MPRINT.GT.0) .AND. (ICNTL(4).GE.2) UULOC = CNTL1 PIMASTER = 1 NSTK = PIMASTER + KEEP(28) PTRAST = 1 PAMASTER = 1 + KEEP(28) IF (KEEP(4).LE.0) KEEP(4)=32 IF (KEEP(5).LE.0) KEEP(5)=16 IF (KEEP(5).GT.KEEP(4)) KEEP(5) = KEEP(4) IF (KEEP(6).LE.0) KEEP(6)=24 IF (KEEP(3).LE.KEEP(4)) KEEP(3)=KEEP(4)*2 IF (KEEP(6).GT.KEEP(3)) KEEP(6) = KEEP(3) POSFAC = 1_8 IWPOS = 1 LRLU = LA LRLUS = LRLU KEEP8(63) = 0_8 KEEP8(64) = 0_8 KEEP8(65) = 0_8 KEEP8(66) = 0_8 KEEP8(68) = 0_8 KEEP8(69) = 0_8 KEEP8(70) = 0_8 KEEP8(71) = 0_8 KEEP8(73) = 0_8 KEEP8(74) = 0_8 IPTRLU = LRLU NSTEPSDONE = 0 OPASS = 0.0D0 OPELI = 0.0D0 NELVA = 0 COMP = 0 MAXFRT = 0 NMAXNPIV = 0 NTOTPV = 0 NOFFNEGPV = 0 NB22T1 = 0 NB22T2 = 0 NBTINY = 0 DET_EXP = 0 DET_SIGN = 1 DET_MANT = cmplx(1.0E0,0.0E0, kind=kind(1.0E0)) IW1(NSTK:NSTK+KEEP(28)-1) = NE_STEPS(1:KEEP(28)) CALL MUMPS_INIT_NROOT_DIST(N, NBROOT, NROOT, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP, STEP, & PROCNODE_STEPS) CALL MUMPS_INIT_POOL_DIST(N, LEAF, & MYID_NODES, & SLAVEF, NA, LNA, & KEEP,KEEP8, STEP, & PROCNODE_STEPS, & POOL, LPOOL) CALL CMUMPS_INIT_POOL_LAST3(POOL, LPOOL, LEAF) CALL CMUMPS_LOAD_INIT_SBTR_STRUCT(POOL, LPOOL,KEEP,KEEP8) IF ( KEEP( 38 ) .NE. 0 ) THEN NBROOT = NBROOT + root%NPROW * root%NPCOL - 1 END IF IF ( root%yes ) THEN IF ( MUMPS_PROCNODE( PROCNODE_STEPS(STEP(KEEP(38))), & KEEP(199) ) & .NE. MYID_NODES ) THEN NROOT = NROOT + 1 END IF END IF PTRIST(1:KEEP(28))=0 PTLUST_S(1:KEEP(28))=0 PTRFAC(1:KEEP(28))=-99999_8 IW2(PTRAST:PTRAST+KEEP(28)-1)=0_8 IW1(PIMASTER:PIMASTER+KEEP(28)-1)=-99999_8 KEEP(405) = 0 KEEP8(67) = LRLUS IF (associated(S_IS_POINTERS%IW)) THEN WRITE(*,*) " Internal error CMUMPS_FAC_B IW" CALL MUMPS_ABORT() ENDIF IF (INFO(1) .GE. 0 ) THEN ALLOCATE(S_IS_POINTERS%IW(LIW), stat=allocok) IF (allocok .GT.0) THEN INFO(1) = -13 INFO(2) = LIW IF (LPOK) THEN WRITE(LP,*) & 'Allocation error for id%IS(',LIW,') on worker', & MYID_NODES ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN IF (.NOT. associated(S_IS_POINTERS%A)) THEN ALLOCATE(S_IS_POINTERS%A(LA), stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -13 CALL MUMPS_SETI8TOI4(LA, INFO(2)) DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) KEEP8(23)=0_8 ELSE KEEP8(23)=LA ENDIF ENDIF ENDIF IF (INFO(1) .GE. 0) THEN CALL CMUMPS_BUF_ALLOC_CB( CMUMPS_LBUF, IERR ) IF ( IERR .NE. 0 ) THEN INFO(1)= -13 INFO(2)= (CMUMPS_LBUF+KEEP(34)-1)/KEEP(34) IF (LPOK) THEN WRITE(LP,*) & 'Allocation error in CMUMPS_BUF_ALLOC_CB' & ,INFO(2), ' on worker', MYID_NODES ENDIF DEALLOCATE(S_IS_POINTERS%IW); NULLIFY(S_IS_POINTERS%IW) DEALLOCATE(S_IS_POINTERS%A); NULLIFY(S_IS_POINTERS%A) END IF ENDIF IW_DUMMY = .FALSE. A_DUMMY = .FALSE. IF (INFO(1) .GE. 0) THEN LIW_ARG_FAC_PAR = LIW LA_ARG_FAC_PAR = LA ELSE LIW_ARG_FAC_PAR = 1 LA_ARG_FAC_PAR = 1_8 IF (.NOT. associated(S_IS_POINTERS%IW)) THEN S_IS_POINTERS%IW => IDUMMY IW_DUMMY = .TRUE. ENDIF IF (.NOT. associated(S_IS_POINTERS%A)) THEN S_IS_POINTERS%A => CDUMMY A_DUMMY = .TRUE. ENDIF ENDIF IF ( INFO(1) .LT. 0 ) THEN CALL CMUMPS_BDC_ERROR( MYID_NODES, SLAVEF, COMM_NODES, KEEP ) ENDIF KEEP(398)=NSTEPSDONE CALL CMUMPS_FAC_PAR_I(N,S_IS_POINTERS%IW(1),LIW_ARG_FAC_PAR, & S_IS_POINTERS%A(1),LA_ARG_FAC_PAR,IW1(NSTK), & NFSIZ,FILS,STEP,FRERE,DAD,CAND,ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, IW2(PTRAST), IW1(PIMASTER), IW2(PAMASTER), & PTRAR(1,2), PTRAR(1,1), & ITLOC, RHS_MUMPS, POOL, LPOOL, & RINFO, POSFAC, IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NROOT, NBROOT, & UULOC, ICNTL, PTLUST_S, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS,SLAVEF,MYID,COMM_NODES, MYID_NODES, BUFR, LBUFR, & LBUFR_BYTES, INTARR, DBLARR, root, SYM_PERM, NELT, FRTPTR, & FRTELT, LDPTRAR, COMM_LOAD, ASS_IRECV, SEUIL, SEUIL_LDLT_NIV2, & MEM_DISTRIB,NE_STEPS, DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & LRGROUPS(1) ) IF (IW_DUMMY) THEN NULLIFY( S_IS_POINTERS%IW ) ENDIF IF (A_DUMMY) THEN NULLIFY( S_IS_POINTERS%A ) ENDIF CALL CMUMPS_BUF_DEALL_CB( IERR ) RINFO(2) = real(OPASS) RINFO(3) = real(OPELI) INFO(13) = NELVA INFO(14) = COMP KEEP(33) = MAXFRT; INFO(11) = MAXFRT KEEP(246) = NMAXNPIV KEEP(89) = NTOTPV; INFO(23) = NTOTPV INFO(12) = NOFFNEGPV KEEP(103) = NB22T1 KEEP(105) = NB22T2 KEEP(98) = NBTINY KEEP(260) = KEEP(260) * DET_SIGN KEEP(259) = KEEP(259) + DET_EXP CALL CMUMPS_UPDATEDETER( DET_MANT, DKEEP(6), KEEP(259) ) POSFAC = POSFAC -1_8 IWPOS = IWPOS -1 IF (KEEP(201).LE.0) THEN IF (KEEP(201) .EQ. -1 .AND. INFO(1) .LT. 0) THEN POSFAC = 0_8 ENDIF KEEP8(31) = POSFAC RINFO(6) = ZERO ELSE RINFO(6) = real(KEEP8(31)*int(KEEP(35),8))/1E6 ENDIF KEEP8(48) = KEEP8(31)+KEEP8(71)+KEEP8(64) KEEP(32) = IWPOS CALL MUMPS_SETI8TOI4(KEEP8(48), INFO(9)) INFO(10) = KEEP(32) KEEP8(67) = LA - KEEP8(67) CALL MPI_ALLREDUCE(NTOTPV, NTOTPVTOT, 1, MPI_INTEGER, MPI_SUM, & COMM_NODES, IERR) IF ( ( (INFO(1).EQ.-10 .OR. INFO(1).EQ.-40) & .AND. (NTOTPVTOT.EQ.N) ) & .OR. ( NTOTPVTOT.GT.N ) ) THEN write(*,*) ' Error 1 NTOTPVTOT=', NTOTPVTOT,N CALL MUMPS_ABORT() ENDIF IF ( (KEEP(19).NE.0 ) .AND. (NTOTPVTOT.NE.N) .AND. & (INFO(1).GE.0) ) THEN write(*,*) ' Error 2 NTOTPVTOT=', NTOTPVTOT CALL MUMPS_ABORT() ENDIF IF ( (INFO(1) .GE. 0 ) & .AND. (NTOTPVTOT.NE.N) ) THEN INFO(1) = -10 ENDIF IF (INFO(1).EQ.-10) THEN INFO(2) = NTOTPVTOT ENDIF IF (PROK) THEN WRITE (MPRINT,99980) INFO(1), INFO(2), & KEEP(28), KEEP8(48), INFO(10), INFO(11) IF(KEEP(50) .EQ. 0) THEN WRITE(MPRINT,99982) INFO(12) ENDIF WRITE (MPRINT, 99986) & INFO(13), INFO(14), RINFO(2), RINFO(3) IF (KEEP(97) .NE. 0) THEN WRITE (MPRINT, 99987) INFO(25) ENDIF ENDIF RETURN 99980 FORMAT (/' LEAVING FACTORIZATION PHASE WITH ...'/ & ' INFO (1) =',I15/ & ' --- (2) =',I15/ & ' Number of nodes in the tree =',I15/ & ' INFO (9) Real space for factors =',I15/ & ' --- (10) Integer space for factors =',I15/ & ' --- (11) Maximum size of frontal matrices =',I15) 99982 FORMAT (' --- (12) Number of off diagonal pivots =',I15) 99986 FORMAT (' --- (13) Number of delayed pivots =',I15/ & ' --- (14) Number of memory compresses =',I15/ & ' RINFO(2) Operations during node assembly =',1PD10.3/ & ' -----(3) Operations during node elimination =',1PD10.3) 99987 FORMAT (' INFO (25) Number of tiny pivots(static) =',I15) END SUBROUTINE CMUMPS_FAC_B SUBROUTINE CMUMPS_FAC_PAR_I(N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, & TAB_POS_IN_PERE, NSTEPSDONE, OPASS, OPELI, NELVA, COMP, & MAXFRT, NMAXNPIV, NTOTPV, NOFFNEGPV, NB22T1, NB22T2, NBTINY, & DET_EXP, DET_MANT, DET_SIGN, PTRIST, PTRAST, PIMASTER, PAMASTER, & PTRARW, PTRAIW, ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP, KEEP8, & PROCNODE_STEPS, SLAVEF, MYID, COMM_NODES, MYID_NODES, & BUFR, LBUFR, LBUFR_BYTES, INTARR, DBLARR, root, & PERM, NELT, FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) USE CMUMPS_LOAD USE CMUMPS_OOC USE CMUMPS_FAC_ASM_MASTER_M USE CMUMPS_FAC_ASM_MASTER_ELT_M USE CMUMPS_FAC1_LDLT_M USE CMUMPS_FAC2_LDLT_M USE CMUMPS_FAC1_LU_M USE CMUMPS_FAC2_LU_M USE CMUMPS_STRUC_DEF, ONLY : CMUMPS_ROOT_STRUC USE CMUMPS_FAC_PAR_M, ONLY : CMUMPS_FAC_PAR IMPLICIT NONE TYPE (CMUMPS_ROOT_STRUC) :: root INTEGER N, LIW, LPTRAR, NSTEPSDONE, INFO(80) DOUBLE PRECISION, INTENT(INOUT) :: OPASS, OPELI INTEGER, INTENT(INOUT) :: NELVA, COMP INTEGER, INTENT(INOUT) :: MAXFRT, NTOTPV, NMAXNPIV, NOFFNEGPV INTEGER, INTENT(INOUT) :: NB22T1, NB22T2, NBTINY INTEGER, INTENT(INOUT) :: DET_SIGN, DET_EXP COMPLEX, INTENT(INOUT) :: DET_MANT INTEGER(8) :: LA COMPLEX :: A(LA) INTEGER SLAVEF, COMM_NODES, MYID, MYID_NODES INTEGER, DIMENSION(0: SLAVEF - 1) :: MEM_DISTRIB INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER LPOOL INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER ITLOC(N+KEEP(253)) COMPLEX :: RHS_MUMPS(KEEP(255)) INTEGER IW(LIW), NSTK_STEPS(KEEP(28)) INTEGER(8), INTENT(IN) :: PTRARW(LPTRAR), PTRAIW(LPTRAR) INTEGER ND(KEEP(28)) INTEGER FILS(N),PTRIST(KEEP(28)) INTEGER STEP(N), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER PIMASTER(KEEP(28)) INTEGER PTLUST(KEEP(28)), PERM(N) INTEGER CAND(SLAVEF+1,max(1,KEEP(56))) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER IPOOL(LPOOL) INTEGER NE(KEEP(28)) REAL RINFO(40) INTEGER(8) :: PAMASTER(KEEP(28)), PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER(8) :: POSFAC, LRLU, LRLUS, IPTRLU INTEGER IWPOS, LEAF, NBROOT, NBRTOT INTEGER COMM_LOAD, ASS_IRECV REAL UU, SEUIL, SEUIL_LDLT_NIV2 INTEGER NELT INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) COMPLEX DBLARR( KEEP8(26) ) INTEGER INTARR( KEEP8(27) ) INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) REAL DKEEP(230) INTEGER LRGROUPS(N) CALL CMUMPS_FAC_PAR( N, IW, LIW, A, LA, NSTK_STEPS, & ND,FILS,STEP, FRERE, DAD, CAND, ISTEP_TO_INIV2, TAB_POS_IN_PERE, & NSTEPSDONE, OPASS, OPELI, NELVA, COMP, MAXFRT, NMAXNPIV, NTOTPV, & NOFFNEGPV, NB22T1, NB22T2, NBTINY, DET_EXP, DET_MANT, DET_SIGN, & PTRIST, PTRAST, PIMASTER, PAMASTER, PTRARW, PTRAIW, & ITLOC, RHS_MUMPS, IPOOL, LPOOL, & RINFO, POSFAC ,IWPOS, LRLU, IPTRLU, LRLUS, LEAF, NBROOT, NBRTOT, & UU, ICNTL, PTLUST, PTRFAC, INFO, KEEP,KEEP8, & PROCNODE_STEPS,SLAVEF,MYID, COMM_NODES, MYID_NODES, & BUFR,LBUFR,LBUFR_BYTES,INTARR,DBLARR,root, PERM, NELT, & FRTPTR, FRTELT, LPTRAR, COMM_LOAD, ASS_IRECV, & SEUIL, SEUIL_LDLT_NIV2, MEM_DISTRIB, NE, DKEEP, & PIVNUL_LIST,LPN_LIST, LRGROUPS ) RETURN END SUBROUTINE CMUMPS_FAC_PAR_I MUMPS_5.4.1/src/sfac_mem_stack.F0000664000175000017500000005501314102210521016553 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE SMUMPS_FAC_STACK(COMM_LOAD, ASS_IRECV, & N, INODE, TYPE, TYPEF, & LA, IW, LIW, A, & IFLAG, IERROR, OPELIW, NELVAW, NMAXNPIV, & PTRIST, PTLUST_S, & PTRFAC, PTRAST, & STEP, PIMASTER, PAMASTER, NE, & POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU, ICNTL, KEEP,KEEP8,DKEEP, & COMP, IWPOS, IWPOSCB, PROCNODE_STEPS, SLAVEF, & FPERE, COMM, MYID, IPOOL, LPOOL, LEAF, NSTK_S, & PERM, BUFR, LBUFR, LBUFR_BYTES, NBFIN, root, & OPASSW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, INTARR, DBLARR, & ND, FRERE, LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE SMUMPS_BUF USE SMUMPS_LOAD USE SMUMPS_STRUC_DEF, ONLY : SMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (SMUMPS_ROOT_STRUC) :: root INTEGER COMM_LOAD, ASS_IRECV INTEGER COMM, MYID, TYPE, TYPEF INTEGER N, LIW, INODE,IFLAG,IERROR INTEGER ICNTL(60), KEEP(500) REAL DKEEP(230) INTEGER(8) KEEP8(150) INTEGER(8) :: LA, POSFAC, LRLU, LRLUS, LRLUSM, IPTRLU INTEGER IWPOSCB, IWPOS, & FPERE, SLAVEF, NELVAW, NMAXNPIV INTEGER IW(LIW),PROCNODE_STEPS(KEEP(28)) INTEGER(8) :: PTRAST (KEEP(28)) INTEGER(8) :: PTRFAC (KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) INTEGER STEP(N), PIMASTER(KEEP(28)), NE(KEEP(28)) REAL A(LA) INTEGER, intent(in) :: LRGROUPS(N) DOUBLE PRECISION OPASSW, OPELIW REAL DBLARR(KEEP8(26)) INTEGER INTARR(KEEP8(27)) INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) ), & ND( KEEP(28) ), FRERE( KEEP(28) ) REAL :: RHS_MUMPS(KEEP(255)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER LPOOL, LEAF, COMP INTEGER IPOOL( LPOOL ) INTEGER NSTK_S( KEEP(28) ) INTEGER PERM(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR( LBUFR ) INTEGER NBFIN INTEGER NFRONT_ESTIM,NELIM_ESTIM INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER LP INTEGER NBROWS_ALREADY_SENT INTEGER(8) :: POSELT, OPSFAC INTEGER(8) :: IOLD, INEW, FACTOR_POS INTEGER NSLAVES, NCB, & H_INODE, IERR, NBCOL, NBROW, NBROW_SEND, & NELIM INTEGER NBROW_STACK, NBROW_INDICES, NBCOL_STACK INTEGER NCBROW_ALREADY_MOVED, NCBROW_PREVIOUSLY_MOVED, &NCBROW_NEWLY_MOVED INTEGER(8) :: LAST_ALLOWED_POS INTEGER(8) :: LREQCB, MIN_SPACE_IN_PLACE INTEGER(8) :: SHIFT_VAL_SON INTEGER SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON, & LIST_ROW_SON, LIST_COL_SON, LIST_SLAVES INTEGER IOLDPS,NFRONT,NPIV,NASS,IOLDP1,PTROWEND, & LREQI, LCONT INTEGER I,LDA, INIV2 INTEGER MSGDEST, MSGTAG, CHK_LOAD INCLUDE 'mumps_headers.h' LOGICAL MUST_COMPACT_FACTORS LOGICAL PACKED_CB, COMPRESS_PANEL, COMPRESS_CB, LR_SOLVE LOGICAL INPLACE INTEGER(8) :: SIZE_INPLACE, FAC_ENTRIES, COUNT_EXTRA_IP_COPIES INTEGER INTSIZ DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED LOGICAL SSARBR, SSARBR_ROOT, MUMPS_INSSARBR, & MUMPS_IN_OR_ROOT_SSARBR, MUMPS_ROOTSSARBR EXTERNAL MUMPS_INSSARBR, MUMPS_IN_OR_ROOT_SSARBR, & MUMPS_ROOTSSARBR LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP = -1 INPLACE = .FALSE. MIN_SPACE_IN_PLACE = 0_8 IOLDPS = PTLUST_S(STEP(INODE)) INTSIZ = IW(IOLDPS+XXI) NFRONT = IW(IOLDPS+KEEP(IXSZ)) NPIV = IW(IOLDPS + 1+KEEP(IXSZ)) NMAXNPIV = max(NPIV, NMAXNPIV) NASS = iabs(IW(IOLDPS + 2+KEEP(IXSZ))) NSLAVES= IW(IOLDPS+5+KEEP(IXSZ)) H_INODE= 6 + NSLAVES + KEEP(IXSZ) LCONT = NFRONT - NPIV NBCOL = LCONT SSARBR = MUMPS_INSSARBR(PROCNODE_STEPS(STEP(INODE)),KEEP(199)) SSARBR_ROOT = MUMPS_IN_OR_ROOT_SSARBR & (PROCNODE_STEPS(STEP(INODE)),KEEP(199)) LREQCB = 0_8 INPLACE = .FALSE. PACKED_CB = ((KEEP(215).EQ.0) & .AND.(KEEP(50).NE.0) & .AND.(TYPEF.EQ.1 & .OR.TYPEF.EQ.2 & ) & .AND.(TYPE.EQ.1)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = (IW(IOLDPS+XXLR).EQ.1.OR.IW(IOLDPS+XXLR).EQ.3) LR_SOLVE = (KEEP(486).EQ.2) MUST_COMPACT_FACTORS = .TRUE. IF (KEEP(201).EQ.1 .OR. KEEP(201).EQ.-1 & .OR. (COMPRESS_PANEL.AND.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .FALSE. ENDIF IF ((FPERE.EQ.0).AND.(NASS.NE.NPIV)) THEN IFLAG = -10 GOTO 600 ENDIF NBROW = LCONT IF (TYPE.EQ.2) NBROW = NASS - NPIV IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN LDA = NASS ELSE LDA = NFRONT ENDIF NBROW_SEND = NBROW NELIM = NASS-NPIV IF (TYPEF.EQ.2) NBROW_SEND = NELIM POSELT = PTRAST(STEP(INODE)) IF (POSELT .ne. PTRFAC(STEP(INODE))) THEN WRITE(*,*) MYID,":Error 1 in SMUMPS_FAC_STACK:" WRITE(*,*) "INODE, PTRAST, PTRFAC =", & INODE, PTRAST(STEP(INODE)), PTRFAC(STEP(INODE)) WRITE(*,*) "PACKED_CB, NFRONT, NPIV, NASS, NSLAVES", & PACKED_CB, NFRONT, NPIV, NASS, NSLAVES WRITE(*,*) "TYPE, TYPEF, FPERE ", & TYPE, TYPEF, FPERE CALL MUMPS_ABORT() END IF NELVAW = NELVAW + NASS - NPIV IF (KEEP(50) .eq. 0) THEN FAC_ENTRIES = int(NPIV,8) * int(NFRONT,8) ELSE FAC_ENTRIES = ( int(NPIV,8)*int(NPIV+1,8) )/ 2_8 ENDIF FAC_ENTRIES = FAC_ENTRIES + int(NBROW,8) * int(NPIV,8) IF ( KEEP(405) .EQ. 0 ) THEN KEEP8(10) = KEEP8(10) + FAC_ENTRIES KEEP(429) = KEEP(429) - 1 ELSE !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + FAC_ENTRIES !$OMP END ATOMIC ENDIF CALL MUMPS_GET_FLOPS_COST( NFRONT, NPIV, NASS, & KEEP(50), TYPE,FLOP1 ) IF ( (.NOT. SSARBR_ROOT) .and. TYPE == 1) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL SMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., -FLOP1, & KEEP,KEEP8) ENDIF FLOP1_EFFECTIVE = FLOP1 OPELIW = OPELIW + FLOP1 IF ( NPIV .NE. NASS ) THEN CALL MUMPS_GET_FLOPS_COST( NFRONT, NASS, NASS, & KEEP(50), TYPE,FLOP1 ) IF (.NOT. SSARBR_ROOT ) THEN IF (NE(STEP(INODE))==0) THEN CHK_LOAD=0 ELSE CHK_LOAD=1 ENDIF CALL SMUMPS_LOAD_UPDATE(CHK_LOAD, .FALSE., & FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) ENDIF END IF IF ( SSARBR_ROOT ) THEN NFRONT_ESTIM=ND(STEP(INODE)) + KEEP(253) NELIM_ESTIM=NASS-(NFRONT-NFRONT_ESTIM) CALL MUMPS_GET_FLOPS_COST(NFRONT_ESTIM,NELIM_ESTIM,NELIM_ESTIM, & KEEP(50),1,FLOP1) END IF FLOP1=-FLOP1 IF (SSARBR_ROOT) THEN CALL SMUMPS_LOAD_UPDATE(0,.FALSE.,FLOP1,KEEP,KEEP8) ELSE CALL SMUMPS_LOAD_UPDATE(2,.FALSE.,FLOP1,KEEP,KEEP8) ENDIF IF ( FPERE .EQ. 0 ) THEN IF ( KEEP(253) .NE. 0 .AND. KEEP(201).NE.-1 & .AND. KEEP(201).NE.1 & .AND. (.NOT.COMPRESS_PANEL.OR..NOT.LR_SOLVE) & ) THEN MUST_COMPACT_FACTORS = .TRUE. GOTO 190 ELSE MUST_COMPACT_FACTORS = .FALSE. GOTO 190 ENDIF ENDIF IF ( FPERE.EQ.KEEP(38) ) THEN NCB = NFRONT - NASS SHIFT_LIST_ROW_SON = H_INODE + NASS SHIFT_LIST_COL_SON = H_INODE + NFRONT + NASS SHIFT_VAL_SON = int(NASS,8)*int(NFRONT+1,8) IF (TYPE.EQ.1) THEN CALL SMUMPS_BUILD_AND_SEND_CB_ROOT( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & PTLUST_S, PTRAST, & root, NCB, NCB, SHIFT_LIST_ROW_SON, & SHIFT_LIST_COL_SON , SHIFT_VAL_SON, NFRONT, & ROOT_CONT_STATIC, MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,.FALSE., ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) IF (IFLAG < 0 ) GOTO 500 ENDIF MSGDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)),KEEP(199)) IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) IF (MSGDEST.EQ.MYID) THEN CALL SMUMPS_PROCESS_RTNELIND( root, & INODE, NELIM, NSLAVES, IW(LIST_ROW_SON), & IW(LIST_COL_SON), IW(LIST_SLAVES), & & PROCNODE_STEPS, IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, & ITLOC, RHS_MUMPS, COMP, & IFLAG, IERROR, & IPOOL, LPOOL, LEAF, MYID, SLAVEF, & KEEP, KEEP8, DKEEP, & COMM, COMM_LOAD, FILS, DAD, ND) IF (IFLAG.LT.0) GOTO 600 ELSE IERR = -1 DO WHILE (IERR.EQ.-1) CALL SMUMPS_BUF_SEND_RTNELIND( INODE, NELIM, & IW(LIST_ROW_SON), IW(LIST_COL_SON), NSLAVES, & IW(LIST_SLAVES), MSGDEST, COMM, KEEP, IERR) IF ( IERR .EQ. -1 ) THEN BLOCKING =.FALSE. SET_IRECV =.TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, PERM, & IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, & ND, FRERE, LPTRAR, NELT, & FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & .TRUE., LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 500 IOLDPS = PTLUST_S(STEP(INODE)) LIST_ROW_SON = IOLDPS + H_INODE + NPIV LIST_COL_SON = IOLDPS + H_INODE + NFRONT + NPIV LIST_SLAVES = IOLDPS + 6 + KEEP(IXSZ) ENDIF ENDDO IF ( IERR .EQ. -2 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = - 17 GOTO 600 ELSE IF ( IERR .EQ. -3 ) THEN IERROR = ( 3 + NSLAVES + 2 * NELIM ) * KEEP( 34 ) IFLAG = -20 GOTO 600 ENDIF ENDIF IF (NELIM.EQ.0) THEN POSELT = PTRAST(STEP(INODE)) OPSFAC = POSELT + int(NPIV,8) * int(NFRONT,8) + int(NPIV,8) GOTO 190 ELSE GOTO 500 ENDIF ENDIF OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .NE. MYID ) THEN MSGTAG =NOEUD MSGDEST=MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), KEEP(199) ) IERR = -1 NBROWS_ALREADY_SENT = 0 DO WHILE (IERR.EQ.-1) IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN CALL SMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, & LCONT, NASS, NPIV, IW( IOLDPS + H_INODE + NPIV ), & IW( IOLDPS + H_INODE + NPIV + NFRONT ), & A( OPSFAC ), PACKED_CB, & MSGDEST, MSGTAG, COMM, KEEP, IERR ) ELSE IF ( TYPE.EQ.2 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) ELSE INIV2 = -9999 ENDIF CALL SMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & FPERE, INODE, & NBROW_SEND, IW(IOLDPS + H_INODE + NPIV ), & NBCOL, IW(IOLDPS + H_INODE + NPIV + NFRONT ), & A(OPSFAC), LDA, NELIM, TYPE, & NSLAVES, IW(IOLDPS+6+KEEP(IXSZ)), MSGDEST, & COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) END IF IF ( IERR .EQ. -1 ) THEN BLOCKING = .FALSE. SET_IRECV = .TRUE. MESSAGE_RECEIVED = .FALSE. CALL SMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, & NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS ) IF ( IFLAG .LT. 0 ) GOTO 500 ENDIF IOLDPS = PTLUST_S(STEP( INODE )) OPSFAC = POSELT + int(NPIV,8) * int(LDA,8) + int(NPIV,8) END DO IF ( IERR .EQ. -2 .OR. IERR .EQ. -3 ) THEN IF ( (TYPE.EQ.1) .AND. (TYPEF.EQ.1) ) THEN IERROR = ( 2*LCONT + 9 ) * KEEP( 34 ) + & LCONT*LCONT * KEEP( 35 ) ELSE IF (KEEP(50).ne.0 .AND. TYPE .eq. 2 ) THEN IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) & * KEEP( 34 ) + & NBROW_SEND*NBROW_SEND*KEEP( 35 ) ELSE IERROR = ( NBROW_SEND + NBCOL+ 5 + NSLAVES) * KEEP( 34 ) + & NBROW_SEND*NBCOL*KEEP( 35 ) ENDIF IF (IERR .EQ. -2) THEN IFLAG = -17 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, SEND BUFFER TOO SMALL DURING & SMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF IF (IERR .EQ. -3) THEN IFLAG = -20 IF ( LP > 0 ) THEN WRITE(LP, *) MYID, & ": FAILURE, RECV BUFFER TOO SMALL DURING & SMUMPS_FAC_STACK", TYPE, TYPEF ENDIF ENDIF GOTO 600 ENDIF ENDIF IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN NBROW_SEND = 0 LREQI = 2 + KEEP(IXSZ) NBROW_STACK = NBROW NBROW_INDICES = NBROW IF ((KEEP(50).NE.0).AND.(TYPE.EQ.2)) THEN NBCOL_STACK = NELIM ELSE NBCOL_STACK = NBCOL ENDIF IF (COMPRESS_CB) THEN NBROW_STACK=NELIM IF (KEEP(50).NE.0) NBCOL_STACK = NELIM ENDIF ELSE NBROW_STACK = NBROW-NBROW_SEND NBROW_INDICES = NBROW-NBROW_SEND NBCOL_STACK = NBCOL IF (COMPRESS_CB) THEN NBROW_STACK = 0 NBCOL_STACK = 0 ENDIF LREQI = 6 + NBROW_INDICES + NBCOL + KEEP(IXSZ) IF (.NOT. (TYPE.EQ.1 .AND. TYPEF.EQ.2 ) ) GOTO 190 IF (FPERE.EQ.0) GOTO 190 ENDIF IF (PACKED_CB) THEN IF (NBROW_STACK.EQ.0.OR.NBCOL_STACK.EQ.0) THEN LREQCB = 0 ELSE LREQCB = ( int(NBCOL_STACK,8) * int( NBCOL_STACK + 1, 8) ) / 2_8 & - ( int(NBROW_SEND ,8) * int( NBROW_SEND + 1, 8) ) / 2_8 ENDIF ELSE LREQCB = int(NBROW_STACK,8) * int(NBCOL_STACK,8) ENDIF INPLACE = ( KEEP(234).NE.0 ) IF (KEEP(50).NE.0 .AND. TYPE .EQ. 2) INPLACE = .FALSE. INPLACE = INPLACE .OR. .NOT. MUST_COMPACT_FACTORS INPLACE = INPLACE .AND. & ( PTLUST_S(STEP(INODE)) + INTSIZ .EQ. IWPOS ) MIN_SPACE_IN_PLACE = 0_8 IF ( INPLACE .AND. KEEP(50).eq. 0 .AND. & MUST_COMPACT_FACTORS) THEN MIN_SPACE_IN_PLACE = int(NBCOL_STACK,8) ENDIF IF ( MIN_SPACE_IN_PLACE .GT. LREQCB ) THEN INPLACE = .FALSE. ENDIF CALL SMUMPS_ALLOC_CB( INPLACE, MIN_SPACE_IN_PLACE, & SSARBR, .FALSE., & MYID,N,KEEP,KEEP8,DKEEP,IW, LIW, A, LA, & LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD, & PTRIST,PTRAST,STEP, PIMASTER,PAMASTER, & LREQI, LREQCB, INODE, S_NOTFREE, .TRUE., & COMP, LRLUS, LRLUSM, IFLAG, IERROR ) IF (IFLAG.LT.0) GOTO 600 IW(IWPOSCB+1+XXF) = IW(IOLDPS+XXF) IW(IWPOSCB+1+XXLR) = IW(IOLDPS+XXLR) PTRIST(STEP(INODE)) = IWPOSCB+1 IF ( MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID ) THEN PIMASTER (STEP(INODE)) = PTLUST_S(STEP(INODE)) PAMASTER(STEP(INODE)) = IPTRLU + 1_8 PTRAST(STEP(INODE)) = -99999999_8 IW(IWPOSCB+1+KEEP(IXSZ)) = min(-NBCOL_STACK,-1) IW(IWPOSCB+2+KEEP(IXSZ)) = NBROW_STACK IF (PACKED_CB) IW(IWPOSCB+1+XXS) = S_CB1COMP ELSE PTRAST(STEP(INODE)) = IPTRLU+1_8 IF (PACKED_CB) IW(IWPOSCB+1+XXS)=S_CB1COMP IW(IWPOSCB+1+KEEP(IXSZ)) = NBCOL IW(IWPOSCB+2+KEEP(IXSZ)) = 0 IW(IWPOSCB+3+KEEP(IXSZ)) = NBROW_STACK IW(IWPOSCB+4+KEEP(IXSZ)) = 0 IW(IWPOSCB+5+KEEP(IXSZ)) = 1 IW(IWPOSCB+6+KEEP(IXSZ)) = 0 IOLDP1 = PTLUST_S(STEP(INODE))+H_INODE PTROWEND = IWPOSCB+6+NBROW_STACK+KEEP(IXSZ) DO I = 1, NBROW_STACK IW(IWPOSCB+7+KEEP(IXSZ)+I-1) = & IW(IOLDP1+NFRONT-NBROW_STACK+I-1) ENDDO DO I = 1, NBCOL IW(PTROWEND+I)=IW(IOLDP1+NFRONT+NPIV+I-1) ENDDO END IF IF ( KEEP(50).NE.0 .AND. TYPE .EQ. 1 & .AND. MUST_COMPACT_FACTORS ) THEN POSELT = PTRFAC(STEP(INODE)) CALL SMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IF (COMPRESS_CB.AND.(LREQCB.EQ.0)) GOTO 190 IF ( KEEP(50).EQ.0 .AND. MUST_COMPACT_FACTORS ) & THEN LAST_ALLOWED_POS = POSELT + int(LDA,8)*int(NPIV+NBROW-1,8) & + int(NPIV,8) ELSE LAST_ALLOWED_POS = -1_8 ENDIF NCBROW_ALREADY_MOVED = 0 COUNT_EXTRA_IP_COPIES = 0_8 10 CONTINUE NCBROW_PREVIOUSLY_MOVED = NCBROW_ALREADY_MOVED IF (IPTRLU .LT. POSFAC ) THEN CALL SMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB, & LAST_ALLOWED_POS, NCBROW_ALREADY_MOVED ) ELSE CALL SMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, & POSELT, IPTRLU, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND, LREQCB, KEEP, PACKED_CB ) NCBROW_ALREADY_MOVED = NBROW_STACK ENDIF IF (LAST_ALLOWED_POS .NE. -1_8) THEN MUST_COMPACT_FACTORS =.FALSE. IF ( NCBROW_ALREADY_MOVED .EQ. NBROW_STACK ) THEN IF (COMPRESS_CB) THEN NCBROW_ALREADY_MOVED = NBROW ELSE NCBROW_ALREADY_MOVED = NCBROW_ALREADY_MOVED + NBROW_SEND ENDIF ENDIF NCBROW_NEWLY_MOVED = NCBROW_ALREADY_MOVED & - NCBROW_PREVIOUSLY_MOVED FACTOR_POS = POSELT + & int(LDA,8)*int(NPIV+NBROW-NCBROW_ALREADY_MOVED,8) CALL SMUMPS_COMPACT_FACTORS_UNSYM( A(FACTOR_POS), LDA, NPIV, & NCBROW_NEWLY_MOVED, & int(NCBROW_NEWLY_MOVED,8) * int(LDA,8) ) INEW = FACTOR_POS + int(NPIV,8) * int(NCBROW_NEWLY_MOVED,8) IOLD = INEW + int(NCBROW_NEWLY_MOVED,8) * int(NBCOL_STACK,8) DO I = 1, NCBROW_PREVIOUSLY_MOVED*NPIV A(INEW) = A(IOLD) IOLD = IOLD + 1_8 INEW = INEW + 1_8 ENDDO COUNT_EXTRA_IP_COPIES = COUNT_EXTRA_IP_COPIES + & int(NCBROW_PREVIOUSLY_MOVED,8) & * int(NPIV,8) LAST_ALLOWED_POS = INEW IF (NCBROW_ALREADY_MOVED.LT.NBROW_STACK) THEN GOTO 10 ENDIF ENDIF IF ( COUNT_EXTRA_IP_COPIES .GT. 0_8 ) THEN !$OMP ATOMIC UPDATE KEEP8(8) = KEEP8(8) + COUNT_EXTRA_IP_COPIES !$OMP END ATOMIC COUNT_EXTRA_IP_COPIES = 0_8 ENDIF 190 CONTINUE IF (MUST_COMPACT_FACTORS) THEN POSELT = PTRFAC(STEP(INODE)) CALL SMUMPS_COMPACT_FACTORS(A(POSELT), LDA, & NPIV, NBROW, KEEP(50), & int(LDA,8)*int(NBROW+NPIV,8)) MUST_COMPACT_FACTORS = .FALSE. ENDIF IOLDPS = PTLUST_S(STEP(INODE)) IW(IOLDPS+KEEP(IXSZ)) = NBCOL IW(IOLDPS + 1+KEEP(IXSZ)) = NASS - NPIV IF (TYPE.EQ.2) THEN IW(IOLDPS + 2+KEEP(IXSZ)) = NASS ELSE IW(IOLDPS + 2+KEEP(IXSZ)) = NFRONT ENDIF IW(IOLDPS + 3+KEEP(IXSZ)) = NPIV IF (INPLACE) THEN SIZE_INPLACE = LREQCB - MIN_SPACE_IN_PLACE ELSE SIZE_INPLACE = 0_8 ENDIF CALL SMUMPS_COMPRESS_LU(SIZE_INPLACE,MYID,N,IOLDPS,TYPE, IW, LIW, & A, LA, POSFAC, LRLU, LRLUS, & IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, SSARBR,INODE,IERR & , LRGROUPS, NASS & ) IF(IERR.LT.0)THEN IFLAG=IERR IERROR=0 GOTO 600 ENDIF 500 CONTINUE RETURN 600 CONTINUE IF (IFLAG .NE. -1 .AND. KEEP(405) .EQ. 0) THEN CALL SMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF RETURN END SUBROUTINE SMUMPS_FAC_STACK MUMPS_5.4.1/src/ztools.F0000664000175000017500000022034114102210524015147 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_COMPRESS_LU(SIZE_INPLACE, &MYID,N,IOLDPS,TYPE,IW, LIW, A, LA, &POSFAC, LRLU, LRLUS, IWPOS, PTRAST, PTRFAC, STEP, KEEP,KEEP8, &SSARBR,INODE,IERR & , LRGROUPS, NASS &) USE ZMUMPS_LOAD USE ZMUMPS_OOC !$ USE OMP_LIB USE ZMUMPS_LR_CORE IMPLICIT NONE INTEGER MYID INTEGER IOLDPS, TYPE, LIW, N, KEEP(500) INTEGER(8) :: SIZE_INPLACE, LA, POSFAC, LRLU, LRLUS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) KEEP8(150) INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER IWPOS, LDLT INTEGER STEP( N ) INTEGER (8) :: PTRFAC(KEEP(28)) LOGICAL SSARBR INTEGER IOLDSHIFT, IPSSHIFT INTEGER LRGROUPS(N), NASS INCLUDE 'mumps_headers.h' INTEGER LCONT, NELIM, NROW, NPIV, INTSIZ INTEGER NFRONT, NSLAVES INTEGER IPS, IPSIZE INTEGER(8) :: SIZELU, SIZECB, IAPOS, I, SIZESHIFT, ITMP8 LOGICAL MOVEPTRAST LOGICAL LRCOMPRESS_PANEL INTEGER INODE INTEGER IERR INTEGER PARPIV_T1 LOGICAL LR_ACTIVATED IERR=0 LDLT = KEEP(50) IOLDSHIFT = IOLDPS + KEEP(IXSZ) IF ( IW( IOLDSHIFT ) < 0 ) THEN write(*,*) ' ERROR 1 compressLU:Should not point to a band.' CALL MUMPS_ABORT() ELSE IF ( IW( IOLDSHIFT + 2 ) < 0 ) THEN write(*,*) ' ERROR 2 compressLU:Stack not performed yet', & IW(IOLDSHIFT + 2) CALL MUMPS_ABORT() ENDIF LCONT = IW( IOLDSHIFT ) NELIM = IW( IOLDSHIFT + 1 ) NROW = IW( IOLDSHIFT + 2 ) NPIV = IW( IOLDSHIFT + 3 ) IAPOS = PTRFAC(IW( IOLDSHIFT + 4 )) NSLAVES= IW( IOLDSHIFT + 5 ) NFRONT = LCONT + NPIV INTSIZ = IW(IOLDPS+XXI) LRCOMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) IF ( (NSLAVES > 0 .AND. TYPE .NE. 2) .OR. & (NSLAVES .eq. 0 .AND. TYPE .EQ. 2 ) ) THEN WRITE(*,*) ' ERROR 3 compressLU: problem with level of inode' CALL MUMPS_ABORT() END IF IF (LDLT.EQ.0) THEN SIZELU = int(LCONT + NROW, 8) * int(NPIV,8) ELSE SIZELU = int(NROW,8) * int(NPIV,8) ENDIF IF ( TYPE .EQ. 2 ) THEN IF (LDLT.EQ.0) THEN SIZECB = int(NELIM,8) * int(LCONT,8) ELSE IF (KEEP(219).NE.0.AND.KEEP(50).EQ.2) THEN SIZECB = int(NELIM+1,8) * int(NELIM + NPIV,8) ELSE SIZECB = int(NELIM,8) * int(NELIM + NPIV,8) ENDIF ENDIF ELSE LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (LDLT.EQ.0) THEN CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(LCONT,8) * int(LCONT,8) ELSE SIZECB = int(LCONT,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ELSE CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NELIM+NPIV, & KEEP, LR_ACTIVATED, PARPIV_T1) IF (PARPIV_T1.EQ.0) THEN SIZECB = int(NROW,8) * int(LCONT,8) ELSE SIZECB = int(NROW,8) * int(LCONT,8) + int(NELIM + NPIV,8) ENDIF ENDIF END IF CALL MUMPS_SUBTRI8TOARRAY( IW(IOLDPS+XXR), SIZECB ) IF ((KEEP(201).NE.0) & .OR.(LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) & ) THEN SIZESHIFT = SIZELU ELSE SIZESHIFT = 0_8 IF (SIZECB.EQ.0_8) THEN GOTO 500 ENDIF ENDIF IF (KEEP(201).EQ.2) THEN IF (KEEP(405) .EQ. 0) THEN KEEP8(31)=KEEP8(31)+SIZELU CALL ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) ELSE !$OMP CRITICAL(critical_old_ooc) KEEP8(31)=KEEP8(31)+SIZELU CALL ZMUMPS_NEW_FACTOR(INODE,PTRFAC,KEEP,KEEP8, & A,LA,SIZELU, IERR) !$OMP END CRITICAL(critical_old_ooc) ENDIF IF(IERR.LT.0)THEN WRITE(*,*)MYID,': Internal error in ZMUMPS_NEW_FACTOR' CALL MUMPS_ABORT() ENDIF ENDIF IF ( IOLDPS + INTSIZ .NE. IWPOS ) THEN IPS = IOLDPS + INTSIZ MOVEPTRAST = .FALSE. DO WHILE ( IPS .NE. IWPOS ) IPSIZE = IW(IPS+XXI) IPSSHIFT = IPS + KEEP(IXSZ) IF ( IPSIZE .LE. 0 .OR. IPS .GT. IWPOS ) THEN WRITE(*,*) " Internal error 1 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) CALL MUMPS_ABORT() ENDIF IF (IPS+IPSIZE .GT. IWPOS) THEN WRITE(*,*) " Internal error 2 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IOLDPS, INTSIZ, IWPOS, LIW=", & IOLDPS, INTSIZ, IWPOS, LIW WRITE(*,*) " IWPOS, IPS, IPSIZE =", IWPOS, IPS, IPSIZE WRITE(*,*) " Header at IOLDPS =", & IW(IOLDPS:IOLDPS+KEEP(IXSZ)+5) WRITE(*,*) " Header at IOLDPS+INTSIZ =", & IW(IOLDPS+INTSIZ:IOLDPS+INTSIZ+KEEP(IXSZ)+5) WRITE(*,*) " Header at IPS =", & IW(IPS:IPS+KEEP(IXSZ)+5) WRITE(*,*) " ========================== " WRITE(*,*) " Headers starting at IOLDPS:" IPS = IOLDPS DO WHILE (IPS .LE. IWPOS) WRITE(*,*) " -> new IW header at position" , IPS, ":", & IW(IPS:IPS+KEEP(IXSZ)+5) IPS = IPS + IW(IPS+XXI) ENDDO CALL MUMPS_ABORT() ENDIF IF ( IW( IPSSHIFT + 2 ) < 0 ) THEN NFRONT = IW( IPSSHIFT ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 3 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+4))=PTRFAC(IW(IPSSHIFT+4)) - & SIZECB - SIZESHIFT MOVEPTRAST = .TRUE. PTRAST(IW(IPSSHIFT+4))=PTRAST(IW(IPSSHIFT+4))-SIZECB & - SIZESHIFT ELSE IF ( IW( IPSSHIFT ) < 0 ) THEN IF (IW(IPSSHIFT+3) .LT. 0) THEN WRITE(*,*) " Internal error 4 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW(IPSSHIFT+3)) = PTRFAC(IW(IPSSHIFT+3)) & -SIZECB-SIZESHIFT ELSE NFRONT = IW( IPSSHIFT ) + IW( IPSSHIFT + 3 ) IF (IW(IPSSHIFT+4) .LT. 0) THEN WRITE(*,*) " Internal error 4 ZMUMPS_COMPRESS_LU" WRITE(*,*) " IPS,IPSSHIFT,IWPOS=" ,IPS,IPSSHIFT,IWPOS WRITE(*,*) " Header at IPS =", IW(IPS:IPS+KEEP(IXSZ)+5) ENDIF PTRFAC(IW( IPSSHIFT + 4 )) = & PTRFAC(IW( IPSSHIFT + 4 )) - SIZECB - SIZESHIFT END IF IPS = IPS + IPSIZE END DO IF (SIZECB+SIZESHIFT .NE. 0_8) THEN DO I=IAPOS+SIZELU-SIZESHIFT, POSFAC-SIZECB-SIZESHIFT-1_8 A( I ) = A( I + SIZECB + SIZESHIFT) END DO END IF ENDIF POSFAC = POSFAC - (SIZECB+SIZESHIFT) LRLU = LRLU + (SIZECB+SIZESHIFT) ITMP8 = (SIZECB+SIZESHIFT) - SIZE_INPLACE LRLUS = LRLUS + ITMP8 IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - ITMP8 ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - ITMP8 !$OMP END ATOMIC ENDIF 500 CONTINUE IF (LRCOMPRESS_PANEL.AND.KEEP(486).EQ.2) THEN CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU-SIZESHIFT,-(SIZECB+SIZESHIFT)+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ELSE CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,SIZELU,-SIZECB+SIZE_INPLACE, & KEEP,KEEP8,LRLUS) ENDIF RETURN END SUBROUTINE ZMUMPS_COMPRESS_LU SUBROUTINE ZMUMPS_STACK_BAND( N, ISON, & PTRIST, PTRAST, PTLUST_S, PTRFAC, IW, LIW, A, LA, & LRLU, LRLUS, IWPOS, IWPOSCB, POSFAC, COMP, & IPTRLU, OPELIW, STEP, PIMASTER, PAMASTER, & IFLAG, IERROR, SLAVEF, PROCNODE_STEPS, DAD, MYID, COMM, & KEEP, KEEP8, DKEEP, TYPE_SON & ) !$ USE OMP_LIB USE ZMUMPS_OOC USE ZMUMPS_LOAD USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER(8) :: LA, LRLU, LRLUS, POSFAC, IPTRLU INTEGER N, ISON, LIW, IWPOS, IWPOSCB, & COMP, IFLAG, IERROR, SLAVEF, MYID, COMM, & TYPE_SON INTEGER KEEP(500) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)), PAMASTER(KEEP(28)) INTEGER PTRIST(KEEP(28)), STEP(N), & PIMASTER(KEEP(28)), IW(LIW) INTEGER PTLUST_S(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) DOUBLE PRECISION OPELIW DOUBLE PRECISION FLOP1, FLOP1_EFFECTIVE COMPLEX(kind=8) A( LA ) INTEGER(8) :: LREQA, POSA, POSALOC, OLDPOS, JJ INTEGER NFRONT, NCOL_L, NROW_L, LREQI, NSLAVES_L, & POSI, I, IROW_L, ICOL_L, LDA_BAND, NASS LOGICAL NONEED_TO_COPY_FACTORS INTEGER(8) :: LREQA_HEADER INTEGER LIWFAC, STRAT, TYPEFile, NextPivDummy, & IOLDPS_CB LOGICAL LAST_CALL TYPE(IO_BLOCK) :: MonBloc INTEGER LRSTATUS INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0d0) COMPLEX(kind=8), POINTER, DIMENSION(:) :: SON_A INTEGER(8) :: IACHK, SIZFR_SON_A, ITMP8 FLOP1 = ZERO NCOL_L = IW( PTRIST(STEP( ISON )) + 3 + KEEP(IXSZ) ) NROW_L = IW( PTRIST(STEP( ISON )) + 2 + KEEP(IXSZ) ) NSLAVES_L = IW( PTRIST(STEP( ISON )) + 5 + KEEP(IXSZ) ) LRSTATUS = IW( PTRIST(STEP( ISON )) + XXLR) LDA_BAND = NCOL_L + IW( PTRIST(STEP( ISON )) + KEEP(IXSZ) ) IF ( KEEP(50) .eq. 0 ) THEN NFRONT = LDA_BAND ELSE NFRONT = IW( PTRIST(STEP( ISON )) + 7 + KEEP(IXSZ) ) END IF IF (KEEP(201).EQ.1) THEN IOLDPS_CB = PTRIST(STEP( ISON )) LIWFAC = IW(IOLDPS_CB+XXI) TYPEFile = TYPEF_L NextPivDummy = -8888 MonBloc%INODE = ISON MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW_L MonBloc%NCOL = LDA_BAND MonBloc%NFS = IW(IOLDPS_CB+1+KEEP(IXSZ)) MonBloc%LastPiv = NCOL_L MonBloc%LastPanelWritten_L=-9999 MonBloc%LastPanelWritten_U=-9999 NULLIFY(MonBloc%INDICES) STRAT = STRAT_WRITE_MAX LAST_CALL = .TRUE. MonBloc%Last = .TRUE. CALL ZMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) CALL ZMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & SON_A(IACHK), SIZFR_SON_A, MonBloc, & NextPivDummy, NextPivDummy, & IW(IOLDPS_CB), LIWFAC, & MYID, KEEP8(31), IFLAG,LAST_CALL ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN ENDIF ENDIF NONEED_TO_COPY_FACTORS = ((KEEP(201).EQ.1) .OR. (KEEP(201).EQ.-1) & .OR. (LRSTATUS.GE.2.AND.KEEP(486).EQ.2) & ) IF ((NCOL_L.EQ.0).OR.(NROW_L.EQ.0)) THEN GOTO 80 ENDIF LREQI = 4 + NCOL_L + NROW_L + KEEP(IXSZ) LREQA_HEADER = int(NCOL_L,8) * int(NROW_L,8) IF (NONEED_TO_COPY_FACTORS) THEN LREQA = 0_8 ELSE LREQA = LREQA_HEADER ENDIF IF ( LRLU .LT. LREQA .OR. & IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IF ( LRLUS .LT. LREQA ) THEN IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GO TO 700 END IF CALL ZMUMPS_COMPRE_NEW( N,KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS,IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ), COMP, DKEEP(97), & MYID, SLAVEF, KEEP(199), PROCNODE_STEPS, DAD ) IF ( LRLU .NE. LRLUS ) THEN WRITE(*,*) 'PB compress ZMUMPS_STACK_BAND:LRLU,LRLUS=', & LRLU, LRLUS IFLAG = -9 CALL MUMPS_SET_IERROR(LREQA - LRLUS, IERROR) GOTO 700 END IF IF ( IWPOS + LREQI - 1 .GT. IWPOSCB ) THEN IFLAG = -8 IERROR = IWPOS + LREQI - 1 - IWPOSCB GOTO 700 END IF END IF IF (.NOT. NONEED_TO_COPY_FACTORS) THEN POSA = POSFAC POSFAC = POSFAC + LREQA LRLU = LRLU - LREQA LRLUS = LRLUS - LREQA KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LREQA KEEP8(68) = max(KEEP8(69), KEEP8(68)) IF(KEEP(201).NE.2)THEN CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,LREQA,KEEP,KEEP8,LRLUS) ELSE CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,LREQA,KEEP,KEEP8,LRLUS) ENDIF ENDIF POSI = IWPOS IWPOS = IWPOS + LREQI PTLUST_S(STEP( ISON )) = POSI IW(POSI:POSI+KEEP(IXSZ)-1)=-99999 IW(POSI+XXS)=-9999 IW(POSI+XXI)=LREQI CALL MUMPS_STOREI8(0_8, IW(POSI+XXD)) CALL MUMPS_STOREI8(LREQA, IW(POSI+XXR)) CALL MUMPS_STOREI8(LREQA_HEADER, IW(POSI+XXR)) IW(POSI+XXLR) = LRSTATUS IW(POSI+XXF) = IW(PTRIST(STEP(ISON))+XXF) POSI=POSI+KEEP(IXSZ) IW( POSI ) = - NCOL_L IW( POSI + 1 ) = NROW_L IW( POSI + 2 ) = NFRONT - NCOL_L IW( POSI + 3 ) = STEP(ISON) IF (.NOT. NONEED_TO_COPY_FACTORS) THEN PTRFAC(STEP(ISON)) = POSA ELSE PTRFAC(STEP(ISON)) = -77777_8 ENDIF IROW_L = PTRIST(STEP(ISON)) + 6 + NSLAVES_L + KEEP(IXSZ) ICOL_L = PTRIST(STEP(ISON)) + 6 + NROW_L + NSLAVES_L + KEEP(IXSZ) DO I = 1, NROW_L IW( POSI+3+I ) = IW( IROW_L+I-1 ) ENDDO DO I = 1, NCOL_L IW( POSI+NROW_L+3+I) = IW( ICOL_L+I-1 ) ENDDO IF (.NOT.NONEED_TO_COPY_FACTORS) THEN CALL ZMUMPS_DM_SET_DYNPTR(IW(PTRIST(STEP(ISON))+XXS), & A, LA, PTRAST(STEP(ISON)), & IW(PTRIST(STEP(ISON))+XXD), & IW(PTRIST(STEP(ISON))+XXR), & SON_A, IACHK, SIZFR_SON_A) POSALOC = POSA DO I = 1, NROW_L OLDPOS = IACHK + int(I-1,8)*int(LDA_BAND,8) DO JJ = 0_8, int(NCOL_L-1,8) A( POSALOC+JJ ) = SON_A( OLDPOS+JJ ) ENDDO POSALOC = POSALOC + int(NCOL_L,8) END DO ENDIF IF (KEEP(201).EQ.2) THEN KEEP8(31)=KEEP8(31)+LREQA ENDIF ITMP8 = int(NCOL_L,8) * int(NROW_L,8) IF (KEEP(405) .EQ.1) THEN !$OMP ATOMIC UPDATE KEEP8(10) = KEEP8(10) + ITMP8 !$OMP END ATOMIC ELSE KEEP8(10) = KEEP8(10) + ITMP8 ENDIF IF (KEEP(201).EQ.2) THEN CALL ZMUMPS_NEW_FACTOR(ISON,PTRFAC,KEEP,KEEP8,A,LA,LREQA,IFLAG) IF(IFLAG.LT.0)THEN WRITE(*,*)MYID,': Internal error in ZMUMPS_NEW_FACTOR' IERROR=0 GOTO 700 ENDIF POSFAC = POSFAC - LREQA LRLU = LRLU + LREQA LRLUS = LRLUS + LREQA !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - LREQA !$OMP END ATOMIC CALL ZMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,LREQA,0_8,KEEP,KEEP8,LRLUS) ENDIF 80 CONTINUE IF (TYPE_SON == 1) THEN GOTO 90 ENDIF IF ( KEEP(50) .eq. 0 ) THEN FLOP1 = dble( NCOL_L * NROW_L) + & dble(NROW_L*NCOL_L)*dble(2*NFRONT-NCOL_L-1) ELSE FLOP1 = dble( NCOL_L ) * dble( NROW_L ) & * dble( 2 * LDA_BAND - NROW_L - NCOL_L + 1) END IF OPELIW = OPELIW + FLOP1 FLOP1_EFFECTIVE = FLOP1 NASS = IW( PTRIST(STEP( ISON )) + 4 + KEEP(IXSZ) ) IF ( NCOL_L .NE. NASS ) THEN IF ( KEEP(50).eq.0 ) THEN FLOP1 = dble( NASS * NROW_L) + & dble(NROW_L*NASS)*dble(2*NFRONT-NASS-1) ELSE FLOP1 = dble( NASS ) * dble( NROW_L ) * & dble( 2 * LDA_BAND - NROW_L - NASS + 1) END IF END IF CALL ZMUMPS_LOAD_UPDATE(1,.FALSE.,FLOP1_EFFECTIVE-FLOP1, & KEEP,KEEP8) CALL ZMUMPS_LOAD_UPDATE(2,.FALSE.,-FLOP1,KEEP,KEEP8) 90 CONTINUE RETURN 700 CONTINUE CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE ZMUMPS_STACK_BAND SUBROUTINE ZMUMPS_FREE_BAND( N, ISON, & PTRIST, PTRAST, IW, LIW, A, LA, & LRLU, LRLUS, IWPOSCB, & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON & ) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_PTR, & ZMUMPS_DM_FREE_BLOCK IMPLICIT NONE include 'mumps_headers.h' INTEGER(8) :: LRLU, LRLUS, IPTRLU, LA INTEGER ISON, MYID, N, IWPOSCB, TYPE_SON INTEGER KEEP(500), STEP(N) INTEGER(8) KEEP8(150) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER PTRIST(KEEP(28)) INTEGER LIW INTEGER IW(LIW) COMPLEX(kind=8) A(LA) INTEGER ISTCHK INTEGER(8) :: DYN_SIZE COMPLEX(kind=8), DIMENSION(:), POINTER :: FORTRAN_POINTER ISTCHK = PTRIST(STEP(ISON)) CALL MUMPS_GETI8( DYN_SIZE, IW(ISTCHK+XXD) ) IF (DYN_SIZE .GT. 0_8) THEN CALL ZMUMPS_DM_SET_PTR( PTRAST(STEP(ISON)), & DYN_SIZE, FORTRAN_POINTER ) ENDIF CALL ZMUMPS_FREE_BLOCK_CB_STATIC(.FALSE.,MYID, N, ISTCHK, & IW, LIW, LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP,KEEP8, .FALSE. & ) PTRIST(STEP( ISON )) = -9999888 PTRAST(STEP( ISON )) = -9999888_8 RETURN END SUBROUTINE ZMUMPS_FREE_BAND SUBROUTINE ZMUMPS_MEM_ESTIM_BLR_ALL( SUM_OF_PEAKS, KEEP, KEEP8, & MYID, COMM, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & INFO, INFOG, PROK, MP, PROKG, MPG & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: PROK, PROKG, SUM_OF_PEAKS INTEGER , INTENT(IN) :: MYID, COMM, N, NELT, NSLAVES, & LNA, MP, MPG INTEGER(8), INTENT(IN):: NA_ELT8, NNZ8 INTEGER, INTENT(IN):: NA(LNA) INTEGER :: KEEP(500), INFO(80), INFOG(80) INTEGER(8) :: KEEP8(150) INTEGER, PARAMETER :: MASTER = 0 INTEGER :: OOC_STAT, BLR_STRAT, BLR_CASE INTEGER :: IRANK LOGICAL :: EFF, PERLU_ON, COMPUTE_MAXAVG INTEGER(8) :: TOTAL_BYTES INTEGER :: TOTAL_MBYTES INTEGER, DIMENSION(3) :: LRLU_UD, OOC_LRLU_UD PERLU_ON = .TRUE. EFF = .FALSE. COMPUTE_MAXAVG = .NOT.(NSLAVES.EQ.1 .AND. KEEP(46).EQ.1) IF ( PROKG.AND.SUM_OF_PEAKS) THEN WRITE( MPG,'(A)') & ' Estimations with BLR compression of LU factors:' WRITE( MPG,'(A,I6,A) ') & ' ICNTL(38) Estimated compression rate of LU factors =', & KEEP(464), '/1000' ENDIF OOC_STAT = 0 BLR_STRAT = 1 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(30) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(36) = LRLU_UD(1) INFOG(37) = LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN LRLU_UD(3) = (LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE LRLU_UD(3) = LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, IC facto. (INFOG(36)):', & INFOG(36) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, IC factorization (INFOG(37)):' & ,INFOG(37) END IF OOC_STAT = 1 BLR_STRAT = 1 BLR_CASE = 1 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), NSLAVES, TOTAL_MBYTES, EFF, & OOC_STAT, BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) CALL MUMPS_MEM_CENTRALIZE( MYID, COMM, & TOTAL_MBYTES, OOC_LRLU_UD, IRANK ) IF (SUM_OF_PEAKS) THEN INFO(31) = TOTAL_MBYTES IF (MYID.EQ.MASTER) THEN INFOG(38)= OOC_LRLU_UD(1) INFOG(39)= OOC_LRLU_UD(2) ENDIF ENDIF IF (MYID.EQ.MASTER) THEN IF ( KEEP(46) .eq. 0 ) THEN OOC_LRLU_UD(3) = (OOC_LRLU_UD(2)-TOTAL_MBYTES)/NSLAVES ELSE OOC_LRLU_UD(3) = OOC_LRLU_UD(2)/NSLAVES ENDIF ENDIF IF ( PROKG.AND.SUM_OF_PEAKS ) THEN IF (COMPUTE_MAXAVG) THEN WRITE( MPG,'(A,I12) ') & ' Maximum estim. space in Mbytes, OOC facto. (INFOG(38)):', & INFOG(38) ENDIF WRITE(MPG,'(A,I12) ') & ' Total space in MBytes, OOC factorization (INFOG(39)):' & ,INFOG(39) END IF END SUBROUTINE ZMUMPS_MEM_ESTIM_BLR_ALL SUBROUTINE ZMUMPS_MAX_MEM( KEEP, KEEP8, & MYID, N, NELT, NA, LNA, NNZ8, NA_ELT8, NSLAVES, & MEMORY_MBYTES, EFF, OOC_STRAT, BLR_STRAT, PERLU_ON, & MEMORY_BYTES, & BLR_CASE, SUM_OF_PEAKS, MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) IMPLICIT NONE LOGICAL, INTENT(IN) :: EFF, PERLU_ON, UNDER_L0_OMP INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER(8), INTENT(IN) :: NA_ELT8, NNZ8 INTEGER, INTENT(IN) :: NA(LNA) INTEGER(8), INTENT(OUT):: MEMORY_BYTES INTEGER, INTENT(OUT) :: MEMORY_MBYTES INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS LOGICAL, INTENT(IN) :: MEM_EFF_ALLOCATED INTEGER :: MUMPS_GET_POOL_LENGTH EXTERNAL :: MUMPS_GET_POOL_LENGTH INTEGER(8) :: MemEstimGlobal LOGICAL :: I_AM_SLAVE, I_AM_MASTER INTEGER :: PERLU, NBRECORDS INTEGER(8) :: NB_REAL INTEGER(8) :: TEMP, NB_BYTES, NB_INT INTEGER :: ZMUMPS_LBUF_INT INTEGER(8) :: ZMUMPS_LBUFR_BYTES8, ZMUMPS_LBUF8 INTEGER :: NBUFS INTEGER(8) :: TEMPI INTEGER(8) :: TEMPR INTEGER :: MIN_PERLU INTEGER(8) :: BUF_OOC, BUF_OOC_PANEL, BUF_OOC_NOPANEL INTEGER(8) :: OOC_NB_FILE_TYPE INTEGER(8) :: NSTEPS8, N8, NELT8 INTEGER(8) :: I8OVERI INTEGER(8) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 I8OVERI = int(KEEP(10),8) PERLU = KEEP(12) NSTEPS8 = int(KEEP(28),8) N8 = int(N,8) NELT8 = int(NELT,8) IF (.NOT.PERLU_ON) PERLU = 0 I_AM_MASTER = ( MYID .eq. 0 ) I_AM_SLAVE = ( KEEP(46).eq. 1 .or. MYID .ne. 0 ) TEMP = 0_8 NB_REAL = 0_8 NB_BYTES = 0_8 NB_INT = 0_8 IF (KEEP(235) .NE. 0 .OR. KEEP(237) .NE. 0) THEN NB_INT = NB_INT + NSTEPS8 ENDIF NB_INT = NB_INT + 5_8 * NSTEPS8 NB_INT = NB_INT + NSTEPS8 + int(KEEP(56),8)*int(NSLAVES+2,8) NB_INT = NB_INT + 3_8 * N8 IF (KEEP(23).ne.0 .and. I_AM_MASTER) NB_INT=NB_INT + N8 IF (KEEP(55).eq.0) THEN NB_INT = NB_INT + 2_8 * N8 ELSE NB_INT = NB_INT + 2_8 * ( NELT8 + 1_8 ) ENDIF IF (KEEP(55) .ne. 0 ) THEN NB_INT = NB_INT + N8 + 1_8 + NELT8 END IF NB_INT = NB_INT + int(LNA,8) IF ( .NOT. EFF ) THEN IF (I_AM_SLAVE) THEN IF ( KEEP8(24).EQ.0_8 ) THEN SUM_NRLADU_underL0 = 0_8 SUM_NRLADU_if_LR_LU_underL0 = 0_8 SUM_NRLADULR_UD_underL0 = 0_8 SUM_NRLADULR_WC_underL0 = 0_8 CALL ZMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & KEEP8(53), & KEEP8(54), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50), & KEEP8(36), & KEEP8(47), & KEEP8(37), & KEEP8(38), & KEEP8(39), & MemEstimGlobal & ) IF (KEEP(400).LE.0) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ELSE IF (BLR_STRAT.EQ.0) THEN IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(14) / 100_8 + 1_8 ) ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(KEEP8(12) / 100_8 + 1_8 ) ENDIF ELSE NB_REAL = NB_REAL + MemEstimGlobal + & int(PERLU,8)*(MemEstimGlobal / 100_8 + 1_8 ) ENDIF ENDIF ELSE NB_REAL = NB_REAL + 1_8 ENDIF ELSE IF (I_AM_SLAVE) THEN IF (UNDER_L0_OMP) THEN IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(63) ELSE NB_REAL = NB_REAL + KEEP8(62) ENDIF ELSE IF (MEM_EFF_ALLOCATED) THEN NB_REAL = NB_REAL + KEEP8(23) + KEEP8(74) ELSE NB_REAL = NB_REAL + KEEP8(67) + KEEP8(74) ENDIF ENDIF ENDIF IF ( OOC_STRAT .GT. 0 .AND. I_AM_SLAVE ) THEN BUF_OOC_NOPANEL = 2_8 * KEEP8(119) IF (KEEP(50).EQ.0)THEN BUF_OOC_PANEL = 8_8 * int(KEEP(226),8) ELSE BUF_OOC_PANEL = 4_8 * int(KEEP(226),8) ENDIF IF (OOC_STRAT .EQ. 2) THEN BUF_OOC = BUF_OOC_NOPANEL ELSE BUF_OOC = BUF_OOC_PANEL ENDIF NB_REAL = NB_REAL + min(BUF_OOC + int(max(PERLU,0),8) * & (BUF_OOC/100_8+1_8),12000000_8) IF (OOC_STRAT .EQ. 2) THEN OOC_NB_FILE_TYPE = 1_8 ELSE IF (KEEP(50).EQ.0) THEN OOC_NB_FILE_TYPE = 2_8 ELSE OOC_NB_FILE_TYPE = 1_8 ENDIF ENDIF NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 * I8OVERI NB_INT = NB_INT + OOC_NB_FILE_TYPE * NSTEPS8 ENDIF NB_REAL = NB_REAL + KEEP8(26) IF (KEEP(252).EQ.1 .AND. .NOT. I_AM_MASTER) THEN NB_REAL = NB_REAL + N8 ENDIF IF ( .not. ( I_AM_SLAVE .and. I_AM_MASTER .and. KEEP(52) .eq. 0 & .and. KEEP(55) .ne. 0 ) ) THEN NB_INT = NB_INT + KEEP8(27) END IF IF ( I_AM_SLAVE .and. KEEP(38) .ne. 0 ) THEN NB_INT = NB_INT + 2_8 * N8 END IF TEMPI= 0_8 TEMPR = 0_8 NBRECORDS = KEEP(39) IF (KEEP(55).eq.0) THEN IF (NNZ8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NNZ8) ENDIF ELSE IF (NA_ELT8 < int(NBRECORDS,8)) THEN NBRECORDS=int(NA_ELT8) ENDIF ENDIF IF ( KEEP(54) .eq. 0 ) THEN IF ( I_AM_MASTER ) THEN IF ( KEEP(46) .eq. 0 ) THEN NBUFS = NSLAVES ELSE NBUFS = NSLAVES - 1 IF (KEEP(55) .eq. 0 ) & TEMPI = TEMPI + 2_8 * N8 END IF TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) * int(NBUFS,8) TEMPR = TEMPR + int(NBRECORDS,8) * int(NBUFS,8) ELSE IF ( KEEP(55) .eq. 0 )THEN TEMPI = TEMPI + 2_8 * int(NBRECORDS,8) TEMPR = TEMPR + int(NBRECORDS,8) END IF END IF ELSE IF ( I_AM_SLAVE ) THEN TEMPI = TEMPI + int(1+4*NSLAVES,8) * int(NBRECORDS,8) TEMPR = TEMPR + int(1+2*NSLAVES,8) * int(NBRECORDS,8) END IF END IF TEMP = max( NB_BYTES + (NB_INT + TEMPI) * int(KEEP(34),8) & + (NB_REAL+TEMPR) * int(KEEP(35),8) & , TEMP ) IF ( I_AM_SLAVE ) THEN IF (BLR_STRAT.NE.0) THEN ZMUMPS_LBUFR_BYTES8 = int(KEEP(380),8) * int(KEEP(35),8) ELSE ZMUMPS_LBUFR_BYTES8 = int(KEEP(44),8) * int(KEEP(35),8) ENDIF ZMUMPS_LBUFR_BYTES8 = max( ZMUMPS_LBUFR_BYTES8, & 100000_8 ) IF (KEEP(48).EQ.5) THEN MIN_PERLU=2 ELSE MIN_PERLU=0 ENDIF IF (KEEP(489).GT.0) THEN ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( 0.5D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0,8) ELSE ZMUMPS_LBUFR_BYTES8 = ZMUMPS_LBUFR_BYTES8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUFR_BYTES8)/100D0,8) ENDIF ZMUMPS_LBUFR_BYTES8 = min(ZMUMPS_LBUFR_BYTES8, & int(huge (KEEP(43))-100,8)) NB_BYTES = NB_BYTES + ZMUMPS_LBUFR_BYTES8 IF (.NOT.UNDER_L0_OMP) THEN IF (BLR_STRAT.NE.0) THEN ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 379 ) * KEEP( 35 )), 8 ) ELSE ZMUMPS_LBUF8 = int( dble(KEEP(213)) / 100.0D0 & * dble(KEEP( 43 ) * KEEP( 35 )), 8 ) ENDIF ZMUMPS_LBUF8 = max( ZMUMPS_LBUF8, 100000_8 ) ZMUMPS_LBUF8 = ZMUMPS_LBUF8 & + int( 2.0D0 * dble(max(PERLU,MIN_PERLU))* & dble(ZMUMPS_LBUF8)/100D0, 8) ZMUMPS_LBUF8 = min(ZMUMPS_LBUF8, int(huge (KEEP(43)-100),8)) ZMUMPS_LBUF8 = max(ZMUMPS_LBUF8, ZMUMPS_LBUFR_BYTES8+ & 3_8*int(KEEP(34),8)) NB_BYTES = NB_BYTES + ZMUMPS_LBUF8 ENDIF ZMUMPS_LBUF_INT = ( KEEP(56) + & NSLAVES * NSLAVES ) * 5 & * KEEP(34) NB_BYTES = NB_BYTES + int(ZMUMPS_LBUF_INT,8) IF (.NOT.EFF) THEN IF (UNDER_L0_OMP) THEN NB_INT = NB_INT + N8*KEEP(400) ENDIF IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(138) + 2 * max(PERLU,10) * & ( KEEP(138) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(137) + 2 * max(PERLU,10) * & ( KEEP(137) / 100 + 1 ) & ,8) ENDIF ENDIF IF (.NOT.UNDER_L0_OMP) THEN IF (OOC_STRAT .GT. 0) THEN NB_INT = NB_INT + int( & KEEP(225) + 2 * max(PERLU,10) * & ( KEEP(225) / 100 + 1 ) & ,8) ELSE NB_INT = NB_INT + int( & KEEP(15) + 2 * max(PERLU,10) * & ( KEEP(15) / 100 + 1 ) & ,8) ENDIF ENDIF NB_INT = NB_INT + NSTEPS8 NB_INT = NB_INT + NSTEPS8 * I8OVERI NB_INT = NB_INT + N8 + 4_8 * NSTEPS8 + & int(MUMPS_GET_POOL_LENGTH(NA(1), KEEP, KEEP8),8) NB_INT = NB_INT + 2_8 * NSTEPS8 * I8OVERI IF (KEEP(494).NE.0) THEN NB_INT = NB_INT + N8 ENDIF ENDIF MEMORY_BYTES = NB_BYTES + NB_INT * int(KEEP(34),8) + & NB_REAL * int(KEEP(35),8) MEMORY_BYTES = max( MEMORY_BYTES, TEMP ) MEMORY_MBYTES = nint( dble(MEMORY_BYTES) / dble(1000000) ) RETURN END SUBROUTINE ZMUMPS_MAX_MEM SUBROUTINE ZMUMPS_SET_MEMESTIMGLOBAL ( & OOC_STRAT, BLR_STRAT, BLR_CASE, SUM_OF_PEAKS, & KEEP8, & SUM_NRLADU_underL0, SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, SUM_NRLADULR_WC_underL0, & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC, & MemEstimGlobal & ) INTEGER, INTENT(IN) :: OOC_STRAT, BLR_STRAT INTEGER, INTENT(IN) :: BLR_CASE LOGICAL, INTENT(IN) :: SUM_OF_PEAKS INTEGER(8), INTENT(IN) :: KEEP8(150) INTEGER(8), INTENT(IN) :: SUM_NRLADU_underL0, & SUM_NRLADU_if_LR_LU_underL0, & SUM_NRLADULR_UD_underL0, & SUM_NRLADULR_WC_underL0 INTEGER(8), INTENT(IN) :: & PEAK_FR, & PEAK_FR_OOC, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB, & NRLADULR_UD, & NRLADULR_WC, & NRLNECLR_CB_UD, & NRLNECLR_LUCB_UD, & NRLNECLR_LUCB_WC INTEGER(8), INTENT(OUT) :: MemEstimGlobal IF ( OOC_STRAT .GT. 0 .OR. OOC_STRAT .EQ. -1 ) THEN MemEstimGlobal = PEAK_FR_OOC ELSE MemEstimGlobal = PEAK_FR ENDIF IF (BLR_STRAT.GT.0) THEN IF (.NOT.SUM_OF_PEAKS) THEN IF (BLR_STRAT.EQ.1) THEN IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(40) ELSE MemEstimGlobal = KEEP8(41) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(33) ELSE MemEstimGlobal = KEEP8(54) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(53) ELSE MemEstimGlobal = KEEP8(42) ENDIF ENDIF ELSE IF (BLR_CASE.LE.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(43) ELSE MemEstimGlobal = KEEP8(45) ENDIF ELSE IF (BLR_CASE.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(34) ELSE MemEstimGlobal = KEEP8(35) ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = KEEP8(44) ELSE MemEstimGlobal = KEEP8(46) ENDIF ENDIF ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LU & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = PEAK_FR_OOC ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLADULR_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_LUCB & + SUM_NRLADU_if_LR_LU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF IF (BLR_CASE.EQ.1) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_UD & + SUM_NRLADULR_UD_underL0 ELSE IF (BLR_CASE.EQ.3) THEN MemEstimGlobal = MemEstimGlobal + NRLNECLR_LUCB_WC & + SUM_NRLADULR_WC_underL0 ENDIF ELSE IF (OOC_STRAT.EQ.0) THEN MemEstimGlobal = NRLNEC_if_LR_CB & + SUM_NRLADU_underL0 ELSE MemEstimGlobal = NRLNECOOC_if_LR_LUCB ENDIF MemEstimGlobal = MemEstimGlobal + NRLNECLR_CB_UD ENDIF ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_SET_MEMESTIMGLOBAL SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS_K8 ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP, KEEP8) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: KEEP8(150) CALL ZMUMPS_SET_BLRSTRAT_AND_MAXS ( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, & KEEP(1), & KEEP8(12), & KEEP8(14), & KEEP8(33), & KEEP8(34), & KEEP8(35), & KEEP8(50) ) RETURN END SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS_K8 SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS( & MAXS_BASE8, MAXS_BASE_RELAXED8, & BLR_STRAT, KEEP, & NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS_BASE8, MAXS_BASE_RELAXED8 INTEGER, INTENT(OUT) :: BLR_STRAT INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(IN) :: NRLNEC, & NRLNEC_ACTIVE, & NRLNEC_if_LR_LU, & NRLNEC_if_LR_LUCB, & NRLNECOOC_if_LR_LUCB, & NRLNEC_if_LR_CB INTEGER :: PERLU PERLU = KEEP(12) IF (KEEP(201) .EQ. 0) THEN MAXS_BASE8 = NRLNEC ELSE MAXS_BASE8 = NRLNEC_ACTIVE ENDIF BLR_STRAT = 0 IF (KEEP(486).EQ.2) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 2 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_LUCB ENDIF ELSE BLR_STRAT = 1 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNEC_ACTIVE ELSE MAXS_BASE8 = NRLNEC_if_LR_LU ENDIF ENDIF ELSE IF (KEEP(486).EQ.3) THEN IF (KEEP(489).EQ.1) THEN BLR_STRAT = 3 IF (KEEP(201).NE.0) THEN MAXS_BASE8 = NRLNECOOC_if_LR_LUCB ELSE MAXS_BASE8 = NRLNEC_if_LR_CB ENDIF ENDIF ENDIF IF ( MAXS_BASE8 .GT. 0_8 ) THEN MAXS_BASE_RELAXED8 = & MAXS_BASE8 + int(PERLU,8) * ( MAXS_BASE8 / 100_8 + 1_8) MAXS_BASE_RELAXED8 = max(MAXS_BASE_RELAXED8, 1_8) ELSE MAXS_BASE_RELAXED8 = 1_8 END IF RETURN END SUBROUTINE ZMUMPS_SET_BLRSTRAT_AND_MAXS SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_MAXS ( MAXS, & BLR_STRAT, OOC_STRAT, MAXS_ESTIM_RELAXED8, & KEEP, KEEP8, MYID, N, NELT, NA, LNA, & NSLAVES, ICNTL38, ICNTL39, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(OUT) :: MAXS INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(IN) :: BLR_STRAT INTEGER, INTENT(IN) :: OOC_STRAT INTEGER(8), INTENT(IN) :: MAXS_ESTIM_RELAXED8 INTEGER, INTENT(IN) :: KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(IN) :: MYID, N, NELT, NSLAVES, LNA INTEGER, INTENT(IN) :: NA(LNA), ICNTL38, ICNTL39 INTEGER(8) :: SMALLER_MAXS, UPDATED_DIFF LOGICAL :: EFF, PERLU_ON, SUM_OF_PEAKS INTEGER :: BLR_CASE INTEGER(8) :: TOTAL_BYTES, MEM_ALLOWED_BYTES, & MEM_DISPO_BYTES, MEM_DISPO INTEGER :: TOTAL_MBYTES, PERLU INTEGER(8) :: MEM_DISPO_BYTES_NR, MEM_DISPO_NR, & TOTAL_BYTES_NR INTEGER :: TOTAL_MBYTES_NR INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. PERLU_ON = .TRUE. PERLU = KEEP(12) EFF = .FALSE. SUM_OF_PEAKS = .TRUE. BLR_CASE = 1 MEM_ALLOWED_BYTES = KEEP8(4) CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & BLR_CASE, SUM_OF_PEAKS, .FALSE. , & .FALSE. & ) MEM_DISPO_BYTES = MEM_ALLOWED_BYTES-TOTAL_BYTES MEM_DISPO = MEM_DISPO_BYTES/int(KEEP(35),8) IF (BLR_STRAT.EQ.0) THEN UPDATED_DIFF = 0_8 ELSE IF (BLR_STRAT.EQ.1) THEN IF (KEEP(464).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(36)) * ( 1.0D0 - & dble(ICNTL38)/dble(KEEP(464)) ) & , 8) ELSE UPDATED_DIFF = int ( & -dble(KEEP8(11)-KEEP8(32)) * & dble(ICNTL38) / 1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF (KEEP(464)+KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(38)) * ( 1.0D0 - & dble(ICNTL38+ICNTL39)/ & dble(KEEP(464)+KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL38+ICNTL39)/1000.0D0 & , 8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF (KEEP(465).NE.0) THEN UPDATED_DIFF = int( & dble(KEEP8(37)) * ( 1.0D0 - & dble(ICNTL39)/dble(KEEP(465)) ) & , 8) ELSE UPDATED_DIFF = int( & -dble(KEEP8(39))* & dble(ICNTL39)/1000.0D0 & , 8) ENDIF ELSE UPDATED_DIFF = 0_8 ENDIF MEM_DISPO = MEM_DISPO + UPDATED_DIFF MAXS = MAXS_ESTIM_RELAXED8 MEM_DISPO_NR = 0_8 IF ( (MEM_DISPO.LT.0) .AND. MAXS_ESTIM_RELAXED8.GT. & (KEEP8(4)/int(KEEP(35),8)) ) THEN PERLU_ON = .FALSE. CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, & KEEP8(28), KEEP8(30), & NSLAVES, TOTAL_MBYTES_NR, EFF, OOC_STRAT, & BLR_STRAT, PERLU_ON, TOTAL_BYTES_NR, & BLR_CASE, SUM_OF_PEAKS, .FALSE., & .FALSE. & ) MEM_DISPO_BYTES_NR = MEM_ALLOWED_BYTES-TOTAL_BYTES_NR MEM_DISPO_NR = & MEM_DISPO_BYTES_NR/int(KEEP(35),8) & + UPDATED_DIFF IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE IF (BLR_STRAT.GE.2) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE MEM_DISPO_NR = MEM_DISPO_NR - & (int(KEEP(12),8)/120_8)* & (KEEP8(11)/4_8) IF ( MEM_DISPO_NR.LT.0 ) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-MEM_DISPO_NR,IERROR) GOTO 500 ELSE ENDIF ENDIF ENDIF ENDIF MAXS = MAXS_ESTIM_RELAXED8 IF (BLR_STRAT.EQ.0) THEN IF (MEM_DISPO.GT.0) THEN IF (OOC_STRAT.EQ.0) THEN MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ELSE MAXS = MAXS_ESTIM_RELAXED8+(MEM_DISPO/2_8) ENDIF ELSE MAXS = MAXS_ESTIM_RELAXED8 + MEM_DISPO ENDIF ELSE IF (BLR_STRAT.EQ.1) THEN IF ( MEM_DISPO .LT. 0) THEN IF (OOC_STRAT.EQ.0) THEN SMALLER_MAXS = KEEP8(34) + & int(PERLU,8) * ( KEEP8(34) / 100_8 + 1_8) ELSE SMALLER_MAXS = KEEP8(35) + & int(PERLU,8) * ( KEEP8(35) / 100_8 + 1_8) ENDIF MAXS = max(MAXS_ESTIM_RELAXED8+MEM_DISPO, & SMALLER_MAXS) ENDIF ELSE IF (BLR_STRAT.EQ.2) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ELSE IF (BLR_STRAT.EQ.3) THEN IF ( MEM_DISPO.LT.0) THEN MAXS = max( & MAXS_ESTIM_RELAXED8+MEM_DISPO, & MAXS_ESTIM_RELAXED8) ENDIF ENDIF IF (MAXS .LE. 0_8) THEN IFLAG=-19 IF (MEM_DISPO.LT.0) THEN CALL MUMPS_SET_IERROR(MEM_DISPO,IERROR) ELSE CALL MUMPS_SET_IERROR(MAXS_ESTIM_RELAXED8-MAXS,IERROR) ENDIF ENDIF CALL ZMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, & .FALSE., & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) 500 CONTINUE RETURN END SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_MAXS SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_K75 ( & MAXS, MYID, UNDER_L0_OMP, & N, NELT, NA, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT, & KEEP, KEEP8, IFLAG, IERROR & ) IMPLICIT NONE INTEGER(8), INTENT(IN) :: MAXS INTEGER, INTENT(IN) :: MYID, N, NELT, LNA, NSLAVES, & BLR_STRAT, OOC_STRAT LOGICAL, INTENT(IN) :: UNDER_L0_OMP INTEGER, INTENT(IN) :: NA(LNA), KEEP(500) INTEGER(8), INTENT(INOUT) :: KEEP8(150) INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER(8) :: KEEP8_23_SAVETMP, TOTAL_BYTES INTEGER :: TOTAL_MBYTES LOGICAL :: PERLU_ON, MEM_EFF_ALLOCATED, EFF INTEGER, PARAMETER :: IDUMMY = -9999 LOGICAL, PARAMETER :: BDUMMY =.FALSE. KEEP8_23_SAVETMP = KEEP8(23) KEEP8(23) = MAXS PERLU_ON =.TRUE. MEM_EFF_ALLOCATED = .TRUE. EFF = .TRUE. KEEP8(74) = 0_8 KEEP8(63) = 0_8 CALL ZMUMPS_MAX_MEM( KEEP(1), KEEP8(1), & MYID, N, NELT, NA(1), LNA, KEEP8(28), & KEEP8(30), & NSLAVES, TOTAL_MBYTES, EFF , KEEP(201), & BLR_STRAT, PERLU_ON, TOTAL_BYTES, & IDUMMY, BDUMMY , MEM_EFF_ALLOCATED, & UNDER_L0_OMP & ) KEEP8(23) = KEEP8_23_SAVETMP KEEP8(75) = KEEP8(4) - TOTAL_BYTES KEEP8(75) = KEEP8(75)/int(KEEP(35),8) IF (KEEP8(75).LT.0_8) THEN IFLAG=-19 CALL MUMPS_SET_IERROR(-KEEP8(75),IERROR) ENDIF RETURN END SUBROUTINE ZMUMPS_MEM_ALLOWED_SET_K75 SUBROUTINE ZMUMPS_SETMAXTOZERO(M_ARRAY, M_SIZE) IMPLICIT NONE INTEGER M_SIZE DOUBLE PRECISION M_ARRAY(M_SIZE) DOUBLE PRECISION ZERO PARAMETER (ZERO=0.0D0) M_ARRAY=ZERO RETURN END SUBROUTINE ZMUMPS_SETMAXTOZERO SUBROUTINE ZMUMPS_COMPUTE_NBROWSinF ( & N, INODE, IFATH, KEEP, & IOLDPS, HF, IW, LIW, & NROWS, NCOLS, NPIV, & NELIM, NFS4FATHER, & NBROWSinF & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NROWS, NCOLS INTEGER, INTENT(IN) :: NPIV, NELIM, NFS4FATHER INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: NBROWSinF INTEGER :: ShiftFirstRowinFront NBROWSinF = 0 IF ( (KEEP(219).EQ.0).OR.(KEEP(50).NE.2).OR. & (NFS4FATHER.LE.0) ) THEN RETURN ENDIF ShiftFirstRowinFront = NCOLS-NPIV-NELIM-NROWS IF (ShiftFirstRowinFront.EQ.0) THEN NBROWSinF = min(NROWS, NFS4FATHER-NELIM) ELSE IF (ShiftFirstRowinFront.LT.NFS4FATHER-NELIM) THEN NBROWSinF = min(NROWS,NFS4FATHER-NELIM-ShiftFirstRowinFront) ELSE NBROWSinF=0 ENDIF RETURN END SUBROUTINE ZMUMPS_COMPUTE_NBROWSinF SUBROUTINE ZMUMPS_COMPUTE_ESTIM_NFS4FATHER ( & N, INODE, IFATH, FILS, PERM, KEEP, & IOLDPS, HF, IW, LIW, NFRONT, NASS1, & ESTIM_NFS4FATHER_ATSON & ) IMPLICIT NONE INTEGER, INTENT(IN) :: N, INODE, IFATH INTEGER, INTENT(IN) :: FILS(N), PERM(N), KEEP(500) INTEGER, INTENT(IN) :: IOLDPS, HF, LIW, NFRONT, NASS1 INTEGER, INTENT(IN) :: IW(LIW) INTEGER, INTENT(OUT):: ESTIM_NFS4FATHER_ATSON INTEGER :: J, J_LASTFS, IN, NCB, I, IPOS ESTIM_NFS4FATHER_ATSON = 0 IN = IFATH J_LASTFS = IN DO WHILE (IN.GT.0) J_LASTFS = IN IN = FILS(IN) ENDDO NCB = NFRONT-NASS1 IPOS = IOLDPS + HF + NASS1 ESTIM_NFS4FATHER_ATSON = 0 DO I=1, NCB J = IW(IPOS+ESTIM_NFS4FATHER_ATSON) IF (PERM(J).LE.PERM(J_LASTFS)) THEN ESTIM_NFS4FATHER_ATSON = & ESTIM_NFS4FATHER_ATSON+1 ELSE EXIT ENDIF ENDDO RETURN END SUBROUTINE ZMUMPS_COMPUTE_ESTIM_NFS4FATHER SUBROUTINE ZMUMPS_COMPUTE_MAXPERCOL( & A,ASIZE,NCOL,NROW, & M_ARRAY,NMAX,PACKED_CB,LROW1) IMPLICIT NONE INTEGER(8) :: ASIZE INTEGER NROW,NCOL,NMAX,LROW1 LOGICAL PACKED_CB COMPLEX(kind=8) A(ASIZE) DOUBLE PRECISION M_ARRAY(NMAX) INTEGER I INTEGER(8):: APOS, J, LROW DOUBLE PRECISION ZERO,TMP PARAMETER (ZERO=0.0D0) DO I=1, NMAX M_ARRAY(I) = ZERO ENDDO APOS = 0_8 IF (PACKED_CB) THEN LROW=int(LROW1,8) ELSE LROW=int(NCOL,8) ENDIF DO I=1,NROW DO J=1_8,int(NMAX,8) TMP = abs(A(APOS+J)) IF(TMP.GT.M_ARRAY(J)) M_ARRAY(J) = TMP ENDDO APOS = APOS + LROW IF (PACKED_CB) LROW=LROW+1_8 ENDDO RETURN END SUBROUTINE ZMUMPS_COMPUTE_MAXPERCOL SUBROUTINE ZMUMPS_SIZE_IN_STRUCT( id, NB_INT, NB_CMPLX, NB_CHAR ) USE ZMUMPS_STRUC_DEF IMPLICIT NONE TYPE(ZMUMPS_STRUC) :: id INTEGER(8) NB_INT, NB_CMPLX INTEGER(8) NB_REAL,NB_CHAR NB_INT = 0_8 NB_CMPLX = 0_8 NB_REAL = 0_8 NB_CHAR = 0_8 IF (associated(id%IS)) NB_INT=NB_INT+size(id%IS) NB_INT=NB_INT+size(id%KEEP) NB_INT=NB_INT+size(id%ICNTL) NB_INT=NB_INT+size(id%INFO) NB_INT=NB_INT+size(id%INFOG) IF (associated(id%MAPPING)) NB_INT=NB_INT+size(id%MAPPING) IF (associated(id%STEP)) NB_INT=NB_INT+size(id%STEP) IF (associated(id%NE_STEPS )) NB_INT=NB_INT+size(id%NE_STEPS ) IF (associated(id%ND_STEPS)) NB_INT=NB_INT+size(id%ND_STEPS) IF (associated(id%Step2node)) NB_INT=NB_INT+size(id%Step2node) IF (associated(id%FRERE_STEPS)) NB_INT=NB_INT+size(id%FRERE_STEPS) IF (associated(id%DAD_STEPS)) NB_INT=NB_INT+size(id%DAD_STEPS) IF (associated(id%FILS)) NB_INT=NB_INT+size(id%FILS) IF (associated(id%PTRAR)) & NB_INT=NB_INT+size(id%PTRAR)* id%KEEP(10) IF (associated(id%FRTPTR)) NB_INT=NB_INT+size(id%FRTPTR) NB_INT=NB_INT+size(id%KEEP8) * id%KEEP(10) IF (associated(id%PTRFAC)) NB_INT=NB_INT+size(id%PTRFAC) * & id%KEEP(10) IF (associated(id%FRTELT)) NB_INT=NB_INT+size(id%FRTELT) IF (associated(id%NA)) NB_INT=NB_INT+size(id%NA) IF (associated(id%PROCNODE_STEPS)) & NB_INT=NB_INT+size(id%PROCNODE_STEPS) IF (associated(id%PTLUST_S)) NB_INT=NB_INT+size(id%PTLUST_S) IF (associated(id%INTARR)) NB_INT=NB_INT+id%KEEP8(27) IF (associated(id%ELTPROC)) NB_INT=NB_INT+size(id%ELTPROC) IF (associated(id%CANDIDATES)) & NB_INT=NB_INT+size(id%CANDIDATES) IF (associated(id%SYM_PERM)) & NB_INT=NB_INT+size(id%SYM_PERM) IF (associated(id%UNS_PERM)) & NB_INT=NB_INT+size(id%UNS_PERM) IF (associated(id%ISTEP_TO_INIV2)) & NB_INT=NB_INT+size(id%ISTEP_TO_INIV2) IF (associated(id%FUTURE_NIV2)) & NB_INT=NB_INT+size(id%FUTURE_NIV2) IF (associated(id%TAB_POS_IN_PERE)) & NB_INT=NB_INT+size(id%TAB_POS_IN_PERE) IF (associated(id%I_AM_CAND)) & NB_INT=NB_INT+size(id%I_AM_CAND) IF (associated(id%MEM_DIST)) & NB_INT=NB_INT+size(id%MEM_DIST) IF (associated(id%POSINRHSCOMP_ROW)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_ROW) IF(id%POSINRHSCOMP_COL_ALLOC.AND.associated(id%POSINRHSCOMP_COL)) & NB_INT=NB_INT+size(id%POSINRHSCOMP_COL) IF (associated(id%MEM_SUBTREE)) & NB_REAL=NB_REAL+size(id%MEM_SUBTREE)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%MY_ROOT_SBTR)) & NB_INT=NB_INT+size(id%MY_ROOT_SBTR) IF (associated(id%MY_FIRST_LEAF)) & NB_INT=NB_INT+size(id%MY_FIRST_LEAF) IF (associated(id%MY_NB_LEAF)) NB_INT=NB_INT+size(id%MY_NB_LEAF) IF (associated(id%DEPTH_FIRST)) NB_INT=NB_INT+size(id%DEPTH_FIRST) IF (associated(id%DEPTH_FIRST_SEQ)) & NB_INT=NB_INT+size(id%DEPTH_FIRST_SEQ) IF (associated(id%SBTR_ID)) NB_INT=NB_INT+size(id%SBTR_ID) IF (associated(id%SCHED_DEP)) NB_INT=NB_INT+size(id%SCHED_DEP) IF (associated(id%SCHED_GRP)) NB_INT=NB_INT+size(id%SCHED_GRP) IF (associated(id%SCHED_SBTR)) NB_INT=NB_INT+size(id%SCHED_SBTR) IF (associated(id%CROIX_MANU)) NB_INT=NB_INT+size(id%CROIX_MANU) IF (associated(id%COST_TRAV)) & NB_REAL=NB_REAL+size(id%COST_TRAV)*(id%KEEP(35)/id%KEEP(16)) IF (associated(id%CB_SON_SIZE)) NB_INT=NB_INT+size(id%CB_SON_SIZE) IF (associated(id%OOC_INODE_SEQUENCE)) & NB_INT=NB_INT+size(id%OOC_INODE_SEQUENCE) IF (associated(id%OOC_SIZE_OF_BLOCK)) & NB_INT=NB_INT+size(id%OOC_SIZE_OF_BLOCK)*id%KEEP(10) IF (associated(id%OOC_VADDR)) & NB_INT=NB_INT+size(id%OOC_VADDR)*id%KEEP(10) IF (associated(id%OOC_TOTAL_NB_NODES)) & NB_INT=NB_INT+size(id%OOC_TOTAL_NB_NODES) IF (associated(id%OOC_NB_FILES)) & NB_INT=NB_INT+size(id%OOC_NB_FILES) IF (associated(id%OOC_FILE_NAME_LENGTH)) & NB_INT=NB_INT+size(id%OOC_FILE_NAME_LENGTH) IF (associated(id%PIVNUL_LIST)) NB_INT=NB_INT+size(id%PIVNUL_LIST) IF (associated(id%SUP_PROC)) NB_INT=NB_INT+size(id%SUP_PROC) IF (associated(id%IPTR_WORKING)) & NB_INT=NB_INT+size(id%IPTR_WORKING) IF (associated(id%WORKING)) NB_INT=NB_INT+size(id%WORKING) IF (associated(id%LRGROUPS)) & NB_INT=NB_INT+size(id%LRGROUPS) IF (associated(id%IPOOL_B_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_B_L0_OMP) IF (associated(id%IPOOL_A_L0_OMP)) & NB_INT=NB_INT+size(id%IPOOL_A_L0_OMP) IF (associated(id%PHYS_L0_OMP)) & NB_INT=NB_INT+size(id%PHYS_L0_OMP) IF (associated(id%VIRT_L0_OMP)) & NB_INT=NB_INT+size(id%VIRT_L0_OMP) IF (associated(id%PERM_L0_OMP)) & NB_INT=NB_INT+size(id%PERM_L0_OMP) IF (associated(id%PTR_LEAFS_L0_OMP)) & NB_INT=NB_INT+size(id%PTR_LEAFS_L0_OMP) IF (associated(id%L0_OMP_MAPPING)) & NB_INT=NB_INT+size(id%L0_OMP_MAPPING) IF (associated(id%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%SINGULAR_VALUES) IF (associated(id%root%RG2L_COL)) & NB_INT=NB_INT+size(id%root%RG2L_COL) IF (associated(id%root%RG2L_ROW)) & NB_INT=NB_INT+size(id%root%RG2L_ROW) IF (associated(id%root%IPIV)) & NB_INT=NB_INT+size(id%root%IPIV) IF (associated(id%root%RHS_CNTR_MASTER_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_CNTR_MASTER_ROOT) IF (associated(id%root%SCHUR_POINTER)) & NB_CMPLX=NB_CMPLX+size(id%root%SCHUR_POINTER) IF (associated(id%root%QR_TAU)) & NB_CMPLX=NB_CMPLX+size(id%root%QR_TAU) IF (associated(id%root%RHS_ROOT)) & NB_CMPLX=NB_CMPLX+size(id%root%RHS_ROOT) IF (associated(id%root%SVD_U)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_U) IF (associated(id%root%SVD_VT)) & NB_CMPLX=NB_CMPLX+size(id%root%SVD_VT) IF (associated(id%root%SINGULAR_VALUES)) & NB_REAL=NB_REAL+size(id%root%SINGULAR_VALUES) IF (associated(id%DBLARR)) NB_CMPLX=NB_CMPLX+id%KEEP8(26) IF (associated(id%RHSCOMP)) NB_CMPLX = NB_CMPLX + id%KEEP8(25) IF (associated(id%S)) NB_CMPLX=NB_CMPLX+id%KEEP8(23) IF (associated(id%COLSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%COLSCA) IF (associated(id%ROWSCA).AND.(id%KEEP(52).NE.-1)) & NB_REAL=NB_REAL+size(id%ROWSCA) NB_REAL=NB_REAL+size(id%CNTL) NB_REAL=NB_REAL+size(id%RINFO) NB_REAL=NB_REAL+size(id%RINFOG) NB_REAL=NB_REAL+size(id%DKEEP) NB_CHAR=NB_CHAR+len(id%VERSION_NUMBER) NB_CHAR=NB_CHAR+len(id%OOC_TMPDIR) NB_CHAR=NB_CHAR+len(id%OOC_PREFIX) NB_CHAR=NB_CHAR+len(id%WRITE_PROBLEM) NB_CHAR=NB_CHAR+len(id%SAVE_DIR) NB_CHAR=NB_CHAR+len(id%SAVE_PREFIX) NB_CMPLX = NB_CMPLX + NB_REAL/2_8 NB_CMPLX = NB_CMPLX + id%KEEP8(71) + id%KEEP8(64) RETURN END SUBROUTINE ZMUMPS_SIZE_IN_STRUCT SUBROUTINE ZMUMPS_COPYI8SIZE(N8,SRC,DEST) IMPLICIT NONE INTEGER(8) :: N8 COMPLEX(kind=8), intent(in) :: SRC(N8) COMPLEX(kind=8), intent(out) :: DEST(N8) INTEGER(8) :: SHIFT8, HUG8 INTEGER :: I, I4SIZE IF(int(huge(I4SIZE),8) .EQ. int(huge(HUG8),8)) THEN CALL zcopy(N8, SRC(1), 1, DEST(1), 1) ELSE HUG8=int(huge(I4SIZE),8) DO I = 1, int(( N8 + HUG8 - 1_8 ) / HUG8) SHIFT8 = 1_8 + int(I-1,8) * HUG8 I4SIZE = int(min(HUG8, N8-SHIFT8+1_8)) CALL zcopy(I4SIZE, SRC(SHIFT8), 1, DEST(SHIFT8), 1) ENDDO END IF RETURN END SUBROUTINE ZMUMPS_COPYI8SIZE SUBROUTINE ZMUMPS_SET_TMP_PTR( THE_ADDRESS, THE_SIZE8 ) USE ZMUMPS_STATIC_PTR_M INTEGER(8), INTENT(IN) :: THE_SIZE8 COMPLEX(kind=8), INTENT(IN) :: THE_ADDRESS(THE_SIZE8) CALL ZMUMPS_SET_STATIC_PTR(THE_ADDRESS(1:THE_SIZE8)) RETURN END SUBROUTINE ZMUMPS_SET_TMP_PTR SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL_I & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) USE ZMUMPS_OOC, ONLY : IO_BLOCK, & ZMUMPS_OOC_IO_LU_PANEL IMPLICIT NONE TYPE(IO_BLOCK), INTENT(INOUT):: MonBloc INTEGER(8) :: LAFAC INTEGER, INTENT(IN) :: STRAT, LIWFAC, MYID, TYPEFile INTEGER, INTENT(INOUT) :: IW(0:LIWFAC-1) COMPLEX(kind=8), INTENT(IN) :: AFAC(LAFAC) INTEGER, INTENT(INOUT) :: LNextPiv2beWritten, UNextPiv2beWritten INTEGER(8), INTENT(INOUT) :: FILESIZE INTEGER, INTENT(OUT) :: IERR LOGICAL, INTENT(IN) :: LAST_CALL CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEFile, & AFAC, LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW, LIWFAC, & MYID, FILESIZE, IERR , LAST_CALL) RETURN END SUBROUTINE ZMUMPS_OOC_IO_LU_PANEL_I SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE3_I ( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) USE ZMUMPS_BUF, ONLY : ZMUMPS_BUF_SEND_CONTRIB_TYPE3 IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) COMPLEX(kind=8) VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT CALL ZMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) RETURN END SUBROUTINE ZMUMPS_BUF_SEND_CONTRIB_TYPE3_I SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_I( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, sizeBEGS_BLR_L, & BEGS_BLR_U, sizeBEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_BLR_UPDATE_TRAILING INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: POSELT INTEGER, intent(in) :: NFRONT, NB_BLR_L, NB_BLR_U, & CURRENT_BLR, & NELIM, NIV, SYM, TOL_OPT INTEGER, intent(inout) :: IFLAG, IERROR LOGICAL, intent(in) :: LBANDSLAVE INTEGER, intent(in) :: ISHIFT COMPLEX(kind=8), intent(inout) :: A(LA) TYPE(LRB_TYPE),intent(in) :: BLR_U(NB_BLR_U-CURRENT_BLR) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER :: sizeBEGS_BLR_L, sizeBEGS_BLR_U INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) INTEGER :: BEGS_BLR_U(sizeBEGS_BLR_U) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL ZMUMPS_BLR_UPDATE_TRAILING( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR_L, BEGS_BLR_U, CURRENT_BLR, BLR_L, NB_BLR_L, & BLR_U, & NB_BLR_U, NELIM, LBANDSLAVE, ISHIFT, NIV, SYM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT) RETURN END SUBROUTINE ZMUMPS_BLR_UPDATE_TRAILING_I SUBROUTINE ZMUMPS_COMPRESS_CB_I(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, sizeBEGS_BLR, BEGS_BLR_U, sizeBEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY, & NELIM, & NBROWSinF & ) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_COMPRESS_CB IMPLICIT NONE INTEGER(8), intent(in) :: LA_PTR COMPLEX(kind=8), intent(inout) :: A_PTR(LA_PTR) INTEGER(8), intent(in) :: POSELT INTEGER :: sizeBEGS_BLR, sizeBEGS_BLR_U INTEGER, intent(in) :: LDA, NB_ROWS, NB_COLS, NB_INASM INTEGER, INTENT(IN) :: NIV, IWHANDLER, MAXI_CLUSTER, & KPERCENT, TOL_OPT, LWORK, OMP_NUM INTEGER, INTENT(IN) :: K489, NROWS, NCOLS, INODE, SYM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: CB_LRB(NB_ROWS,NB_COLS) INTEGER :: BEGS_BLR(sizeBEGS_BLR), BEGS_BLR_U(sizeBEGS_BLR_U) DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER, MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: WORK(LWORK*OMP_NUM), TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER(8) :: KEEP8(150) DOUBLE PRECISION,intent(in) :: TOLEPS INTEGER, INTENT(in) :: NFS4FATHER, NPIV, NVSCHUR_K253, KEEP(500) DOUBLE PRECISION :: M_ARRAY(max(NFS4FATHER,1)) INTEGER, intent(in) :: NELIM INTEGER, intent(in) :: NBROWSinF CALL ZMUMPS_COMPRESS_CB(A_PTR, LA_PTR, POSELT, LDA, & BEGS_BLR, BEGS_BLR_U, & NB_ROWS, NB_COLS, NB_INASM, & NROWS, NCOLS, INODE, & IWHANDLER, SYM, NIV, IFLAG, IERROR, & TOLEPS, TOL_OPT, KPERCENT, K489, CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & NFS4FATHER, NPIV, NVSCHUR_K253, KEEP, & M_ARRAY=M_ARRAY, & NELIM=NELIM, & NBROWSinF=NBROWSinF & ) RETURN END SUBROUTINE ZMUMPS_COMPRESS_CB_I SUBROUTINE ZMUMPS_COMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, sizeBEGS_BLR, & NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8, OMP_NUM & ) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_COMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA, POSELT INTEGER, intent(in) :: NFRONT, NB_BLR, CURRENT_BLR, NIV INTEGER, intent(in) :: OMP_NUM INTEGER, intent(inout) :: IFLAG, IERROR TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER :: MAXI_CLUSTER DOUBLE PRECISION :: RWORK(2*MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: WORK(MAXI_CLUSTER*MAXI_CLUSTER*OMP_NUM) COMPLEX(kind=8) :: TAU(MAXI_CLUSTER*OMP_NUM) INTEGER :: JPVT(MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR INTEGER :: BEGS_BLR(sizeBEGS_BLR) INTEGER(8) :: KEEP8(150) INTEGER, intent(in) :: NPIV, ISHIFT, KPERCENT, K473, & TOL_OPT LOGICAL, intent(in) :: LBANDSLAVE INTEGER :: LWORK, NELIM DOUBLE PRECISION,intent(in) :: TOLEPS CHARACTER(len=1) :: DIR CALL ZMUMPS_COMPRESS_PANEL( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, NB_BLR, TOLEPS, TOL_OPT, K473, BLR_PANEL, & CURRENT_BLR, & DIR, WORK, TAU, JPVT, & LWORK, RWORK, BLOCK, & MAXI_CLUSTER, NELIM, & LBANDSLAVE, NPIV, ISHIFT, NIV, KPERCENT, & KEEP8 & ) RETURN END SUBROUTINE ZMUMPS_COMPRESS_PANEL_I_NOOPT SUBROUTINE ZMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_DECOMPRESS_PANEL IMPLICIT NONE INTEGER(8), intent(in) :: LA COMPLEX(kind=8), intent(inout) :: A(LA) INTEGER(8), intent(in) :: POSELT LOGICAL, intent(in) :: COPY_DENSE_BLOCKS INTEGER, intent(in) :: NB_BLR, CURRENT_BLR INTEGER, intent(in) :: BEGS_BLR_DIAG, & BEGS_BLR_FIRST_OFFDIAG TYPE(LRB_TYPE), intent(inout) :: BLR_PANEL(NB_BLR-CURRENT_BLR) CHARACTER(len=1) :: DIR INTEGER, intent(in) :: DECOMP_TIMER INTEGER, intent(in) :: LDA11, LDA21 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, LDA11, & LDA21, COPY_DENSE_BLOCKS, & BEGS_BLR_DIAG, BEGS_BLR_FIRST_OFFDIAG, & NB_BLR, BLR_PANEL, CURRENT_BLR, DIR, & DECOMP_TIMER) RETURN END SUBROUTINE ZMUMPS_DECOMPRESS_PANEL_I_NOOPT SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L_I( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, sizeBEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_BLR_UPD_NELIM_VAR_L IMPLICIT NONE INTEGER(8), intent(in) :: LA_U, LA_L INTEGER(8), intent(in) :: UPOS, LPOS INTEGER, intent(in) :: LDU, LDL, NB_BLR_L, CURRENT_BLR, & NELIM, FIRST_BLOCK CHARACTER(len=1),INTENT(IN) :: UTRANS INTEGER, intent(inout) :: IFLAG, IERROR COMPLEX(kind=8), TARGET, intent(inout) :: A_L(LA_L), A_U(LA_U) TYPE(LRB_TYPE),intent(in) :: BLR_L(NB_BLR_L-CURRENT_BLR) INTEGER, INTENT(in) :: sizeBEGS_BLR_L INTEGER :: BEGS_BLR_L(sizeBEGS_BLR_L) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L( & A_U, LA_U, UPOS, A_L, LA_L, LPOS, IFLAG, IERROR, LDU, LDL, & BEGS_BLR_L, CURRENT_BLR, BLR_L, NB_BLR_L, & FIRST_BLOCK, NELIM, UTRANS) RETURN END SUBROUTINE ZMUMPS_BLR_UPD_NELIM_VAR_L_I SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, sizeBEGS_BLR_LM, & NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, sizeBEGS_BLR_LS, & NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, OMP_NUM, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) USE ZMUMPS_LR_TYPE, ONLY : LRB_TYPE USE ZMUMPS_FAC_LR, ONLY : ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT IMPLICIT NONE INTEGER(8), intent(in) :: LA, LA_BLOCFACTO COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: A_BLOCFACTO(LA_BLOCFACTO) INTEGER(8), intent(in) :: POSELT INTEGER, intent(inout) :: IFLAG, IERROR INTEGER, intent(in) :: NCOL, NROW, IW2(*), TOL_OPT, & MAXI_CLUSTER, OMP_NUM, LD_BLOCFACTO INTEGER, intent(in) :: NB_BLR_LM, NB_BLR_LS, & ISHIFT_LM, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS COMPLEX(kind=8), INTENT(INOUT) :: & BLOCK(MAXI_CLUSTER,MAXI_CLUSTER*OMP_NUM) INTEGER :: sizeBEGS_BLR_LM, sizeBEGS_BLR_LS INTEGER :: BEGS_BLR_LM(sizeBEGS_BLR_LM) INTEGER :: BEGS_BLR_LS(sizeBEGS_BLR_LS) TYPE(LRB_TYPE),intent(in) :: BLR_LM(NB_BLR_LM-CURRENT_BLR_LM), & BLR_LS(NB_BLR_LS-CURRENT_BLR_LS) INTEGER,intent(in) :: MIDBLK_COMPRESS, KPERCENT DOUBLE PRECISION,intent(in) :: TOLEPS CALL ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT(A, LA, POSELT, & IFLAG, IERROR, NCOL, NROW, & A_BLOCFACTO, LA_BLOCFACTO, LD_BLOCFACTO, & BEGS_BLR_LM, NB_BLR_LM, BLR_LM, ISHIFT_LM, & BEGS_BLR_LS, NB_BLR_LS, BLR_LS, ISHIFT_LS, & CURRENT_BLR_LM, CURRENT_BLR_LS, & IW2, BLOCK, & MAXI_CLUSTER, & MIDBLK_COMPRESS, TOLEPS, TOL_OPT, KPERCENT & ) RETURN END SUBROUTINE ZMUMPS_BLR_SLV_UPD_TRAIL_LDLT_I MUMPS_5.4.1/src/cana_LDLT_preprocess.F0000664000175000017500000007141314102210523017606 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_SET_CONSTRAINTS( & N,PIV,FRERE,FILS,NFSIZ,IKEEP, & NCST,KEEP,KEEP8, ROWSCA & ) USE CMUMPS_STRUC_DEF IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER, INTENT(OUT) :: NCST INTEGER :: PIV(N),FRERE(N),FILS(N),NFSIZ(N),IKEEP(N) INTEGER :: KEEP(500) INTEGER(8) :: KEEP8(150) REAL :: ROWSCA(N) INTEGER I,P11,P1,P2,K1,K2,NLOCKED LOGICAL V1,V2 NCST = 0 NLOCKED = 0 P11 = KEEP(93) DO I=KEEP(93)-1,1,-2 P1 = PIV(I) P2 = PIV(I+1) K1 = IKEEP(P1) IF (K1 .NE. 0) THEN V1 = (K1+2*exponent(ROWSCA(P1)) .GE. -3) ELSE V1 = .FALSE. ENDIF K2 = IKEEP(P2) IF (K2 .NE. 0) THEN V2 = (K2+exponent(ROWSCA(P2)**2) .GE. -3) ELSE V2 = .FALSE. ENDIF IF(V1 .AND. V2) THEN PIV(P11) = P1 P11 = P11 - 1 PIV(P11) = P2 P11 = P11 - 1 ELSE IF(V1) THEN NCST = NCST+1 FRERE(NCST) = P1 NCST = NCST+1 FRERE(NCST) = P2 ELSE IF(V2) THEN NCST = NCST+1 FRERE(NCST) = P2 NCST = NCST+1 FRERE(NCST) = P1 ELSE NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P1 NLOCKED = NLOCKED + 1 FILS(NLOCKED) = P2 ENDIF ENDDO DO I=1,NLOCKED PIV(I) = FILS(I) ENDDO KEEP(94) = KEEP(94) + KEEP(93) - NLOCKED KEEP(93) = NLOCKED DO I=1,NCST NLOCKED = NLOCKED + 1 PIV(NLOCKED) = FRERE(I) ENDDO DO I=1,KEEP(93)/2 NFSIZ(I) = 0 ENDDO DO I=(KEEP(93)/2)+1,(KEEP(93)/2)+NCST,2 NFSIZ(I) = I+1 NFSIZ(I+1) = -1 ENDDO DO I=(KEEP(93)/2)+NCST+1,(KEEP(93)/2)+KEEP(94) NFSIZ(I) = 0 ENDDO END SUBROUTINE CMUMPS_SET_CONSTRAINTS SUBROUTINE CMUMPS_EXPAND_PERMUTATION(N,NCMP,N11,N22,PIV, & INVPERM,PERM) IMPLICIT NONE INTEGER N11,N22,N,NCMP INTEGER, intent(in) :: PIV(N),PERM(N) INTEGER, intent (out):: INVPERM(N) INTEGER CMP_POS,EXP_POS,I,J,N2,K N2 = N22/2 EXP_POS = 1 DO CMP_POS=1,NCMP J = PERM(CMP_POS) IF(J .LE. N2) THEN K = 2*J-1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 K = K+1 I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ELSE K = N2 + J I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDIF ENDDO DO K=N22+N11+1,N I = PIV(K) INVPERM(I) = EXP_POS EXP_POS = EXP_POS+1 ENDDO RETURN END SUBROUTINE CMUMPS_EXPAND_PERMUTATION SUBROUTINE CMUMPS_LDLT_COMPRESS( & N,NZ, IRN, ICN, PIV, & NCMP, IW, LW, IPE, LEN, IQ, & FLAG, ICMP, IWFR, & IERROR, KEEP,KEEP8, ICNTL,INPLACE64_GRAPH_COPY) IMPLICIT NONE INTEGER, intent(in) :: N INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: IRN(NZ), ICN(NZ), PIV(N) INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(out) :: NCMP, IERROR INTEGER(8), intent(out) :: IWFR, IPE(N+1) INTEGER, intent(out) :: IW(LW) INTEGER, intent(out) :: LEN(N) INTEGER(8), intent(out) :: IQ(N) INTEGER, intent(out) :: FLAG(N), ICMP(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, N11, N22 INTEGER :: I, J, N1, K INTEGER(8) :: NDUP, L, K8, K1, K2, LAST INTRINSIC nint MP = ICNTL(2) IERROR = 0 N22 = KEEP(93) N11 = KEEP(94) NCMP = N22/2 + N11 DO I=1,NCMP IPE(I) = 0 ENDDO K = 1 DO I=1,N22/2 J = PIV(K) ICMP(J) = I K = K + 1 J = PIV(K) ICMP(J) = I K = K + 1 ENDDO K = N22/2 + 1 DO I=N22+1,N22+N11 J = PIV(I) ICMP(J) = K K = K + 1 ENDDO DO I=N11+N22+1,N J = PIV(I) ICMP(J) = 0 ENDDO DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ICMP(I) J = ICMP(J) IF ((I.NE.0).AND.(J.NE.0).AND.(I.NE.J)) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 ENDIF ENDIF ENDDO IQ(1) = 1_8 N1 = NCMP - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(NCMP)+IQ(NCMP)-1_8,IQ(NCMP)) DO I = 1,NCMP FLAG(I) = 0 IPE(I) = IQ(I) ENDDO IW(1:LAST) = 0 IWFR = LAST + 1_8 DO K8=1,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.N).OR.(J.GT.N).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ICMP(I) J = ICMP(J) IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1_8 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1_8 ENDIF ENDIF ENDIF ENDDO NDUP = 0_8 DO I=1,NCMP K1 = IPE(I) K2 = IQ(I) -1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) GO TO 250 L = IQ(J) IQ(J) = L + 1_8 IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(L) = 0 IW(K8) = 0 ELSE IW(L) = I IW(K8) = J FLAG(J) = I ENDIF ENDDO 250 LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,NCMP K1 = IPE(I) IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF ENDDO LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(NCMP+1) = IPE(NCMP) + int(LEN(NCMP),8) IWFR = IPE(NCMP+1) INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1_8)) RETURN END SUBROUTINE CMUMPS_LDLT_COMPRESS SUBROUTINE CMUMPS_SYM_MWM( & N, NE, IP, IRN, SCALING,LSC,CPERM, DIAG, & ICNTL, WEIGHT,MARKED,FLAG, & PIV_OUT, INFO) IMPLICIT NONE INTEGER, INTENT(IN) :: N INTEGER(8), INTENT(IN) :: NE INTEGER :: ICNTL(10), INFO(10),LSC INTEGER :: CPERM(N),PIV_OUT(N), IRN(NE), DIAG(N) INTEGER(8), INTENT(IN) :: IP(N+1) REAL :: SCALING(LSC),WEIGHT(N+2) INTEGER :: MARKED(N),FLAG(N) INTEGER :: NUM1,NUM2,NUMTOT,PATH_LENGTH,NLAST INTEGER :: I,BEST_BEG, CUR_EL,CUR_EL_PATH,CUR_EL_PATH_NEXT INTEGER :: L1,L2,TUP,T22 INTEGER(8) :: PTR_SET1,PTR_SET2 REAL :: BEST_SCORE,CUR_VAL,TMP,VAL REAL INITSCORE, CMUMPS_UPDATESCORE, & CMUMPS_UPDATE_INVERSE, CMUMPS_METRIC2x2 LOGICAL VRAI,FAUX,MAX_CARD_DIAG,USE_SCALING INTEGER SUM REAL ZERO,ONE PARAMETER (SUM = 1, VRAI = .TRUE., FAUX = .FALSE.) PARAMETER(ZERO = 0.0E0, ONE = 1.0E0) MAX_CARD_DIAG = .TRUE. NUM1 = 0 NUM2 = 0 NUMTOT = 0 NLAST = N INFO = 0 MARKED = 1 FLAG = 0 VAL = ONE IF(LSC .GT. 1) THEN USE_SCALING = .TRUE. ELSE USE_SCALING = .FALSE. ENDIF TUP = ICNTL(2) IF(TUP .EQ. SUM) THEN INITSCORE = ZERO ELSE INITSCORE = ONE ENDIF IF(ICNTL(2) .GT. 2 .OR. ICNTL(2) .LE. 0) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(2) = ',ICNTL(2) INFO(1) = -1 RETURN ENDIF T22 = ICNTL(1) IF(ICNTL(1) .LT. 0 .OR. ICNTL(1) .GT. 2) THEN WRITE(*,*) & 'ERROR: WRONG VALUE FOR ICNTL(1) = ',ICNTL(1) INFO(1) = -1 RETURN ENDIF DO CUR_EL=1,N IF(MARKED(CUR_EL) .LE. 0) THEN CYCLE ENDIF IF(CPERM(CUR_EL) .LT. 0) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF PATH_LENGTH = 2 CUR_EL_PATH = CPERM(CUR_EL) IF(CUR_EL_PATH .EQ. CUR_EL) THEN MARKED(CUR_EL) = -1 CYCLE ENDIF MARKED(CUR_EL) = 0 WEIGHT(1) = INITSCORE WEIGHT(2) = INITSCORE L1 = int(IP(CUR_EL+1)-IP(CUR_EL)) L2 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) PTR_SET1 = IP(CUR_EL) PTR_SET2 = IP(CUR_EL_PATH) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH) - SCALING(CUR_EL+N) ENDIF CUR_VAL = CMUMPS_METRIC2x2( & CUR_EL,CUR_EL_PATH, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,FAUX,T22) WEIGHT(PATH_LENGTH+1) = & CMUMPS_UPDATESCORE(WEIGHT(1),CUR_VAL,TUP) DO IF(CUR_EL_PATH .EQ. CUR_EL) EXIT PATH_LENGTH = PATH_LENGTH+1 MARKED(CUR_EL_PATH) = 0 CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) L1 = int(IP(CUR_EL_PATH+1)-IP(CUR_EL_PATH)) L2 = int(IP(CUR_EL_PATH_NEXT+1)-IP(CUR_EL_PATH_NEXT)) PTR_SET1 = IP(CUR_EL_PATH) PTR_SET2 = IP(CUR_EL_PATH_NEXT) IF(USE_SCALING) THEN VAL = -SCALING(CUR_EL_PATH_NEXT) & - SCALING(CUR_EL_PATH+N) ENDIF CUR_VAL = CMUMPS_METRIC2x2( & CUR_EL_PATH,CUR_EL_PATH_NEXT, & IRN(PTR_SET1),IRN(PTR_SET2), & L1,L2, & VAL,DIAG,N,FLAG,VRAI,T22) WEIGHT(PATH_LENGTH+1) = & CMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH-1),CUR_VAL,TUP) CUR_EL_PATH = CUR_EL_PATH_NEXT ENDDO IF(mod(PATH_LENGTH,2) .EQ. 1) THEN IF(WEIGHT(PATH_LENGTH+1) .GE. WEIGHT(PATH_LENGTH)) THEN CUR_EL_PATH = CPERM(CUR_EL) ELSE CUR_EL_PATH = CUR_EL ENDIF DO I=1,(PATH_LENGTH-1)/2 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 1 ELSE IF(MAX_CARD_DIAG) THEN CUR_EL_PATH = CPERM(CUR_EL) IF(DIAG(CUR_EL) .NE. 0) THEN BEST_BEG = CUR_EL_PATH GOTO 1000 ENDIF DO I=1,(PATH_LENGTH/2) CUR_EL_PATH_NEXT = CPERM(CUR_EL_PATH) IF(DIAG(CUR_EL_PATH) .NE. 0) THEN BEST_BEG = CUR_EL_PATH_NEXT GOTO 1000 ENDIF ENDDO ENDIF BEST_BEG = CUR_EL BEST_SCORE = WEIGHT(PATH_LENGTH-1) CUR_EL_PATH = CPERM(CUR_EL) DO I=1,(PATH_LENGTH/2)-1 TMP = CMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH), & WEIGHT(2*I-1),TUP) TMP = CMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) TMP = CMUMPS_UPDATESCORE(WEIGHT(PATH_LENGTH+1), & WEIGHT(2*I),TUP) TMP = CMUMPS_UPDATE_INVERSE(TMP,WEIGHT(2*I+1),TUP) IF(TMP .GT. BEST_SCORE) THEN BEST_SCORE = TMP BEST_BEG = CUR_EL_PATH ENDIF CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO 1000 CUR_EL_PATH = BEST_BEG DO I=1,(PATH_LENGTH/2)-1 NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) NUM2 = NUM2+1 PIV_OUT(NUM2) = CUR_EL_PATH CUR_EL_PATH = CPERM(CUR_EL_PATH) ENDDO NUMTOT = NUMTOT + PATH_LENGTH - 2 MARKED(CUR_EL_PATH) = -1 ENDIF ENDDO DO I=1,N IF(MARKED(I) .LT. 0) THEN IF(DIAG(I) .EQ. 0) THEN PIV_OUT(NLAST) = I NLAST = NLAST - 1 ELSE NUM1 = NUM1 + 1 PIV_OUT(NUM2+NUM1) = I NUMTOT = NUMTOT + 1 ENDIF ENDIF ENDDO INFO(2) = NUMTOT INFO(3) = NUM1 INFO(4) = NUM2 RETURN END SUBROUTINE CMUMPS_SYM_MWM FUNCTION CMUMPS_UPDATESCORE(A,B,T) IMPLICIT NONE REAL CMUMPS_UPDATESCORE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN CMUMPS_UPDATESCORE = A+B ELSE CMUMPS_UPDATESCORE = A*B ENDIF END FUNCTION CMUMPS_UPDATESCORE FUNCTION CMUMPS_UPDATE_INVERSE(A,B,T) IMPLICIT NONE REAL CMUMPS_UPDATE_INVERSE REAL A,B INTEGER T INTEGER SUM PARAMETER(SUM = 1) IF(T .EQ. SUM) THEN CMUMPS_UPDATE_INVERSE = A-B ELSE CMUMPS_UPDATE_INVERSE = A/B ENDIF END FUNCTION CMUMPS_UPDATE_INVERSE FUNCTION CMUMPS_METRIC2x2(CUR_EL,CUR_EL_PATH, & SET1,SET2,L1,L2,VAL,DIAG,N,FLAG,FLAGON,T) IMPLICIT NONE REAL CMUMPS_METRIC2x2 INTEGER CUR_EL,CUR_EL_PATH,L1,L2,N INTEGER SET1(L1),SET2(L2),DIAG(N),FLAG(N) REAL VAL LOGICAL FLAGON INTEGER T INTEGER I,INTER,MERGE INTEGER STRUCT,MA47 PARAMETER(STRUCT=0,MA47=1) IF(T .EQ. STRUCT) THEN IF(.NOT. FLAGON) THEN DO I=1,L1 FLAG(SET1(I)) = CUR_EL ENDDO ENDIF INTER = 0 DO I=1,L2 IF(FLAG(SET2(I)) .EQ. CUR_EL) THEN INTER = INTER + 1 FLAG(SET2(I)) = CUR_EL_PATH ENDIF ENDDO MERGE = L1 + L2 - INTER CMUMPS_METRIC2x2 = real(INTER) / real(MERGE) ELSE IF (T .EQ. MA47) THEN MERGE = 3 IF(DIAG(CUR_EL) .NE. 0) MERGE = 2 IF(DIAG(CUR_EL_PATH) .NE. 0) MERGE = MERGE - 2 IF(MERGE .EQ. 0) THEN CMUMPS_METRIC2x2 = real(L1+L2-2) CMUMPS_METRIC2x2 = -(CMUMPS_METRIC2x2**2)/2.0E0 ELSE IF(MERGE .EQ. 1) THEN CMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L1-2) ELSE IF(MERGE .EQ. 2) THEN CMUMPS_METRIC2x2 = - real(L1+L2-4) * real(L2-2) ELSE CMUMPS_METRIC2x2 = - real(L1-2) * real(L2-2) ENDIF ELSE CMUMPS_METRIC2x2 = VAL ENDIF RETURN END FUNCTION SUBROUTINE CMUMPS_EXPAND_PERM_SCHUR(NA, NCMP, & INVPERM,PERM, & LISTVAR_SCHUR, SIZE_SCHUR, AOTOA) IMPLICIT NONE INTEGER, INTENT(IN):: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, INTENT(IN):: NA, NCMP INTEGER, INTENT(IN):: AOTOA(NCMP), PERM(NCMP) INTEGER, INTENT(OUT):: INVPERM(NA) INTEGER CMP_POS, IO, I, K, IPOS DO CMP_POS=1, NCMP IO = PERM(CMP_POS) INVPERM(AOTOA(IO)) = CMP_POS ENDDO IPOS = NCMP DO K =1, SIZE_SCHUR I = LISTVAR_SCHUR(K) IPOS = IPOS+1 INVPERM(I) = IPOS ENDDO RETURN END SUBROUTINE CMUMPS_EXPAND_PERM_SCHUR SUBROUTINE CMUMPS_GNEW_SCHUR & (NA, N, NZ, IRN, ICN, IW, LW, IPE, LEN, & IQ, FLAG, IWFR, & NRORM, NIORM, IFLAG,IERROR, ICNTL, & symmetry, SYM, NBQD, AvgDens, & KEEP264, KEEP265, & LISTVAR_SCHUR, SIZE_SCHUR, ATOAO, AOTOA, & INPLACE64_GRAPH_COPY & ) IMPLICIT NONE INTEGER, intent(in) :: NA INTEGER, intent(in) :: N, SYM INTEGER(8), intent(in) :: NZ, LW INTEGER, intent(in) :: ICNTL(60) INTEGER, intent(in) :: IRN(NZ), ICN(NZ) INTEGER, INTENT(IN) :: SIZE_SCHUR, LISTVAR_SCHUR(SIZE_SCHUR) INTEGER, intent(out) :: IERROR, symmetry INTEGER, intent(out) :: NBQD, AvgDens INTEGER, intent(out) :: LEN(N), IW(LW) INTEGER(8), intent(out):: IWFR INTEGER(8), intent(out):: NRORM, NIORM INTEGER(8), intent(out):: IPE(N+1) INTEGER, INTENT(OUT) :: AOTOA(N) INTEGER, INTENT(OUT) :: ATOAO(NA) INTEGER, intent(inout) :: IFLAG, KEEP264 INTEGER, intent(in) :: KEEP265 INTEGER(8), intent(out):: IQ(N) INTEGER, intent(out) :: FLAG(N) LOGICAL, intent(inout) :: INPLACE64_GRAPH_COPY INTEGER :: MP, MPG, I, J, N1 INTEGER :: NBERR, THRESH, IAO INTEGER(8) :: K8, K1, K2, LAST, NDUP INTEGER(8) :: NZOFFA, NDIAGA, L, N8 REAL :: RSYM INTRINSIC nint MP = ICNTL(2) MPG= ICNTL(3) ATOAO(1:NA) = 0 DO I = 1, SIZE_SCHUR ATOAO(LISTVAR_SCHUR(I)) = -1 ENDDO IAO = 0 DO I= 1, NA IF (ATOAO(I).LT.0) CYCLE IAO = IAO +1 ATOAO(I) = IAO AOTOA(IAO) = I ENDDO NZOFFA = 0_8 NDIAGA = 0 IERROR = 0 N8 = int(N,8) DO I=1,N+1 IPE(I) = 0_8 ENDDO IF (KEEP264.EQ.0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN IERROR = IERROR + 1 ELSE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDIF ENDDO ENDIF IF (IERROR.GE.1) THEN KEEP264 = 0 ELSE KEEP264 = 1 ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.EQ.J) THEN NDIAGA = NDIAGA + 1_8 ELSE IPE(I) = IPE(I) + 1_8 NZOFFA = NZOFFA + 1_8 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IPE(I) = IPE(I) + 1_8 IPE(J) = IPE(J) + 1_8 NZOFFA = NZOFFA + 1_8 ELSE NDIAGA = NDIAGA + 1_8 ENDIF ENDDO ENDIF ENDIF NIORM = NZOFFA + 3_8*N8 IF (IERROR.GE.1) THEN NBERR = 0 IF (mod(IFLAG,2) .EQ. 0) IFLAG = IFLAG+1 IF ((MP.GT.0).AND.(ICNTL(4).GE.2)) THEN WRITE (MP,99999) DO 70 K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) THEN NBERR = NBERR + 1 IF (NBERR.LE.10) THEN IF (mod(K8,10_8).GT.3_8 .OR. mod(K8,10_8).EQ.0_8 .OR. & (10_8.LE.K8 .AND. K8.LE.20_8)) THEN WRITE (MP,'(I16,A,I10,A,I10,A)') & K8,'th entry (in row',I,' and column',J,') ignored' ELSE IF (mod(K8,10_8).EQ.1_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'st entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.2_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'nd entry (in row',I,' and column',J,') ignored' IF (mod(K8,10_8).EQ.3_8) & WRITE(MP,'(I16,A,I10,A,I10,A)') & K8,'rd entry (in row',I,' and column',J,') ignored' ENDIF ELSE GO TO 100 ENDIF ENDIF 70 CONTINUE ENDIF ENDIF 100 NRORM = NIORM - 2_8*N8 IQ(1) = 1_8 N1 = N - 1 IF (N1.GT.0) THEN DO I=1,N1 IQ(I+1) = IPE(I) + IQ(I) ENDDO ENDIF LAST = max(IPE(N)+IQ(N)-1,IQ(N)) FLAG(1:N) = 0 IPE(1:N) = IQ(1:N) IW(1:LAST) = 0 IWFR = LAST + 1_8 IF (KEEP264 .EQ. 0) THEN IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) IF ((I.GT.NA).OR.(J.GT.NA).OR.(I.LT.1) & .OR.(J.LT.1)) CYCLE I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IF ((I.GE.1).AND.(J.LE.N)) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ENDIF ELSE IF ((J.GE.1).AND.(I.LE.N)) THEN IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDIF ENDDO ENDIF ELSE IF ((SYM.EQ.0).AND.(KEEP265.EQ.-1)) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE IF (KEEP265.EQ.1) THEN DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IW(IQ(J)) = I IQ(J) = IQ(J) + 1 IW(IQ(I)) = J IQ(I) = IQ(I) + 1 ENDIF ENDDO ELSE DO K8=1_8,NZ I = IRN(K8) J = ICN(K8) I = ATOAO(I) J = ATOAO(J) IF ((I.LT.0).OR.(J.LT.0)) CYCLE IF (I.NE.J) THEN IF (I.LT.J) THEN IW(IQ(I)) = -J IQ(I) = IQ(I) + 1 ELSE IW(IQ(J)) = -I IQ(J) = IQ(J) + 1 ENDIF ENDIF ENDDO ENDIF ENDIF IF (KEEP265.EQ.0) THEN NDUP = 0_8 DO I=1,N K1 = IPE(I) K2 = IQ(I) - 1_8 IF (K1.GT.K2) THEN LEN(I) = 0 ELSE DO K8=K1,K2 J = -IW(K8) IF (J.LE.0) EXIT IF (FLAG(J).EQ.I) THEN NDUP = NDUP + 1_8 IW(K8) = 0 ELSE L = IQ(J) IQ(J) = L + 1 IW(L) = I IW(K8) = J FLAG(J) = I ENDIF END DO LEN(I) = int(IQ(I) - IPE(I)) ENDIF ENDDO IF (NDUP.NE.0_8) THEN IWFR = 1_8 DO I=1,N IF (LEN(I).EQ.0) THEN IPE(I) = IWFR CYCLE ENDIF K1 = IPE(I) K2 = K1 + LEN(I) - 1 L = IWFR IPE(I) = IWFR DO 270 K8=K1,K2 IF (IW(K8).NE.0) THEN IW(IWFR) = IW(K8) IWFR = IWFR + 1_8 ENDIF 270 CONTINUE LEN(I) = int(IWFR - L) ENDDO ENDIF IPE(N+1) = IPE(N) + int(LEN(N),8) IWFR = IPE(N+1) ELSE IPE(1) = 1_8 DO I = 1, N LEN(I) = int(IQ(I) - IPE(I)) ENDDO DO I = 1, N IPE(I+1) = IPE(I) + int(LEN(I),8) ENDDO IWFR = IPE(N+1) ENDIF symmetry = 100 IF (SYM.EQ.0) THEN RSYM = real(NDIAGA+2_8*NZOFFA - (IWFR-1_8))/ & real(NZOFFA+NDIAGA) IF ((KEEP265.EQ.0) .AND. (NZOFFA - (IWFR-1_8)).EQ.0_8) THEN ENDIF symmetry = nint (100.0E0*RSYM) IF ((MPG .GT. 0).AND.(ICNTL(4).GE.2) ) & write(MPG,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry IF (MP.GT.0 .AND. MPG.NE.MP.AND. (ICNTL(4).GE.2) ) & write(MP,'(A,A,I5)') & ' Case of Schur:', & ' structural symmetry (in percent) of interior block=', & symmetry ELSE symmetry = 100 ENDIF INPLACE64_GRAPH_COPY = (LW.GE.2*(IWFR-1)) AvgDens = nint(real(IWFR-1_8)/real(N)) THRESH = AvgDens*50 - AvgDens/10 + 1 NBQD = 0 IF (N.GT.2) THEN DO I= 1, N J = max(LEN(I),1) IF (J.GT.THRESH) NBQD = NBQD+1 ENDDO ENDIF IF (MPG .GT. 0.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens IF (MP.GT.0 .AND. MPG.NE.MP.AND.(ICNTL(4).GE.2)) & write(MPG,'(A,1I5)') & ' Average density of rows/columns =', AvgDens RETURN 99999 FORMAT (/'*** Warning message from analysis routine ***') END SUBROUTINE CMUMPS_GNEW_SCHUR SUBROUTINE CMUMPS_GET_PERM_FROM_PE(N,PE,INVPERM,NFILS,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),INVPERM(N),NFILS(N),WORK(N) INTEGER I,FATHER,STKLEN,STKPOS,PERMPOS,CURVAR NFILS = 0 DO I=1,N FATHER = -PE(I) IF(FATHER .NE. 0) NFILS(FATHER) = NFILS(FATHER) + 1 ENDDO STKLEN = 0 PERMPOS = 1 DO I=1,N IF(NFILS(I) .EQ. 0) THEN STKLEN = STKLEN + 1 WORK(STKLEN) = I INVPERM(I) = PERMPOS PERMPOS = PERMPOS + 1 ENDIF ENDDO DO STKPOS = 1,STKLEN CURVAR = WORK(STKPOS) FATHER = -PE(CURVAR) DO IF(FATHER .EQ. 0) EXIT IF(NFILS(FATHER) .EQ. 1) THEN INVPERM(FATHER) = PERMPOS FATHER = -PE(FATHER) PERMPOS = PERMPOS + 1 ELSE NFILS(FATHER) = NFILS(FATHER) - 1 EXIT ENDIF ENDDO ENDDO RETURN END SUBROUTINE CMUMPS_GET_PERM_FROM_PE SUBROUTINE CMUMPS_GET_ELIM_TREE(N,PE,NV,WORK) IMPLICIT NONE INTEGER N INTEGER PE(N),NV(N),WORK(N) INTEGER I,FATHER,LEN,NEWSON,NEWFATHER DO I=1,N IF(NV(I) .GT. 0) CYCLE LEN = 1 WORK(LEN) = I FATHER = -PE(I) DO IF(NV(FATHER) .GT. 0) THEN NEWSON = FATHER EXIT ENDIF LEN = LEN + 1 WORK(LEN) = FATHER NV(FATHER) = 1 FATHER = -PE(FATHER) ENDDO NEWFATHER = -PE(FATHER) PE(WORK(LEN)) = -NEWFATHER PE(NEWSON) = -WORK(1) ENDDO END SUBROUTINE CMUMPS_GET_ELIM_TREE MUMPS_5.4.1/src/dfac_distrib_distentry.F0000664000175000017500000010076314102210522020342 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_BUILD_MAPPING & ( N, MAPPING, NNZ, IRN, JCN, PROCNODE, STEP, & SLAVEF, PERM, FILS, & RG2L, KEEP,KEEP8, MBLOCK, NBLOCK, NPROW, NPCOL ) USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N, SLAVEF, MBLOCK, NBLOCK, NPROW, NPCOL iNTEGER(8) :: NNZ INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER IRN( NNZ ), JCN( NNZ ) INTEGER MAPPING( NNZ ), STEP( N ) INTEGER PROCNODE( KEEP(28) ), PERM( N ), FILS( N ), RG2L( N ) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE INTEGER K4, IOLD, JOLD, INEW, JNEW, ISEND, JSEND, IARR, INODE INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IPOSROOT, JPOSROOT, IROW_GRID, JCOL_GRID INODE = KEEP(38) K4 = 1 DO WHILE ( INODE .GT. 0 ) RG2L( INODE ) = K4 INODE = FILS( INODE ) K4 = K4 + 1 END DO DO K8 = 1_8, NNZ IOLD = IRN( K8 ) JOLD = JCN( K8 ) IF ( IOLD .GT. N .OR. IOLD .LT. 1 .OR. & JOLD .GT. N .OR. JOLD .LT. 1 ) THEN MAPPING( K8 ) = -1 CYCLE END IF IF ( IOLD .eq. JOLD ) THEN ISEND = IOLD JSEND = JOLD ELSE INEW = PERM( IOLD ) JNEW = PERM( JOLD ) IF ( INEW .LT. JNEW ) THEN ISEND = IOLD IF ( KEEP(50) .ne. 0 ) ISEND = -IOLD JSEND = JOLD ELSE ISEND = -JOLD JSEND = IOLD END IF END IF IARR = abs( ISEND ) TYPE_NODE = MUMPS_TYPENODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) IF ( TYPE_NODE .eq. 1 .or. TYPE_NODE .eq. 2 ) THEN IF ( KEEP(46) .eq. 0 ) THEN DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) + 1 ELSE DEST = MUMPS_PROCNODE( PROCNODE(abs(STEP(IARR))), & KEEP(199) ) END IF ELSE IF ( ISEND .LT. 0 ) THEN IPOSROOT = RG2L( JSEND ) JPOSROOT = RG2L( IARR ) ELSE IPOSROOT = RG2L( IARR ) JPOSROOT = RG2L( JSEND ) END IF IROW_GRID = mod( ( IPOSROOT - 1 )/MBLOCK, NPROW ) JCOL_GRID = mod( ( JPOSROOT - 1 )/NBLOCK, NPCOL ) IF ( KEEP( 46 ) .eq. 0 ) THEN DEST = IROW_GRID * NPCOL + JCOL_GRID + 1 ELSE DEST = IROW_GRID * NPCOL + JCOL_GRID END IF END IF MAPPING( K8 ) = DEST END DO RETURN END SUBROUTINE DMUMPS_BUILD_MAPPING SUBROUTINE DMUMPS_REDISTRIBUTION( & N, NZ_loc8, id, & DBLARR, LDBLARR, INTARR, LINTARR, & PTRAIW, PTRARW, KEEP,KEEP8, MYID, COMM, NBRECORDS, & & A, LA, root, PROCNODE_STEPS, SLAVEF, PERM, STEP, & ICNTL, INFO, NSEND8, NLOCAL8, & ISTEP_TO_INIV2, CANDIDATES & ) !$ USE OMP_LIB USE DMUMPS_STRUC_DEF IMPLICIT NONE INTEGER N INTEGER(8) :: NZ_loc8 TYPE (DMUMPS_STRUC) :: id INTEGER(8) :: LDBLARR, LINTARR DOUBLE PRECISION DBLARR( LDBLARR ) INTEGER INTARR( LINTARR ) INTEGER(8), INTENT(IN) :: PTRAIW( N ), PTRARW( N ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID, COMM, NBRECORDS INTEGER(8) :: LA INTEGER SLAVEF INTEGER ISTEP_TO_INIV2(KEEP(71)) INTEGER CANDIDATES(SLAVEF+1, max(1,KEEP(56))) DOUBLE PRECISION A( LA ) TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER PROCNODE_STEPS(KEEP(28)), PERM( N ), STEP( N ) INTEGER INFO( 80 ), ICNTL(60) INTEGER MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT EXTERNAL MUMPS_PROCNODE, MUMPS_TYPENODE, numroc, & MUMPS_TYPESPLIT INCLUDE 'mumps_tags.h' INCLUDE 'mpif.h' INTEGER :: IERR, MSGSOU INTEGER :: STATUS(MPI_STATUS_SIZE) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) INTEGER, ALLOCATABLE, DIMENSION(:,:) :: IW4 INTEGER END_MSG_2_RECV INTEGER I INTEGER(8) :: I18, IA8 INTEGER(8) :: K8 INTEGER TYPE_NODE, DEST INTEGER IOLD, JOLD, IARR, ISEND, JSEND INTEGER allocok, TYPESPLIT, T4MASTER, INIV2, NCAND LOGICAL T4_MASTER_CONCERNED, EARLYT3ROOTINS DOUBLE PRECISION VAL INTEGER(8) :: PTR_ROOT INTEGER LOCAL_M, LOCAL_N, ARROW_ROOT INTEGER IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, & ILOCROOT, JLOCROOT INTEGER MP,LP INTEGER KPROBE, FREQPROBE INTEGER(8) :: IS18, IIW8, IS8, IAS8 INTEGER ISHIFT INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: BUFI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: BUFR INTEGER, ALLOCATABLE, DIMENSION(:) :: BUFRECI DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: BUFRECR INTEGER, ALLOCATABLE, DIMENSION(:) :: IACT, IREQI, IREQR LOGICAL, ALLOCATABLE, DIMENSION(:) :: SEND_ACTIVE LOGICAL :: FLAG INTEGER(8), INTENT(OUT) :: NSEND8, NLOCAL8 INTEGER MASTER_NODE, ISTEP LOGICAL :: DOIT, OMP_FLAG, OMP_FLAG_P INTEGER NOMP, NOMP_P, IOMP, P2 NSEND8 = 0_8 NLOCAL8 = 0_8 LP = ICNTL(1) MP = ICNTL(2) END_MSG_2_RECV = SLAVEF ALLOCATE( IACT(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IACT in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQI(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQI in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( IREQR(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating IREQR in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( SEND_ACTIVE(SLAVEF), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating SEND_ACTIVE in matrix distribution' END IF INFO(1) = -13 INFO(2) = SLAVEF GOTO 20 END IF ALLOCATE( BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ), stat=allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = ( NBRECORDS * 2 + 1 ) * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFR( NBRECORDS, 2, SLAVEF), stat = allocok) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating real buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * SLAVEF * 2 GOTO 20 END IF ALLOCATE( BUFRECI( NBRECORDS * 2 + 1 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS * 2 + 1 GOTO 20 END IF ALLOCATE( BUFRECR( NBRECORDS ), stat = allocok ) IF ( allocok .GT. 0 ) THEN IF ( LP > 0 ) THEN WRITE(LP,*) & '** Error allocating int recv buffer for matrix distribution' END IF INFO(1) = -13 INFO(2) = NBRECORDS GOTO 20 END IF ALLOCATE( IW4( N, 2 ), stat = allocok ) IF ( allocok .GT. 0 ) THEN WRITE(LP,*) '** Error allocating IW4 for matrix distribution' INFO(1) = -13 INFO(2) = N * 2 END IF 20 CONTINUE CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT. 0 ) GOTO 100 ARROW_ROOT = 0 DO I = 1, N I18 = PTRAIW( I ) IA8 = PTRARW( I ) IF ( IA8 .GT. 0_8 ) THEN DBLARR( IA8 ) = ZERO IW4( I, 1 ) = INTARR( I18 ) IW4( I, 2 ) = -INTARR( I18 + 1_8 ) INTARR( I18 + 2_8 ) = I END IF END DO EARLYT3ROOTINS = KEEP(200) .EQ.0 IF ( KEEP(38) .NE. 0 .AND. EARLYT3ROOTINS ) THEN CALL DMUMPS_GET_ROOT_INFO(root,LOCAL_M, LOCAL_N, PTR_ROOT, LA) CALL DMUMPS_SET_ROOT_TO_ZERO(root, KEEP, A, LA) ELSE LOCAL_M = -19999; LOCAL_N = -29999; PTR_ROOT = -99999_8 END IF DO I = 1, SLAVEF BUFI( 1, 1, I ) = 0 END DO DO I = 1, SLAVEF BUFI( 1, 2, I ) = 0 END DO DO I = 1, SLAVEF SEND_ACTIVE( I ) = .FALSE. IACT( I ) = 1 END DO KPROBE = 0 FREQPROBE = max(1,NBRECORDS/10) IF (SLAVEF .EQ. 1) FREQPROBE = huge(FREQPROBE) NOMP = 1 !$ NOMP=omp_get_max_threads() OMP_FLAG = KEEP(399).EQ.1 .AND. NOMP .GE.2 .AND. SLAVEF.EQ.1 !$OMP PARALLEL PRIVATE( K8, I, DEST, !$OMP& T4MASTER, T4_MASTER_CONCERNED, !$OMP& INIV2, NCAND, IROW_GRID, JCOL_GRID, IPOSROOT, JPOSROOT, !$OMP& ILOCROOT, JLOCROOT, !$OMP& TYPE_NODE, TYPESPLIT, MASTER_NODE, !$OMP& IA8, ISHIFT, IIW8, IS18, IS8, IAS8, VAL, !$OMP& IARR, ISTEP, ISEND, JSEND, !$OMP& IOLD, JOLD, IOMP, DOIT, P2, NOMP_P, OMP_FLAG_P ) !$OMP& REDUCTION(+:NSEND8, NLOCAL8, ARROW_ROOT) IF (OMP_FLAG) IOMP=0 !$ IOMP=omp_get_thread_num() NOMP_P=1 !$ NOMP_P=omp_get_num_threads() OMP_FLAG_P = .FALSE. !$ OMP_FLAG_P = OMP_FLAG .AND. NOMP_P .GT. 1 IF (OMP_FLAG_P) THEN IF ( NOMP_P .GE. 16 ) THEN NOMP_P=16 P2 = 4 ELSE IF (NOMP_P.GE.8) THEN NOMP_P=8 P2 = 3 ELSE IF (NOMP_P.GE.4) THEN NOMP_P=4 P2 = 2 ELSE IF (NOMP_P.GE.2) THEN NOMP_P=2 P2 = 1 ENDIF ELSE NOMP_P = 1 P2 = 0 ENDIF IF ( IOMP .LT. NOMP_P ) THEN DO K8 = 1_8, NZ_loc8 IF ( SLAVEF .GT. 1 ) THEN !$OMP MASTER KPROBE = KPROBE + 1 IF ( KPROBE .eq. FREQPROBE ) THEN KPROBE = 0 CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, & MPI_INTEGER, & MSGSOU, ARR_INT, COMM, STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_PRECISION, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF END IF !$OMP END MASTER ENDIF IOLD = id%IRN_loc(K8) JOLD = id%JCN_loc(K8) IF ( (IOLD.GT.N).OR.(JOLD.GT.N).OR.(IOLD.LT.1) & .OR.(JOLD.LT.1) ) THEN CYCLE ENDIF IF (OMP_FLAG_P) THEN IF (IOLD.EQ.JOLD) THEN IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD ELSE IARR = JOLD ENDIF DOIT = ( IOMP .EQ. ibits(IARR, P2-1, P2)) ELSE DOIT = .TRUE. ENDIF IF (DOIT) THEN IF (IOLD.EQ.JOLD) THEN ISEND = IOLD JSEND = IOLD IARR = IOLD ELSE IF (PERM(IOLD).LT.PERM(JOLD)) THEN IARR = IOLD IF ( KEEP(50) .NE. 0 ) THEN ISEND = -IOLD ELSE ISEND = IOLD ENDIF JSEND = JOLD ELSE IARR = JOLD ISEND = -JOLD JSEND = IOLD ENDIF ISTEP = abs(STEP(IARR)) CALL MUMPS_TYPEANDPROCNODE( TYPE_NODE, MASTER_NODE, & PROCNODE_STEPS(ISTEP), KEEP(199) ) T4_MASTER_CONCERNED = .FALSE. T4MASTER = -9999 VAL = id%A_loc(K8) IF ((KEEP(52).EQ.7).OR.(KEEP(52).EQ.8)) THEN VAL = VAL * id%ROWSCA(IOLD)*id%COLSCA(JOLD) ENDIF IF ( TYPE_NODE .eq. 1 ) THEN DEST = MASTER_NODE IF (DEST.EQ.MYID) THEN NLOCAL8 = NLOCAL8 + 1_8 IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) INTARR(IS18+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,2) = IW4(IARR,2) - 1 ELSE ISHIFT = IW4(IARR,1) INTARR(PTRAIW(IARR)+ISHIFT+2) = JSEND DBLARR(PTRARW(IARR)+ISHIFT) = VAL IW4(IARR,1) = IW4(IARR,1) - 1 IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF CYCLE ENDIF ELSE IF ( TYPE_NODE .eq. 2 ) THEN IF ( ISEND .LT. 0 ) THEN DEST = -1 ELSE DEST = MASTER_NODE END IF INIV2 = ISTEP_TO_INIV2(ISTEP) IF ( KEEP(79) .GT. 0) THEN TYPESPLIT = MUMPS_TYPESPLIT( PROCNODE_STEPS(ISTEP), & KEEP(199) ) IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6)) THEN T4_MASTER_CONCERNED = .TRUE. T4MASTER=CANDIDATES(CANDIDATES(SLAVEF+1,INIV2)+1,INIV2) ENDIF ENDIF ELSE ARROW_ROOT = ARROW_ROOT + 1 IF (EARLYT3ROOTINS) THEN IF ( ISEND < 0 ) THEN IPOSROOT = root%RG2L_ROW(JSEND) JPOSROOT = root%RG2L_ROW(IARR ) ELSE IPOSROOT = root%RG2L_ROW(IARR ) JPOSROOT = root%RG2L_ROW(JSEND) END IF IROW_GRID = mod( ( IPOSROOT-1 )/root%MBLOCK, root%NPROW ) JCOL_GRID = mod( ( JPOSROOT-1 )/root%NBLOCK, root%NPCOL ) DEST = IROW_GRID * root%NPCOL + JCOL_GRID ELSE DEST = -2 ENDIF IF ( OMP_FLAG_P ) THEN IF ( EARLYT3ROOTINS ) THEN ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (ISEND.EQ.JSEND) THEN IA8 = PTRARW(ISEND) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IF (ISEND.GE.0) THEN IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JSEND IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ELSE IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JSEND IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & INTARR( PTRAIW(IARR) ), 1, & INTARR( PTRAIW(IARR) ) ) END IF ENDIF ENDIF CYCLE ENDIF END IF IF (DEST .eq. -1) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .EQ. -2) THEN NLOCAL8 = NLOCAL8 + 1_8 NSEND8 = NSEND8 + int(SLAVEF -1,8) ELSE IF (DEST .eq.MYID ) THEN NLOCAL8 = NLOCAL8 + 1_8 ELSE NSEND8 = NSEND8 + 1_8 ENDIF ENDIF IF ( DEST.EQ.-1) THEN INIV2 = ISTEP_TO_INIV2(ISTEP) NCAND = CANDIDATES(SLAVEF+1,INIV2) IF (KEEP(79) .GT. 0) THEN DO I=1, SLAVEF DEST=CANDIDATES(I,INIV2) IF (DEST.LT.0) EXIT IF (I.EQ.NCAND+1) CYCLE CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ELSE DO I=1, NCAND DEST=CANDIDATES(I,INIV2) CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDDO ENDIF DEST=MASTER_NODE CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .GE. 0) THEN CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) IF (T4_MASTER_CONCERNED) THEN DEST = T4MASTER CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP,KEEP8 ) ENDIF ELSE IF (DEST .EQ. -2) THEN DO I = 0, SLAVEF-1 DEST=I CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, & N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, & IW4(1,1), root, KEEP, KEEP8 ) ENDDO ENDIF ENDIF END DO ENDIF !$OMP END PARALLEL DEST = -3 CALL DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, &BUFI, BUFR, BUFRECI, BUFRECR, &NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, &SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, &N, PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, &PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, &IW4(1,1), root, KEEP,KEEP8 ) DO WHILE ( END_MSG_2_RECV .NE. 0 ) CALL MPI_RECV( BUFRECI(1), NBRECORDS * 2 + 1, MPI_INTEGER, & MPI_ANY_SOURCE, ARR_INT, COMM, STATUS, IERR ) MSGSOU = STATUS( MPI_SOURCE ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, MPI_DOUBLE_PRECISION, & MSGSOU, ARR_REAL, COMM, STATUS, IERR ) CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END DO DO I = 1, SLAVEF IF ( SEND_ACTIVE( I ) ) THEN CALL MPI_WAIT( IREQI( I ), STATUS, IERR ) CALL MPI_WAIT( IREQR( I ), STATUS, IERR ) END IF END DO KEEP(49) = ARROW_ROOT 100 CONTINUE IF (ALLOCATED(IW4)) DEALLOCATE( IW4 ) IF (ALLOCATED(BUFI)) DEALLOCATE( BUFI ) IF (ALLOCATED(BUFR)) DEALLOCATE( BUFR ) IF (ALLOCATED(BUFRECI)) DEALLOCATE( BUFRECI ) IF (ALLOCATED(BUFRECR)) DEALLOCATE( BUFRECR ) IF (ALLOCATED(IACT)) DEALLOCATE( IACT ) IF (ALLOCATED(IREQI)) DEALLOCATE( IREQI ) IF (ALLOCATED(IREQR)) DEALLOCATE( IREQR ) IF (ALLOCATED(SEND_ACTIVE)) DEALLOCATE( SEND_ACTIVE ) RETURN END SUBROUTINE DMUMPS_REDISTRIBUTION SUBROUTINE DMUMPS_DIST_FILL_BUFFER( DEST, ISEND, JSEND, VAL, & BUFI, BUFR, BUFRECI, BUFRECR, & NBRECORDS, SLAVEF, COMM, MYID, IACT, IREQI, IREQR, & SEND_ACTIVE, INTARR, LINTARR, DBLARR, LDBLARR, N, & PTRAIW, PTRARW, PERM, STEP, END_MSG_2_RECV, & PROCNODE_STEPS, A, LA, PTR_ROOT, LOCAL_M, LOCAL_N, IW4, root, & KEEP,KEEP8 ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ISEND, JSEND, DEST, NBRECORDS, SLAVEF, COMM, MYID, N INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV, LOCAL_M, LOCAL_N INTEGER(8) :: LINTARR, LDBLARR INTEGER(8) :: LA, PTR_ROOT INTEGER BUFI( NBRECORDS * 2 + 1, 2, SLAVEF ) INTEGER BUFRECI( NBRECORDS * 2 + 1 ) INTEGER IREQI(SLAVEF), IREQR(SLAVEF), IACT(SLAVEF) INTEGER IW4( N, 2 ) INTEGER(8) PTRAIW( N ), PTRARW( N ) INTEGER PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER INTARR( LINTARR ) DOUBLE PRECISION DBLARR( LDBLARR ), A( LA ) LOGICAL SEND_ACTIVE(SLAVEF) DOUBLE PRECISION BUFR( NBRECORDS, 2, SLAVEF ) DOUBLE PRECISION BUFRECR( NBRECORDS ) DOUBLE PRECISION VAL INTEGER ISLAVE, IBEG, IEND, NBREC, IREQ INTEGER TAILLE_SEND_I, TAILLE_SEND_R, MSGSOU LOGICAL FLAG, SEND_LOCAL INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( DEST .eq. -3 ) THEN IBEG = 1 IEND = SLAVEF ELSE IBEG = DEST + 1 IEND = DEST + 1 END IF SEND_LOCAL = .FALSE. DO ISLAVE = IBEG, IEND NBREC = BUFI(1,IACT(ISLAVE),ISLAVE) IF ( DEST .eq. -3 ) THEN BUFI(1,IACT(ISLAVE),ISLAVE) = - NBREC END IF IF ( DEST .eq. -3 .or. NBREC + 1 > NBRECORDS ) THEN DO WHILE ( SEND_ACTIVE( ISLAVE ) ) CALL MPI_TEST( IREQR( ISLAVE ), FLAG, STATUS, IERR ) IF ( .NOT. FLAG ) THEN CALL MPI_IPROBE( MPI_ANY_SOURCE, ARR_INT, COMM, & FLAG, STATUS, IERR ) IF ( FLAG ) THEN MSGSOU = STATUS(MPI_SOURCE) CALL MPI_RECV( BUFRECI(1), 2*NBRECORDS+1, & MPI_INTEGER, MSGSOU, ARR_INT, COMM, & STATUS, IERR ) CALL MPI_RECV( BUFRECR(1), NBRECORDS, & MPI_DOUBLE_PRECISION, MSGSOU, & ARR_REAL, COMM, STATUS, IERR ) CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFRECI, BUFRECR, NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF ELSE CALL MPI_WAIT( IREQI( ISLAVE ), STATUS, IERR ) SEND_ACTIVE( ISLAVE ) = .FALSE. END IF END DO IF ( ISLAVE - 1 .ne. MYID ) THEN TAILLE_SEND_I = NBREC * 2 + 1 TAILLE_SEND_R = NBREC CALL MPI_ISEND( BUFI(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_I, & MPI_INTEGER, ISLAVE - 1, ARR_INT, COMM, & IREQI( ISLAVE ), IERR ) CALL MPI_ISEND( BUFR(1, IACT(ISLAVE), ISLAVE ), & TAILLE_SEND_R, & MPI_DOUBLE_PRECISION, ISLAVE - 1, ARR_REAL, COMM, & IREQR( ISLAVE ), IERR ) SEND_ACTIVE( ISLAVE ) = .TRUE. ELSE SEND_LOCAL = .TRUE. END IF IACT( ISLAVE ) = 3 - IACT( ISLAVE ) BUFI( 1, IACT( ISLAVE ), ISLAVE ) = 0 END IF IF ( DEST .ne. -3 ) THEN IREQ = BUFI(1,IACT(ISLAVE),ISLAVE) + 1 BUFI(1,IACT(ISLAVE),ISLAVE) = IREQ BUFI(IREQ*2,IACT(ISLAVE),ISLAVE) = ISEND BUFI(IREQ*2+1,IACT(ISLAVE),ISLAVE) = JSEND BUFR(IREQ,IACT(ISLAVE),ISLAVE ) = VAL END IF END DO IF ( SEND_LOCAL ) THEN ISLAVE = MYID + 1 CALL DMUMPS_DIST_TREAT_RECV_BUF( & BUFI(1,3-IACT(ISLAVE),ISLAVE), & BUFR(1,3-IACT(ISLAVE),ISLAVE), & NBRECORDS, N, IW4(1,1), & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, & A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR & ) END IF RETURN END SUBROUTINE DMUMPS_DIST_FILL_BUFFER SUBROUTINE DMUMPS_DIST_TREAT_RECV_BUF & ( BUFI, BUFR, NBRECORDS, N, IW4, & KEEP,KEEP8, LOCAL_M, LOCAL_N, root, PTR_ROOT, A, LA, & END_MSG_2_RECV, MYID, PROCNODE_STEPS, & SLAVEF, & PTRAIW, PTRARW, PERM, STEP, & INTARR, LINTARR, DBLARR, LDBLARR ) USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC IMPLICIT NONE TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER NBRECORDS, N, MYID, SLAVEF INTEGER BUFI( NBRECORDS * 2 + 1 ) DOUBLE PRECISION BUFR( NBRECORDS ) INTEGER IW4( N, 2 ) INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER END_MSG_2_RECV INTEGER(8) :: PTRAIW( N ), PTRARW( N ) INTEGER :: PERM( N ), STEP( N ) INTEGER PROCNODE_STEPS( KEEP(28) ) INTEGER(8), INTENT(IN) :: LINTARR, LDBLARR INTEGER INTARR( LINTARR ) INTEGER LOCAL_M, LOCAL_N INTEGER(8) :: PTR_ROOT, LA DOUBLE PRECISION A( LA ), DBLARR( LDBLARR ) INTEGER MUMPS_TYPENODE, MUMPS_PROCNODE EXTERNAL MUMPS_TYPENODE, MUMPS_PROCNODE INTEGER IREC, NB_REC, NODE_TYPE, IPROC INTEGER IPOSROOT, JPOSROOT, ILOCROOT, JLOCROOT INTEGER(8) :: IA8, IS18, IIW8, IS8, IAS8 INTEGER ISHIFT, IARR, JARR INTEGER TAILLE LOGICAL :: EARLYT3ROOTINS DOUBLE PRECISION VAL EARLYT3ROOTINS = KEEP(200) .EQ.0 NB_REC = BUFI( 1 ) IF ( NB_REC .LE. 0 ) THEN END_MSG_2_RECV = END_MSG_2_RECV - 1 NB_REC = - NB_REC END IF IF ( NB_REC .eq. 0 ) GOTO 100 DO IREC = 1, NB_REC IARR = BUFI( IREC * 2 ) JARR = BUFI( IREC * 2 + 1 ) VAL = BUFR( IREC ) NODE_TYPE = MUMPS_TYPENODE( & PROCNODE_STEPS(abs(STEP(abs( IARR )))), & KEEP(199) ) IF ( NODE_TYPE .eq. 3 .AND. EARLYT3ROOTINS ) THEN IF ( IARR .GT. 0 ) THEN IPOSROOT = root%RG2L_ROW( IARR ) JPOSROOT = root%RG2L_COL( JARR ) ELSE IPOSROOT = root%RG2L_ROW( JARR ) JPOSROOT = root%RG2L_COL( -IARR ) END IF ILOCROOT = root%MBLOCK * ( ( IPOSROOT - 1 ) / & ( root%MBLOCK * root%NPROW ) ) & + mod( IPOSROOT - 1, root%MBLOCK ) + 1 JLOCROOT = root%NBLOCK * ( ( JPOSROOT - 1 ) / & ( root%NBLOCK * root%NPCOL ) ) & + mod( JPOSROOT - 1, root%NBLOCK ) + 1 IF (KEEP(60)==0) THEN A( PTR_ROOT + int(JLOCROOT-1,8) * int(LOCAL_M,8) & + int(ILOCROOT-1,8)) = A( PTR_ROOT & + int(JLOCROOT - 1,8) * int(LOCAL_M,8) & + int(ILOCROOT - 1,8) ) & + VAL ELSE root%SCHUR_POINTER( int(JLOCROOT-1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8) ) & = root%SCHUR_POINTER( int(JLOCROOT - 1,8) & * int(root%SCHUR_LLD,8) & + int(ILOCROOT,8)) & + VAL ENDIF ELSE IF (IARR.GE.0) THEN IF (IARR.EQ.JARR) THEN IA8 = PTRARW(IARR) DBLARR(IA8) = DBLARR(IA8) + VAL ELSE IS18 = PTRAIW(IARR) ISHIFT = INTARR(IS18) + IW4(IARR,2) IW4(IARR,2) = IW4(IARR,2) - 1 IIW8 = IS18 + ISHIFT + 2 INTARR(IIW8) = JARR IS8 = PTRARW(IARR) IAS8 = IS8 + ISHIFT DBLARR(IAS8) = VAL ENDIF ELSE IARR = -IARR IS8 = PTRAIW(IARR)+IW4(IARR,1)+2 INTARR(IS8) = JARR IAS8 = PTRARW(IARR)+IW4(IARR,1) IW4(IARR,1) = IW4(IARR,1) - 1 DBLARR(IAS8) = VAL IF ( IW4(IARR,1) .EQ. 0 & .AND. STEP(IARR) > 0 ) THEN IPROC = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(IARR)), & KEEP(199) ) IF ( IPROC .EQ. MYID ) THEN TAILLE = INTARR( PTRAIW(IARR) ) CALL DMUMPS_QUICK_SORT_ARROWHEADS( N, PERM, & INTARR( PTRAIW(IARR) + 3 ), & DBLARR( PTRARW(IARR) + 1 ), & TAILLE, 1, TAILLE ) ENDIF END IF ENDIF ENDDO 100 CONTINUE RETURN END SUBROUTINE DMUMPS_DIST_TREAT_RECV_BUF MUMPS_5.4.1/src/zfac_front_LU_type1.F0000664000175000017500000012154114102210525017475 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FAC1_LU_M CONTAINS SUBROUTINE ZMUMPS_FAC1_LU( & N, INODE, IW, LIW, A, & LA, & IOLDPS, POSELT, IFLAG, IERROR, UU, & NOFFW, NPVW, NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & KEEP, KEEP8, STEP, & PROCNODE_STEPS, MYID, SLAVEF, SEUIL, & AVOID_DELAYED, ETATASS, & DKEEP,PIVNUL_LIST,LPN_LIST, & IWPOS & , LRGROUPS & , PERM & ) USE ZMUMPS_FAC_FRONT_AUX_M USE ZMUMPS_OOC USE ZMUMPS_FAC_LR USE ZMUMPS_LR_TYPE USE ZMUMPS_LR_STATS USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_DATA_M #if defined(BLR_MT) #endif !$ USE OMP_LIB IMPLICIT NONE INTEGER(8) :: LA, POSELT INTEGER N, INODE, LIW, IFLAG, IERROR INTEGER, INTENT(INOUT) :: NOFFW, NPVW, NBTINYW INTEGER, INTENT(INOUT) :: DET_EXPW, DET_SIGNW COMPLEX(kind=8), INTENT(INOUT) :: DET_MANTW INTEGER IW( LIW ) COMPLEX(kind=8) A( LA ) INTEGER MYID, SLAVEF, IOLDPS INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) INTEGER PROCNODE_STEPS( KEEP(28) ), STEP(N) DOUBLE PRECISION UU, SEUIL LOGICAL AVOID_DELAYED INTEGER ETATASS, IWPOS INTEGER LPN_LIST INTEGER PIVNUL_LIST(LPN_LIST) DOUBLE PRECISION DKEEP(230) INTEGER :: LRGROUPS(N), PERM(N) INTEGER INOPV, IFINB, NFRONT, NPIV, IBEG_BLOCK, IEND_BLOCK INTEGER NASS, NBKJIB_ORIG, XSIZE INTEGER NBLR_ORIG, IBEG_BLR, IEND_BLR INTEGER Inextpiv INTEGER LAST_ROW, LAST_COL, FIRST_COL LOGICAL CALL_LTRSM, CALL_UTRSM DOUBLE PRECISION UUTEMP LOGICAL STATICMODE DOUBLE PRECISION SEUIL_LOC INTEGER PIVOT_OPTION INTEGER LRTRSM_OPTION INTEGER(8) :: LAFAC INTEGER LIWFAC, STRAT, LNextPiv2beWritten, & UNextPiv2beWritten, IFLAG_OOC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & PP_LastPIVRPTRFilled_L, & PP_LastPIVRPTRFilled_U INTEGER TYPEF_LOC TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER PARPIV_T1 INTEGER CURRENT_BLR LOGICAL LR_ACTIVATED LOGICAL COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR, & OOC_EFFECTIVE_ON_FRONT, & OOC_EFF_AND_WRITE_BYPANEL INTEGER :: K473_LOC INTEGER FIRST_BLOCK, LAST_BLOCK INTEGER INFO_TMP(2), MAXI_RANK INTEGER HF, NPARTSASS, NPARTSCB, NB_BLR INTEGER MAXI_CLUSTER, LWORK, NELIM, NELIM_LOC INTEGER :: IROW_L, NVSCHUR INTEGER, POINTER, DIMENSION(:) :: PTDummy INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR TYPE(LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: ACC_LUA TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_U, BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_TMP TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: BLR_PANEL COMPLEX(kind=8), POINTER, DIMENSION(:) :: DIAG INTEGER :: DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, LorU, I, MEM, MEM_TOT INTEGER(8) :: POSELT_DIAG CHARACTER(len=1) :: DIR COMPLEX(kind=8), ALLOCATABLE :: WORK(:), TAU(:) INTEGER, ALLOCATABLE :: JPVT(:) DOUBLE PRECISION, ALLOCATABLE :: RWORK(:) COMPLEX(kind=8), ALLOCATABLE :: BLOCK(:,:) INTEGER :: allocok,J INTEGER :: OMP_NUM INTEGER :: IP INTEGER(8) :: UPOS, LPOS INTEGER :: MY_NUM TYPE(LRB_TYPE), POINTER, DIMENSION(:) :: NEXT_BLR_U, NEXT_BLR_L INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_STATIC COMPLEX(kind=8) :: ZERO PARAMETER (ZERO=(0.0D0,0.0D0)) INCLUDE 'mumps_headers.h' INTEGER(8):: KEEP8TMPCOPY, KEEP873COPY FIRST_BLOCK = -99999 LAST_BLOCK = -99999 IP=0 IF (KEEP(206).GE.1) THEN Inextpiv = 1 ELSE Inextpiv = 0 ENDIF INOPV = 0 SEUIL_LOC = SEUIL IF(KEEP(97) .EQ. 0) THEN STATICMODE = .FALSE. ELSE STATICMODE = .TRUE. ENDIF IF (AVOID_DELAYED) THEN STATICMODE = .TRUE. UUTEMP=UU SEUIL_LOC = max(SEUIL,epsilon(SEUIL)) ELSE UUTEMP=UU ENDIF PIVOT_OPTION = KEEP(468) LRTRSM_OPTION = KEEP(475) LAFAC = -9999_8 XSIZE = KEEP(IXSZ) NFRONT = IW(IOLDPS+XSIZE) NASS = iabs(IW(IOLDPS+2+XSIZE)) IW(IOLDPS+3+XSIZE) = -99999 LR_ACTIVATED = .FALSE. COMPRESS_PANEL = .FALSE. COMPRESS_CB = .FALSE. NULLIFY(PTDummy) NULLIFY(BEGS_BLR) NULLIFY(CB_LRB) NULLIFY(ACC_LUA) NULLIFY(BLR_U) NULLIFY(BLR_L) NULLIFY(BEGS_BLR_TMP) NULLIFY(BLR_PANEL) NULLIFY(DIAG) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) LR_ACTIVATED = (IW(IOLDPS+XXLR).GT.0) IF (COMPRESS_CB.AND.(.NOT.COMPRESS_PANEL)) THEN K473_LOC = 1 ELSE K473_LOC = KEEP(473) ENDIF K473_LOC = KEEP(473) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) OOC_EFFECTIVE_ON_FRONT= ((KEEP(201).EQ.1).AND. & OOCWRITE_COMPATIBLE_WITH_BLR) CALL ZMUMPS_SET_PARPIVT1 ( INODE, NFRONT, NASS, KEEP, & LR_ACTIVATED, PARPIV_T1) IF (UUTEMP.EQ.ZERO) THEN PIVOT_OPTION=0 ELSE IF (PARPIV_T1.NE.0) THEN PIVOT_OPTION = min(PIVOT_OPTION,2) ENDIF IF (LR_ACTIVATED) THEN IF (LRTRSM_OPTION.EQ.3) THEN PIVOT_OPTION = MIN(PIVOT_OPTION,1) ELSEIF (LRTRSM_OPTION.EQ.2) THEN PIVOT_OPTION = MIN(PIVOT_OPTION, 2) ENDIF ENDIF IF (PIVOT_OPTION.LE.1) THEN PARPIV_T1 = 0 ENDIF IF (NASS.LT.KEEP(4)) THEN NBKJIB_ORIG = NASS ELSE IF (NASS .GT. KEEP(3)) THEN NBKJIB_ORIG = min( KEEP(6), NASS ) ELSE NBKJIB_ORIG = min( KEEP(5), NASS ) ENDIF IF (.not.LR_ACTIVATED) THEN NBLR_ORIG = KEEP(420) ELSE NBLR_ORIG = -9999 ENDIF IF ((KEEP(114).EQ.1) .AND. & (KEEP(116).GT.0) .AND. ((NFRONT-NASS-KEEP(253)).GT.0) & ) THEN IROW_L = IOLDPS+6+XSIZE+NASS CALL ZMUMPS_COMPUTE_SIZE_SCHUR_IN_FRONT ( & N, & NFRONT-NASS-KEEP(253), & KEEP(116), & IW(IROW_L), PERM, & NVSCHUR ) ELSE NVSCHUR = 0 ENDIF IEND_BLOCK = 0 IEND_BLR = 0 CURRENT_BLR = 0 CALL MUMPS_GETI8(LAFAC,IW(IOLDPS+XXR)) LIWFAC = IW(IOLDPS+XXI) IF ( OOC_EFFECTIVE_ON_FRONT ) THEN LNextPiv2beWritten = 1 UNextPiv2beWritten = 1 PP_FIRST2SWAP_L = LNextPiv2beWritten PP_FIRST2SWAP_U = UNextPiv2beWritten MonBloc%LastPanelWritten_L = 0 MonBloc%LastPanelWritten_U = 0 PP_LastPIVRPTRFilled_L = 0 PP_LastPIVRPTRFilled_U = 0 MonBloc%INODE = INODE MonBloc%MASTER = .TRUE. MonBloc%Typenode = 1 MonBloc%NROW = NFRONT MonBloc%NCOL = NFRONT MonBloc%NFS = NASS MonBloc%Last = .FALSE. MonBloc%LastPiv = -88877 NULLIFY(MonBloc%INDICES) ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(405) .EQ. 1) THEN !$OMP ATOMIC UPDATE CNT_NODES = CNT_NODES + 1 !$OMP END ATOMIC ELSE CNT_NODES = CNT_NODES + 1 ENDIF ELSE IF (KEEP(486).NE.0) THEN ENDIF OOC_EFF_AND_WRITE_BYPANEL = ( (PIVOT_OPTION.GE.3) .AND. & OOC_EFFECTIVE_ON_FRONT ) HF = 6 + IW(IOLDPS+5+XSIZE)+XSIZE IF (LR_ACTIVATED) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NFRONT-1), NASS, & NFRONT-NASS, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR) CALL REGROUPING2(BEGS_BLR, NPARTSASS, NASS, NPARTSCB, & NFRONT-NASS, KEEP(488), .FALSE., KEEP(472)) NB_BLR = NPARTSASS + NPARTSCB call MAX_CLUSTER(BEGS_BLR,NB_BLR,MAXI_CLUSTER) MAXI_RANK = KEEP(479)*MAXI_CLUSTER LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF ALLOCATE(ACC_LUA(OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 490 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF IF (LR_ACTIVATED.AND. & (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & .OR.COMPRESS_CB & )) THEN INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR CALL ZMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .FALSE., & .FALSE., & NPARTSASS, & BEGS_BLR, PTDummy, & huge(NPARTSASS), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IFLAG.LT.0) GOTO 500 ENDIF IF (COMPRESS_CB.AND.NPARTSCB.GT.0) THEN allocate(CB_LRB(NPARTSCB,NPARTSCB),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NPARTSCB*NPARTSCB GOTO 490 ENDIF CALL ZMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF DO WHILE (IEND_BLR < NASS ) CURRENT_BLR = CURRENT_BLR + 1 IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (.NOT. LR_ACTIVATED) THEN IEND_BLR = min(IEND_BLR + NBLR_ORIG, NASS) ELSE IEND_BLR = min(BEGS_BLR(CURRENT_BLR+1)-1, NASS) BEGS_BLR( CURRENT_BLR ) = IBEG_BLR IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) GOTO 490 ENDIF IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) CALL ALLOC_LRB(ACC_LUA(MY_NUM), MAXI_RANK, & MAXI_CLUSTER, MAXI_CLUSTER, .TRUE., & IFLAG, IERROR, KEEP8) IF (IFLAG.LT.0) GOTO 500 ACC_LUA(MY_NUM)%K = 0 ENDDO ENDIF ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (KEEP(480).GE.5) THEN IF (CURRENT_BLR.EQ.1) THEN ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR) THEN BLR_U(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) BLR_L(1:NB_BLR-CURRENT_BLR)%ISLR=.FALSE. CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ELSE IF (NB_BLR.GT.CURRENT_BLR) THEN CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF IF (CURRENT_BLR.LT.NPARTSASS) THEN ALLOCATE(NEXT_BLR_U(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF ALLOCATE(NEXT_BLR_L(NB_BLR-CURRENT_BLR-1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR-1 GOTO 490 ENDIF IF (NB_BLR.GT.CURRENT_BLR+1) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR+1, NEXT_BLR_U) CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR+1, NEXT_BLR_L) ENDIF ENDIF ELSE ALLOCATE(BLR_U(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ALLOCATE(BLR_L(NB_BLR-CURRENT_BLR),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR-CURRENT_BLR GOTO 490 ENDIF ENDIF ENDIF DO WHILE (IEND_BLOCK < IEND_BLR ) IBEG_BLOCK = IW(IOLDPS+1+KEEP(IXSZ)) + 1 IF (KEEP(405).EQ.0) THEN KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) ELSE !$OMP ATOMIC UPDATE KEEP(425)=max(KEEP(425),IEND_BLOCK-IBEG_BLOCK) !$OMP END ATOMIC ENDIF IEND_BLOCK = min(IEND_BLOCK + NBKJIB_ORIG, IEND_BLR) 50 CONTINUE CALL ZMUMPS_FAC_I(NFRONT,NASS,NFRONT, & IBEG_BLOCK,IEND_BLOCK,N,INODE, & IW,LIW,A,LA,INOPV,NOFFW,NBTINYW, & DET_EXPW, DET_MANTW, DET_SIGNW, & IFLAG,IOLDPS,POSELT,UU,SEUIL_LOC,KEEP,KEEP8, & DKEEP(1),PIVNUL_LIST(1),LPN_LIST, & PP_FIRST2SWAP_L, MonBloc%LastPanelWritten_L, & PP_LastPIVRPTRFilled_L, & PP_FIRST2SWAP_U, MonBloc%LastPanelWritten_U, & PP_LastPIVRPTRFilled_U, & PIVOT_OPTION, LR_ACTIVATED, IEND_BLR, & Inextpiv, OOC_EFFECTIVE_ON_FRONT, & NVSCHUR, PARPIV_T1 & ) IF (IFLAG.LT.0) GOTO 500 IF (INOPV.EQ.1) THEN IF(STATICMODE) THEN INOPV = -1 GOTO 50 ENDIF ELSE IF ( INOPV.LE.0 ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_MQ(IBEG_BLOCK, IEND_BLOCK, & NFRONT, NASS, IW(IOLDPS+1+XSIZE), & LAST_COL, A, LA, POSELT, IFINB, & LR_ACTIVATED & ) IW(IOLDPS+1+XSIZE) = IW(IOLDPS+1+XSIZE) + 1 IF (IFINB.EQ.0) THEN GOTO 50 ENDIF ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_U, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF NPIV = IW(IOLDPS+1+XSIZE) IF ( IEND_BLR .GT. IEND_BLOCK ) THEN IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = IEND_BLR ENDIF CALL ZMUMPS_FAC_SQ(IBEG_BLOCK, IEND_BLOCK, & NPIV, NFRONT, IEND_BLR, LAST_COL, & A, LA, POSELT, & -66666, & .TRUE., .FALSE., .TRUE., & .FALSE., & LR_ACTIVATED & ) ENDIF END DO NPIV = IW(IOLDPS+1+XSIZE) IF (.NOT. LR_ACTIVATED & .OR. (.NOT. COMPRESS_PANEL) & ) THEN IF (PIVOT_OPTION.EQ.4) THEN LAST_ROW = NFRONT ELSE LAST_ROW = NASS ENDIF IF (PIVOT_OPTION.GE.3) THEN LAST_COL = NFRONT ELSE LAST_COL = NASS ENDIF IF (IEND_BLR.LT.LAST_ROW) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, LAST_ROW, LAST_COL, & A, LA, POSELT, IEND_BLR, .TRUE., (PIVOT_OPTION.LT.2), & .TRUE., .FALSE., & LR_ACTIVATED) ENDIF ELSE NELIM = IEND_BLR - NPIV IF (NELIM .EQ. IEND_BLR - IBEG_BLR + 1) THEN IF (KEEP(480).GE.2 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN DO J=1,NB_BLR-CURRENT_BLR BLR_U(J)%M=0 BLR_U(J)%N=0 BLR_U(J)%K=0 BLR_U(J)%ISLR=.FALSE. NULLIFY(BLR_U(J)%Q) NULLIFY(BLR_U(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) DO J=1,NB_BLR-CURRENT_BLR BLR_L(J)%M=0 BLR_L(J)%N=0 BLR_L(J)%K=0 BLR_L(J)%ISLR=.FALSE. NULLIFY(BLR_L(J)%Q) NULLIFY(BLR_L(J)%R) ENDDO CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) IF (KEEP(480).GE.2 .AND. IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 900 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 900 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 ENDIF ENDIF IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN DEALLOCATE(BLR_U,BLR_L) NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF ENDIF GOTO 100 ENDIF IF (PIVOT_OPTION.GE.3) THEN FIRST_COL = NFRONT ELSEIF (PIVOT_OPTION.EQ.2) THEN FIRST_COL = NASS ELSE FIRST_COL = IEND_BLR ENDIF IF (LRTRSM_OPTION.EQ.3) THEN LAST_COL = IEND_BLR ELSEIF (LRTRSM_OPTION.EQ.2) THEN LAST_COL = NASS ELSE LAST_COL = NFRONT ENDIF CALL_LTRSM = (LRTRSM_OPTION.EQ.0) CALL_UTRSM = (LAST_COL-FIRST_COL.GT.0) IF ((IEND_BLR.LT.NFRONT) .AND. & (CALL_LTRSM.OR.CALL_UTRSM)) THEN CALL ZMUMPS_FAC_SQ(IBEG_BLR, IEND_BLR, & NPIV, NFRONT, NFRONT, & LAST_COL, & A, LA, POSELT, & FIRST_COL, CALL_LTRSM, & CALL_UTRSM, .FALSE., & .FALSE., & LR_ACTIVATED) ENDIF #if defined(BLR_MT) #endif #if defined(BLR_MT) !$OMP PARALLEL PRIVATE(UPOS,LPOS) FIRSTPRIVATE(FIRST_BLOCK,LAST_BLOCK) #endif CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_U, CURRENT_BLR, & 'H', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, IERROR, & NFRONT, & BEGS_BLR, NB_BLR, DKEEP(8), KEEP(466), K473_LOC, BLR_L, & CURRENT_BLR, & 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & K480=KEEP(480) & ) #if defined(BLR_MT) !$OMP BARRIER !$OMP MASTER #endif IF (KEEP(480).NE.0 & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN IF (KEEP(480).LT.5) THEN CALL ZMUMPS_BLR_SAVE_PANEL_LORU( & IW(IOLDPS+XXF), & 1, & CURRENT_BLR, BLR_U) CALL ZMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & CURRENT_BLR, BLR_L) ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (LRTRSM_OPTION.GT.0) THEN CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, & NB_BLR, BLR_L, CURRENT_BLR, CURRENT_BLR+1, & NB_BLR, 1, 0, 0, .FALSE.) IF (PIVOT_OPTION.LT.3.AND.LRTRSM_OPTION.GE.2) THEN IF (PIVOT_OPTION.LE.1.AND.LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = CURRENT_BLR+1 ELSE FIRST_BLOCK = NPARTSASS+1 ENDIF CALL ZMUMPS_BLR_PANEL_LRTRSM(A, LA, POSELT, NFRONT, & IBEG_BLR, NB_BLR, BLR_U, & CURRENT_BLR, FIRST_BLOCK, NB_BLR, & 1, 0, 1, .FALSE.) #if defined(BLR_MT) !$OMP BARRIER #endif CALL ZMUMPS_BLR_UPD_NELIM_VAR_U( & A, LA, POSELT, IFLAG, IERROR, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_U, NB_BLR, & FIRST_BLOCK, IBEG_BLR, NPIV, NELIM) ENDIF ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(480).GE.2) THEN UPOS = POSELT+int(BEGS_BLR(CURRENT_BLR)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) LPOS = POSELT+int(BEGS_BLR(CURRENT_BLR+1)-1,8)*int(NFRONT,8) & +int(BEGS_BLR(CURRENT_BLR+1)-NELIM-1,8) CALL ZMUMPS_BLR_UPD_NELIM_VAR_L(A, LA, UPOS, A, LA, & LPOS, IFLAG, IERROR, NFRONT, NFRONT, & BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & CURRENT_BLR+1, NELIM, 'N') IF (IFLAG.LT.0) GOTO 444 IF (IEND_BLR.LT.NASS) THEN IF (LRTRSM_OPTION.EQ.3) THEN FIRST_BLOCK = 1 ELSE FIRST_BLOCK = NPARTSASS-CURRENT_BLR ENDIF CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 0, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) IF (IFLAG.LT.0) GOTO 442 CALL ZMUMPS_BLR_UPD_PANEL_LEFT(A, LA, POSELT, & NFRONT, IW(IOLDPS+XXF), 1, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, ACC_LUA, & NB_BLR, NPARTSASS, NELIM, & 1, 0, & .FALSE., IFLAG, IERROR, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & KEEP(480), KEEP(479), KEEP(478), KEEP(476), & KEEP(483), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & KEEP8, & FIRST_BLOCK=FIRST_BLOCK) 442 CONTINUE ENDIF 444 CONTINUE ELSE CALL ZMUMPS_BLR_UPDATE_TRAILING(A, LA, POSELT, & IFLAG, IERROR, NFRONT, & BEGS_BLR, BEGS_BLR, CURRENT_BLR, BLR_L, NB_BLR, & BLR_U, NB_BLR, & NELIM,.FALSE., 0, & 1, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 400 IF (KEEP(486).NE.2) THEN LAST_BLOCK = NB_BLR ELSEIF(UU.GT.0) THEN LAST_BLOCK = NPARTSASS ELSE LAST_BLOCK = CURRENT_BLR ENDIF IF (LRTRSM_OPTION.GT.0) THEN FIRST_BLOCK = CURRENT_BLR+1 CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_L, CURRENT_BLR, 'V', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) #if defined(BLR_MT) #endif ENDIF IF (LRTRSM_OPTION.GE.2) THEN IF (LRTRSM_OPTION.EQ.2) THEN FIRST_BLOCK = NPARTSASS+1 ELSE FIRST_BLOCK = CURRENT_BLR+1 ENDIF CALL ZMUMPS_DECOMPRESS_PANEL(A, LA, POSELT, NFRONT, & NFRONT, .TRUE., & BEGS_BLR(CURRENT_BLR), & BEGS_BLR(CURRENT_BLR+1), & NB_BLR, BLR_U, CURRENT_BLR, 'H', 1, & BEG_I_IN=FIRST_BLOCK, END_I_IN=LAST_BLOCK) ENDIF 400 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_LRGAIN(BLR_U, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'H') CALL UPD_MRY_LU_LRGAIN(BLR_L, & NB_BLR-CURRENT_BLR-NPARTSCB, & NPARTSCB, 'V') IF (KEEP(486).EQ.3) THEN IF (KEEP(480).EQ.0) THEN CALL DEALLOC_BLR_PANEL (BLR_U, NB_BLR-CURRENT_BLR, KEEP8) CALL DEALLOC_BLR_PANEL (BLR_L, NB_BLR-CURRENT_BLR, KEEP8) DEALLOCATE(BLR_U,BLR_L) ENDIF ENDIF NULLIFY(BLR_L) NULLIFY(BLR_U) ENDIF IF ( OOC_EFF_AND_WRITE_BYPANEL ) THEN IF (PIVOT_OPTION.LT.4) THEN TYPEF_LOC = TYPEF_U ELSE TYPEF_LOC = TYPEF_BOTH_LU ENDIF MonBloc%LastPiv= IW(IOLDPS+1+XSIZE) STRAT = STRAT_TRY_WRITE LAST_CALL = .FALSE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_LOC, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC,LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF ENDIF 100 CONTINUE END DO IF (LR_ACTIVATED) THEN IBEG_BLR = IW(IOLDPS+1+KEEP(IXSZ)) + 1 BEGS_BLR( CURRENT_BLR + 1 ) = IBEG_BLR IF ( & (KEEP(486).EQ.2) & ) THEN CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) IF (UU.GT.0) THEN allocate(BEGS_BLR_TMP(NB_BLR+1),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR+1 GOTO 500 ENDIF DO IP=1,NB_BLR+1 BEGS_BLR_TMP(IP) = BEGS_BLR_STATIC(IP) ENDDO ENDIF ENDIF MEM_TOT = 0 #if defined(BLR_MT) !$OMP PARALLEL !$OMP& PRIVATE(IP, LorU, DIR, NELIM_LOC) #endif IF ( & (KEEP(486).EQ.2) & ) THEN #if defined(BLR_MT) !$OMP DO PRIVATE(DIAG, DIAGSIZ_STA, DIAGSIZ_DYN, DPOS, POSELT_DIAG, MEM, !$OMP& allocok) !$OMP& REDUCTION(+:MEM_TOT) #endif DO IP=1,NPARTSASS IF (IFLAG.LT.0) CYCLE DIAGSIZ_DYN = BEGS_BLR(IP+1)-BEGS_BLR(IP) DIAGSIZ_STA = BEGS_BLR_STATIC(IP+1)-BEGS_BLR(IP) MEM = DIAGSIZ_DYN*(2*DIAGSIZ_STA-DIAGSIZ_DYN) MEM_TOT = MEM_TOT + MEM ALLOCATE(DIAG(MEM), stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = MEM CYCLE ENDIF DPOS = 1 POSELT_DIAG = POSELT + int(BEGS_BLR(IP)-1,8)*int(NFRONT,8) & + int(BEGS_BLR(IP)-1,8) DO I=1,DIAGSIZ_STA IF (I.LE.DIAGSIZ_DYN) THEN DIAG(DPOS:DPOS+DIAGSIZ_STA-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_STA-1,8)) DPOS = DPOS + DIAGSIZ_STA ELSE DIAG(DPOS:DPOS+DIAGSIZ_DYN-1) = & A(POSELT_DIAG:POSELT_DIAG+int(DIAGSIZ_DYN-1,8)) DPOS = DPOS + DIAGSIZ_DYN ENDIF POSELT_DIAG = POSELT_DIAG + int(NFRONT,8) ENDDO CALL ZMUMPS_BLR_SAVE_DIAG_BLOCK( & IW(IOLDPS+XXF), & IP, DIAG) ENDDO #if defined(BLR_MT) !$OMP ENDDO !$OMP SINGLE #endif IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) KEEP8(70) = max(KEEP8(71), KEEP8(70)) KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) KEEP8(74) = max(KEEP8(74), KEEP873COPY) ELSE !$OMP ATOMIC CAPTURE KEEP8(69) = KEEP8(69) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(69) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(68) = max(KEEP8TMPCOPY, KEEP8(68)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(71) = KEEP8(71) + int(MEM_TOT,8) KEEP8TMPCOPY = KEEP8(71) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(70) = max(KEEP8TMPCOPY, KEEP8(70)) !$OMP END ATOMIC !$OMP ATOMIC CAPTURE KEEP8(73) = KEEP8(73) + int(MEM_TOT,8) KEEP873COPY = KEEP8(73) !$OMP END ATOMIC !$OMP ATOMIC UPDATE KEEP8(74) = max(KEEP8(74), KEEP873COPY) !$OMP END ATOMIC ENDIF IF ( KEEP873COPY .GT. KEEP8(75) ) THEN IFLAG = -19 CALL MUMPS_SET_IERROR( & (KEEP873COPY-KEEP8(75)), IERROR) ENDIF #if defined(BLR_MT) !$OMP END SINGLE #endif IF (IFLAG.LT.0) GOTO 447 IF (UU.GT.0) THEN DO IP=1,NPARTSASS NELIM_LOC = BEGS_BLR_TMP(IP+1)-BEGS_BLR(IP+1) DO LorU=0,1 #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_PANEL_LORU( & IW(IOLDPS+XXF), LorU, IP, BLR_PANEL) CALL DEALLOC_BLR_PANEL(BLR_PANEL, NPARTSASS-IP, KEEP8) #if defined(BLR_MT) !$OMP END SINGLE #endif IF (LorU.EQ.0) THEN DIR = 'V' ELSE DIR = 'H' ENDIF CALL ZMUMPS_COMPRESS_PANEL(A, LA, POSELT, IFLAG, & IERROR, NFRONT, BEGS_BLR_TMP, & NB_BLR, DKEEP(8), KEEP(466), K473_LOC, & BLR_PANEL, IP, & DIR, WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM_LOC, & .FALSE., 0, 0, & 1, KEEP(483), KEEP8, & END_I_IN=NPARTSASS, FRSWAP=.TRUE. & ) #if defined(BLR_MT) !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 445 ENDDO #if defined(BLR_MT) !$OMP BARRIER !$OMP SINGLE #endif BEGS_BLR_TMP(IP+1) = BEGS_BLR(IP+1) #if defined(BLR_MT) !$OMP END SINGLE #endif ENDDO #if defined(BLR_MT) !$OMP BARRIER #endif 445 CONTINUE ENDIF 447 CONTINUE ENDIF IF (IFLAG .LT. 0) GOTO 450 IF (KEEP(480) .GE. 2) THEN #if defined(BLR_MT) !$OMP SINGLE #endif CALL ZMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW(IOLDPS+XXF), & BEGS_BLR_STATIC) #if defined(BLR_MT) !$OMP END SINGLE #endif CALL ZMUMPS_BLR_UPD_CB_LEFT(A, LA, POSELT, NFRONT, & BEGS_BLR_STATIC, BEGS_BLR_STATIC, & NPARTSCB, NPARTSCB, NPARTSASS, NASS, & IW(IOLDPS+XXF), & 1, .FALSE., IFLAG, IERROR, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477), & ACC_LUA, KEEP(480),KEEP(479),KEEP(478),KEEP(476), & KEEP(484), MAXI_CLUSTER, MAXI_RANK, & KEEP(474), 0, BLR_U, & .FALSE., & CB_LRB, KEEP8) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF IF (IFLAG.LT.0) GOTO 450 #if defined(BLR_MT) !$OMP MASTER #endif IF (COMPRESS_CB & .OR. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_SAVE_BEGS_BLR_DYN(IW(IOLDPS+XXF), & BEGS_BLR) ENDIF IF (COMPRESS_CB) THEN IEND_BLR = BEGS_BLR(CURRENT_BLR+2) IF ( IEND_BLR - IBEG_BLR + 1 .GT. MAXI_CLUSTER ) THEN MAXI_CLUSTER = IEND_BLR - IBEG_BLR + 1 LWORK = MAXI_CLUSTER*MAXI_CLUSTER DEALLOCATE(BLOCK, WORK, RWORK, TAU, JPVT) ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM),stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = OMP_NUM*(LWORK + MAXI_CLUSTER*(MAXI_CLUSTER+4)) ENDIF ENDIF ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 450 IF (COMPRESS_CB) THEN CALL ZMUMPS_COMPRESS_CB(A, LA, POSELT, NFRONT, & BEGS_BLR, BEGS_BLR, NPARTSCB, NPARTSCB, NPARTSASS, & NFRONT-NASS, NFRONT-NASS, INODE, & IW(IOLDPS+XXF), 0, 1, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), CB_LRB, & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, & -9999, -9999, -9999, KEEP(1), & NELIM=NELIM) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF 450 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF ( & ( & (KEEP(486).EQ.2) & ) & .AND.UU.GT.0 & ) THEN deallocate(BEGS_BLR_TMP) ENDIF IF (IFLAG.LT.0) GOTO 500 CALL UPD_MRY_LU_FR(NASS, NFRONT-NASS, 0, NASS-NPIV) CALL UPD_FLOP_FACTO_FR(NFRONT, NASS, NPIV, 0, 1) ENDIF IF ( (PIVOT_OPTION.LT.4) .AND. (.NOT.LR_ACTIVATED) ) THEN CALL ZMUMPS_FAC_FR_UPDATE_CBROWS( INODE, & NFRONT, NASS, (PIVOT_OPTION.LT.3), A, LA, LAFAC, POSELT, & IW, LIW, IOLDPS, MonBloc, MYID, NOFFW, & DET_EXPW, DET_MANTW, DET_SIGNW, & LIWFAC, & PP_FIRST2SWAP_L, PP_FIRST2SWAP_U, & LNextPiv2beWritten, UNextPiv2beWritten, & PP_LastPIVRPTRFilled_L, PP_LastPIVRPTRFilled_U, & & XSIZE, SEUIL, UU, DKEEP, KEEP8, KEEP, IFLAG, & OOC_EFFECTIVE_ON_FRONT, NVSCHUR ) ENDIF IF (KEEP(486).NE.0) THEN IF (.NOT.LR_ACTIVATED) THEN CALL UPD_FLOP_FRFRONTS(NFRONT, NPIV, NASS, 0, 1) ENDIF ENDIF IF ( OOC_EFFECTIVE_ON_FRONT ) THEN STRAT = STRAT_WRITE_MAX MonBloc%Last = .TRUE. MonBloc%LastPiv = IW(IOLDPS+1+XSIZE) LAST_CALL = .TRUE. CALL ZMUMPS_OOC_IO_LU_PANEL & ( STRAT, TYPEF_BOTH_LU, & A(POSELT), LAFAC, MonBloc, & LNextPiv2beWritten, UNextPiv2beWritten, & IW(IOLDPS), LIWFAC, & MYID, KEEP8(31), IFLAG_OOC, LAST_CALL ) IF (IFLAG_OOC < 0 ) THEN IFLAG=IFLAG_OOC GOTO 500 ENDIF CALL ZMUMPS_OOC_PP_TRYRELEASE_SPACE (IWPOS, & IOLDPS, IW, LIW, MonBloc , NFRONT, KEEP) ENDIF GOTO 600 490 CONTINUE 500 CONTINUE 600 CONTINUE IF (LR_ACTIVATED) THEN IF (allocated(WORK)) deallocate(WORK) IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(TAU)) deallocate(TAU) IF (allocated(JPVT)) deallocate(JPVT) IF (allocated(BLOCK)) deallocate(BLOCK) IF (associated(ACC_LUA)) THEN IF (KEEP(480).GE.3) THEN DO MY_NUM=1,OMP_NUM CALL DEALLOC_LRB(ACC_LUA(MY_NUM),KEEP8) ENDDO ENDIF DEALLOCATE(ACC_LUA) NULLIFY(ACC_LUA) ENDIF IF (associated(BEGS_BLR)) THEN DEALLOCATE(BEGS_BLR) NULLIFY(BEGS_BLR) ENDIF ENDIF IF (LR_ACTIVATED.AND.(KEEP(480).NE.0)) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & ) THEN CALL ZMUMPS_BLR_FREE_ALL_PANELS(IW(IOLDPS+XXF), 2, & KEEP8) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (.NOT. & ( & (KEEP(486).EQ.2) & ) & .AND..NOT.COMPRESS_CB) THEN CALL ZMUMPS_BLR_END_FRONT(IW(IOLDPS+XXF), IFLAG, KEEP8, & MTK405=KEEP(405)) ENDIF ENDIF NPVW = NPVW + IW(IOLDPS+1+XSIZE) END SUBROUTINE ZMUMPS_FAC1_LU END MODULE ZMUMPS_FAC1_LU_M MUMPS_5.4.1/src/dsol_bwd.F0000664000175000017500000001504114102210522015407 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_SOL_S(N, A, LA, IW, LIW, W, LWC, & NRHS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, DAD, FILS, IPOOL, LPOOL, PTRIST, PTRFAC, & MYLEAF, MYROOT, ICNTL, INFO, & PROCNODE_STEPS, & SLAVEF, COMM,MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & ) USE DMUMPS_STATIC_PTR_M, ONLY : DMUMPS_SET_STATIC_PTR, & DMUMPS_GET_TMP_PTR IMPLICIT NONE INTEGER MTYPE INTEGER(8), intent(in) :: LA INTEGER(8), intent(in) :: LWC INTEGER, intent(in) :: N,LIW,LIWW,LPOOL INTEGER, intent(in) :: SLAVEF,MYLEAF,MYROOT,COMM,MYID INTEGER KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER NE_STEPS(KEEP(28)) INTEGER IPOOL(LPOOL) INTEGER LPANEL_POS INTEGER PANEL_POS(LPANEL_POS) INTEGER ICNTL(60), INFO(80) INTEGER PTRIST(KEEP(28)), & PTRICB(KEEP(28)) INTEGER(8) :: PTRACB(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER NRHS DOUBLE PRECISION A(LA), W(LWC) DOUBLE PRECISION W2(KEEP(133)) INTEGER IW(LIW),IWCB(LIWW) INTEGER STEP(N), FRERE(KEEP(28)),DAD(KEEP(28)),FILS(N) INTEGER LBUFR, LBUFR_BYTES INTEGER BUFR(LBUFR) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER LRHSCOMP, POSINRHSCOMP_BWD(N) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER(8), intent(in) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) LOGICAL, INTENT(in) :: PRUN_BELOW INTEGER, intent(in) :: SIZE_TO_PROCESS LOGICAL, intent(in) :: TO_PROCESS(SIZE_TO_PROCESS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' LOGICAL FLAG DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER(8) :: POSWCB, PLEFTW INTEGER POSIWCB INTEGER NBFINF INTEGER INODE INTEGER III,IIPOOL,MYLEAF_LEFT LOGICAL BLOQ INTEGER DUMMY(1) LOGICAL :: ERROR_WAS_BROADCASTED, DO_MCAST2_TERMBWD LOGICAL :: ALLOW_OTHERS_TO_LEAVE LOGICAL, DIMENSION(:), ALLOCATABLE :: DEJA_SEND INTEGER :: allocok DUMMY(1)=0 KEEP(266)=0 ALLOCATE(DEJA_SEND( 0:SLAVEF-1 ), stat=allocok) if(allocok.ne.0) then WRITE(6,*) ' Allocation error of DEJA_SEND in ' & //'routine DMUMPS_SOL_S ' INFO(1)=-13 INFO(2)=SLAVEF endif CALL MUMPS_PROPINFO( ICNTL, INFO, COMM, MYID ) IF ( INFO(1) .LT.0 ) GOTO 340 PLEFTW = 1_8 POSIWCB = LIWW POSWCB = LWC III = 1 IIPOOL = MYROOT + 1 MYLEAF_LEFT = MYLEAF NBFINF = SLAVEF ALLOW_OTHERS_TO_LEAVE = ( MYLEAF_LEFT .EQ. 0 .AND. & KEEP(31) .EQ. 0 ) ALLOW_OTHERS_TO_LEAVE = ALLOW_OTHERS_TO_LEAVE .OR. & KEEP(31) .EQ. 1 IF (ALLOW_OTHERS_TO_LEAVE) THEN CALL DMUMPS_MCAST2(DUMMY, 1, MPI_INTEGER, MYID, COMM, TERMBWD, & SLAVEF, KEEP) NBFINF = NBFINF - 1 IF (NBFINF .EQ. 0 .AND. MYLEAF_LEFT .EQ. 0) THEN GOTO 340 ENDIF ENDIF ERROR_WAS_BROADCASTED = .FALSE. DO_MCAST2_TERMBWD = .FALSE. DO WHILE ( NBFINF .NE. 0 .OR. MYLEAF_LEFT .NE. 0 ) BLOQ = ( III .EQ. IIPOOL ) CALL DMUMPS_BACKSLV_RECV_AND_TREAT( BLOQ, FLAG, BUFR, LBUFR, & LBUFR_BYTES, MYID, SLAVEF, COMM, & N, IWCB, LIWW, POSIWCB, & W, LWC, POSWCB, & IIPOOL, NBFINF, PTRICB, PTRACB, INFO, & IPOOL, LPOOL, PANEL_POS, LPANEL_POS, & STEP, FRERE, FILS, PROCNODE_STEPS, & PLEFTW, KEEP,KEEP8, DKEEP, & PTRIST, PTRFAC, IW, LIW, A, LA, W2, MYLEAF_LEFT, & NRHS, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD & , PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , FROM_PP & ) IF ( INFO(1) .LT. 0 ) GOTO 340 IF ( .NOT. FLAG ) THEN IF (III .NE. IIPOOL) THEN INODE = IPOOL(IIPOOL-1) IIPOOL = IIPOOL - 1 CALL DMUMPS_SET_STATIC_PTR(A) CALL DMUMPS_GET_TMP_PTR(A_PTR) LA_PTR = LA CALL DMUMPS_SOLVE_NODE_BWD( INODE, & N, IPOOL, LPOOL, IIPOOL, NBFINF, & A_PTR(1), LA_PTR, IW, LIW, W, LWC, NRHS, & POSWCB, PLEFTW, POSIWCB, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_BWD, & PTRICB, PTRACB, IWCB, LIWW, W2, & NE_STEPS, STEP, & FRERE, FILS, PTRIST, PTRFAC, & MYLEAF_LEFT, INFO, & PROCNODE_STEPS, DEJA_SEND, & SLAVEF, COMM, MYID, BUFR, LBUFR, LBUFR_BYTES, & KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, PANEL_POS, LPANEL_POS, & PRUN_BELOW, TO_PROCESS, SIZE_TO_PROCESS & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & , DO_MCAST2_TERMBWD & ) IF ( INFO(1) .LT. 0 ) THEN IF (.NOT. ERROR_WAS_BROADCASTED) THEN IF (NBFINF .EQ. 0 ) THEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ENDIF ENDIF ENDIF IF (DO_MCAST2_TERMBWD) THEN CALL DMUMPS_MCAST2( DUMMY, 1, MPI_INTEGER, MYID, COMM, & TERMBWD, SLAVEF, KEEP ) ENDIF ENDIF END IF ENDDO 340 CONTINUE IF (ALLOCATED(DEJA_SEND)) DEALLOCATE(DEJA_SEND) RETURN END SUBROUTINE DMUMPS_SOL_S MUMPS_5.4.1/src/dfac_mem_stack_aux.F0000664000175000017500000001553214102210522017414 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE DMUMPS_COMPACT_FACTORS(A, LDA, NPIV, NBROW, K50, & SIZEA ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 INTEGER(8), INTENT(IN) :: SIZEA DOUBLE PRECISION A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500 IF ( K50.NE.0 ) THEN IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN INEW = INEW + int(NPIV,8) * int(NPIV - 1,8) IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8) ELSE DO I = 1, NPIV - 1 IF ( I .LE. NPIV-2 ) THEN ILAST = I+1 ELSE ILAST = I ENDIF DO J8 = 0_8, int(ILAST,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) END DO ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW ELSE INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8) IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8) NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1 ENDIF DO I = 1, NBROW_L_RECTANGLE_TO_MOVE DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) ENDDO 500 RETURN END SUBROUTINE DMUMPS_COMPACT_FACTORS SUBROUTINE DMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA DOUBLE PRECISION, INTENT(INOUT) :: A(SIZEA) INTEGER I, J INTEGER(8) :: INEW, IOLD INEW = int(NPIV+1,8) IOLD = int(LDA+1,8) DO I = 2, NCONTIG DO J = 1, NPIV A(INEW)=A(IOLD) INEW = INEW + 1_8 IOLD = IOLD + 1_8 ENDDO IOLD = IOLD + int(LDA - NPIV,8) ENDDO RETURN END SUBROUTINE DMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE DMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB DOUBLE PRECISION A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE DMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE DMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB DOUBLE PRECISION A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) DOUBLE PRECISION ZERO PARAMETER( ZERO = 0.0D0 ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE DMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.4.1/src/zana_reordertree.F0000664000175000017500000012350114102210524017150 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_REORDER_TREE(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K215,K234,K55,K199, & PROCNODE,SLAVEF, PEAK,SBTR_WHICH_M & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K215,K234,K55,K199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) INTEGER :: SBTR_WHICH_M EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DOUBLE PRECISION PEAK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: COST_TRAV INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,NSTK,INODE,I,allocok,LOCAL_PERM INTEGER(8) NCB INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER, DIMENSION (:), POINTER :: TAB INTEGER dernier,fin INTEGER cour,II INTEGER CB_current,CB_MAX,ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE,SUM,MEM_SEC_PERM,FACT_SIZE_T, & MEM_SIZE_T,TOTAL_MEM_SIZE,TMP_TOTAL_MEM_SIZE,TMP_SUM, & SIZECB, SIZECB_LASTSON INTEGER(8) TMP8 LOGICAL SBTR_M INTEGER FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF SBTR_M=.FALSE. MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.LT.0 .OR. PERM.GT.7)) THEN WRITE(*,*) "Internal Error in ZMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) RETURN IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN ALLOCATE(M(NSTEPS),stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error &in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), fact(NSTEPS),TNSTK(NSTEPS), & stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(PERM.EQ.7) THEN GOTO 001 ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN ALLOCATE(COST_TRAV(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error & in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL ZMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 91 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 96 CONTINUE NFR = int(ND(STEP(INODE)),8) NSTK = NE(STEP(INODE)) NELIM4 = 0 IN = INODE 101 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 101 NELIM=int(NELIM4,8) IF(NE(STEP(INODE)).EQ.0) THEN M(STEP(INODE))=NFR*NFR IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(INODE))=NFR*NFR ENDIF ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.3))THEN IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN DEPTH(STEP(INODE))=0 ENDIF ENDIF IF ( SYM .eq. 0 ) THEN fact(STEP(INODE))=fact(STEP(INODE))+ & (2_8*NFR*NELIM)-(NELIM*NELIM) ELSE fact(STEP(INODE))=fact(STEP(INODE))+NFR*NELIM ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 113 IN = FRERE(IN) IF (IN.GT.0) GO TO 113 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 116 GOTO 91 ELSE fact(STEP(IFATH))=fact(STEP(IFATH))+fact(STEP(INODE)) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEPTH(STEP(IFATH))=max(DEPTH(STEP(INODE)), & DEPTH(STEP(IFATH))) ENDIF ENDIF TNSTK(STEP(IFATH)) = TNSTK(STEP(IFATH)) - 1 IF ( TNSTK(STEP(IFATH)) .EQ. 0 ) THEN INODE = IFATH IN=INODE dernier=IN I=1 5700 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN I=I+1 GOTO 5700 ENDIF NCB=int(ND(STEP(INODE))-I,8) IN=-IN IF(PERM.NE.7)THEN DO I=1,NE(STEP(INODE)) SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ELSE DO I=NE(STEP(INODE)),1,-1 SON(I)=IN TEMP(I)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) ENDDO ENDIF NFR = int(ND(STEP(INODE)),8) DO II=1,NE(STEP(INODE)) TAB1(II)=0_8 TAB2(II)=0_8 cour=SON(II) NELIM4=1 151 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 151 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0)) THEN SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(SON(II))),8)-NELIM) & *(int(ND(STEP(SON(II))),8)- & NELIM+1_8)/2_8 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.5))THEN IF (K234 .NE. 0 .AND. K55.EQ.0 ) THEN TMP8=NFR TMP8=TMP8*TMP8 TAB1(II)=max(TMP8, M(STEP(SON(II)))) - SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))- SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF((PERM.EQ.1).OR.(PERM.EQ.6)) THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB1(II)=TAB1(II)-fact(STEP(SON(II))) TAB2(II)=SIZECB+fact(STEP(SON(II))) ENDIF IF(PERM.EQ.2)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M_TOTAL(STEP(SON(II)))-SIZECB & -fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ENDIF ENDIF IF(PERM.EQ.3)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))-SIZECB TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF IF(PERM.EQ.4)THEN IF (MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & K199))THEN TAB1(II)=M(STEP(SON(II)))- & SIZECB-fact(STEP(SON(II))) TAB2(II)=SIZECB ELSE TAB1(II)=int(DEPTH(STEP(SON(II))),8) TAB2(II)=M(STEP(SON(II))) ENDIF ENDIF ENDDO CALL ZMUMPS_FUSION_SORT(SON,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) IF(PERM.EQ.0) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 153 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 153 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB ENDDO CALL ZMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF IF(PERM.EQ.1) THEN DO II=1,NE(STEP(INODE)) cour=TEMP(II) NELIM4=1 187 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 187 ENDIF NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM) ELSE SIZECB=(int(ND(STEP(TEMP(II))),8)-NELIM)* & (int(ND(STEP(TEMP(II))),8)-NELIM+1_8)/2_8 ENDIF TAB1(II)=SIZECB+fact(STEP(TEMP(II))) ENDDO CALL ZMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2,3, & RESULT,T1,T2) ENDIF CONTINUE IFATH=INODE DO II=1,2 SUM=0_8 FACT_SIZE=0_8 FACT_SIZE_T=0_8 MEM_SIZE=0_8 MEM_SIZE_T=0_8 CB_MAX=0 CB_current=0 TMP_SUM=0_8 IF(II.EQ.1) TAB=>SON IF(II.EQ.2) TAB=>TEMP DO I=1,NE(STEP(INODE)) cour=TAB(I) NELIM4=1 149 cour=FILS(cour) IF(cour.GT.0) THEN NELIM4=NELIM4+1 GOTO 149 ENDIF NELIM=int(NELIM4, 8) NFR=int(ND(STEP(TAB(I))),8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF MEM_SIZE=max(MEM_SIZE,(M(STEP(TAB(I)))+SUM+FACT_SIZE)) IF (SBTR_M.OR.(PERM.EQ.2)) THEN MEM_SIZE_T=max(MEM_SIZE_T,(M_TOTAL(STEP(TAB(I)))+ & SUM+ & FACT_SIZE_T)) FACT_SIZE_T=FACT_SIZE_T+fact(STEP(TAB(I))) ENDIF TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & (M(STEP(TAB(I)))+SUM+FACT_SIZE)) TMP_SUM=TMP_SUM+fact(STEP(TAB(I))) SUM=SUM+SIZECB SIZECB_LASTSON = SIZECB IF((PERM.EQ.1).OR.(PERM.EQ.4))THEN FACT_SIZE=FACT_SIZE+fact(STEP(TAB(I))) ENDIF ENDDO IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=NCB*NCB ELSE SIZECB=(NCB*(NCB+1_8))/2_8 ENDIF IF (K234.NE.0 .AND. K55.EQ.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM-SIZECB_LASTSON+TMP_SUM ) & ) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8) ) & + SUM + TMP_SUM ) & ) ELSE TOTAL_MEM_SIZE=max(TOTAL_MEM_SIZE, & ( ( int(ND(STEP(IFATH)),8) & * int(ND(STEP(IFATH)),8)) & + max(SUM,SIZECB) + TMP_SUM ) & ) ENDIF IF(II.EQ.1)THEN TMP_TOTAL_MEM_SIZE=TOTAL_MEM_SIZE ENDIF IF(II.EQ.1)THEN IF (K234.NE.0 .AND. K55.EQ.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM-SIZECB_LASTSON+ & FACT_SIZE)) ELSE IF (K234.NE.0 .AND. K55.NE.0) THEN M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+SUM+FACT_SIZE)) ELSE M(STEP(IFATH))=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN M_TOTAL(STEP(IFATH))=max(MEM_SIZE_T, & ((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+ & FACT_SIZE_T)) ENDIF ENDIF IF((II.EQ.2).AND.(PERM.EQ.1).OR.(PERM.EQ.0).OR. & (PERM.EQ.5).OR.(PERM.EQ.6).OR. & (.NOT.SBTR_M.OR.(SBTR_WHICH_M.NE.1)))THEN MEM_SEC_PERM=max(MEM_SIZE,((int(ND(STEP(IFATH)),8) & *int(ND(STEP(IFATH)),8))+max(SUM,SIZECB)+FACT_SIZE)) ENDIF IF((PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4))THEN MEM_SEC_PERM=huge(MEM_SEC_PERM) ENDIF ENDDO IF(MEM_SEC_PERM.EQ.M(STEP(IFATH))) THEN TAB=>TEMP ELSE IF (MEM_SEC_PERM.LT.M(STEP(IFATH))) THEN WRITE(*,*)'Internal error 1 in ZMUMPS_REORDER_TREE', & MEM_SEC_PERM, M(STEP(IFATH)) CALL MUMPS_ABORT() ELSE TOTAL_MEM_SIZE=TMP_TOTAL_MEM_SIZE TAB=>SON ENDIF DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 222 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 222 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 222 ENDIF 222 CONTINUE ENDDO GOTO 96 ELSE GOTO 91 ENDIF 116 CONTINUE NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) IF (PERM.eq.1) THEN DO I=1,NBROOT TAB1(I)=M(STEP(NA(I+2+NBLEAF)))-fact(STEP(NA(I+2+NBLEAF))) TAB1(I)=-TAB1(I) ENDDO CALL ZMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) ENDIF 001 CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),K199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF ENDIF ENDIF DO I=1,NE(STEP(INODE)) TEMP(I)=IN IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 II = TEMP(I) 845 NELIM4 = NELIM4 + 1 II = FILS(II) IF (II .GT. 0 ) GOTO 845 NELIM=int(NELIM4,8) CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) TAB1(I)=int(dble(COST_NODE)+ & COST_TRAV(STEP(INODE)),8) TAB2(I)=0_8 ELSE SON(I)=IN ENDIF ELSE SON(I)=IN ENDIF IN=FRERE(STEP(IN)) ENDDO IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN IF((SLAVEF.NE.1).AND.(.NOT.MUMPS_IN_OR_ROOT_SSARBR( & PROCNODE(STEP(INODE)),K199)))THEN CALL ZMUMPS_FUSION_SORT(TEMP,NE(STEP(INODE)),TAB1,TAB2, & LOCAL_PERM & ,RESULT,T1,T2) TAB=>TEMP DO I=NE(STEP(INODE)),1,-1 IF(I.EQ.NE(STEP(INODE))) THEN FILS(dernier)=-TAB(I) dernier=TAB(I) GOTO 221 ENDIF IF(I.EQ.1) THEN FRERE(STEP(dernier))=TAB(I) FRERE(STEP(TAB(I)))=-INODE GOTO 221 ENDIF IF(I.GT.1) THEN FRERE(STEP(dernier))=TAB(I) dernier=TAB(I) GOTO 221 ENDIF 221 CONTINUE SON(NE(STEP(INODE))-I+1)=TAB(I) ENDDO ENDIF ENDIF DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(PERM.EQ.7) GOTO 5483 NBROOT=NA(2) NBLEAF=NA(1) PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO 5483 CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) IF(PERM.NE.7)THEN DEALLOCATE(M) ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF((PERM.EQ.5).OR.(PERM.EQ.6))THEN DEALLOCATE(COST_TRAV) ENDIF IF ((PERM.NE.7).AND.(SBTR_M.OR.(PERM.EQ.2))) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_REORDER_TREE SUBROUTINE ZMUMPS_BUILD_LOAD_MEM_INFO(N,FRERE, STEP, FILS, & NA,LNA,NE,ND, DAD, LDAD, USE_DAD, & NSTEPS,PERM,SYM,INFO,LP,K47,K81,K76,K215,K234,K55,KEEP199, & PROCNODE,MEM_SUBTREE,SLAVEF, SIZE_MEM_SBTR, PEAK & ,SBTR_WHICH_M,SIZE_DEPTH_FIRST,SIZE_COST_TRAV, & DEPTH_FIRST_TRAV,DEPTH_FIRST_SEQ,COST_TRAV,MY_FIRST_LEAF, & MY_NB_LEAF,MY_ROOT_SBTR,SBTR_ID & ) IMPLICIT NONE INTEGER N,PERM,SYM, NSTEPS, LNA, LP, SIZE_MEM_SBTR,LDAD INTEGER FRERE(NSTEPS), FILS(N), STEP(N) INTEGER NA(LNA), NE(NSTEPS), ND(NSTEPS) INTEGER K47,K81,K76,K215,K234,K55,KEEP199 INTEGER DAD(LDAD) LOGICAL USE_DAD INTEGER INFO(80) INTEGER SLAVEF,PROCNODE(NSTEPS) DOUBLE PRECISION, intent(out) :: MEM_SUBTREE(SIZE_MEM_SBTR,SLAVEF) INTEGER :: SBTR_WHICH_M INTEGER MY_FIRST_LEAF(SIZE_MEM_SBTR,SLAVEF), & MY_ROOT_SBTR(SIZE_MEM_SBTR,SLAVEF), & MY_NB_LEAF(SIZE_MEM_SBTR,SLAVEF) EXTERNAL MUMPS_ROOTSSARBR,MUMPS_PROCNODE LOGICAL MUMPS_ROOTSSARBR INTEGER MUMPS_PROCNODE DOUBLE PRECISION PEAK INTEGER SIZE_DEPTH_FIRST,DEPTH_FIRST_TRAV(SIZE_DEPTH_FIRST), & DEPTH_FIRST_SEQ(SIZE_DEPTH_FIRST) INTEGER SIZE_COST_TRAV INTEGER SBTR_ID(SIZE_DEPTH_FIRST),OOC_CUR_SBTR DOUBLE PRECISION COST_TRAV(SIZE_COST_TRAV) INTEGER, DIMENSION (:), ALLOCATABLE :: DEPTH INTEGER IFATH,IN,INODE,I,allocok,LOCAL_PERM INTEGER(8) NELIM,NFR INTEGER NFR4,NELIM4 INTEGER LEAF,NBLEAF,NBROOT, SIZE_TAB INTEGER, DIMENSION (:), ALLOCATABLE :: IPOOL,TNSTK INTEGER, DIMENSION (:), ALLOCATABLE,TARGET :: SON,TEMP INTEGER(8), DIMENSION (:), ALLOCATABLE :: M,M_TOTAL, fact INTEGER(8), DIMENSION (:), ALLOCATABLE :: TAB1,TAB2 INTEGER x,dernier,fin,RANK_TRAV INTEGER II INTEGER ROOT_OF_CUR_SBTR INTEGER(8), DIMENSION (:), ALLOCATABLE :: T1,T2 INTEGER, DIMENSION (:), ALLOCATABLE :: RESULT INTEGER(8) MEM_SIZE,FACT_SIZE, & TOTAL_MEM_SIZE, & SIZECB LOGICAL SBTR_M INTEGER,DIMENSION(:),ALLOCATABLE :: INDICE INTEGER ID,FIRST_LEAF,SIZE_SBTR EXTERNAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR LOGICAL MUMPS_IN_OR_ROOT_SSARBR,MUMPS_INSSARBR DOUBLE PRECISION COST_NODE INTEGER CUR_DEPTH_FIRST_RANK INCLUDE 'mumps_headers.h' TOTAL_MEM_SIZE=0_8 ROOT_OF_CUR_SBTR=0 ALLOCATE(INDICE( SLAVEF ), stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in &ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SLAVEF RETURN ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR. & (PERM.EQ.2).OR.(PERM.EQ.3).OR.(PERM.EQ.4).OR. & (PERM.EQ.5).OR.(PERM.EQ.6))THEN LOCAL_PERM=0 ENDIF IF (K47 == 4 .OR. ((K47.GE.2).AND.(K81.GE. 1))) THEN DO I=1,SLAVEF INDICE(I)=1 ENDDO DO I=1,SLAVEF DO x=1,SIZE_MEM_SBTR MEM_SUBTREE(x,I)=-1.0D0 ENDDO ENDDO ENDIF SBTR_M=((K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1)))) MEM_SIZE=0_8 FACT_SIZE=0_8 IF ((PERM.GT.7).AND. & (.NOT.(K47 == 4 .OR. ((K47.GE.2).AND.(K81 .GE. 1))))) THEN WRITE(*,*) "Internal Error in ZMUMPS_REORDER_TREE",PERM CALL MUMPS_ABORT() END IF NBLEAF = NA(1) NBROOT = NA(2) CUR_DEPTH_FIRST_RANK=1 IF((PERM.EQ.0).AND.(NBROOT.EQ.NBLEAF)) THEN DEALLOCATE(INDICE) RETURN ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN ALLOCATE(M_TOTAL(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ENDIF ENDIF ALLOCATE( IPOOL(NBLEAF), M(NSTEPS), fact(NSTEPS), & TNSTK(NSTEPS), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF II=0 DO I=1,NSTEPS TNSTK(I) = NE(I) IF(NE(I).GE.II) II=NE(I) ENDDO SIZE_TAB=max(II,NBROOT) ALLOCATE(SON(II), TEMP(II), & TAB1(SIZE_TAB), TAB2(SIZE_TAB), stat=allocok ) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF ALLOCATE(T1(SIZE_TAB),T2(SIZE_TAB), & RESULT(SIZE_TAB),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=SIZE_TAB RETURN ENDIF IF(NBROOT.EQ.NBLEAF)THEN IF((PERM.NE.1).OR.(PERM.EQ.4).OR.(PERM.EQ.6))THEN WRITE(*,*)'Internal Error in reordertree:' WRITE(*,*)' problem with perm parameter in reordertree' CALL MUMPS_ABORT() ENDIF DO I=1,NBROOT TAB1(I)=int(ND(STEP(NA(I+2+NBLEAF))),8) IPOOL(I)=NA(I+2+NBLEAF) M(STEP(IPOOL(I)))=TAB1(I)*TAB1(I) ENDDO CALL ZMUMPS_FUSION_SORT(NA(2+NBLEAF+1),NBROOT,TAB1,TAB2,4, & RESULT,T1,T2) GOTO 789 ENDIF IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN ALLOCATE(DEPTH(NSTEPS),stat=allocok) IF (allocok > 0) THEN IF ( LP .GT. 0 ) & WRITE(LP,*)'Memory allocation error in & ZMUMPS_REORDER_TREE' INFO(1)=-7 INFO(2)=NSTEPS RETURN ENDIF DEPTH=0 NBROOT = NA(2) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) fin=NBROOT LEAF=NA(1) 499 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IN=INODE 4602 IN = FILS(IN) IF (IN .GT. 0 ) THEN GOTO 4602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) SON(I)=IN IN=FRERE(STEP(IN)) ENDDO DO I=1,NE(STEP(INODE)) IPOOL(fin)=SON(I) DEPTH(STEP(SON(I)))=DEPTH(STEP(INODE))+1 SON(I)=0 fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN LEAF=LEAF-1 ELSE fin=fin-1 GOTO 499 ENDIF fin=fin-1 IF(fin.EQ.0) GOTO 489 GOTO 499 489 CONTINUE ENDIF IF(K76.EQ.4.OR.(K76.EQ.6))THEN RANK_TRAV=NSTEPS DEPTH_FIRST_TRAV=0 DEPTH_FIRST_SEQ=0 ENDIF IF((K76.EQ.5).OR.(PERM.EQ.5).OR.(PERM.EQ.6))THEN COST_TRAV=0.0D0 COST_NODE=0.0d0 ENDIF DO I=1,NSTEPS M(I)=0_8 IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN M_TOTAL(I)=0_8 ENDIF ENDIF ENDDO DO I=1,NSTEPS fact(I)=0_8 ENDDO NBROOT = NA(2) NBLEAF = NA(1) IPOOL(1:NBROOT) = NA(3+NBLEAF:2+NBLEAF+NBROOT) CONTINUE fin=NBROOT LEAF=NA(1) FIRST_LEAF=-9999 SIZE_SBTR=0 999 CONTINUE INODE=IPOOL(fin) IF(INODE.LT.0)THEN WRITE(*,*)'Internal Error in reordertree INODE < 0 !' CALL MUMPS_ABORT() ENDIF IF(SIZE_SBTR.NE.0)THEN IF(.NOT.MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN ROOT_OF_CUR_SBTR=INODE ENDIF IF (K76.EQ.4)THEN IF(SLAVEF.NE.1)THEN WRITE(*,*)'INODE=',INODE,'RANK',RANK_TRAV IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN DEPTH_FIRST_TRAV(STEP(INODE))=DEPTH_FIRST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE DEPTH_FIRST_TRAV(STEP(INODE))=RANK_TRAV ENDIF RANK_TRAV=RANK_TRAV-1 ENDIF ENDIF IF (K76.EQ.5)THEN IF(SLAVEF.NE.1)THEN IF (USE_DAD) THEN IFATH=DAD(INODE) ELSE IN = INODE 395 IN = FRERE(IN) IF (IN.GT.0) GO TO 395 IFATH = -IN ENDIF NFR4 = ND(STEP(INODE)) NFR = int(NFR4,8) NELIM4 = 0 IN = INODE 396 NELIM4 = NELIM4 + 1 IN = FILS(IN) IF (IN .GT. 0 ) GOTO 396 NELIM=int(NELIM4,8) IF((SYM.EQ.0).OR.(K215.NE.0))THEN SIZECB=(NFR-NELIM)*(NFR-NELIM) ELSE SIZECB=(NFR-NELIM)*(NFR-NELIM+1_8)/2_8 ENDIF CALL MUMPS_GET_FLOPS_COST(NFR4,NELIM4,NELIM4, & SYM,1,COST_NODE) IF(IFATH.NE.0)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN COST_TRAV(STEP(INODE))=COST_TRAV(STEP( & ROOT_OF_CUR_SBTR)) ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE)+ & COST_TRAV(STEP(IFATH))+ & dble(SIZECB*18_8) ENDIF ELSE COST_TRAV(STEP(INODE))=dble(COST_NODE) ENDIF IF(K76.EQ.5)THEN WRITE(*,*)'INODE=',INODE,'COST=',COST_TRAV(STEP(INODE)) ENDIF ENDIF ENDIF IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1).AND. & MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF (NE(STEP(INODE)).NE.0) THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF MY_ROOT_SBTR(INDICE(ID+1),ID+1)=INODE INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IF((SLAVEF.EQ.1).AND.FRERE(STEP(INODE)).EQ.0)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1))THEN MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M_TOTAL(STEP(INODE))) ELSE MEM_SUBTREE(INDICE(ID+1),ID+1)= & dble(M(STEP(INODE))) ENDIF INDICE(ID+1)=INDICE(ID+1)+1 ENDIF ENDIF IN=INODE 5602 IN = FILS(IN) IF (IN .GT. 0 ) THEN dernier=IN GOTO 5602 ENDIF IN=-IN DO I=1,NE(STEP(INODE)) IPOOL(fin)=IN IF(IN.GT.0) IN=FRERE(STEP(IN)) fin=fin+1 ENDDO IF(NE(STEP(INODE)).EQ.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF(SLAVEF.NE.1)THEN IF(MUMPS_INSSARBR(PROCNODE(STEP(INODE)),KEEP199))THEN IF(FIRST_LEAF.EQ.-9999)THEN FIRST_LEAF=INODE ENDIF SIZE_SBTR=SIZE_SBTR+1 ENDIF ENDIF ENDIF IF(PERM.NE.7)THEN NA(LEAF+2)=INODE ENDIF LEAF=LEAF-1 ELSE fin=fin-1 GOTO 999 ENDIF fin=fin-1 IF(fin.EQ.0) THEN IF(SIZE_SBTR.NE.0)THEN IF ( K47 == 4 .OR. ((K81.GE.1).AND.(K47.GE.2))) THEN IF((SLAVEF.NE.1))THEN MY_FIRST_LEAF(INDICE(ID+1)-1,ID+1)=FIRST_LEAF MY_NB_LEAF(INDICE(ID+1)-1,ID+1)=SIZE_SBTR FIRST_LEAF=-9999 SIZE_SBTR=0 ENDIF ENDIF ENDIF GOTO 789 ENDIF GOTO 999 789 CONTINUE IF(K76.EQ.6)THEN OOC_CUR_SBTR=1 DO I=1,NSTEPS TNSTK(I) = NE(I) ENDDO NBROOT=NA(2) NBLEAF=NA(1) IPOOL(1:NBLEAF)=NA(3:2+NBLEAF) LEAF = NBLEAF + 1 9100 CONTINUE IF (LEAF.NE.1) THEN LEAF = LEAF -1 INODE = IPOOL(LEAF) ENDIF 9600 CONTINUE IF(SLAVEF.NE.1)THEN ID=MUMPS_PROCNODE(PROCNODE(STEP(INODE)),KEEP199) DEPTH_FIRST_TRAV(STEP(INODE))=CUR_DEPTH_FIRST_RANK DEPTH_FIRST_SEQ(CUR_DEPTH_FIRST_RANK)=INODE CUR_DEPTH_FIRST_RANK=CUR_DEPTH_FIRST_RANK+1 IF(MUMPS_IN_OR_ROOT_SSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN SBTR_ID(STEP(INODE))=OOC_CUR_SBTR ELSE SBTR_ID(STEP(INODE))=-9999 ENDIF IF(MUMPS_ROOTSSARBR(PROCNODE(STEP(INODE)), & KEEP199))THEN OOC_CUR_SBTR=OOC_CUR_SBTR+1 ENDIF ENDIF IF (USE_DAD) THEN IFATH = DAD( STEP(INODE) ) ELSE IN = INODE 1133 IN = FRERE(IN) IF (IN.GT.0) GO TO 1133 IFATH = -IN ENDIF IF (IFATH.EQ.0) THEN NBROOT = NBROOT - 1 IF (NBROOT.EQ.0) GOTO 1163 GOTO 9100 ENDIF TNSTK(STEP(IFATH))=TNSTK(STEP(IFATH))-1 IF(TNSTK(STEP(IFATH)).EQ.0) THEN INODE=IFATH GOTO 9600 ELSE GOTO 9100 ENDIF 1163 CONTINUE ENDIF PEAK=0.0D0 FACT_SIZE=0_8 DO I=1,NBROOT PEAK=max(PEAK,dble(M(STEP(NA(2+NBLEAF+I))))) FACT_SIZE=FACT_SIZE+fact(STEP(NA(2+NBLEAF+I))) ENDDO CONTINUE DEALLOCATE(IPOOL) DEALLOCATE(M) DEALLOCATE(fact) DEALLOCATE(TNSTK) DEALLOCATE(SON) DEALLOCATE(TAB2) DEALLOCATE(TAB1) DEALLOCATE(T1) DEALLOCATE(T2) DEALLOCATE(RESULT) DEALLOCATE(TEMP) DEALLOCATE(INDICE) IF((PERM.EQ.3).OR.(PERM.EQ.4))THEN DEALLOCATE(DEPTH) ENDIF IF (SBTR_M.OR.(PERM.EQ.2)) THEN IF((SBTR_WHICH_M.EQ.1).AND.(PERM.NE.1).OR.(PERM.EQ.2))THEN DEALLOCATE(M_TOTAL) ENDIF ENDIF RETURN END SUBROUTINE ZMUMPS_BUILD_LOAD_MEM_INFO RECURSIVE SUBROUTINE ZMUMPS_FUSION_SORT(TAB,DIM,TAB1,TAB2,PERM, & RESULT,TEMP1,TEMP2) IMPLICIT NONE INTEGER DIM INTEGER(8) TAB1(DIM),TAB2(DIM) INTEGER(8) TEMP1(DIM),TEMP2(DIM) INTEGER TAB(DIM), PERM,RESULT(DIM) INTEGER I,J,I1,I2 IF(DIM.EQ.1) THEN RESULT(1)=TAB(1) TEMP1(1)=TAB1(1) TEMP2(1)=TAB2(1) RETURN ENDIF I=DIM/2 CALL ZMUMPS_FUSION_SORT(TAB(1),I,TAB1(1),TAB2(1),PERM, & RESULT(1),TEMP1(1),TEMP2(1)) CALL ZMUMPS_FUSION_SORT(TAB(I+1),DIM-I,TAB1(I+1),TAB2(I+1), & PERM,RESULT(I+1),TEMP1(I+1),TEMP2(I+1)) I1=1 I2=I+1 J=1 DO WHILE ((I1.LE.I).AND.(I2.LE.DIM)) IF((PERM.EQ.3))THEN IF(TEMP1(I1).LE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.4).OR.(PERM.EQ.5))THEN IF (TEMP1(I1).GE.TEMP1(I2))THEN TAB(J)=RESULT(I1) TAB1(J)=TEMP1(I1) J=J+1 I1=I1+1 ELSE TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) J=J+1 I2=I2+1 ENDIF GOTO 3 ENDIF IF((PERM.EQ.0).OR.(PERM.EQ.1).OR.(PERM.EQ.2)) THEN IF(TEMP1(I1).GT.TEMP1(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 GOTO 3 ENDIF IF(TEMP1(I1).LT.TEMP1(I2))THEN TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 GOTO 3 ENDIF IF((TEMP1(I1).EQ.TEMP1(I2)))THEN IF(TEMP2(I1).LE.TEMP2(I2))THEN TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ELSE TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) TAB(J)=RESULT(I2) J=J+1 I2=I2+1 ENDIF ENDIF ENDIF 3 CONTINUE ENDDO IF(I1.GT.I)THEN DO WHILE(I2.LE.DIM) TAB(J)=RESULT(I2) TAB1(J)=TEMP1(I2) TAB2(J)=TEMP2(I2) J=J+1 I2=I2+1 ENDDO ELSE IF(I2.GT.DIM)THEN DO WHILE(I1.LE.I) TAB1(J)=TEMP1(I1) TAB2(J)=TEMP2(I1) TAB(J)=RESULT(I1) J=J+1 I1=I1+1 ENDDO ENDIF ENDIF DO I=1,DIM TEMP1(I)=TAB1(I) TEMP2(I)=TAB2(I) RESULT(I)=TAB(I) ENDDO RETURN END SUBROUTINE ZMUMPS_FUSION_SORT MUMPS_5.4.1/src/fac_asm_build_sort_index_m.F0000664000175000017500000005057214102210475021153 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_BUILD_SORT_INDEX_M CONTAINS SUBROUTINE MUMPS_BUILD_SORT_INDEX( & MYID, INODE, N, IOLDPS, HF, LP, LPOK, & NFRONT, NFRONT_EFF, PERM, DAD, & NASS1, NASS, NUMSTK, NUMORG, IWPOSCB, IWPOS, & IFSON, STEP, PIMASTER, PTRIST, PTRAIW, IW, LIW, & INTARR, LINTARR, ITLOC, FILS, FRERE_STEPS, & SON_LEVEL2, NIV1, KEEP,KEEP8, IFLAG, & ISON_IN_PLACE, PROCNODE_STEPS, SLAVEF, & SONROWS_PER_ROW, LSONROWS_PER_ROW & ) IMPLICIT NONE INTEGER INODE, N, IOLDPS, HF, NFRONT, NASS1, LIW, NASS, & NUMSTK, NUMORG, IFSON, MYID, LP LOGICAL, intent(in) :: LPOK INTEGER, intent(in) :: ISON_IN_PLACE INTEGER KEEP(500) INTEGER(8) KEEP8(150) INTEGER(8), INTENT(IN) :: PTRAIW(N) INTEGER STEP(N), PIMASTER(KEEP(28)), PTRIST(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), FRERE_STEPS(KEEP(28)), & PERM(N) INTEGER, TARGET :: IW(LIW) INTEGER, INTENT(IN), TARGET :: IWPOSCB INTEGER, INTENT(IN) :: IWPOS INTEGER(8), INTENT(IN) :: LINTARR INTEGER :: INTARR(LINTARR) LOGICAL, intent(in) :: NIV1 INTEGER, intent(inout) :: IFLAG LOGICAL, intent(out) :: SON_LEVEL2 INTEGER, intent(out) :: NFRONT_EFF INTEGER, intent(in) :: DAD (KEEP(28)) INTEGER, intent(in) :: PROCNODE_STEPS(KEEP(28)), SLAVEF INTEGER, intent(in) :: LSONROWS_PER_ROW INTEGER, intent(out) :: SONROWS_PER_ROW(LSONROWS_PER_ROW) INTEGER NELIM_SON_IN_PLACE INTEGER NEWEL, IOLDP2, INEW, INEW1, & IN, NTOTFS, ICT11, NELIM, NPIVS, NSLSON, NCOLS, & ITRANS, J, JT1, ISON, IELL, LSTK, & NROWS, HS, IP1, IP2, IBROT, IORG, & I, K, ILOC, NEWEL_SAVE, NEWEL1_SAVE, & LAST_J_ASS, JMIN, MIN_PERM LOGICAL LEVEL1_SON INTEGER :: K1, K2, K3, KK INTEGER(8) :: J18, J28, JJ8, JDEBROW8 INTEGER INBPROCFILS_SON INTEGER TYPESPLIT INCLUDE 'mumps_headers.h' INTEGER, POINTER :: SON_IWPOSCB INTEGER, POINTER, DIMENSION(:) :: SON_IW INTEGER, POINTER, DIMENSION(:) :: PTTRI, PTLAST INTEGER :: LREQ, allocok INTEGER, ALLOCATABLE, TARGET :: TMP_ALLOC_ARRAY(:) INTEGER MUMPS_TYPESPLIT, MUMPS_TYPENODE EXTERNAL MUMPS_TYPESPLIT, MUMPS_TYPENODE IW(IOLDPS+XXNBPR) = 0 TYPESPLIT = MUMPS_TYPESPLIT (PROCNODE_STEPS(STEP(INODE)), & KEEP(199)) SON_LEVEL2 = .FALSE. IOLDP2 = IOLDPS + HF - 1 ICT11 = IOLDP2 + NFRONT NTOTFS = 0 NELIM_SON_IN_PLACE = 0 IF ( (TYPESPLIT.EQ.5).OR.(TYPESPLIT.EQ.6) ) THEN K2 = PIMASTER(STEP(IFSON)) LSTK = IW(K2 +KEEP(IXSZ)) NELIM = IW(K2 + 1+KEEP(IXSZ)) IF ( ISON_IN_PLACE > 0 ) THEN IF (ISON_IN_PLACE.NE.IFSON) THEN write(6,*) MYID, ':', & ' Internal error 1 in MUMPS_BUILD_SORT_INDEX ', & ' in place node is not the first son a interior split node ' CALL MUMPS_ABORT() ENDIF NELIM_SON_IN_PLACE = NELIM ENDIF NPIVS = IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF (NIV1) THEN write(6,*) MYID, ':', & ' Internal error 2 in MUMPS_BUILD_SORT_INDEX ', & ' interior split node of type 1 ' CALL MUMPS_ABORT() ENDIF I= MUMPS_TYPENODE(PROCNODE_STEPS(STEP(IFSON)),KEEP(199)) J= MUMPS_TYPESPLIT(PROCNODE_STEPS(STEP(IFSON)), & KEEP(199)) IF (LEVEL1_SON.or.J.LT.4) THEN write(6,*) MYID, ':', & ' Internal error 3 in MUMPS_BUILD_SORT_INDEX ', & ' son', IFSON, & ' of interior split node', INODE, ' of type 1 ', & ' NSLSON =', NSLSON, ' TYPE_SON=', I, 'TYPESPLIT_SON=', J CALL MUMPS_ABORT() ENDIF SON_IW => IW SON_IWPOSCB => IWPOSCB IF (K2 .GT. SON_IWPOSCB) THEN INBPROCFILS_SON = K2 + XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(IFSON))+XXNBPR ENDIF IW(IOLDPS+XXNBPR)=NSLSON SON_IW(INBPROCFILS_SON) = NSLSON SONROWS_PER_ROW(1:NFRONT-NASS1) = 1 IF ( K2.GT. IWPOSCB ) THEN NROWS = IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 IF (NELIM.GT.0) THEN DO KK=K1,K3 NTOTFS = NTOTFS + 1 JT1 = IW(KK) IW(ICT11 + NTOTFS) = JT1 IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(KK - ITRANS) ENDDO ENDIF DO KK =K3+1, K3+NUMORG NTOTFS = NTOTFS + 1 JT1 = IW(KK) ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO DO KK =K3+NUMORG+1, K2 NTOTFS = NTOTFS + 1 JT1 = IW(KK) ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(ICT11 + NTOTFS) = JT1 IW(IOLDP2 + NTOTFS) = JT1 ENDDO NFRONT_EFF = NTOTFS IBROT = INODE DO IORG = 1, NUMORG J18 = PTRAIW(IBROT) + 2 JT1 = INTARR(J18) INTARR(J18) = ITLOC(JT1) IBROT = FILS(IBROT) J28 = J18 + INTARR(J18 - 2) - INTARR(J18 - 1) J18 = J18 + 1 IF (J18 .LE. J28) THEN DO JJ8 = J18, J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDIF ENDDO K1 = IOLDPS+HF DO KK=K1+NELIM,K1+NFRONT_EFF-1 ITLOC(IW(KK)) = 0 ENDDO RETURN ENDIF LREQ= 2*NUMSTK+2 IF ((IWPOS + LREQ -1) .GT. IWPOSCB) THEN ALLOCATE(TMP_ALLOC_ARRAY(LREQ), stat=allocok) IF (allocok .GT. 0) THEN IFLAG = -13 GOTO 800 ENDIF PTTRI => TMP_ALLOC_ARRAY(1:NUMSTK+1) PTLAST => TMP_ALLOC_ARRAY(NUMSTK+2:LREQ) ELSE PTTRI => IW(IWPOS:IWPOS+NUMSTK) PTLAST => IW(IWPOS+NUMSTK+1:IWPOS+LREQ-1) ENDIF NFRONT_EFF = NASS1 IF ( ISON_IN_PLACE > 0 ) THEN ISON = ISON_IN_PLACE K2 = PIMASTER(STEP(ISON)) LSTK = IW(K2 +KEEP(IXSZ)) NELIM = IW(K2 + 1+KEEP(IXSZ)) NPIVS = IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = IW(K2 + 5+KEEP(IXSZ)) NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF ( K2 .GT. IWPOSCB ) THEN NROWS = IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 DO KK = K1, K3 NTOTFS = NTOTFS + 1 JT1 = IW(KK) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = IW(KK - ITRANS) ENDDO NELIM_SON_IN_PLACE = NTOTFS ENDIF IF (.NOT. NIV1) SONROWS_PER_ROW(1:NFRONT-NASS1) = 0 IN = INODE INEW = IOLDPS + HF + NTOTFS INEW1 = NTOTFS + 1 JDEBROW8 = PTRAIW(INODE)+3 PTTRI(NUMSTK+1) = 0 PTLAST(NUMSTK+1) = 0 + INTARR(JDEBROW8-3) - 1 50 CONTINUE J18 = PTRAIW(IN) + 2 JT1 = INTARR(J18) INTARR(J18) = INEW1 ITLOC(JT1) = INEW1 IW(INEW) = JT1 IW(INEW+NFRONT) = JT1 INEW = INEW + 1 INEW1 = INEW1 + 1 IN = FILS(IN) IF (IN .GT. 0) GOTO 50 NTOTFS = NTOTFS + NUMORG IF (NUMSTK .NE. 0) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB LSTK = SON_IW(K2 +KEEP(IXSZ)) NELIM = SON_IW(K2 + 1+KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3+KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5+KEEP(IXSZ)) IF( NSLSON.GT.0) SON_LEVEL2 = .TRUE. LEVEL1_SON = NSLSON.EQ.0 NCOLS = NPIVS + LSTK NROWS = NCOLS ITRANS = NROWS IF ( K2 .GT. SON_IWPOSCB ) THEN INBPROCFILS_SON = K2+XXNBPR ELSE INBPROCFILS_SON = PTRIST(STEP(ISON))+XXNBPR ENDIF IF (NIV1) THEN SON_IW(INBPROCFILS_SON) = NSLSON IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + NSLSON ELSE IF (LEVEL1_SON) THEN SON_IW(INBPROCFILS_SON) = 1 ELSE SON_IW(INBPROCFILS_SON) = NSLSON ENDIF IW(IOLDPS+XXNBPR) = IW(IOLDPS+XXNBPR) + & SON_IW(INBPROCFILS_SON) ENDIF IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ITRANS = NPIVS + NROWS ENDIF HS = NSLSON + 6 + KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 - KEEP(253) K3 = K1 + NELIM - 1 IF (NELIM .NE. 0 .AND. ISON.NE.ISON_IN_PLACE) THEN DO KK = K1, K3 NTOTFS = NTOTFS + 1 JT1 = SON_IW(KK) IW(ICT11 + NTOTFS) = JT1 ITLOC(JT1) = NTOTFS SON_IW(KK) = NTOTFS IW(IOLDP2 + NTOTFS) = SON_IW(KK - ITRANS) ENDDO ENDIF PTTRI(IELL) = K2+1 PTLAST(IELL) = K2 K1 = K3 + 1 IF (NASS1 .NE. NFRONT - KEEP(253)) THEN DO KK = K1, K2 J = SON_IW(KK) IF (ITLOC(J) .EQ. 0) THEN PTTRI(IELL) = KK EXIT ENDIF ENDDO ELSE DO KK = K1, K2 SON_IW(KK) = ITLOC(SON_IW(KK)) ENDDO DO KK=K2+1, K2+KEEP(253) SON_IW(KK)=NFRONT-KEEP(253)+KK-K2 ENDDO ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF IF (NFRONT-KEEP(253).EQ.NASS1) GOTO 500 199 CONTINUE IF ( PTTRI( NUMSTK + 1 ) .LE. PTLAST( NUMSTK + 1 ) ) THEN IF ( ITLOC( INTARR( JDEBROW8+PTTRI( NUMSTK + 1 ) ) ) .NE. 0 ) THEN PTTRI( NUMSTK + 1 ) = PTTRI( NUMSTK + 1 ) + 1 GOTO 199 END IF END IF MIN_PERM = N + 1 DO IELL = 1, NUMSTK SON_IW => IW ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( SON_IW( ILOC ) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( ILOC ) MIN_PERM = PERM( JMIN ) END IF END IF END DO IELL = NUMSTK + 1 ILOC = PTTRI( IELL ) IF ( ILOC .LE. PTLAST( IELL ) ) THEN IF ( PERM( INTARR( JDEBROW8+ILOC ) ) .LT. MIN_PERM ) THEN JMIN = INTARR( JDEBROW8+ILOC ) MIN_PERM = PERM( JMIN ) END IF END IF NEWEL = IOLDP2 + NASS1 + NFRONT DO WHILE ( MIN_PERM .NE. N + 1 ) NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = JMIN ITLOC( JMIN ) = NFRONT_EFF LAST_J_ASS = JMIN MIN_PERM = N + 1 DO IELL = 1, NUMSTK SON_IW => IW IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( SON_IW( PTTRI( IELL ) ) .eq. LAST_J_ASS ) & PTTRI( IELL ) = PTTRI( IELL ) + 1 ENDIF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( PERM(SON_IW( PTTRI( IELL )) ) .LT. MIN_PERM ) THEN JMIN = SON_IW( PTTRI( IELL ) ) MIN_PERM = PERM( JMIN ) END IF END IF END DO IELL = NUMSTK + 1 145 CONTINUE IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF ( INTARR( JDEBROW8+PTTRI( IELL ) ) .eq. LAST_J_ASS ) THEN PTTRI( IELL ) = PTTRI( IELL ) + 1 GOTO 145 END IF END IF IF ( PTTRI( IELL ) .LE. PTLAST( IELL ) ) THEN IF (PERM(INTARR( JDEBROW8+PTTRI(IELL) )) .LT. MIN_PERM) THEN JMIN = INTARR( JDEBROW8+PTTRI(IELL) ) MIN_PERM = PERM( JMIN ) END IF END IF END DO NEWEL_SAVE = NEWEL NEWEL1_SAVE = NFRONT_EFF IF (NEWEL1_SAVE.LT.NFRONT - KEEP(253)) THEN IBROT = INODE DO IORG = 1, NUMORG J18 = PTRAIW(IBROT) + 2 J28 = J18 + INTARR(J18 - 2) - INTARR(J18-1) IBROT = FILS( IBROT ) IF ( IORG.EQ. 1) THEN IF ( KEEP(50).NE.0 ) CYCLE J18 = J18 + 1 + INTARR(J18-2) ELSE J18 = J18 + 1 ENDIF DO JJ8 = J18, J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF ( (TYPESPLIT.EQ.4).AND. & (NFRONT_EFF.LT.NFRONT-KEEP(253)) ) THEN IBROT = INODE DO WHILE & ( & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.5 & ) & .OR. & ( MUMPS_TYPESPLIT & (PROCNODE_STEPS(STEP(DAD(STEP(IBROT)))),KEEP(199)) & .EQ.6 & ) & ) IBROT = DAD(STEP(IBROT)) IN = IBROT DO WHILE (IN.GT.0.AND.NFRONT_EFF.LT.NFRONT-KEEP(253)) J18 = PTRAIW(IN) + 2 J28 = J18 + INTARR(J18 - 2) - INTARR(J18-1) IN = FILS( IN ) DO JJ8 = J18, J28 J = INTARR( JJ8 ) IF ( ITLOC( J ) .eq. 0 ) THEN NEWEL = NEWEL + 1 NFRONT_EFF = NFRONT_EFF + 1 IW( NEWEL ) = J ITLOC( J ) = NFRONT_EFF END IF ENDDO ENDDO IF (NFRONT_EFF.EQ.NFRONT-KEEP(253)) EXIT ENDDO IF (NFRONT_EFF.NE.NFRONT-KEEP(253) .AND. & .NOT. (KEEP(376).EQ.1 .AND. KEEP(79) .GE.1)) THEN write(6,*) MYID, ': INODE', INODE, ' of type 4 ', & ' not yet fully assembled ', & ' NFRONT_EFF, NFRONT =', NFRONT_EFF, NFRONT CALL MUMPS_ABORT() ENDIF ENDIF ENDIF IF ( NEWEL1_SAVE .eq. NFRONT_EFF ) THEN DO KK=NASS1+1, NFRONT_EFF IW( IOLDP2+KK ) = IW( ICT11+KK ) ENDDO ELSE CALL MUMPS_SORT( N, PERM, & IW( NEWEL_SAVE + 1 ), NFRONT_EFF - NEWEL1_SAVE ) CALL MUMPS_SORTED_MERGE( N, NASS1, PERM, ITLOC, & IW( NEWEL_SAVE + 1), NFRONT_EFF - NEWEL1_SAVE, & IW( ICT11 + NASS1 + 1 ), NEWEL1_SAVE - NASS1, & IW( IOLDP2 + NASS1 + 1 ), NFRONT_EFF - NASS1 ) DO KK = NASS1+1, NFRONT_EFF IW(ICT11 + KK) = IW(IOLDP2+KK) ENDDO END IF 500 CONTINUE IF ( KEEP(253).GT.0) THEN IP1 = IOLDPS + HF + NFRONT_EFF IP2 = IOLDPS + HF + NFRONT + NFRONT_EFF DO I= 1, KEEP(253) IW(IP1+I-1) = N+I IW(IP2+I-1) = N+I ITLOC(N+I) = NFRONT_EFF + I ENDDO NFRONT_EFF = NFRONT_EFF + KEEP(253) ENDIF IF (NFRONT.GT.NFRONT_EFF) THEN IP1 = IOLDPS + NFRONT + HF IP2 = IOLDPS + NFRONT_EFF + HF DO I=1, NFRONT_EFF IW(IP2+I-1)=IW(IP1+I-1) ENDDO ELSE IF (NFRONT .LT. NFRONT_EFF) THEN IF (LPOK) THEN WRITE(LP,*) " Error in MUMPS_BUILD_SORT_INDEX:", & " matrix structure might have changed,", & " analysis (JOB=1) should be performed again ", & " NFRONTexpected, NFRONTeffective=", NFRONT, NFRONT_EFF ENDIF IFLAG = -53 GOTO 800 ENDIF IF ( NUMSTK .NE. 0 & .AND. (NFRONT-KEEP(253).GT.NASS1) & ) THEN ISON = IFSON DO IELL = 1, NUMSTK K2 = PIMASTER(STEP(ISON)) SON_IW => IW SON_IWPOSCB => IWPOSCB LSTK = SON_IW(K2+KEEP(IXSZ)) NELIM = SON_IW(K2 + 1 +KEEP(IXSZ)) NPIVS = SON_IW(K2 + 3 +KEEP(IXSZ)) IF (NPIVS.LT.0) NPIVS = 0 NSLSON = SON_IW(K2 + 5 +KEEP(IXSZ)) LEVEL1_SON = (NSLSON .EQ. 0) NCOLS = NPIVS + LSTK NROWS = NCOLS IF (K2.GT.SON_IWPOSCB) THEN NROWS = SON_IW(K2 + 2+KEEP(IXSZ)) ENDIF HS = NSLSON + 6 +KEEP(IXSZ) K1 = K2 + HS + NROWS + NPIVS K2 = K1 + LSTK - 1 K3 = K1 + NELIM - 1 K1 = K3 + 1 IF (NFRONT-KEEP(253).GT.NASS1) THEN DO KK = K1, K2 J = SON_IW(KK) SON_IW(KK) = ITLOC(J) IF (NIV1 .AND. NSLSON.EQ.0) THEN ELSE IF (SON_IW(KK) .LE. NASS1 .OR. NIV1) THEN ELSE SONROWS_PER_ROW(SON_IW(KK)-NASS1) = & SONROWS_PER_ROW(SON_IW(KK)-NASS1) + 1 ENDIF ENDIF ENDDO ELSE IF (.not. NIV1) THEN WRITE(*,*) "Internal error 1 in MUMPS_BUILD_SORT_INDEX" CALL MUMPS_ABORT() ENDIF IF (.not.LEVEL1_SON) THEN ENDIF ENDIF ISON = FRERE_STEPS(STEP(ISON)) ENDDO ENDIF IBROT = INODE DO IORG = 1, NUMORG J18 = PTRAIW(IBROT) + 2 IBROT = FILS(IBROT) J28 = J18 + INTARR(J18 - 2) - INTARR(J18 - 1) J18 = J18 + 1 DO JJ8 = J18, J28 J = INTARR(JJ8) INTARR(JJ8) = ITLOC(J) ENDDO ENDDO K1 = IOLDPS + HF K2 = K1 + NFRONT_EFF -1 IF (KEEP(50).EQ.0) K2 = K2 + NELIM_SON_IN_PLACE DO K = K1, K2 I = IW(K) ITLOC(I) = 0 ENDDO IF (KEEP(50).EQ.0) THEN K1 = IOLDPS+HF+NFRONT_EFF+NELIM_SON_IN_PLACE+NUMORG K2 = K1 + NASS -NELIM_SON_IN_PLACE - 1 DO K = K1, K2 I = IW(K) ITLOC(I) = 0 ENDDO ENDIF 800 CONTINUE IF (allocated(TMP_ALLOC_ARRAY)) DEALLOCATE(TMP_ALLOC_ARRAY) RETURN END SUBROUTINE MUMPS_BUILD_SORT_INDEX END MODULE MUMPS_BUILD_SORT_INDEX_M SUBROUTINE MUMPS_SORT( N, PERM, IW, LIW ) IMPLICIT NONE INTEGER N, LIW INTEGER PERM( N ), IW( LIW ) INTEGER I, SWAP LOGICAL DONE DONE = .FALSE. DO WHILE ( .NOT. DONE ) DONE = .TRUE. DO I = 1, LIW - 1 IF ( PERM( IW( I ) ) .GT. PERM( IW( I + 1 ) ) ) THEN DONE = .FALSE. SWAP = IW( I + 1 ) IW( I + 1 ) = IW( I ) IW( I ) = SWAP END IF END DO END DO RETURN END SUBROUTINE MUMPS_SORT SUBROUTINE MUMPS_SORTED_MERGE( N, NASS1, PERM, ITLOC, & SMALL, LSMALL, & LARGE, LLARGE, & MERGE, LMERGE ) IMPLICIT NONE INTEGER N, NASS1, LSMALL, LLARGE, LMERGE INTEGER PERM( N ), ITLOC( N ) INTEGER SMALL(LSMALL), LARGE(LLARGE), MERGE(LMERGE) INTEGER PSMALL, PLARGE, PMERGE, VSMALL, VLARGE, VMERGE PSMALL = 1 PLARGE = 1 PMERGE = 1 DO WHILE ( PSMALL .LE. LSMALL .or. PLARGE.LE. LLARGE ) IF ( PSMALL .GT. LSMALL ) THEN VMERGE = LARGE( PLARGE ) PLARGE = PLARGE + 1 ELSE IF ( PLARGE .GT. LLARGE ) THEN VMERGE = SMALL( PSMALL ) PSMALL = PSMALL + 1 ELSE VSMALL = SMALL( PSMALL ) VLARGE = LARGE( PLARGE ) IF ( PERM( VSMALL ) .LT. PERM( VLARGE ) ) THEN VMERGE = VSMALL PSMALL = PSMALL + 1 ELSE VMERGE = VLARGE PLARGE = PLARGE + 1 END IF END IF MERGE( PMERGE ) = VMERGE ITLOC( VMERGE ) = PMERGE + NASS1 PMERGE = PMERGE + 1 END DO PMERGE = PMERGE - 1 RETURN END SUBROUTINE MUMPS_SORTED_MERGE MUMPS_5.4.1/src/mumps_tags.h0000664000175000017500000001261014102210475016041 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C ----------------------------------------- C This file contains the definition C of all tags. C ----------------------------------------- C C --------------- C Tags for L0OMP C --------------- INTEGER F_IPOOLAFTER, F_PHYS_L0 PARAMETER ( F_IPOOLAFTER = 60, F_PHYS_L0 = 61 ) C ----------------- C Tag for grouping C ----------------- INTEGER GROUPING PARAMETER ( GROUPING = 49 ) C ---------------------------------------------- C Tag for LMAT distribution (analysis by block) C and for gathering graph C ---------------------------------------------- INTEGER LMATDIST, GATHERG_NZG, GATHERG_NB, & GATHERG_FIRST, GATHERG_IPE, GATHERG_ADJ PARAMETER ( LMATDIST = 43, GATHERG_NZG=44, GATHERG_NB=45, & GATHERG_FIRST=46, GATHERG_IPE=47, GATHERG_ADJ= 48) C ----------------------------------------- C Tag for arrowheads distribution C ----------------------------------------- INTEGER ARROWHEAD, ARR_INT, ARR_REAL, ELT_INT, ELT_REAL PARAMETER ( ARROWHEAD = 20, & ARR_INT = 29, & ARR_REAL = 30, & ELT_INT = 31, & ELT_REAL = 32 ) C ---------------------------------------------------- C Tags for collecting distributed integer info C for analysis in case of initial distributed matrix C ---------------------------------------------------- INTEGER COLLECT_NZ, COLLECT_IRN, COLLECT_JCN PARAMETER( COLLECT_NZ = 35, & COLLECT_IRN = 36, & COLLECT_JCN = 37 ) C ----------------------------------------- C Tags for factorization C ----------------------------------------- INTEGER RACINE, & NOEUD, & TERREUR, & MAITRE_DESC_BANDE, & MAITRE2, & BLOC_FACTO_RELAY, & CONTRIB_TYPE2, & MAPLIG, & FACTOR, & BLOC_FACTO PARAMETER ( RACINE = 2, & NOEUD = 3, & MAITRE_DESC_BANDE = 4, & MAITRE2 = 5, & BLOC_FACTO_RELAY = 6, & CONTRIB_TYPE2 = 7, & MAPLIG = 8, & FACTOR = 9, & BLOC_FACTO = 10, & TERREUR = 99 ) C ----------------------------------------- C Tags for assembly of root (in facto) C ----------------------------------------- INTEGER ROOT_NELIM_INDICES, & ROOT_CONT_STATIC, & ROOT_NON_ELIM_CB, & ROOT_2SLAVE, & ROOT_2SON PARAMETER( ROOT_NELIM_INDICES = 15, & ROOT_CONT_STATIC = 16, & ROOT_NON_ELIM_CB = 17, & ROOT_2SLAVE = 18, & ROOT_2SON = 19 ) C ----------------------------------------- C Tags for solve C ----------------------------------------- INTEGER RACINE_SOLVE, & ContVec, & Master2Slave, & GatherSol, & ScatterRhsI, & ScatterRhsR, & DistRhsI, & DistRhsR PARAMETER( RACINE_SOLVE = 14, & ContVec = 11, & Master2Slave = 12, & GatherSol = 13, & ScatterRhsI = 54, & ScatterRhsR = 55, & DistRhsI = 51, & DistRhsR = 52) INTEGER, PARAMETER :: DIST_RHS_INT = 56 INTEGER, PARAMETER :: DIST_RHS_SCALAR = 57 C ----------------------------------------- C Tags for backsolve C ----------------------------------------- INTEGER TERMBWD, & BACKSLV_UPDATERHS, & BACKSLV_MASTER2SLAVE PARAMETER( TERMBWD = 21, & BACKSLV_UPDATERHS = 22, & BACKSLV_MASTER2SLAVE = 23 ) C ------------------------ C Tag for symmetrization C ------------------------ INTEGER SYMMETRIZE PARAMETER ( SYMMETRIZE = 24 ) C ---------------------------- C Tags specific to symmetric C ---------------------------- INTEGER BLOC_FACTO_SYM, & BLOC_FACTO_SYM_SLAVE, END_NIV2_LDLT, & END_NIV2 PARAMETER ( BLOC_FACTO_SYM = 25, & BLOC_FACTO_SYM_SLAVE = 26, & END_NIV2_LDLT = 33, & END_NIV2 = 34 ) C ------------------------------------- C Tags specific to dynamic scheduling C ------------------------------------- INTEGER UPDATE_LOAD PARAMETER ( UPDATE_LOAD = 27 ) C To send deficientcy INTEGER DEFIC_TAG PARAMETER( DEFIC_TAG = 28 ) C To send Schur INTEGER TAG_SCHUR PARAMETER( TAG_SCHUR = 38 ) C To clean up IRECV INTEGER TAG_DUMMY PARAMETER( TAG_DUMMY = 39 ) C To send zero pivot indices INTEGER ZERO_PIV PARAMETER( ZERO_PIV = 40 ) C To send Singular values (if defined(try_null_space)) INTEGER TAG_ROOT1, TAG_ROOT2 PARAMETER( TAG_ROOT1 = 41 ) PARAMETER( TAG_ROOT2 = 42 ) C C Note: tags 100-160 are reserved for C the parallel scaling routine C MUMPS_5.4.1/src/dsol_fwd_aux.F0000664000175000017500000011702614102210522016276 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_TRAITER_MESSAGE_SOLVE & ( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, & PTRFAC, IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, & INFO, KEEP, KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) USE DMUMPS_OOC USE DMUMPS_SOL_LR, ONLY: DMUMPS_SOL_SLAVE_LR_U USE DMUMPS_BUF IMPLICIT NONE INTEGER LBUFR, LBUFR_BYTES INTEGER MSGTAG, MSGSOU, MYID, SLAVEF, COMM INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER N, NRHS, LPOOL, LEAF, NBFIN, LRHSCOMP INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S( N ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) INTEGER PTRICB(KEEP(28)),PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) DOUBLE PRECISION WCB( LWCB ), A( LA ) DOUBLE PRECISION RHSCOMP( LRHSCOMP, NRHS ) INTEGER, intent(in) :: POSINRHSCOMP_FWD(N) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER(8) :: PTRX, PTRY, IFR8 INTEGER IERR, K, JJ, JBDEB, JBFIN, NRHS_B INTEGER :: IWHDLR, LDA_SLAVE INTEGER :: MTYPE_SLAVE INTEGER FINODE, FPERE, LONG, NCB, POSITION, NCV, NPIV INTEGER PDEST, I, IPOSINRHSCOMP INTEGER J1 INTEGER(8) :: APOS LOGICAL DUMMY LOGICAL FLAG !$ LOGICAL :: OMP_FLAG EXTERNAL MUMPS_PROCNODE INTEGER MUMPS_PROCNODE LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR DOUBLE PRECISION ALPHA, ONE PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INCLUDE 'mumps_headers.h' IF ( MSGTAG .EQ. RACINE_SOLVE ) THEN NBFIN = NBFIN - 1 IF ( NBFIN .eq. 0 ) GOTO 270 ELSE IF (MSGTAG .EQ. ContVec ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LONG, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 IF ( NCB .eq. 0 ) THEN PTRICB(STEP(FINODE)) = -1 ELSE IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN PTRICB(STEP(FINODE)) = NCB + 1 END IF IF ( ( POSIWCB - LONG ) .LT. 0 ) THEN INFO( 1 ) = -14 INFO( 2 ) = LONG GOTO 260 END IF IF ( POSWCB - PLEFTWCB + 1_8 .LT. & int(LONG,8) * int(NRHS_B,8)) THEN INFO( 1 ) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8+ & int(LONG,8) * int(NRHS_B,8), & INFO(2)) GOTO 260 END IF IF (LONG .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IWCB( 1 ), & LONG, MPI_INTEGER, COMM, IERR ) DO K = 1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PLEFTWCB ), & LONG, MPI_DOUBLE_PRECISION, COMM, IERR ) DO I = 1, LONG IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(IWCB(I))) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) = & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) + & WCB(PLEFTWCB+I-1) ENDDO END DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - LONG ENDIF END IF IF ( PTRICB(STEP(FINODE)) == 1 .OR. & PTRICB(STEP(FINODE)) == -1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'Internal error 1 DMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSEIF ( MSGTAG .EQ. Master2Slave ) THEN POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FINODE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & FPERE, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NCV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPIV, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBDEB, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & JBFIN, 1, MPI_INTEGER, COMM, IERR ) NRHS_B = JBFIN-JBDEB+1 PTRY = PLEFTWCB PTRX = PLEFTWCB + int(NCV,8) * int(NRHS_B,8) PLEFTWCB = PLEFTWCB + int(NPIV + NCV,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(-POSWCB+PLEFTWCB-1_8,INFO(2)) GO TO 260 END IF DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRY + (K-1) * NCV ), NCV, & MPI_DOUBLE_PRECISION, COMM, IERR ) ENDDO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS_B CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & WCB( PTRX + (K-1)*NPIV ), NPIV, & MPI_DOUBLE_PRECISION, COMM, IERR ) END DO END IF LR_ACTIVATED = (IW(PTRIST(STEP(FINODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(FINODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (KEEP(201).GT.0.AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & FINODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,DUMMY,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF IF ( IW(PTRIST(STEP(FINODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(FINODE))+XXF) MTYPE_SLAVE = 1 CALL DMUMPS_SOL_SLAVE_LR_U( FINODE, IWHDLR, & -9999, & WCB, LWCB, & NPIV, NCV, & PTRX, PTRY, & JBDEB, JBFIN, & MTYPE_SLAVE, KEEP, & INFO(1), INFO(2) ) ELSE APOS = PTRFAC(STEP(FINODE)) IF (KEEP(201) .EQ. 1) THEN MTYPE_SLAVE = 0 LDA_SLAVE = NCV ELSE MTYPE_SLAVE = 1 LDA_SLAVE = NPIV ENDIF CALL DMUMPS_SOLVE_GEMM_UPDATE & ( A, LA, APOS, NPIV, & LDA_SLAVE, & NCV, & NRHS_B, WCB, LWCB, & PTRX, NPIV, & PTRY, NCV, & MTYPE_SLAVE, KEEP, ONE ) ENDIF IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(FINODE,PTRFAC, & KEEP(28),A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 GOTO 260 ENDIF ENDIF PLEFTWCB = PLEFTWCB - int(NPIV,8) * int(NRHS_B,8) PDEST = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) IF ( PDEST .EQ. MYID ) THEN IF ( PTRICB(STEP(FINODE)) .EQ. 0 ) THEN NCB = IW( PTRIST(STEP(FINODE)) + 2 + KEEP(IXSZ) ) PTRICB(STEP(FINODE)) = NCB + 1 END IF J1 = PTRIST(STEP(FINODE))+3+KEEP(IXSZ) !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (NCV*(JBFIN-JBDEB+1) .GE. KEEP(363) ) ) !$OMP PARALLEL DO PRIVATE(I,JJ,IFR8,IPOSINRHSCOMP) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = PTRY+int(K-1,8)*int(NCV,8) DO I = 1,NCV JJ = IW(J1+I) IPOSINRHSCOMP= abs(POSINRHSCOMP_FWD(JJ)) RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1)= & RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1) & + WCB(IFR8+int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO PTRICB(STEP(FINODE)) = PTRICB(STEP(FINODE)) - NCV IF ( PTRICB( STEP( FINODE ) ) == 1 ) THEN NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 PTRICB(STEP(FINODE)) = 0 END IF IF ( NSTK_S(STEP(FPERE)) .EQ. 0 ) THEN IPOOL( LEAF ) = FPERE LEAF = LEAF + 1 IF ( LEAF > LPOOL ) THEN WRITE(*,*) & 'INTERNAL Error in DMUMPS_TRAITER_MESSAGE_SOLVE', & LEAF, LPOOL CALL MUMPS_ABORT() END IF ENDIF ELSE 210 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, FINODE, FPERE, & IW(PTRIST(STEP( FINODE )) + 2 + KEEP(IXSZ) ), NCV,NCV, & IW(PTRIST(STEP(FINODE))+4+ KEEP(IXSZ) ), & WCB( PTRY ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, PDEST, ContVec, COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) GOTO 270 GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) GOTO 260 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = ( NCV + 4 ) * KEEP( 34 ) + & NCV * KEEP( 35 ) END IF END IF PLEFTWCB = PLEFTWCB - int(NCV,8) * int(NRHS_B,8) ELSEIF ( MSGTAG .EQ. TERREUR ) THEN INFO(1) = -001 INFO(2) = MSGSOU GOTO 270 ELSE IF ( (MSGTAG.EQ.UPDATE_LOAD).OR. & (MSGTAG.EQ.TAG_DUMMY) ) THEN GO TO 270 ELSE INFO(1)=-100 INFO(2)=MSGTAG GO TO 260 ENDIF GO TO 270 260 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) 270 CONTINUE RETURN END SUBROUTINE DMUMPS_TRAITER_MESSAGE_SOLVE SUBROUTINE DMUMPS_SOLVE_NODE_FWD( INODE, & LASTFSL0STA, LASTFSL0DYN, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, & IWCB, LIWCB, & WCB, LWCB, A, LA, IW, LIW, & NRHS, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, PTRIST, PTRFAC, PROCNODE_STEPS, & FILS, STEP, FRERE, DAD, & INFO, KEEP,KEEP8, DKEEP, RHS_ROOT, LRHS_ROOT, MTYPE, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD, & & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , RHS_BOUNDS, LRHS_BOUNDS, DO_NBSPARSE, FROM_PP & , ERROR_WAS_BROADCASTED & ) USE DMUMPS_SOL_LR USE DMUMPS_OOC USE DMUMPS_BUF IMPLICIT NONE INTEGER MTYPE INTEGER, INTENT( IN ) :: INODE, LASTFSL0STA, LASTFSL0DYN INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER LIWCB, LIW, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB, LWCB INTEGER(8) :: LA INTEGER N, LPOOL, LEAF, NBFIN INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ) INTEGER IPOOL( LPOOL ), NSTK_S(KEEP(28)) INTEGER IWCB( LIWCB ), IW( LIW ) INTEGER NRHS DOUBLE PRECISION WCB( LWCB ), A( LA ) INTEGER(8) :: LRHS_ROOT DOUBLE PRECISION RHS_ROOT( LRHS_ROOT ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PROCNODE_STEPS(KEEP(28)) INTEGER FILS( N ), STEP( N ), FRERE(KEEP(28)), DAD(KEEP(28)) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INTEGER POSINRHSCOMP_FWD(N), LRHSCOMP DOUBLE PRECISION RHSCOMP(LRHSCOMP, NRHS) LOGICAL, intent(in) :: DO_NBSPARSE INTEGER, intent(in) :: LRHS_BOUNDS INTEGER, intent(in) :: RHS_BOUNDS(LRHS_BOUNDS) LOGICAL, intent(in) :: FROM_PP LOGICAL, intent(out) :: ERROR_WAS_BROADCASTED EXTERNAL dgemv, dtrsv, dgemm, dtrsm, MUMPS_PROCNODE INTEGER MUMPS_PROCNODE DOUBLE PRECISION ALPHA,ONE,ZERO PARAMETER (ZERO=0.0D0, ONE = 1.0D0, ALPHA=-1.0D0) INTEGER :: IWHDLR INTEGER JBDEB, JBFIN, NRHS_B INTEGER LDADIAG INTEGER(8) :: APOS, APOS1, IFR8, IFR_ini8 INTEGER I, J, K, IPOS, NSLAVES, J1, J2, J3, FPERE, FPERE_MAPPING, & NPIV, NCB, LIELL, JJ, NELIM, IERR INTEGER(8) :: PCB_COURANT, PPIV_COURANT, PPIV_PANEL, PCB_PANEL INTEGER IPOSINRHSCOMP_TMP INTEGER Effective_CB_Size, NUPDATE, ISLAVE, PDEST, FirstIndex LOGICAL FLAG INTEGER :: NUPDATE_NONCRITICAL, IPOSINRHSCOMPLASTFSDYN !$ LOGICAL :: OMP_FLAG INCLUDE 'mumps_headers.h' INTEGER(8) :: APOSDEB INTEGER TempNROW, TempNCOL, PANEL_SIZE, & JFIN, NBJ, NUPDATE_PANEL, & TYPEF INTEGER LD_WCBPIV INTEGER LD_WCBCB LOGICAL :: LDEQLIELLPANEL LOGICAL :: CBINITZERO INTEGER LDAJ, LDAJ_FIRST_PANEL INTEGER LDAtemp LOGICAL COMPRESS_PANEL, LR_ACTIVATED LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPANEL LOGICAL MUST_BE_PERMUTED INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER DUMMY( 1 ) ERROR_WAS_BROADCASTED = .FALSE. DUMMY(1)=1 LR_ACTIVATED = (IW(PTRIST(STEP(INODE))+XXLR).GT.0) COMPRESS_PANEL = (IW(PTRIST(STEP(INODE))+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & (.NOT.LR_ACTIVATED.OR.(.NOT.COMPRESS_PANEL).OR. & (KEEP(485).EQ.0) & ) IF (DO_NBSPARSE) THEN JBDEB= RHS_BOUNDS(2*STEP(INODE)-1) JBFIN= RHS_BOUNDS(2*STEP(INODE)) ELSE JBDEB = 1 JBFIN = NRHS ENDIF NRHS_B = JBFIN-JBDEB+1 IF (DO_NBSPARSE) THEN if (JBDEB.GT.JBFIN) then write(6,*) " Internal error 1 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif IF (JBDEB.LT.1 .OR. JBDEB.GT.NRHS .or. & JBFIN.LT.1 .OR. JBFIN.GT.NRHS ) THEN write(6,*) " Internal error 2 in nbsparse :", & JBDEB, JBFIN CALL MUMPS_ABORT() endif ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq.KEEP( 20 ) ) THEN LIELL = IW( PTRIST( STEP(INODE)) + 3 + KEEP(IXSZ)) NPIV = LIELL NELIM = 0 NSLAVES = 0 IPOS = PTRIST( STEP(INODE)) + 5 + KEEP(IXSZ) ELSE IPOS = PTRIST(STEP(INODE)) + 2 + KEEP(IXSZ) LIELL = IW(IPOS-2)+IW(IPOS+1) NELIM = IW(IPOS-1) NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ) ) IPOS = IPOS + 1 NPIV = IW(IPOS) IPOS = IPOS + 1 IF ((KEEP(201).GT.0).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN CALL DMUMPS_SOLVE_GET_OOC_NODE( & INODE,PTRFAC,KEEP,A,LA,STEP, & KEEP8,N,MUST_BE_PERMUTED,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF IF (KEEP(201).EQ.1 .AND. KEEP(50).NE.1) THEN CALL DMUMPS_OOC_PP_CHECK_PERM_FREED( & IW(IPOS+1+2*LIELL+1+NSLAVES), & MUST_BE_PERMUTED ) ENDIF ENDIF NSLAVES = IW( PTRIST(STEP(INODE)) + 5 + KEEP(IXSZ)) IPOS = IPOS + 1 + NSLAVES END IF IF ( MTYPE .EQ. 1 .OR. KEEP(50) .NE. 0 ) THEN J1 = IPOS + 1 J2 = IPOS + LIELL J3 = IPOS + NPIV ELSE J1 = IPOS + LIELL + 1 J2 = IPOS + 2 * LIELL J3 = IPOS + LIELL + NPIV END IF NCB = LIELL-NPIV IF (KEEP(50).NE.0) THEN LDADIAG = NPIV ELSE LDADIAG = LIELL ENDIF IF ( INODE .eq. KEEP( 38 ) .OR. INODE .eq. KEEP(20) ) THEN IFR8 = 0_8 IPOSINRHSCOMP_TMP = POSINRHSCOMP_FWD(IW(J1)) IFR_ini8 = IFR8 !$ OMP_FLAG = ( JBFIN-JBDEB+1.GE.KEEP(362) .AND. !$ & (J3-J1+1)*(JBFIN-JBDEB+1) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(IFR8,JJ) IF(OMP_FLAG) DO K=JBDEB,JBFIN IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 RHS_ROOT(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP_TMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IF ( NPIV .LT. LIELL ) THEN WRITE(*,*) ' Internal error 1 in DMUMPS_SOLVE_NODE_FWD', & NPIV, LIELL CALL MUMPS_ABORT() END IF GO TO 270 END IF APOS = PTRFAC(STEP(INODE)) IF ( (KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR ) THEN IF (MTYPE.EQ.1) THEN IF ((MTYPE.EQ.1).AND.NSLAVES.NE.0) THEN TempNROW= NPIV+NELIM TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ELSE TempNROW= LIELL TempNCOL= NPIV LDAJ_FIRST_PANEL=TempNROW ENDIF TYPEF=TYPEF_L ELSE TempNCOL= LIELL TempNROW= NPIV LDAJ_FIRST_PANEL=TempNCOL TYPEF= TYPEF_U ENDIF PANEL_SIZE = DMUMPS_OOC_PANEL_SIZE( LDAJ_FIRST_PANEL ) ENDIF PPIV_COURANT = PLEFTWCB PLEFTWCB = PLEFTWCB + int(LIELL,8) * int(NRHS_B,8) IF ( POSWCB - PLEFTWCB + 1_8 .LT. 0 ) THEN INFO(1) = -11 CALL MUMPS_SET_IERROR(PLEFTWCB-POSWCB-1_8, INFO(2)) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF IF (KEEP(201) .EQ. 1 .AND. OOCWRITE_COMPATIBLE_WITH_BLR) THEN LDEQLIELLPANEL = .TRUE. LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LDEQLIELLPANEL = .FALSE. LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + int(NPIV,8)*int(NRHS_B,8) ENDIF FPERE = DAD(STEP(INODE)) IF ( FPERE .NE. 0 ) THEN FPERE_MAPPING = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(FPERE)), & KEEP(199) ) ELSE FPERE_MAPPING = -1 ENDIF IF ( LASTFSL0DYN .LE. N ) THEN CBINITZERO = .TRUE. ELSE IF ( FPERE_MAPPING .EQ. MYID ) THEN CBINITZERO = .TRUE. ELSE CBINITZERO = .FALSE. ENDIF CALL DMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP(1, JBDEB), LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB(PPIV_COURANT), & IW, LIW, J1, J3, J2, KEEP, DKEEP) IF ( NPIV .NE. 0 ) THEN IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) THEN APOSDEB = APOS J = 1 IPANEL = 0 10 CONTINUE IPANEL = IPANEL + 1 JFIN = min(J+PANEL_SIZE-1, NPIV) IF (IW(IPOS+ LIELL + JFIN) < 0) THEN JFIN=JFIN+1 ENDIF NBJ = JFIN-J+1 LDAJ = LDAJ_FIRST_PANEL-J+1 IF ( (KEEP(50).NE.1).AND. MUST_BE_PERMUTED ) THEN CALL DMUMPS_GET_OOC_PERM_PTR(TYPEF, TMP_NBPANELS, & I_PIVRPTR, I_PIVR, IPOS+1+2*LIELL, IW, LIW) IF (NPIV.EQ.(IW(I_PIVRPTR+IPANEL-1)-1)) THEN MUST_BE_PERMUTED=.FALSE. ELSE CALL DMUMPS_PERMUTE_PANEL( & IW( I_PIVR+ IW(I_PIVRPTR+IPANEL-1)- & IW(I_PIVRPTR)), & NPIV-IW(I_PIVRPTR+IPANEL-1)+1, & IW(I_PIVRPTR+IPANEL-1)-1, & A(APOSDEB), & LDAJ, NBJ, J-1 ) ENDIF ENDIF NUPDATE_PANEL = LDAJ - NBJ PPIV_PANEL = PPIV_COURANT+int(J-1,8) PCB_PANEL = PPIV_PANEL+int(NBJ,8) APOS1 = APOSDEB+int(NBJ,8) IF (MTYPE.EQ.1) THEN #if defined(MUMPS_USE_BLAS2) IF ( NRHS_B == 1 ) THEN CALL dtrsv( 'L', 'N', 'U', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemv('N', NUPDATE_PANEL,NBJ,ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, ONE, & WCB(PCB_PANEL), 1) ENDIF ELSE #endif CALL dtrsm( 'L','L','N','U', NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ELSE #if defined(MUMPS_USE_BLAS2) IF (NRHS_B == 1) THEN CALL dtrsv( 'L', 'N', 'N', NBJ, A(APOSDEB), LDAJ, & WCB(PPIV_PANEL), 1 ) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemv('N',NUPDATE_PANEL, NBJ, ALPHA, A(APOS1), & LDAJ, WCB(PPIV_PANEL), 1, & ONE, WCB(PCB_PANEL), 1 ) ENDIF ELSE #endif CALL dtrsm('L','L','N','N',NBJ, NRHS_B, ONE, & A(APOSDEB), LDAJ, WCB(PPIV_PANEL), & LIELL) IF (NUPDATE_PANEL.GT.0) THEN CALL dgemm('N', 'N', NUPDATE_PANEL, NRHS_B, NBJ, & ALPHA, & A(APOS1), LDAJ, WCB(PPIV_PANEL), LIELL, ONE, & WCB(PCB_PANEL), LIELL) ENDIF #if defined(MUMPS_USE_BLAS2) ENDIF #endif ENDIF APOSDEB = APOSDEB+int(LDAJ,8)*int(NBJ,8) J=JFIN+1 IF ( J .LE. NPIV ) GOTO 10 ELSE IF ( IW(PTRIST(STEP(INODE))+XXLR) .GE. 2 .AND. & KEEP(485) .EQ. 1 ) THEN IWHDLR = IW(PTRIST(STEP(INODE))+XXF) CALL DMUMPS_SOL_FWD_LR_SU ( & INODE, N, IWHDLR, NPIV, NSLAVES, & IW, IPOS, LIW, & LIELL, WCB, LWCB, & LD_WCBPIV, LD_WCBCB, & PPIV_COURANT, PCB_COURANT, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR, & INFO(1), INFO(2) ) IF (INFO(1).LT.0) THEN ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF ELSE CALL DMUMPS_SOLVE_FWD_TRSOLVE ( & A, LA, APOS, NPIV, LDADIAG, & NRHS_B, WCB, LWCB, LD_WCBPIV, & PPIV_COURANT, MTYPE, KEEP) ENDIF END IF END IF NCB = LIELL - NPIV IF ( MTYPE .EQ. 1 ) THEN IF ( KEEP(50) .eq. 0 ) THEN APOS1 = APOS + int(NPIV,8) * int(LIELL,8) ELSE APOS1 = APOS + int(NPIV,8) * int(NPIV,8) END IF IF ( NSLAVES .EQ. 0 .OR. NPIV .eq. 0 ) THEN NUPDATE = NCB ELSE NUPDATE = NELIM END IF ELSE APOS1 = APOS + int(NPIV,8) NUPDATE = NCB END IF IF (KEEP(201).NE.1) THEN IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN IF (MTYPE .EQ. 1) THEN LDAtemp = NPIV ELSE LDAtemp = LIELL ENDIF CALL DMUMPS_SOLVE_GEMM_UPDATE & (A, LA, APOS1, NPIV, LDAtemp, NUPDATE, & NRHS_B, WCB, LWCB, PPIV_COURANT, LD_WCBPIV, & PCB_COURANT, LD_WCBCB, & MTYPE, KEEP, ONE) ENDIF END IF IF ( IW(PTRIST(STEP(INODE))+XXLR) .LT. 2 .OR. & KEEP(485).EQ.0) THEN CALL DMUMPS_SOLVE_LD_AND_RELOAD ( & INODE, N, NPIV, LIELL, NELIM, NSLAVES, & PPIV_COURANT, & IW, IPOS, LIW, & A, LA, APOS, & WCB, LWCB, LD_WCBPIV, & RHSCOMP, LRHSCOMP, NRHS, & POSINRHSCOMP_FWD, JBDEB, JBFIN, & MTYPE, KEEP, OOCWRITE_COMPATIBLE_WITH_BLR & ) ENDIF IF ((KEEP(201).EQ.1).AND.OOCWRITE_COMPATIBLE_WITH_BLR) &THEN CALL DMUMPS_FREE_FACTORS_FOR_SOLVE(INODE,PTRFAC,KEEP(28), & A,LA,.TRUE.,IERR) IF(IERR.LT.0)THEN INFO(1)=IERR INFO(2)=0 ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ENDIF END IF IF ( FPERE .EQ. 0 ) THEN PLEFTWCB = PLEFTWCB - int(LIELL,8) *int(NRHS_B,8) GOTO 270 ENDIF IF ( NUPDATE .NE. 0 .OR. NCB.EQ.0 ) THEN IF (MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), & KEEP(199)) .EQ. MYID) THEN IF ( NCB .ne. 0 ) THEN PTRICB(STEP(INODE)) = NCB + 1 NUPDATE_NONCRITICAL = NUPDATE IF (LASTFSL0DYN .LE. N) THEN IF ( LASTFSL0DYN .EQ. 0 ) THEN IPOSINRHSCOMPLASTFSDYN = 0 ELSE IPOSINRHSCOMPLASTFSDYN = & abs(POSINRHSCOMP_FWD(LASTFSL0DYN)) ENDIF DO I = 1, NUPDATE IF ( abs(POSINRHSCOMP_FWD( IW(J3+I) )) .GT. & IPOSINRHSCOMPLASTFSDYN ) THEN IF (abs(STEP(IW(J3+I))) .GT. & abs(STEP( LASTFSL0STA)) & .OR. KEEP(261) .NE. 1) THEN NUPDATE_NONCRITICAL = I - 1 EXIT ENDIF ENDIF ENDDO ENDIF !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & (NUPDATE*NRHS_B .GE. KEEP(363)) ) !$OMP PARALLEL DO PRIVATE(I,IFR8,IPOSINRHSCOMP_TMP) IF(OMP_FLAG) DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) DO I = 1, NUPDATE_NONCRITICAL IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO ENDDO !$OMP END PARALLEL DO IF ( CBINITZERO ) THEN IF ( NUPDATE .NE. NUPDATE_NONCRITICAL) THEN IF (.NOT. CBINITZERO) THEN WRITE(*,*) ' Internal error 3 in DMUMPS_SOLVE_NODE_FWD', & CBINITZERO, INODE, NUPDATE, NUPDATE_NONCRITICAL CALL MUMPS_ABORT() ENDIF DO K = JBDEB, JBFIN IFR8 = PCB_COURANT + int(K-JBDEB,8)*int(LD_WCBCB,8) !$OMP CRITICAL(DMUMPS_RHSCOMP_CRI) DO I = NUPDATE_NONCRITICAL+1, NUPDATE IPOSINRHSCOMP_TMP = & abs(POSINRHSCOMP_FWD(IW(J3 + I))) RHSCOMP( IPOSINRHSCOMP_TMP, K ) = & RHSCOMP( IPOSINRHSCOMP_TMP, K ) & + WCB(IFR8 + int(I-1,8)) ENDDO !$OMP END CRITICAL(DMUMPS_RHSCOMP_CRI) ENDDO ENDIF ENDIF PTRICB(STEP( INODE )) = PTRICB(STEP( INODE )) - NUPDATE ELSE PTRICB(STEP( INODE )) = -1 ENDIF ELSE 210 CONTINUE CALL DMUMPS_BUF_SEND_VCB( NRHS_B, INODE, FPERE, & NCB, LD_WCBCB, & NUPDATE, & IW( J3 + 1 ), WCB( PCB_COURANT ), JBDEB, JBFIN, & RHSCOMP, 1, 1, -9999, -9999, & KEEP, & MUMPS_PROCNODE(PROCNODE_STEPS(STEP(FPERE)), KEEP(199)), & ContVec, & COMM, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 210 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = NUPDATE * KEEP( 35 ) + & ( NUPDATE + 3 ) * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF ENDIF END IF IF ( NSLAVES .NE. 0 .AND. MTYPE .eq. 1 & .and. NPIV .NE. 0 ) THEN DO ISLAVE = 1, NSLAVES PDEST = IW( PTRIST(STEP(INODE)) + 5 + ISLAVE +KEEP(IXSZ)) CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, INODE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & ISLAVE, NCB - NELIM, & NSLAVES, & Effective_CB_Size, FirstIndex ) 222 CONTINUE CALL DMUMPS_BUF_SEND_MASTER2SLAVE( NRHS_B, & INODE, FPERE, & Effective_CB_Size, LD_WCBCB, LD_WCBPIV, NPIV, & JBDEB, JBFIN, & WCB( PCB_COURANT + NELIM + FirstIndex - 1 ), & WCB( PPIV_COURANT ), & PDEST, COMM, KEEP, IERR ) IF ( IERR .EQ. -1 ) THEN CALL DMUMPS_SOLVE_RECV_AND_TREAT( .FALSE., FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IF ( INFO( 1 ) .LT. 0 ) THEN ERROR_WAS_BROADCASTED = .TRUE. GOTO 270 ENDIF GOTO 222 ELSE IF ( IERR .EQ. -2 ) THEN INFO( 1 ) = -17 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 ELSE IF ( IERR .EQ. -3 ) THEN INFO( 1 ) = -20 INFO( 2 ) = (NPIV+Effective_CB_Size)*NRHS_B*KEEP(35) + & 6 * KEEP( 34 ) ERROR_WAS_BROADCASTED = .FALSE. GOTO 270 END IF END DO END IF PLEFTWCB = PLEFTWCB - int(LIELL,8)*int(NRHS_B,8) 270 CONTINUE RETURN END SUBROUTINE DMUMPS_SOLVE_NODE_FWD RECURSIVE SUBROUTINE DMUMPS_SOLVE_RECV_AND_TREAT( BLOQ, FLAG, & BUFR, LBUFR, LBUFR_BYTES, & MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST,PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) IMPLICIT NONE LOGICAL BLOQ INTEGER LBUFR, LBUFR_BYTES INTEGER MYID, SLAVEF, COMM INTEGER N, NRHS, LPOOL, LEAF, NBFIN INTEGER LIWCB, POSIWCB INTEGER(8) :: POSWCB, PLEFTWCB INTEGER LIW INTEGER(8), INTENT(IN) :: LA, LWCB INTEGER INFO( 80 ), KEEP( 500) INTEGER(8) KEEP8(150) DOUBLE PRECISION, INTENT(INOUT) :: DKEEP(230) INTEGER BUFR( LBUFR ), IPOOL(LPOOL) INTEGER NSTK_S( KEEP(28) ) INTEGER IWCB( LIWCB ) INTEGER IW( LIW ) DOUBLE PRECISION WCB( LWCB ), A( LA ) INTEGER PTRICB(KEEP(28)), PTRIST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER STEP(N) INTEGER PROCNODE_STEPS(KEEP(28)) LOGICAL FLAG INTEGER LRHSCOMP, POSINRHSCOMP_FWD(N) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) LOGICAL, intent(in) :: FROM_PP INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR INTEGER :: STATUS(MPI_STATUS_SIZE) INTEGER MSGSOU, MSGTAG, MSGLEN FLAG = .FALSE. IF ( BLOQ ) THEN FLAG = .FALSE. CALL MPI_PROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, & COMM, STATUS, IERR ) FLAG = .TRUE. ELSE CALL MPI_IPROBE( MPI_ANY_SOURCE, MPI_ANY_TAG, COMM, & FLAG, STATUS, IERR ) END IF IF ( FLAG ) THEN KEEP(266) = KEEP(266) -1 MSGSOU = STATUS( MPI_SOURCE ) MSGTAG = STATUS( MPI_TAG ) CALL MPI_GET_COUNT( STATUS, MPI_PACKED, MSGLEN, IERR ) IF ( MSGLEN .GT. LBUFR_BYTES ) THEN INFO(1) = -20 INFO(2) = MSGLEN CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) ELSE CALL MPI_RECV( BUFR, LBUFR_BYTES, MPI_PACKED, & MSGSOU, MSGTAG, COMM, STATUS, IERR ) CALL DMUMPS_TRAITER_MESSAGE_SOLVE( BUFR, LBUFR, LBUFR_BYTES, & MSGTAG, MSGSOU, MYID, SLAVEF, COMM, & N, NRHS, IPOOL, LPOOL, LEAF, & NBFIN, NSTK_S, IW, LIW, A, LA, PTRIST, PTRFAC, & IWCB, LIWCB, & WCB, LWCB, POSWCB, & PLEFTWCB, POSIWCB, & PTRICB, INFO, KEEP,KEEP8, DKEEP, STEP, & PROCNODE_STEPS, & RHSCOMP, LRHSCOMP, POSINRHSCOMP_FWD & , FROM_PP & ) END IF END IF RETURN END SUBROUTINE DMUMPS_SOLVE_RECV_AND_TREAT SUBROUTINE DMUMPS_RHSCOMP_TO_WCB( & NPIV, NCB, LIELL, CBINITZERO, LDEQLIELLPANEL, & RHSCOMP, LRHSCOMP, NRHS_B, & POSINRHSCOMP_FWD, N, & WCB, & IW, LIW, J1, J3, J2, KEEP, DKEEP) IMPLICIT NONE INTEGER, INTENT( IN ) :: NPIV, NCB, LIELL, N, & LRHSCOMP, NRHS_B, & LIW, J1, J2, J3 LOGICAL, INTENT( IN ) :: LDEQLIELLPANEL LOGICAL, INTENT( IN ) :: CBINITZERO INTEGER, INTENT( IN ) :: POSINRHSCOMP_FWD( N ), IW( LIW ) DOUBLE PRECISION, INTENT( INOUT ) :: RHSCOMP( LRHSCOMP, NRHS_B ) DOUBLE PRECISION, INTENT( OUT ) :: WCB( int(LIELL,8)* & int(NRHS_B,8) ) INTEGER :: KEEP(500) DOUBLE PRECISION :: DKEEP(150) INTEGER, PARAMETER :: ZERO = 0.0D0 INTEGER(8), PARAMETER :: PPIV_COURANT = 1_8 INTEGER(8) :: PCB_COURANT INTEGER :: LD_WCBCB, LD_WCBPIV, J, JJ, K, IPOSINRHSCOMP INTEGER(8) :: IFR8, IFR_ini8 INCLUDE 'mpif.h' !$ LOGICAL :: OMP_FLAG IF ( LDEQLIELLPANEL ) THEN LD_WCBPIV = LIELL LD_WCBCB = LIELL PCB_COURANT = PPIV_COURANT + NPIV ELSE LD_WCBPIV = NPIV LD_WCBCB = NCB PCB_COURANT = PPIV_COURANT + NPIV * NRHS_B ENDIF IF ( LDEQLIELLPANEL ) THEN DO K=1, NRHS_B IFR8 = PPIV_COURANT+int(K-1,8)*int(LD_WCBPIV,8)-1_8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) DO JJ = J1, J3 IFR8 = IFR8 + 1_8 WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) IPOSINRHSCOMP = IPOSINRHSCOMP + 1 ENDDO IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN DO JJ = J3+1, J2 J = IW(JJ) IFR8 = IFR8 + 1_8 IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP (IPOSINRHSCOMP,K) = ZERO ENDDO ENDIF ENDDO ELSE PCB_COURANT = PPIV_COURANT + LD_WCBPIV*NRHS_B IFR8 = PPIV_COURANT - 1_8 IFR_ini8 = IFR8 IPOSINRHSCOMP = POSINRHSCOMP_FWD(IW(J1)) !$ OMP_FLAG = ( NRHS_B .GE. KEEP(362) .AND. !$ & int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE(JJ,IFR8) IF(OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8 + int(K-1,8)*int(NPIV,8) DO JJ = J1, J3 WCB(IFR8+int(JJ-J1+1,8)) = & RHSCOMP(IPOSINRHSCOMP+JJ-J1,K) ENDDO ENDDO !$OMP END PARALLEL DO IFR8 = PCB_COURANT - 1_8 IF (NCB.GT.0 .AND. .NOT. CBINITZERO) THEN IFR_ini8 = IFR8 !$ OMP_FLAG = ( NRHS_B.GE.KEEP(362) .AND. !$ & NCB*NRHS_B .GE. KEEP(363) ) !$OMP PARALLEL DO PRIVATE (IFR8, JJ, J, IPOSINRHSCOMP) IF (OMP_FLAG) DO K=1, NRHS_B IFR8 = IFR_ini8+(K-1)*NCB DO JJ = J3 + 1, J2 J = IW(JJ) IPOSINRHSCOMP = abs(POSINRHSCOMP_FWD(J)) WCB(IFR8+int(JJ-J3,8)) = RHSCOMP(IPOSINRHSCOMP,K) RHSCOMP(IPOSINRHSCOMP,K)=ZERO ENDDO ENDDO !$OMP END PARALLEL DO ENDIF ENDIF IF ( CBINITZERO ) THEN !$ OMP_FLAG = int(NCB,8)*int(NRHS_B,8) .GE. KEEP(363) !$OMP PARALLEL DO COLLAPSE(2) IF ( OMP_FLAG ) DO K = 1, NRHS_B DO JJ = 1, NCB WCB(PCB_COURANT+int(K-1,8)*int(LD_WCBCB,8)+JJ-1_8) = ZERO ENDDO ENDDO ENDIF RETURN END SUBROUTINE DMUMPS_RHSCOMP_TO_WCB MUMPS_5.4.1/src/fac_descband_data_m.F0000664000175000017500000001247514102210475017512 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE MUMPS_FAC_DESCBAND_DATA_M IMPLICIT NONE #if ! defined(NO_FDM_DESCBAND) INTEGER, SAVE :: INODE_WAITED_FOR PRIVATE PUBLIC :: DESCBAND_STRUC_T, MUMPS_FDBD_INIT, MUMPS_FDBD_END, & MUMPS_FDBD_SAVE_DESCBAND, MUMPS_FDBD_IS_DESCBAND_STORED, & MUMPS_FDBD_RETRIEVE_DESCBAND, & MUMPS_FDBD_FREE_DESCBAND_STRUC, & INODE_WAITED_FOR TYPE DESCBAND_STRUC_T INTEGER :: INODE, LBUFR INTEGER, POINTER, DIMENSION(:) :: BUFR END TYPE DESCBAND_STRUC_T TYPE (DESCBAND_STRUC_T), POINTER, DIMENSION(:), SAVE::FDBD_ARRAY CONTAINS SUBROUTINE MUMPS_FDBD_INIT( INITIAL_SIZE, INFO ) INTEGER, INTENT(IN) :: INITIAL_SIZE INTEGER, INTENT(INOUT) :: INFO(2) INTEGER :: I, IERR ALLOCATE(FDBD_ARRAY( INITIAL_SIZE ), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=INITIAL_SIZE RETURN ENDIF DO I=1, INITIAL_SIZE FDBD_ARRAY(I)%INODE=-9999 FDBD_ARRAY(I)%LBUFR=-9999 NULLIFY(FDBD_ARRAY(I)%BUFR) ENDDO INODE_WAITED_FOR = -1 RETURN END SUBROUTINE MUMPS_FDBD_INIT FUNCTION MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER ) LOGICAL :: MUMPS_FDBD_IS_DESCBAND_STORED INTEGER, INTENT(IN) :: INODE INTEGER, INTENT(OUT) :: IWHANDLER INTEGER :: I DO I = 1, size(FDBD_ARRAY) IF (FDBD_ARRAY(I)%INODE .EQ. INODE) THEN IWHANDLER = I MUMPS_FDBD_IS_DESCBAND_STORED = .TRUE. RETURN ENDIF ENDDO MUMPS_FDBD_IS_DESCBAND_STORED = .FALSE. RETURN END FUNCTION MUMPS_FDBD_IS_DESCBAND_STORED SUBROUTINE MUMPS_FDBD_SAVE_DESCBAND(INODE, LBUFR, BUFR, & IWHANDLER, INFO) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_START_IDX INTEGER, INTENT(IN) :: INODE, LBUFR, BUFR(LBUFR) INTEGER, INTENT(INOUT) :: INFO(2) INTEGER, INTENT(OUT) :: IWHANDLER TYPE(DESCBAND_STRUC_T), POINTER, DIMENSION(:) :: FDBD_ARRAY_TMP INTEGER :: OLD_SIZE, NEW_SIZE, I, IERR IWHANDLER = -1 CALL MUMPS_FDM_START_IDX('A', 'DESCBAND', IWHANDLER, INFO) IF (INFO(1) .LT. 0) RETURN IF (IWHANDLER > size(FDBD_ARRAY)) THEN OLD_SIZE = size(FDBD_ARRAY) NEW_SIZE = max( (OLD_SIZE * 3) / 2 + 1, IWHANDLER) ALLOCATE(FDBD_ARRAY_TMP(NEW_SIZE),stat=IERR) IF (IERR.GT.0) THEN INFO(1)=-13 INFO(2)=NEW_SIZE RETURN ENDIF DO I=1, OLD_SIZE FDBD_ARRAY_TMP(I)=FDBD_ARRAY(I) ENDDO DO I=OLD_SIZE+1, NEW_SIZE FDBD_ARRAY_TMP(I)%INODE = -9999 FDBD_ARRAY_TMP(I)%LBUFR = -9999 NULLIFY(FDBD_ARRAY_TMP(I)%BUFR) ENDDO DEALLOCATE(FDBD_ARRAY) FDBD_ARRAY=>FDBD_ARRAY_TMP NULLIFY(FDBD_ARRAY_TMP) ENDIF FDBD_ARRAY(IWHANDLER)%INODE = INODE FDBD_ARRAY(IWHANDLER)%LBUFR = LBUFR ALLOCATE(FDBD_ARRAY(IWHANDLER)%BUFR(LBUFR), stat=IERR) IF (IERR > 0 ) THEN INFO(1)=-13 INFO(2)=LBUFR RETURN ENDIF FDBD_ARRAY(IWHANDLER)%BUFR = BUFR RETURN END SUBROUTINE MUMPS_FDBD_SAVE_DESCBAND SUBROUTINE MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER,DESCBAND_STRUC) INTEGER, INTENT(IN) :: IWHANDLER #if defined(MUMPS_F2003) TYPE (DESCBAND_STRUC_T), POINTER, INTENT(OUT) :: DESCBAND_STRUC #else TYPE (DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC #endif DESCBAND_STRUC => FDBD_ARRAY(IWHANDLER) RETURN END SUBROUTINE MUMPS_FDBD_RETRIEVE_DESCBAND SUBROUTINE MUMPS_FDBD_FREE_DESCBAND_STRUC(IWHANDLER) USE MUMPS_FRONT_DATA_MGT_M, ONLY : MUMPS_FDM_END_IDX INTEGER, INTENT(INOUT) :: IWHANDLER TYPE (DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC DESCBAND_STRUC => FDBD_ARRAY(IWHANDLER) DESCBAND_STRUC%INODE = -7777 DESCBAND_STRUC%LBUFR = -7777 DEALLOCATE(DESCBAND_STRUC%BUFR) NULLIFY(DESCBAND_STRUC%BUFR) CALL MUMPS_FDM_END_IDX('A', 'DESCBAND', IWHANDLER) RETURN END SUBROUTINE MUMPS_FDBD_FREE_DESCBAND_STRUC SUBROUTINE MUMPS_FDBD_END(INFO1) INTEGER, INTENT(IN) :: INFO1 INTEGER :: I, IWHANDLER IF (.NOT. associated(FDBD_ARRAY)) THEN WRITE(*,*) "Internal error 1 in MUMPS_FAC_FDBD_END" CALL MUMPS_ABORT() ENDIF DO I=1, size(FDBD_ARRAY) IF (FDBD_ARRAY(I)%INODE .GE. 0) THEN IF (INFO1 .GE.0) THEN WRITE(*,*) "Internal error 2 in MUMPS_FAC_FDBD_END",I CALL MUMPS_ABORT() ELSE IWHANDLER=I CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IWHANDLER) ENDIF ENDIF ENDDO DEALLOCATE(FDBD_ARRAY) RETURN END SUBROUTINE MUMPS_FDBD_END #endif END MODULE MUMPS_FAC_DESCBAND_DATA_M MUMPS_5.4.1/src/dmumps_comm_buffer.F0000664000175000017500000040565714102210522017503 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE DMUMPS_BUF PRIVATE PUBLIC :: DMUMPS_BUF_TRY_FREE_CB, DMUMPS_BUF_INIT, & DMUMPS_BUF_INI_MYID, & DMUMPS_BUF_ALLOC_CB , DMUMPS_BUF_DEALL_CB , & DMUMPS_BUF_ALLOC_SMALL_BUF, DMUMPS_BUF_DEALL_SMALL_BUF, & DMUMPS_BUF_ALLOC_LOAD_BUFFER,DMUMPS_BUF_DEALL_LOAD_BUFFER, & DMUMPS_BUF_SEND_CB, DMUMPS_BUF_SEND_VCB, & DMUMPS_BUF_SEND_1INT, DMUMPS_BUF_SEND_DESC_BANDE, & DMUMPS_BUF_SEND_MAPLIG, DMUMPS_BUF_SEND_MAITRE2, & DMUMPS_BUF_SEND_CONTRIB_TYPE2, & DMUMPS_BUF_SEND_BLOCFACTO, DMUMPS_BUF_SEND_BLFAC_SLAVE, & DMUMPS_BUF_SEND_MASTER2SLAVE, & DMUMPS_BUF_SEND_CONTRIB_TYPE3, DMUMPS_BUF_SEND_RTNELIND, & DMUMPS_BUF_SEND_ROOT2SLAVE, DMUMPS_BUF_SEND_ROOT2SON, & DMUMPS_BUF_SEND_BACKVEC,DMUMPS_BUF_SEND_UPDATE_LOAD, & DMUMPS_BUF_DIST_IRECV_SIZE, & DMUMPS_BUF_BCAST_ARRAY, DMUMPS_BUF_ALL_EMPTY, & DMUMPS_BUF_BROADCAST, DMUMPS_BUF_SEND_NOT_MSTR, & DMUMPS_BUF_SEND_FILS ,DMUMPS_BUF_DEALL_MAX_ARRAY & ,DMUMPS_BUF_MAX_ARRAY_MINSIZE & ,DMUMPS_BUF_TEST PUBLIC :: DMUMPS_BLR_PACK_CB_LRB & ,DMUMPS_MPI_PACK_LRB & ,DMUMPS_MPI_UNPACK_LRB INTEGER NEXT, REQ, CONTENT, OVHSIZE PARAMETER( NEXT = 0, REQ = 1, CONTENT = 2, OVHSIZE = 2 ) INTEGER, SAVE :: SIZEofINT, SIZEofREAL, BUF_MYID TYPE DMUMPS_COMM_BUFFER_TYPE INTEGER LBUF, HEAD, TAIL,LBUF_INT, ILASTMSG INTEGER, DIMENSION(:),POINTER :: CONTENT END TYPE DMUMPS_COMM_BUFFER_TYPE TYPE ( DMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_CB TYPE ( DMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_SMALL TYPE ( DMUMPS_COMM_BUFFER_TYPE ), SAVE :: BUF_LOAD INTEGER, SAVE :: SIZE_RBUF_BYTES INTEGER, SAVE :: BUF_LMAX_ARRAY DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE & , SAVE, TARGET :: BUF_MAX_ARRAY PUBLIC :: BUF_LMAX_ARRAY, BUF_MAX_ARRAY CONTAINS SUBROUTINE DMUMPS_BUF_TRY_FREE_CB() CALL DMUMPS_BUF_TRY_FREE(BUF_CB) RETURN END SUBROUTINE DMUMPS_BUF_TRY_FREE_CB SUBROUTINE DMUMPS_BUF_TRY_FREE(B) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: B INCLUDE 'mpif.h' LOGICAL :: FLAG INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, & STATUS, IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF RETURN END SUBROUTINE DMUMPS_BUF_TRY_FREE SUBROUTINE DMUMPS_BUF_INI_MYID( MYID ) IMPLICIT NONE INTEGER MYID BUF_MYID = MYID RETURN END SUBROUTINE DMUMPS_BUF_INI_MYID SUBROUTINE DMUMPS_BUF_INIT( IntSize, RealSize ) IMPLICIT NONE INTEGER IntSize, RealSize SIZEofINT = IntSize SIZEofREAL = RealSize NULLIFY(BUF_CB %CONTENT) NULLIFY(BUF_SMALL%CONTENT) NULLIFY(BUF_LOAD%CONTENT) BUF_CB%LBUF = 0 BUF_CB%LBUF_INT = 0 BUF_CB%HEAD = 1 BUF_CB%TAIL = 1 BUF_CB%ILASTMSG = 1 BUF_SMALL%LBUF = 0 BUF_SMALL%LBUF_INT = 0 BUF_SMALL%HEAD = 1 BUF_SMALL%TAIL = 1 BUF_SMALL%ILASTMSG = 1 BUF_LOAD%LBUF = 0 BUF_LOAD%LBUF_INT = 0 BUF_LOAD%HEAD = 1 BUF_LOAD%TAIL = 1 BUF_LOAD%ILASTMSG = 1 RETURN END SUBROUTINE DMUMPS_BUF_INIT SUBROUTINE DMUMPS_BUF_ALLOC_CB( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_CB, SIZE, IERR ) RETURN END SUBROUTINE DMUMPS_BUF_ALLOC_CB SUBROUTINE DMUMPS_BUF_ALLOC_SMALL_BUF( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_SMALL, SIZE, IERR ) RETURN END SUBROUTINE DMUMPS_BUF_ALLOC_SMALL_BUF SUBROUTINE DMUMPS_BUF_ALLOC_LOAD_BUFFER( SIZE, IERR ) IMPLICIT NONE INTEGER SIZE, IERR CALL BUF_ALLOC( BUF_LOAD, SIZE, IERR ) RETURN END SUBROUTINE DMUMPS_BUF_ALLOC_LOAD_BUFFER SUBROUTINE DMUMPS_BUF_DEALL_LOAD_BUFFER( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_LOAD, IERR ) RETURN END SUBROUTINE DMUMPS_BUF_DEALL_LOAD_BUFFER SUBROUTINE DMUMPS_BUF_DEALL_MAX_ARRAY() IMPLICIT NONE IF (allocated( BUF_MAX_ARRAY)) DEALLOCATE( BUF_MAX_ARRAY ) RETURN END SUBROUTINE DMUMPS_BUF_DEALL_MAX_ARRAY SUBROUTINE DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IMPLICIT NONE INTEGER IERR, NFS4FATHER IERR = 0 IF (allocated( BUF_MAX_ARRAY)) THEN IF (BUF_LMAX_ARRAY .GE. NFS4FATHER) RETURN DEALLOCATE( BUF_MAX_ARRAY ) ENDIF ALLOCATE(BUF_MAX_ARRAY(NFS4FATHER),stat=IERR) IF ( IERR .GT. 0 ) THEN IERR = -1 RETURN END IF BUF_LMAX_ARRAY=NFS4FATHER RETURN END SUBROUTINE DMUMPS_BUF_MAX_ARRAY_MINSIZE SUBROUTINE DMUMPS_BUF_DEALL_CB( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_CB, IERR ) RETURN END SUBROUTINE DMUMPS_BUF_DEALL_CB SUBROUTINE DMUMPS_BUF_DEALL_SMALL_BUF( IERR ) IMPLICIT NONE INTEGER IERR CALL BUF_DEALL( BUF_SMALL, IERR ) RETURN END SUBROUTINE DMUMPS_BUF_DEALL_SMALL_BUF SUBROUTINE BUF_ALLOC( BUF, SIZE, IERR ) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE, IERR IERR = 0 BUF%LBUF = SIZE BUF%LBUF_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT IF ( associated ( BUF%CONTENT ) ) DEALLOCATE( BUF%CONTENT ) ALLOCATE( BUF%CONTENT( BUF%LBUF_INT ), stat = IERR ) IF (IERR .NE. 0) THEN NULLIFY( BUF%CONTENT ) IERR = -1 BUF%LBUF = 0 BUF%LBUF_INT = 0 END IF BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_ALLOC SUBROUTINE BUF_DEALL( BUF, IERR ) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER :: IERR INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( .NOT. associated ( BUF%CONTENT ) ) THEN BUF%HEAD = 1 BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END IF DO WHILE ( BUF%HEAD.NE.0 .AND. BUF%HEAD .NE. BUF%TAIL ) CALL MPI_TEST(BUF%CONTENT( BUF%HEAD + REQ ), FLAG, & STATUS, IERR_MPI) IF ( .not. FLAG ) THEN WRITE(*,*) '** Warning: trying to cancel a request.' WRITE(*,*) '** This might be problematic' CALL MPI_CANCEL( BUF%CONTENT( BUF%HEAD + REQ ), IERR_MPI ) CALL MPI_REQUEST_FREE( BUF%CONTENT( BUF%HEAD + REQ ), & IERR_MPI ) END IF BUF%HEAD = BUF%CONTENT( BUF%HEAD + NEXT ) END DO DEALLOCATE( BUF%CONTENT ) NULLIFY( BUF%CONTENT ) BUF%LBUF = 0 BUF%LBUF_INT = 0 BUF%HEAD = 1 BUF%TAIL = 1 BUF%ILASTMSG = 1 RETURN END SUBROUTINE BUF_DEALL SUBROUTINE DMUMPS_BUF_SEND_CB( NBROWS_ALREADY_SENT, & INODE, FPERE, NFRONT, LCONT, & NASS, NPIV, & IWROW, IWCOL, A, PACKED_CB, & DEST, TAG, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER DEST, TAG, COMM, IERR INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER INODE, FPERE, NFRONT, LCONT, NASS, NPIV INTEGER IWROW( LCONT ), IWCOL( LCONT ) DOUBLE PRECISION A( * ) LOGICAL PACKED_CB INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER NBROWS_PACKET INTEGER POSITION, IREQ, IPOS, I, J1 INTEGER SIZE1, SIZE2, SIZE_PACK, SIZE_AV, SIZE_AV_REALS INTEGER IZERO, IONE INTEGER SIZECB INTEGER LCONT_SENT INTEGER DEST2(1) PARAMETER( IZERO = 0, IONE = 1 ) LOGICAL RECV_BUF_SMALLER_THAN_SEND DOUBLE PRECISION TMP DEST2(1) = DEST IERR = 0 IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( 11 + LCONT + LCONT, MPI_INTEGER, & COMM, SIZE1, IERR_MPI) ELSE CALL MPI_PACK_SIZE( 5, MPI_INTEGER, COMM, SIZE1, IERR_MPI) ENDIF CALL DMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE_RBUF_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE SIZE_AV = SIZE_RBUF_BYTES RECV_BUF_SMALLER_THAN_SEND = .TRUE. ENDIF SIZE_AV_REALS = ( SIZE_AV - SIZE1 ) / SIZEofREAL IF (SIZE_AV_REALS < 0 ) THEN NBROWS_PACKET = 0 ELSE IF (PACKED_CB) THEN TMP=2.0D0*dble(NBROWS_ALREADY_SENT)+1.0D0 NBROWS_PACKET = int( & ( sqrt( TMP * TMP & + 8.0D0 * dble(SIZE_AV_REALS)) - TMP ) & / 2.0D0 ) ELSE IF (LCONT.EQ.0) THEN NBROWS_PACKET = 0 ELSE NBROWS_PACKET = SIZE_AV_REALS / LCONT ENDIF ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max(0, & min(NBROWS_PACKET, LCONT - NBROWS_ALREADY_SENT)) IF (NBROWS_PACKET .EQ. 0 .AND. LCONT .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (PACKED_CB) THEN SIZECB = (NBROWS_ALREADY_SENT*NBROWS_PACKET)+(NBROWS_PACKET & *(NBROWS_PACKET+1))/2 ELSE SIZECB = NBROWS_PACKET * LCONT ENDIF CALL MPI_PACK_SIZE( SIZECB, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.LCONT .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2) IF (IERR .EQ. -1 .OR. IERR .EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (PACKED_CB) THEN LCONT_SENT=-LCONT ELSE LCONT_SENT=LCONT ENDIF CALL MPI_PACK( LCONT_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT == 0) THEN CALL MPI_PACK( LCONT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NASS-NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LCONT , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IONE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IZERO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWROW, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IWCOL, LCONT, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF IF ( LCONT .NE. 0 ) THEN J1 = 1 + NBROWS_ALREADY_SENT * NFRONT IF (PACKED_CB) THEN DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), I, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ELSE DO I = NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( A( J1 ), LCONT, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) J1 = J1 + NFRONT END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) 'Error Try_send_cb: SIZE, POSITION=',SIZE_PACK, & POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. LCONT ) THEN IERR = -1 RETURN ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_CB SUBROUTINE DMUMPS_BUF_SEND_MASTER2SLAVE( NRHS, INODE, IFATH, & EFF_CB_SIZE, LD_CB, LD_PIV, NPIV, & JBDEB, JBFIN, & CB, SOL, & DEST, COMM, KEEP, IERR ) IMPLICIT NONE INTEGER NRHS, INODE, IFATH, EFF_CB_SIZE, LD_CB, LD_PIV, NPIV INTEGER DEST, COMM, IERR, JBDEB, JBFIN DOUBLE PRECISION CB( LD_CB*(NRHS-1)+EFF_CB_SIZE ) DOUBLE PRECISION SOL( max(1, LD_PIV*(NRHS-1)+NPIV) ) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE, SIZE1, SIZE2, K INTEGER POSITION, IREQ, IPOS INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 CALL MPI_PACK_SIZE( 6, MPI_INTEGER, COMM, SIZE1, IERR ) CALL MPI_PACK_SIZE( NRHS * (EFF_CB_SIZE + NPIV), & MPI_DOUBLE_PRECISION, COMM, & SIZE2, IERR_MPI ) SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IFATH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( EFF_CB_SIZE , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBDEB , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN , 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) DO K = 1, NRHS CALL MPI_PACK( CB ( 1 + LD_CB * (K-1) ), & EFF_CB_SIZE, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO IF ( NPIV .GT. 0 ) THEN DO K=1, NRHS CALL MPI_PACK( SOL(1+LD_PIV*(K-1)), & NPIV, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDDO END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, Master2Slave, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE .LT. POSITION ) THEN WRITE(*,*) 'Try_send_master2slave: SIZE, POSITION = ', & SIZE, POSITION CALL MUMPS_ABORT() END IF IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_MASTER2SLAVE SUBROUTINE DMUMPS_BUF_SEND_VCB( NRHS_B, NODE1, NODE2, NCB, LDW, & LONG, & IW, W, JBDEB, JBFIN, & RHSCOMP, NRHS, LRHSCOMP, IPOSINRHSCOMP, NPIV, & KEEP, & DEST, TAG, COMM, IERR ) IMPLICIT NONE INTEGER LDW, DEST, TAG, COMM, IERR INTEGER NRHS_B, NODE1, NODE2, NCB, LONG, JBDEB, JBFIN INTEGER IW( max( 1, LONG ) ) INTEGER, INTENT(IN) :: LRHSCOMP, NRHS, IPOSINRHSCOMP, NPIV DOUBLE PRECISION W( max( 1, LDW * NRHS_B ) ) DOUBLE PRECISION RHSCOMP(LRHSCOMP,NRHS) INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS INTEGER SIZE1, SIZE2, SIZE, K INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 IF ( NODE2 .EQ. 0 ) THEN CALL MPI_PACK_SIZE( 4+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6+LONG, MPI_INTEGER, COMM, SIZE1, & IERR_MPI ) END IF SIZE2 = 0 IF ( LONG .GT. 0 ) THEN CALL MPI_PACK_SIZE( NRHS_B*LONG, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) END IF SIZE = SIZE1 + SIZE2 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = 0 CALL MPI_PACK( NODE1, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( NODE2 .NE. 0 ) THEN CALL MPI_PACK( NODE2, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( JBDEB, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JBFIN, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( LONG, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF ( LONG .GT. 0 ) THEN CALL MPI_PACK( IW, LONG, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) IF (NODE2.EQ.0) THEN DO K=1, NRHS_B IF (NPIV.GT.0) THEN CALL MPI_PACK( RHSCOMP(IPOSINRHSCOMP,JBDEB+K-1), NPIV, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF IF (LONG-NPIV .NE.0) THEN CALL MPI_PACK( W(NPIV+1+(K-1)*LDW), LONG-NPIV, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) ENDIF END DO ELSE DO K=1, NRHS_B CALL MPI_PACK( W(1+(K-1)*LDW), LONG, MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE, & POSITION, COMM, IERR_MPI ) END DO ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_VCB SUBROUTINE DMUMPS_BUF_SEND_1INT( I, DEST, TAG, COMM, & KEEP, IERR ) IMPLICIT NONE INTEGER I INTEGER DEST, TAG, COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER IPOS, IREQ, MSG_SIZE, POSITION INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1)=DEST IERR = 0 CALL MPI_PACK_SIZE( 1, MPI_INTEGER, & COMM, MSG_SIZE, IERR_MPI ) CALL BUF_LOOK( BUF_SMALL, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN write(6,*) ' Internal error in DMUMPS_BUF_SEND_1INT', & ' Buf size (bytes)= ',BUF_SMALL%LBUF RETURN ENDIF POSITION=0 CALL MPI_PACK( I, 1, & MPI_INTEGER, BUF_SMALL%CONTENT( IPOS ), & MSG_SIZE, & POSITION, COMM, IERR_MPI ) KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_SMALL%CONTENT(IPOS), MSG_SIZE, & MPI_PACKED, DEST, TAG, COMM, & BUF_SMALL%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_1INT SUBROUTINE DMUMPS_BUF_ALL_EMPTY(CHECK_COMM_NODES, & CHECK_COMM_LOAD,FLAG) LOGICAL, INTENT(IN) :: CHECK_COMM_NODES, CHECK_COMM_LOAD LOGICAL, INTENT(OUT) :: FLAG LOGICAL FLAG1, FLAG2, FLAG3 FLAG = .TRUE. IF (CHECK_COMM_NODES) THEN CALL DMUMPS_BUF_EMPTY( BUF_SMALL, FLAG1 ) CALL DMUMPS_BUF_EMPTY( BUF_CB, FLAG2 ) FLAG = FLAG .AND. FLAG1 .AND. FLAG2 ENDIF IF ( CHECK_COMM_LOAD ) THEN CALL DMUMPS_BUF_EMPTY( BUF_LOAD, FLAG3 ) FLAG = FLAG .AND. FLAG3 ENDIF RETURN END SUBROUTINE DMUMPS_BUF_ALL_EMPTY SUBROUTINE DMUMPS_BUF_EMPTY( B, FLAG ) TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: B LOGICAL :: FLAG INTEGER SIZE_AVAIL CALL DMUMPS_BUF_SIZE_AVAILABLE(B, SIZE_AVAIL) FLAG = ( B%HEAD == B%TAIL ) RETURN END SUBROUTINE DMUMPS_BUF_EMPTY SUBROUTINE DMUMPS_BUF_SIZE_AVAILABLE( B, SIZE_AV ) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER SIZE_AV INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: FLAG IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END IF IF ( B%HEAD .LE. B%TAIL ) THEN SIZE_AV = max( B%LBUF_INT - B%TAIL, B%HEAD - 2 ) ELSE SIZE_AV = B%HEAD - B%TAIL - 1 END IF SIZE_AV = min(SIZE_AV - OVHSIZE, SIZE_AV) SIZE_AV = SIZE_AV * SIZEofINT RETURN END SUBROUTINE DMUMPS_BUF_SIZE_AVAILABLE SUBROUTINE DMUMPS_BUF_TEST() INTEGER :: IPOS, IREQ, IERR INTEGER, PARAMETER :: IONE=1 INTEGER :: MSG_SIZE INTEGER :: DEST2(1) DEST2=-10 MSG_SIZE=1 CALL BUF_LOOK( BUF_CB, IPOS, IREQ, MSG_SIZE, IERR, & IONE , DEST2,.TRUE.) RETURN END SUBROUTINE DMUMPS_BUF_TEST SUBROUTINE BUF_LOOK( B, IPOS, IREQ, MSG_SIZE, IERR, & NDEST , PDEST, TEST_ONLY) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: B INTEGER, INTENT(IN) :: MSG_SIZE INTEGER, INTENT(OUT) :: IPOS, IREQ, IERR LOGICAL, INTENT(IN), OPTIONAL :: TEST_ONLY INTEGER NDEST INTEGER, INTENT(IN) :: PDEST(max(1,NDEST)) INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER :: MSG_SIZE_INT INTEGER :: IBUF LOGICAL :: FLAG INTEGER :: STATUS(MPI_STATUS_SIZE) IERR = 0 IF ( B%HEAD .NE. B%TAIL ) THEN 10 CONTINUE CALL MPI_TEST( B%CONTENT( B%HEAD + REQ ), FLAG, STATUS, & IERR_MPI ) IF ( FLAG ) THEN B%HEAD = B%CONTENT( B%HEAD + NEXT ) IF ( B%HEAD .EQ. 0 ) B%HEAD = B%TAIL IF ( B%HEAD .NE. B%TAIL ) GOTO 10 END IF END IF IF ( B%HEAD .EQ. B%TAIL ) THEN B%HEAD = 1 B%TAIL = 1 B%ILASTMSG = 1 END iF MSG_SIZE_INT = ( MSG_SIZE + ( SIZEofINT - 1 ) ) / SIZEofINT MSG_SIZE_INT = MSG_SIZE_INT + OVHSIZE IF (present(TEST_ONLY)) RETURN FLAG = ( ( B%HEAD .LE. B%TAIL ) & .AND. ( & ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL ) & .OR. ( MSG_SIZE_INT .LE. B%HEAD - 2 ) ) ) & .OR. & ( ( B%HEAD .GT. B%TAIL ) & .AND. ( MSG_SIZE_INT .LE. B%HEAD - B%TAIL - 1 ) ) IF ( .NOT. FLAG & ) THEN IERR = -1 IF ( MSG_SIZE_INT .GT. B%LBUF_INT - 1 ) THEN IERR = -2 ENDIF IPOS = -1 IREQ = -1 RETURN END IF IF ( B%HEAD .LE. B%TAIL ) THEN IF ( MSG_SIZE_INT .LE. B%LBUF_INT - B%TAIL + 1 ) THEN IBUF = B%TAIL ELSE IF ( MSG_SIZE_INT .LE. B%HEAD - 1 ) THEN IBUF = 1 END IF ELSE IBUF = B%TAIL END IF B%CONTENT( B%ILASTMSG + NEXT ) = IBUF B%ILASTMSG = IBUF B%TAIL = IBUF + MSG_SIZE_INT B%CONTENT( IBUF + NEXT ) = 0 IPOS = IBUF + CONTENT IREQ = IBUF + REQ RETURN END SUBROUTINE BUF_LOOK SUBROUTINE BUF_ADJUST( BUF, SIZE ) IMPLICIT NONE TYPE ( DMUMPS_COMM_BUFFER_TYPE ) :: BUF INTEGER SIZE INTEGER SIZE_INT SIZE_INT = ( SIZE + SIZEofINT - 1 ) / SIZEofINT SIZE_INT = SIZE_INT + OVHSIZE BUF%TAIL = BUF%ILASTMSG + SIZE_INT RETURN END SUBROUTINE BUF_ADJUST SUBROUTINE DMUMPS_BUF_SEND_DESC_BANDE( & INODE, NBPROCFILS, NLIG, ILIG, NCOL, ICOL, & NASS, NSLAVES, LIST_SLAVES, & ESTIM_NFS4FATHER_ATSON, & DEST, IBC_SOURCE, NFRONT, COMM, KEEP, IERR & , LRSTATUS &) IMPLICIT NONE INTEGER COMM, IERR, NFRONT INTEGER, intent(in) :: INODE INTEGER, intent(in) :: NLIG, NCOL, NASS, NSLAVES INTEGER, intent(in) :: ESTIM_NFS4FATHER_ATSON INTEGER NBPROCFILS, DEST INTEGER ILIG( NLIG ) INTEGER ICOL( NCOL ) INTEGER, INTENT(IN) :: IBC_SOURCE INTEGER LIST_SLAVES( NSLAVES ) INTEGER, INTENT(INOUT) :: KEEP(500) INTEGER, INTENT(IN) :: LRSTATUS INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_INT, SIZE_BYTES, POSITION, IPOS, IREQ INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 SIZE_INT = ( 9 + NLIG + NCOL + NSLAVES + 1 ) SIZE_BYTES = SIZE_INT * SIZEofINT IF (SIZE_INT.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_BYTES, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = SIZE_INT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NBPROCFILS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NLIG POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCOL POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = LRSTATUS POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ESTIM_NFS4FATHER_ATSON POSITION = POSITION + 1 IF (NSLAVES.GT.0) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) = & LIST_SLAVES( 1: NSLAVES ) POSITION = POSITION + NSLAVES ENDIF BUF_CB%CONTENT( POSITION:POSITION + NLIG - 1 ) = ILIG POSITION = POSITION + NLIG BUF_CB%CONTENT( POSITION:POSITION + NCOL - 1 ) = ICOL POSITION = POSITION + NCOL POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE_BYTES ) THEN WRITE(*,*) 'Error in DMUMPS_BUF_SEND_DESC_BANDE :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE_BYTES, & MPI_PACKED, & DEST, MAITRE_DESC_BANDE, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_DESC_BANDE SUBROUTINE DMUMPS_BUF_SEND_MAITRE2( NBROWS_ALREADY_SENT, & IPERE, ISON, NROW, & IROW, NCOL, ICOL, VAL, LDA, NELIM, TYPE_SON, & NSLAVES, SLAVES, DEST, COMM, IERR, & & SLAVEF, KEEP,KEEP8, INIV2, TAB_POS_IN_PERE ) IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER LDA, NELIM, TYPE_SON INTEGER IPERE, ISON, NROW, NCOL, NSLAVES INTEGER IROW( NROW ) INTEGER ICOL( NCOL ) INTEGER SLAVES( NSLAVES ) DOUBLE PRECISION VAL(LDA, *) INTEGER IPOS, IREQ, DEST, COMM, IERR INTEGER SLAVEF, KEEP(500), INIV2 INTEGER(8) KEEP8(150) INTEGER TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE3, SIZE_PACK, POSITION, I INTEGER NBROWS_PACKET, NCOL_SEND INTEGER SIZE_AV LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER IONE INTEGER DEST2(1) PARAMETER ( IONE=1 ) DEST2(1) = DEST IERR = 0 IF ( NELIM .NE. NROW ) THEN WRITE(*,*) 'Error in TRY_SEND_MAITRE2:',NELIM, NROW CALL MUMPS_ABORT() END IF IF (NBROWS_ALREADY_SENT .EQ. 0) THEN CALL MPI_PACK_SIZE( NROW+NCOL+7+NSLAVES, MPI_INTEGER, & COMM, SIZE1, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK_SIZE( NSLAVES+1, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) ELSE SIZE3 = 0 ENDIF SIZE1=SIZE1+SIZE3 ELSE CALL MPI_PACK_SIZE(7, MPI_INTEGER,COMM,SIZE1,IERR_MPI) ENDIF IF ( KEEP(50).ne.0 .AND. TYPE_SON .eq. 2 ) THEN NCOL_SEND = NROW ELSE NCOL_SEND = NCOL ENDIF CALL DMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF IF (NROW .GT. 0 ) THEN NBROWS_PACKET = (SIZE_AV - SIZE1) / NCOL_SEND / SIZEofREAL NBROWS_PACKET = min(NBROWS_PACKET, NROW - NBROWS_ALREADY_SENT) NBROWS_PACKET = max(NBROWS_PACKET, 0) ELSE NBROWS_PACKET =0 ENDIF IF (NBROWS_PACKET .EQ. 0 .AND. NROW .NE. 0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR=-1 GOTO 100 ENDIF ENDIF 10 CONTINUE CALL MPI_PACK_SIZE( NBROWS_PACKET * NCOL_SEND, & MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF ( NBROWS_PACKET .GT. 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NROW .AND. & SIZE_PACK - SIZE1 .LT. ( SIZE_RBUF_BYTES - SIZE1 ) / 2 & .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , DEST2 & ) IF ( IERR .LT. 0 ) THEN GOTO 100 ENDIF POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSLAVES, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NBROWS_ALREADY_SENT .EQ. 0) THEN IF (NSLAVES.GT.0) THEN CALL MPI_PACK( SLAVES, NSLAVES, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( IROW, NROW, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ICOL, NCOL, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( TYPE_SON .eq. 2 ) THEN CALL MPI_PACK( TAB_POS_IN_PERE(1,INIV2), NSLAVES+1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF IF (NBROWS_PACKET.GE.1) THEN DO I=NBROWS_ALREADY_SENT+1, & NBROWS_ALREADY_SENT+NBROWS_PACKET CALL MPI_PACK( VAL(1,I), NCOL_SEND, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & DEST, MAITRE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN write(*,*) 'Try_send_maitre2, SIZE,POSITION=', & SIZE_PACK,POSITION CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT = NBROWS_ALREADY_SENT + NBROWS_PACKET IF ( NBROWS_ALREADY_SENT .NE. NROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_MAITRE2 SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE2(NBROWS_ALREADY_SENT, & DESC_IN_LU, & IPERE, NFRONT_PERE, NASS_PERE, NFS4FATHER, & NSLAVES_PERE, & ISON, NBROW, LMAP, MAPROW, PERM, IW_CBSON, A_CBSON, LA_CBSON, & ISLAVE, PDEST, PDEST_MASTER, COMM, IERR, & & KEEP,KEEP8, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & PACKED_CB, KEEP253_LOC, NVSCHUR, & SON_NIV, MYID, NPIV_CHECK ) USE DMUMPS_LR_TYPE USE DMUMPS_LR_DATA_M IMPLICIT NONE INTEGER NBROWS_ALREADY_SENT INTEGER, INTENT (in) :: KEEP253_LOC, NVSCHUR INTEGER, INTENT (in) :: SON_NIV INTEGER, INTENT (in), OPTIONAL :: NPIV_CHECK INTEGER IPERE, ISON, NBROW, MYID INTEGER PDEST, ISLAVE, COMM, IERR INTEGER PDEST_MASTER, NASS_PERE, NSLAVES_PERE, & NFRONT_PERE, LMAP INTEGER MAPROW( LMAP ), PERM( max(1, NBROW )) INTEGER IW_CBSON( * ) DOUBLE PRECISION A_CBSON( : ) INTEGER(8) :: LA_CBSON LOGICAL DESC_IN_LU, PACKED_CB INTEGER KEEP(500), N , SLAVEF INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER NFS4FATHER,SIZE3,PS1,NCA,LROW1 INTEGER(8) :: ASIZE LOGICAL COMPUTE_MAX DOUBLE PRECISION, POINTER, DIMENSION(:) :: M_ARRAY INTEGER NBROWS_PACKET INTEGER MAX_ROW_LENGTH INTEGER LROW, NELIM INTEGER(8) :: ITMP8 INTEGER NPIV, NFRONT, HS INTEGER SIZE_PACK, SIZE0, SIZE1, SIZE2, POSITION,I INTEGER SIZE_INTEGERS, B, SIZE_REALS, TMPSIZE, ONEorTWO, SIZE_AV INTEGER NBINT, L INTEGER(8) :: APOS, SHIFTCB_SON, LDA_SON8 INTEGER IPOS_IN_SLAVE INTEGER STATE_SON INTEGER INDICE_PERE, NROW, IPOS, IREQ, NOSLA INTEGER IONE, J, THIS_ROW_LENGTH INTEGER SIZE_DESC_BANDE, DESC_BANDE_BYTES LOGICAL RECV_BUF_SMALLER_THAN_SEND LOGICAL NOT_ENOUGH_SPACE INTEGER PDEST2(1) LOGICAL CB_IS_LR TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_ROW, BEGS_BLR_COL, & BEGS_BLR_STA INTEGER :: NB_ROW_SHIFT, NB_COL_SHIFT, NASS_SHIFT, PANEL2SEND, & CURRENT_PANEL_SIZE, NB_BLR_ROWS, NB_BLR_COLS, & CB_IS_LR_INT, NCOL_SHIFT, NROW_SHIFT, & NBROWS_PACKET_2PACK, & PANEL_BEG_OFFSET INTEGER :: NPIV_LR PARAMETER ( IONE=1 ) INCLUDE 'mumps_headers.h' DOUBLE PRECISION ZERO PARAMETER (ZERO = 0.0D0) CB_IS_LR = (IW_CBSON(1+XXLR).EQ.1 & .OR. IW_CBSON(1+XXLR).EQ.3) IF (CB_IS_LR) THEN CB_IS_LR_INT = 1 ELSE CB_IS_LR_INT = 0 ENDIF COMPUTE_MAX = (KEEP(219) .NE. 0) .AND. & (KEEP(50) .EQ. 2) .AND. & (PDEST.EQ.PDEST_MASTER) IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL DMUMPS_BUF_MAX_ARRAY_MINSIZE(NFS4FATHER,IERR) IF (IERR .NE. 0) THEN IERR = -4 RETURN ENDIF ENDIF ENDIF PDEST2(1) = PDEST IERR = 0 LROW = IW_CBSON( 1 + KEEP(IXSZ)) NELIM = IW_CBSON( 2 + KEEP(IXSZ)) NPIV = IW_CBSON( 4 + KEEP(IXSZ)) IF ( NPIV .LT. 0 ) THEN NPIV = 0 END IF NROW = IW_CBSON( 3 + KEEP(IXSZ)) NFRONT = LROW + NPIV HS = 6 + IW_CBSON( 6 + KEEP(IXSZ)) + KEEP(IXSZ) IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_CB_LRB(IW_CBSON(1+XXF), CB_LRB) IF (SON_NIV.EQ.1) THEN CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_ROW) CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_DYN(IW_CBSON(1+XXF), & BEGS_BLR_COL) NB_BLR_ROWS = size(BEGS_BLR_ROW) - 1 CALL DMUMPS_BLR_RETRIEVE_NB_PANELS(IW_CBSON(1+XXF), & NB_COL_SHIFT) NB_ROW_SHIFT = NB_COL_SHIFT NASS_SHIFT = BEGS_BLR_ROW(NB_ROW_SHIFT+1)-1 NPIV_LR = BEGS_BLR_COL(NB_COL_SHIFT+1)-1 ELSE NPIV_LR=NPIV CALL DMUMPS_BLR_RETRIEVE_BEGSBLR_STA(IW_CBSON(1+XXF), & BEGS_BLR_STA) NB_BLR_ROWS = size(BEGS_BLR_STA) - 2 BEGS_BLR_ROW => BEGS_BLR_STA(2:NB_BLR_ROWS+2) CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C(IW_CBSON(1+XXF), & BEGS_BLR_COL, NB_COL_SHIFT) NASS_SHIFT = 0 NB_ROW_SHIFT = 0 ENDIF PANEL2SEND = -1 DO I=NB_ROW_SHIFT+1,NB_BLR_ROWS IF (BEGS_BLR_ROW(I+1)-1-NASS_SHIFT & .GT.NBROWS_ALREADY_SENT+PERM(1)-1) THEN PANEL2SEND = I EXIT ENDIF ENDDO IF (PANEL2SEND.EQ.-1) THEN write(*,*) 'Internal error: PANEL2SEND not found' CALL MUMPS_ABORT() ENDIF IF (KEEP(50).EQ.0) THEN NB_BLR_COLS = size(BEGS_BLR_COL) - 1 ELSEIF (SON_NIV.EQ.1) THEN NB_BLR_COLS = PANEL2SEND ELSE NB_BLR_COLS = -1 NCOL_SHIFT = NPIV_LR NROW_SHIFT = LROW - NROW DO I=NB_COL_SHIFT+1,size(BEGS_BLR_COL)-1 IF (BEGS_BLR_COL(I+1)-NCOL_SHIFT.GT. & BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT) THEN NB_BLR_COLS = I EXIT ENDIF ENDDO IF (NB_BLR_COLS.EQ.-1) THEN write(*,*) 'Internal error: NB_BLR_COLS not found' CALL MUMPS_ABORT() ENDIF MAX_ROW_LENGTH = BEGS_BLR_ROW(PANEL2SEND+1)-1+NROW_SHIFT ENDIF CURRENT_PANEL_SIZE = BEGS_BLR_ROW(PANEL2SEND+1) & - BEGS_BLR_ROW(PANEL2SEND) PANEL_BEG_OFFSET = PERM(1) + NBROWS_ALREADY_SENT - & BEGS_BLR_ROW(PANEL2SEND) + NASS_SHIFT ENDIF STATE_SON = IW_CBSON(1+XXS) IF (STATE_SON .EQ. S_NOLCBCONTIG) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = int(NPIV,8)*int(NROW,8) ELSE IF (STATE_SON .EQ. S_NOLCLEANED) THEN LDA_SON8 = int(LROW,8) SHIFTCB_SON = 0_8 ELSE LDA_SON8 = int(NFRONT,8) SHIFTCB_SON = int(NPIV,8) ENDIF CALL DMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (PDEST .EQ. PDEST_MASTER) THEN SIZE_DESC_BANDE=0 ELSE SIZE_DESC_BANDE=(7+SLAVEF+KEEP(127)*2) SIZE_DESC_BANDE=SIZE_DESC_BANDE+int(dble(KEEP(12))* & dble(SIZE_DESC_BANDE)/100.0D0) SIZE_DESC_BANDE=max(SIZE_DESC_BANDE, & 7+NSLAVES_PERE+NFRONT_PERE+NFRONT_PERE-NASS_PERE) ENDIF DESC_BANDE_BYTES=SIZE_DESC_BANDE*SIZEofINT IF ( SIZE_AV .LT. SIZE_RBUF_BYTES-DESC_BANDE_BYTES ) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES-DESC_BANDE_BYTES ENDIF SIZE1=0 IF (NBROWS_ALREADY_SENT==0) THEN IF(COMPUTE_MAX) THEN CALL MPI_PACK_SIZE(1, MPI_INTEGER, & COMM, SIZE0, IERR_MPI ) IF(NFS4FATHER .GT. 0) THEN CALL MPI_PACK_SIZE( NFS4FATHER, MPI_DOUBLE_PRECISION, & COMM, SIZE1, IERR_MPI ) ENDIF SIZE1 = SIZE1+SIZE0 ENDIF ENDIF IF (KEEP(50) .EQ. 0) THEN ONEorTWO = 1 ELSE ONEorTWO = 2 ENDIF IF (PDEST .EQ.PDEST_MASTER) THEN L = 0 ELSE IF (KEEP(50) .EQ. 0) THEN L = LROW ELSE L = LROW + PERM(1) - LMAP + NBROWS_ALREADY_SENT - 1 ONEorTWO=ONEorTWO+1 ENDIF NBINT = 6 + L + 1 IF (CB_IS_LR) THEN NBINT = NBINT + 4*(NB_BLR_COLS-NB_COL_SHIFT) + 2 ENDIF CALL MPI_PACK_SIZE( NBINT, MPI_INTEGER, & COMM, TMPSIZE, IERR_MPI ) SIZE1 = SIZE1 + TMPSIZE SIZE_AV = SIZE_AV - SIZE1 NOT_ENOUGH_SPACE=.FALSE. IF (SIZE_AV .LT.0 ) THEN NBROWS_PACKET = 0 NOT_ENOUGH_SPACE=.TRUE. ELSE IF ( KEEP(50) .EQ. 0 ) THEN NBROWS_PACKET = & SIZE_AV / ( ONEorTWO*SIZEofINT+LROW*SIZEofREAL) ELSE B = 2 * ONEorTWO + & ( 1 + 2 * LROW + 2 * PERM(1) + 2 * NBROWS_ALREADY_SENT ) & * SIZEofREAL / SIZEofINT NBROWS_PACKET=int((dble(-B)+sqrt((dble(B)*dble(B))+ & dble(4)*dble(2)*dble(SIZE_AV)/dble(SIZEofINT) * & dble(SIZEofREAL/SIZEofINT)))* & dble(SIZEofINT) / dble(2) / dble(SIZEofREAL)) ENDIF ENDIF 10 CONTINUE NBROWS_PACKET = max( 0, NBROWS_PACKET) NBROWS_PACKET = min(NBROW-NBROWS_ALREADY_SENT, NBROWS_PACKET) NOT_ENOUGH_SPACE = NOT_ENOUGH_SPACE .OR. & (NBROWS_PACKET .EQ.0.AND. NBROW.NE.0) NBROWS_PACKET_2PACK = NBROWS_PACKET IF (CB_IS_LR) THEN NBROWS_PACKET_2PACK = CURRENT_PANEL_SIZE CALL MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_REALS, CB_LRB, & NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND) NOT_ENOUGH_SPACE = (SIZE_AV.LT.SIZE_REALS) IF (.NOT.NOT_ENOUGH_SPACE) THEN NBROWS_PACKET = min(NBROWS_PACKET, & CURRENT_PANEL_SIZE-PANEL_BEG_OFFSET) ENDIF ENDIF IF (NOT_ENOUGH_SPACE) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF IF (CB_IS_LR) THEN IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 ELSEIF (SON_NIV.EQ.1) THEN MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ELSE IF (KEEP(50).EQ.0) THEN MAX_ROW_LENGTH = -99999 SIZE_REALS = NBROWS_PACKET_2PACK * LROW ELSE SIZE_REALS = ( LROW + PERM(1) + NBROWS_ALREADY_SENT ) * & NBROWS_PACKET_2PACK + ( NBROWS_PACKET_2PACK * & ( NBROWS_PACKET_2PACK + 1) ) / 2 MAX_ROW_LENGTH = LROW+PERM(1)-LMAP+NBROWS_ALREADY_SENT & + NBROWS_PACKET_2PACK-1 ENDIF ENDIF SIZE_INTEGERS = ONEorTWO* NBROWS_PACKET_2PACK CALL MPI_PACK_SIZE( SIZE_REALS, MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) CALL MPI_PACK_SIZE( SIZE_INTEGERS, MPI_INTEGER, & COMM, SIZE3, IERR_MPI ) IF (SIZE2 + SIZE3 .GT. SIZE_AV ) THEN NBROWS_PACKET = NBROWS_PACKET -1 IF (NBROWS_PACKET .GT. 0 .AND..NOT.CB_IS_LR) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF SIZE_PACK = SIZE1 + SIZE2 + SIZE3 IF (NBROWS_PACKET + NBROWS_ALREADY_SENT.NE.NBROW .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 .AND. & .NOT. RECV_BUF_SMALLER_THAN_SEND .AND. & .NOT. CB_IS_LR) & THEN IERR = -1 GOTO 100 ENDIF IF (SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE , PDEST2) IF (IERR .EQ. -1 .OR. IERR.EQ. -2) THEN NBROWS_PACKET = NBROWS_PACKET - 1 IF (NBROWS_PACKET > 0 ) GOTO 10 ENDIF IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( IPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (KEEP(50)==0) THEN CALL MPI_PACK( LROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE CALL MPI_PACK( MAX_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF CALL MPI_PACK( NBROWS_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NBROWS_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CB_IS_LR_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF ( PDEST .NE. PDEST_MASTER ) THEN IF (KEEP(50)==0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), LROW, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE IF (MAX_ROW_LENGTH > 0) THEN CALL MPI_PACK( IW_CBSON( HS + NROW + NPIV + 1 ), & MAX_ROW_LENGTH, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF END IF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) INDICE_PERE = IPOS_IN_SLAVE CALL MPI_PACK( INDICE_PERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO IF (CB_IS_LR) THEN CALL DMUMPS_BLR_PACK_CB_LRB(CB_LRB, NB_ROW_SHIFT, & NB_COL_SHIFT, NB_BLR_COLS, PANEL2SEND, & PANEL_BEG_OFFSET, & BUF_CB%CONTENT(IPOS:), & SIZE_PACK, POSITION, COMM, IERR) IF (KEEP(50).ne.0) THEN DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO ENDIF GOTO 200 ENDIF DO J=NBROWS_ALREADY_SENT+1,NBROWS_ALREADY_SENT+NBROWS_PACKET I = PERM(J) INDICE_PERE=MAPROW(I) CALL MUMPS_BLOC2_GET_ISLAVE( & KEEP,KEEP8, IPERE, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & & NASS_PERE, & NFRONT_PERE - NASS_PERE, & NSLAVES_PERE, & INDICE_PERE, & NOSLA, & IPOS_IN_SLAVE ) IF (KEEP(50).ne.0) THEN THIS_ROW_LENGTH = LROW + I - LMAP CALL MPI_PACK( THIS_ROW_LENGTH, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ELSE THIS_ROW_LENGTH = LROW ENDIF IF (DESC_IN_LU) THEN IF ( PACKED_CB ) THEN IF (NELIM.EQ.0) THEN ITMP8 = int(I,8) ELSE ITMP8 = int(NELIM+I,8) ENDIF APOS = ITMP8 * (ITMP8-1_8) / 2_8 + 1_8 ELSE APOS = int(I+NELIM-1, 8) * int(LROW,8) + 1_8 ENDIF ELSE IF ( PACKED_CB ) THEN IF ( LROW .EQ. NROW ) THEN ITMP8 = int(I,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 ELSE ITMP8 = int(I + LROW - NROW,8) APOS = ITMP8 * (ITMP8-1_8)/2_8 + 1_8 - & int(LROW - NROW, 8) * int(LROW-NROW+1,8) / 2_8 ENDIF ELSE APOS = int( I - 1, 8 ) * LDA_SON8 + SHIFTCB_SON + 1_8 ENDIF ENDIF CALL MPI_PACK( A_CBSON( APOS ), THIS_ROW_LENGTH, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDDO 200 CONTINUE IF (NBROWS_ALREADY_SENT == 0) THEN IF (COMPUTE_MAX) THEN CALL MPI_PACK(NFS4FATHER,1, & MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) IF (NFS4FATHER .GT. 0) THEN IF (CB_IS_LR) THEN CALL DMUMPS_BLR_RETRIEVE_M_ARRAY ( & IW_CBSON(1+XXF), M_ARRAY) CALL MPI_PACK(M_ARRAY(1), NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) CALL DMUMPS_BLR_FREE_M_ARRAY ( IW_CBSON(1+XXF) ) ELSE BUF_MAX_ARRAY(1:NFS4FATHER) = ZERO IF(MAPROW(NROW) .GT. NASS_PERE) THEN DO PS1=1,NROW IF(MAPROW(PS1).GT.NASS_PERE) EXIT ENDDO IF (DESC_IN_LU) THEN IF (PACKED_CB) THEN APOS = int(NELIM+PS1,8) * int(NELIM+PS1-1,8) / & 2_8 + 1_8 NCA = -44444 ASIZE = int(NROW,8) * int(NROW+1,8)/2_8 - & int(NELIM+PS1,8) * int(NELIM+PS1-1,8)/2_8 LROW1 = PS1 + NELIM ELSE APOS = int(PS1+NELIM-1,8) * int(LROW,8) + 1_8 NCA = LROW ASIZE = int(NCA,8) * int(NROW-PS1+1,8) LROW1 = LROW ENDIF ELSE IF (PACKED_CB) THEN IF (NPIV.NE.0) THEN WRITE(*,*) "Error in PARPIV/DMUMPS_BUF_SEND_CONTRIB_TYPE2" CALL MUMPS_ABORT() ENDIF LROW1=LROW-NROW+PS1 ITMP8 = int(PS1 + LROW - NROW,8) APOS = ITMP8 * (ITMP8 - 1_8) / 2_8 + 1_8 - & int(LROW-NROW,8)*int(LROW-NROW+1,8)/2_8 ASIZE = int(LROW,8)*int(LROW+1,8)/2_8 - & ITMP8*(ITMP8-1_8)/2_8 NCA = -555555 ELSE APOS = int(PS1-1,8) * LDA_SON8 + 1_8 + SHIFTCB_SON NCA = int(LDA_SON8) ASIZE = LA_CBSON - APOS + 1_8 LROW1=-666666 ENDIF ENDIF IF ( NROW-PS1+1-KEEP253_LOC-NVSCHUR .GT. 0 ) THEN CALL DMUMPS_COMPUTE_MAXPERCOL( & A_CBSON(APOS),ASIZE,NCA, & NROW-PS1+1-KEEP253_LOC-NVSCHUR, & BUF_MAX_ARRAY,NFS4FATHER,PACKED_CB,LROW1) ENDIF ENDIF CALL MPI_PACK(BUF_MAX_ARRAY, NFS4FATHER, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), SIZE_PACK, & POSITION, COMM, IERR_MPI ) ENDIF ENDIF ENDIF ENDIF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, CONTRIB_TYPE2, COMM, & BUF_CB%CONTENT( IREQ ), IERR_MPI ) IF ( SIZE_PACK.LT. POSITION ) THEN WRITE(*,*) ' contniv2: SIZE, POSITION =',SIZE_PACK, POSITION WRITE(*,*) ' NBROW, LROW = ', NBROW, LROW CALL MUMPS_ABORT() END IF IF ( SIZE_PACK .NE. POSITION ) & CALL BUF_ADJUST( BUF_CB, POSITION ) NBROWS_ALREADY_SENT=NBROWS_ALREADY_SENT + NBROWS_PACKET IF (NBROWS_ALREADY_SENT .NE. NBROW ) THEN IERR = -1 ENDIF 100 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE2 SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB(SIZE_OUT, & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND) USE DMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND INTEGER, intent(out) :: SIZE_OUT INTEGER :: J TYPE(LRB_TYPE), POINTER :: LRB SIZE_OUT = 0 DO J=1,NB_BLR_COLS-NB_COL_SHIFT LRB => CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J) IF (LRB%ISLR) THEN SIZE_OUT = SIZE_OUT + LRB%K*(LRB%M+LRB%N) ELSE SIZE_OUT = SIZE_OUT + LRB%M*LRB%N ENDIF ENDDO RETURN END SUBROUTINE MUMPS_BLR_GET_SIZEREALS_CB_LRB SUBROUTINE DMUMPS_BLR_PACK_CB_LRB( & CB_LRB, NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET, & BUF, LBUF, POSITION, COMM, IERR) USE DMUMPS_LR_TYPE IMPLICIT NONE TYPE(LRB_TYPE), POINTER :: CB_LRB(:,:) INTEGER, INTENT(IN) :: NB_ROW_SHIFT, NB_COL_SHIFT, NB_BLR_COLS, & PANEL2SEND, PANEL_BEG_OFFSET INTEGER, intent(out) :: IERR INTEGER, intent(in) :: COMM, LBUF INTEGER, intent(inout) :: POSITION INTEGER, intent(inout) :: BUF(:) INTEGER :: J, IERR_MPI INCLUDE 'mpif.h' IERR = 0 CALL MPI_PACK( NB_BLR_COLS-NB_COL_SHIFT, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( PANEL_BEG_OFFSET, 1, MPI_INTEGER, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) DO J=1,NB_BLR_COLS-NB_COL_SHIFT CALL DMUMPS_MPI_PACK_LRB( & CB_LRB(PANEL2SEND-NB_ROW_SHIFT,J), & BUF, LBUF, POSITION, COMM, IERR ) ENDDO END SUBROUTINE DMUMPS_BLR_PACK_CB_LRB SUBROUTINE DMUMPS_BUF_SEND_MAPLIG( & INODE, NFRONT, NASS1, NFS4FATHER, & ISON, MYID, NSLAVES, SLAVES_PERE, & TROW, NCBSON, & COMM, IERR, & DEST, NDEST, SLAVEF, & & KEEP,KEEP8, STEP, N, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & & ) IMPLICIT NONE INTEGER INODE, NFRONT, NASS1, NCBSON, NSLAVES, & NDEST INTEGER SLAVEF, MYID, ISON INTEGER TROW( NCBSON ) INTEGER DEST( NDEST ) INTEGER SLAVES_PERE( NSLAVES ) INTEGER COMM, IERR INTEGER KEEP(500), N INTEGER(8) KEEP8(150) INTEGER STEP(N), & ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER SIZE_AV, IDEST, NSEND, SIZE, NFS4FATHER INTEGER TROW_SIZE, POSITION, INDX, INIV2 INTEGER IPOS, IREQ INTEGER IONE PARAMETER ( IONE=1 ) INTEGER NASS_SON NASS_SON = -99998 IERR = 0 IF ( NDEST .eq. 1 ) THEN IF ( DEST(1).EQ.MYID ) GOTO 500 SIZE = SIZEofINT * ( 7 + NSLAVES + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF (SIZE.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 RETURN END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST & ) IF (IERR .LT. 0 ) THEN RETURN ENDIF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NCBSON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+NCBSON-1 ) = & TROW( 1: NCBSON ) POSITION = POSITION + NCBSON POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) 'Error in DMUMPS_BUF_SEND_MAPLIG :', & ' wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( NDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) ELSE NSEND = 0 DO IDEST = 1, NDEST IF ( DEST( IDEST ) .ne. MYID ) NSEND = NSEND + 1 END DO SIZE = SIZEofINT * & ( ( OVHSIZE + 7 + NSLAVES )* NSEND + NCBSON ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * NSEND*( NSLAVES + 1 ) ENDIF CALL DMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF ( SIZE_AV .LT. SIZE ) THEN IERR = -1 RETURN END IF DO IDEST= 1, NDEST CALL MUMPS_BLOC2_GET_SLAVE_INFO( & KEEP,KEEP8, ISON, STEP, N, SLAVEF, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, & IDEST, NCBSON, & NDEST, & TROW_SIZE, INDX ) SIZE = SIZEofINT * ( NSLAVES + TROW_SIZE + 7 ) IF ( NSLAVES.GT.0 ) THEN SIZE = SIZE + SIZEofINT * ( NSLAVES + 1 ) ENDIF IF ( MYID .NE. DEST( IDEST ) ) THEN IF (SIZE.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE, IERR, & IONE, DEST(IDEST) ) IF ( IERR .LT. 0 ) THEN WRITE(*,*) 'Internal error DMUMPS_BUF_SEND_MAPLIG', & 'IERR after BUF_LOOK=',IERR CALL MUMPS_ABORT() END IF POSITION = IPOS BUF_CB%CONTENT( POSITION ) = INODE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = ISON POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NSLAVES POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFRONT POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NASS1 POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = TROW_SIZE POSITION = POSITION + 1 BUF_CB%CONTENT( POSITION ) = NFS4FATHER POSITION = POSITION + 1 IF ( NSLAVES.GT.0 ) THEN INIV2 = ISTEP_TO_INIV2 ( STEP(INODE) ) BUF_CB%CONTENT( POSITION: POSITION + NSLAVES ) & = TAB_POS_IN_PERE(1:NSLAVES+1,INIV2) POSITION = POSITION + NSLAVES + 1 ENDIF IF ( NSLAVES .NE. 0 ) THEN BUF_CB%CONTENT( POSITION: POSITION + NSLAVES - 1 ) & = SLAVES_PERE( 1: NSLAVES ) POSITION = POSITION + NSLAVES END IF BUF_CB%CONTENT( POSITION:POSITION+TROW_SIZE-1 ) = & TROW( INDX: INDX + TROW_SIZE - 1 ) POSITION = POSITION + TROW_SIZE POSITION = POSITION - IPOS IF ( POSITION * SIZEofINT .NE. SIZE ) THEN WRITE(*,*) ' ERROR 1 in TRY_SEND_MAPLIG:', & 'Wrong estimated size' CALL MUMPS_ABORT() END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), SIZE, & MPI_PACKED, & DEST( IDEST ), MAPLIG, COMM, & BUF_CB%CONTENT( IREQ ), & IERR_MPI ) END IF END DO END IF 500 CONTINUE RETURN END SUBROUTINE DMUMPS_BUF_SEND_MAPLIG SUBROUTINE DMUMPS_BUF_SEND_BLOCFACTO( INODE, NFRONT, & NCOL, NPIV, FPERE, LASTBL, IPIV, VAL, & PDEST, NDEST, KEEP, NB_BLOC_FAC, & NSLAVES_TOT, & WIDTH, COMM, & NELIM, NPARTSASS, CURRENT_BLR_PANEL, & LR_ACTIVATED, BLR_LorU, & & IERR ) USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER, intent(in) :: INODE, NCOL, NPIV, & FPERE, NFRONT, NDEST INTEGER, intent(in) :: IPIV( NPIV ) DOUBLE PRECISION, intent(in) :: VAL( NFRONT, * ) INTEGER, intent(in) :: PDEST( NDEST ) INTEGER, intent(inout) :: KEEP(500) INTEGER, intent(in) :: NB_BLOC_FAC, & NSLAVES_TOT, COMM, WIDTH LOGICAL, intent(in) :: LASTBL LOGICAL, intent(in) :: LR_ACTIVATED INTEGER, intent(in) :: NELIM, NPARTSASS, CURRENT_BLR_PANEL TYPE (LRB_TYPE), DIMENSION(:), intent(in) :: BLR_LorU INTEGER, intent(inout) :: IERR INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZE3, SIZET, & IDEST, IPOSMSG, I INTEGER NPIVSENT INTEGER SSS INTEGER :: NBMSGS INTEGER, ALLOCATABLE, DIMENSION(:) :: RELAY_INFO INTEGER :: LRELAY_INFO, DEST_BLOCFACTO, TAG_BLOCFACTO INTEGER :: LR_ACTIVATED_INT IERR = 0 LRELAY_INFO = 0 NBMSGS = NDEST IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + ( NBMSGS - 1 ) * OVHSIZE + & 1+LRELAY_INFO, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) END IF END IF SIZE2 = 0 CALL MPI_PACK_SIZE( 4, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 IF ( KEEP(50).NE.0 ) THEN CALL MPI_PACK_SIZE( 1, MPI_INTEGER, COMM, SIZE3, IERR_MPI ) SIZE2=SIZE2+SIZE3 ENDIF IF ((NPIV.GT.0) & ) THEN IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( NPIV*NCOL, MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 ELSE CALL MPI_PACK_SIZE( NPIV*(NPIV+NELIM), MPI_DOUBLE_PRECISION, & COMM, SIZE3, IERR_MPI ) SIZE2 = SIZE2+SIZE3 CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LorU, SIZE3, COMM, IERR ) SIZE2 = SIZE2+SIZE3 ENDIF ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN SSS = 0 IF ( LASTBL ) THEN IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 6 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF ELSE IF ( KEEP(50) .eq. 0 ) THEN CALL MPI_PACK_SIZE( 3 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) ELSE CALL MPI_PACK_SIZE( 4 + NPIV + 1+LRELAY_INFO, & MPI_INTEGER, COMM, SSS, IERR_MPI ) END IF END IF SSS = SSS + SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -3 RETURN ENDIF ENDIF IF (LRELAY_INFO.GT.0) THEN CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , RELAY_INFO(2)) ELSE CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NBMSGS , PDEST) ENDIF IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NBMSGS - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NBMSGS - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NBMSGS - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NBMSGS POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) NPIVSENT = NPIV IF (LASTBL) NPIVSENT = -NPIV CALL MPI_PACK( NPIVSENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LASTBL .or. KEEP(50).ne.0 ) THEN CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF IF ( LASTBL .AND. KEEP(50) .NE. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NB_BLOC_FAC, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END IF CALL MPI_PACK( NCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NELIM, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPARTSASS, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( CURRENT_BLR_PANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( KEEP(50) .ne. 0 ) THEN CALL MPI_PACK( NSLAVES_TOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF ( (NPIV.GT.0) & ) THEN IF (NPIV.GT.0) THEN CALL MPI_PACK( IPIV, NPIV, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF IF (LR_ACTIVATED) THEN DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NPIV+NELIM, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO CALL DMUMPS_MPI_PACK_LR( BLR_LorU, & BUF_CB%CONTENT(IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1), & SIZET, POSITION, COMM, IERR) ELSE DO I = 1, NPIV CALL MPI_PACK( VAL(1,I), NCOL, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) END DO ENDIF ENDIF CALL MPI_PACK( LRELAY_INFO, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF ( LRELAY_INFO.GT.0) & CALL MPI_PACK( RELAY_INFO, LRELAY_INFO, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) DO IDEST = 1, NBMSGS IF (LRELAY_INFO .GT. 0) THEN DEST_BLOCFACTO = RELAY_INFO(IDEST+1) ELSE DEST_BLOCFACTO = PDEST(IDEST) ENDIF IF ( KEEP(50) .EQ. 0) THEN TAG_BLOCFACTO = BLOC_FACTO KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, TAG_BLOCFACTO, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) ELSE KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, & MPI_PACKED, & DEST_BLOCFACTO, BLOC_FACTO_SYM, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END IF END DO SIZET = SIZET - ( NBMSGS - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blocfacto : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_BLOCFACTO SUBROUTINE DMUMPS_BUF_SEND_BLFAC_SLAVE( INODE, & NPIV, FPERE, IPOSK, JPOSK, UIP21K, NCOLU, & NDEST, PDEST, COMM, KEEP, & LR_ACTIVATED, BLR_LS, IPANEL, & A , LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, MAXI_CLUSTER, IERR ) USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER INODE, NCOLU, IPOSK, JPOSK, NPIV, NDEST, FPERE DOUBLE PRECISION UIP21K( NPIV, * ) INTEGER PDEST( NDEST ) INTEGER COMM, IERR INTEGER, INTENT(INOUT) :: KEEP(500) LOGICAL, intent(in) :: LR_ACTIVATED TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_LS INTEGER(8), intent(in) :: LA, POSBLOCFACTO INTEGER, intent(in) :: LD_BLOCFACTO, IPIV(NPIV), & MAXI_CLUSTER, IPANEL DOUBLE PRECISION, intent(inout) :: A(LA) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: IERR_MPI INTEGER LR_ACTIVATED_INT INTEGER POSITION, IREQ, IPOS, SIZE1, SIZE2, SIZET, & IDEST, IPOSMSG, SSS, SSLR IERR = 0 CALL MPI_PACK_SIZE( 6 + ( NDEST - 1 ) * OVHSIZE, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE2 = 0 CALL MPI_PACK_SIZE(2, MPI_INTEGER, COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR IF (.NOT. LR_ACTIVATED) THEN CALL MPI_PACK_SIZE( abs(NPIV)*NCOLU, MPI_DOUBLE_PRECISION, & COMM, SSLR, IERR_MPI ) SIZE2=SIZE2+SSLR ELSE CALL MUMPS_MPI_PACK_SIZE_LR( BLR_LS, SSLR, COMM, IERR ) SIZE2=SIZE2+SSLR ENDIF SIZET = SIZE1 + SIZE2 IF (SIZET.GT.SIZE_RBUF_BYTES) THEN CALL MPI_PACK_SIZE( 6 , & MPI_INTEGER, COMM, SSS, IERR_MPI ) SSS = SSS+SIZE2 IF (SSS.GT.SIZE_RBUF_BYTES) THEN IERR = -2 RETURN ENDIF END IF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZET, IERR, & NDEST, PDEST) IF ( IERR .LT. 0 ) THEN RETURN ENDIF BUF_CB%ILASTMSG = BUF_CB%ILASTMSG + ( NDEST - 1 ) * OVHSIZE IPOS = IPOS - OVHSIZE DO IDEST = 1, NDEST - 1 BUF_CB%CONTENT( IPOS + ( IDEST - 1 ) * OVHSIZE ) = & IPOS + IDEST * OVHSIZE END DO BUF_CB%CONTENT( IPOS + ( NDEST - 1 ) * OVHSIZE ) = 0 IPOSMSG = IPOS + OVHSIZE * NDEST POSITION = 0 CALL MPI_PACK( INODE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( JPOSK, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NPIV, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( FPERE, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NCOLU, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN LR_ACTIVATED_INT = 1 ELSE LR_ACTIVATED_INT = 0 ENDIF CALL MPI_PACK( LR_ACTIVATED_INT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) CALL MPI_PACK( IPANEL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) IF (LR_ACTIVATED) THEN CALL MUMPS_MPI_PACK_SCALE_LR( BLR_LS, & BUF_CB%CONTENT( IPOSMSG: & IPOSMSG+(SIZET+KEEP(34)-1)/KEEP(34)-1 ), & SIZET, POSITION, COMM, & A, LA, POSBLOCFACTO, LD_BLOCFACTO, & IPIV, NPIV, MAXI_CLUSTER, IERR ) ELSE CALL MPI_PACK( UIP21K, abs(NPIV) * NCOLU, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOSMSG ), SIZET, & POSITION, COMM, IERR_MPI ) ENDIF DO IDEST = 1, NDEST KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOSMSG ), POSITION, MPI_PACKED, & PDEST(IDEST), BLOC_FACTO_SYM_SLAVE, COMM, & BUF_CB%CONTENT( IREQ + ( IDEST-1 ) * OVHSIZE ), & IERR_MPI ) END DO SIZET = SIZET - ( NDEST - 1 ) * OVHSIZE * SIZEofINT IF ( SIZET .LT. POSITION ) THEN WRITE(*,*) ' Error sending blfac slave : size < position' WRITE(*,*) ' Size,position=',SIZET,POSITION CALL MUMPS_ABORT() END IF IF ( SIZET .NE. POSITION ) CALL BUF_ADJUST( BUF_CB, POSITION ) RETURN END SUBROUTINE DMUMPS_BUF_SEND_BLFAC_SLAVE SUBROUTINE DMUMPS_BUF_SEND_CONTRIB_TYPE3( N, ISON, & NBCOL_SON, NBROW_SON, INDCOL_SON, INDROW_SON, & LD_SON, VAL_SON, TAG, SUBSET_ROW, SUBSET_COL, & NSUBSET_ROW, NSUBSET_COL, & NSUPROW, NSUPCOL, & NPROW, NPCOL, MBLOCK, RG2L_ROW, RG2L_COL, & NBLOCK, PDEST, COMM, IERR , & TAB, TABSIZE, TRANSP, SIZE_PACK, & N_ALREADY_SENT, KEEP, BBPCBP ) IMPLICIT NONE INTEGER N, ISON, NBCOL_SON, NBROW_SON, NSUBSET_ROW, NSUBSET_COL INTEGER NPROW, NPCOL, MBLOCK, NBLOCK, LD_SON INTEGER BBPCBP INTEGER PDEST, TAG, COMM, IERR INTEGER INDCOL_SON( NBCOL_SON ), INDROW_SON( NBROW_SON ) INTEGER SUBSET_ROW( NSUBSET_ROW ), SUBSET_COL( NSUBSET_COL ) INTEGER :: RG2L_ROW(N) INTEGER :: RG2L_COL(N) INTEGER NSUPROW, NSUPCOL INTEGER(8), INTENT(IN) :: TABSIZE INTEGER SIZE_PACK INTEGER KEEP(500) DOUBLE PRECISION VAL_SON( LD_SON, * ), TAB(*) LOGICAL TRANSP INTEGER N_ALREADY_SENT INCLUDE 'mpif.h' INTEGER :: IERR_MPI INTEGER SIZE1, SIZE2, SIZE_AV, POSITION INTEGER SIZE_CBP, SIZE_TMP INTEGER IREQ, IPOS, ITAB INTEGER ISUB, JSUB, I, J INTEGER ILOC_ROOT, JLOC_ROOT INTEGER IPOS_ROOT, JPOS_ROOT INTEGER IONE LOGICAL RECV_BUF_SMALLER_THAN_SEND INTEGER PDEST2(1) PARAMETER ( IONE=1 ) INTEGER N_PACKET INTEGER NSUBSET_ROW_EFF, NSUBSET_COL_EFF, NSUPCOL_EFF PDEST2(1) = PDEST IERR = 0 IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN CALL DMUMPS_BUF_SIZE_AVAILABLE( BUF_CB, SIZE_AV ) IF (SIZE_AV .LT. SIZE_RBUF_BYTES) THEN RECV_BUF_SMALLER_THAN_SEND = .FALSE. ELSE RECV_BUF_SMALLER_THAN_SEND = .TRUE. SIZE_AV = SIZE_RBUF_BYTES ENDIF SIZE_AV = min(SIZE_AV, SIZE_RBUF_BYTES) CALL MPI_PACK_SIZE(8 + NSUBSET_COL, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE_CBP = 0 IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW,NSUPCOL) .GT.0) THEN CALL MPI_PACK_SIZE(NSUPROW, MPI_INTEGER, COMM, & SIZE_CBP, IERR_MPI ) CALL MPI_PACK_SIZE(NSUPCOL, MPI_INTEGER, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP CALL MPI_PACK_SIZE(NSUPROW*NSUPCOL, & MPI_DOUBLE_PRECISION, COMM, & SIZE_TMP, IERR_MPI ) SIZE_CBP = SIZE_CBP + SIZE_TMP SIZE1 = SIZE1 + SIZE_CBP ENDIF IF (BBPCBP.EQ.1) THEN NSUBSET_COL_EFF = NSUBSET_COL - NSUPCOL NSUPCOL_EFF = 0 ELSE NSUBSET_COL_EFF = NSUBSET_COL NSUPCOL_EFF = NSUPCOL ENDIF NSUBSET_ROW_EFF = NSUBSET_ROW - NSUPROW N_PACKET = & (SIZE_AV - SIZE1) / (SIZEofINT + NSUBSET_COL_EFF * SIZEofREAL) 10 CONTINUE N_PACKET = min( N_PACKET, & NSUBSET_ROW_EFF-N_ALREADY_SENT ) IF (N_PACKET .LE. 0 .AND. & NSUBSET_ROW_EFF-N_ALREADY_SENT.GT.0) THEN IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR=-3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF CALL MPI_PACK_SIZE( 8 + NSUBSET_COL_EFF + N_PACKET, & MPI_INTEGER, COMM, SIZE1, IERR_MPI ) SIZE1 = SIZE1 + SIZE_CBP CALL MPI_PACK_SIZE( N_PACKET * NSUBSET_COL_EFF, & MPI_DOUBLE_PRECISION, & COMM, SIZE2, IERR_MPI ) SIZE_PACK = SIZE1 + SIZE2 IF (SIZE_PACK .GT. SIZE_AV) THEN N_PACKET = N_PACKET - 1 IF ( N_PACKET > 0 ) THEN GOTO 10 ELSE IF (RECV_BUF_SMALLER_THAN_SEND) THEN IERR = -3 GOTO 100 ELSE IERR = -1 GOTO 100 ENDIF ENDIF ENDIF IF (N_PACKET + N_ALREADY_SENT .NE. NSUBSET_ROW - NSUPROW & .AND. & SIZE_PACK .LT. SIZE_RBUF_BYTES / 4 & .AND. .NOT. RECV_BUF_SMALLER_THAN_SEND) & THEN IERR = -1 GOTO 100 ENDIF ELSE N_PACKET = 0 CALL MPI_PACK_SIZE(8,MPI_INTEGER, COMM, SIZE_PACK, IERR_MPI ) END IF IF ( SIZE_PACK.GT.SIZE_RBUF_BYTES ) THEN IERR = -3 GOTO 100 ENDIF CALL BUF_LOOK( BUF_CB, IPOS, IREQ, SIZE_PACK, IERR, & IONE, PDEST2 & ) IF ( IERR .LT. 0 ) GOTO 100 POSITION = 0 CALL MPI_PACK( ISON, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_ROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPROW, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUBSET_COL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( NSUPCOL, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_ALREADY_SENT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( N_PACKET, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) CALL MPI_PACK( BBPCBP, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) IF ( NSUBSET_ROW * NSUBSET_COL .NE. 0 ) THEN IF (N_ALREADY_SENT .EQ. 0 .AND. & min(NSUPROW, NSUPCOL) .GT. 0) THEN DO ISUB = NSUBSET_ROW-NSUPROW+1, NSUBSET_ROW I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW(INDCOL_SON( I )) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO DO ISUB = NSUBSET_COL-NSUPCOL+1, NSUBSET_COL J = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO IF ( TABSIZE.GE.int(NSUPROW,8)*int(NSUPCOL,8) ) THEN ITAB = 1 DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) TAB(ITAB) = VAL_SON(J, I) ITAB = ITAB + 1 ENDDO ENDDO CALL MPI_PACK(TAB(1), NSUPROW*NSUPCOL, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE DO JSUB = NSUBSET_ROW - NSUPROW+1, NSUBSET_ROW J = SUBSET_ROW(JSUB) DO ISUB = NSUBSET_COL - NSUPCOL+1, NSUBSET_COL I = SUBSET_COL(ISUB) CALL MPI_PACK(VAL_SON(J,I), 1, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ENDDO ENDIF ENDIF IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) IPOS_ROOT = RG2L_ROW( INDROW_SON( I ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = RG2L_COL( INDCOL_SON( J ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO JSUB = NSUBSET_COL_EFF-NSUPCOL_EFF+1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) JPOS_ROOT = INDCOL_SON( J ) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) IPOS_ROOT = RG2L_ROW( INDCOL_SON( J ) ) ILOC_ROOT = MBLOCK & * ( ( IPOS_ROOT - 1 ) / ( MBLOCK * NPROW ) ) & + mod( IPOS_ROOT - 1, MBLOCK ) + 1 CALL MPI_PACK( ILOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = 1, NSUBSET_COL_EFF - NSUPCOL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = RG2L_COL( INDROW_SON( I ) ) JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO DO ISUB = NSUBSET_COL_EFF - NSUPCOL_EFF + 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) JPOS_ROOT = INDROW_SON(I) - N JLOC_ROOT = NBLOCK & * ( ( JPOS_ROOT - 1 ) / ( NBLOCK * NPCOL ) ) & + mod( JPOS_ROOT - 1, NBLOCK ) + 1 CALL MPI_PACK( JLOC_ROOT, 1, MPI_INTEGER, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ENDDO END IF IF ( TABSIZE.GE.int(N_PACKET,8)*int(NSUBSET_COL_EFF,8) ) THEN IF ( .NOT. TRANSP ) THEN ITAB = 1 DO ISUB = N_ALREADY_SENT+1, & N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) TAB( ITAB ) = VAL_SON(J,I) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) ELSE ITAB = 1 DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) TAB( ITAB ) = VAL_SON( J, I ) ITAB = ITAB + 1 END DO END DO CALL MPI_PACK(TAB(1), NSUBSET_COL_EFF*N_PACKET, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END IF ELSE IF ( .NOT. TRANSP ) THEN DO ISUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET I = SUBSET_ROW( ISUB ) DO JSUB = 1, NSUBSET_COL_EFF J = SUBSET_COL( JSUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO ELSE DO JSUB = N_ALREADY_SENT+1, N_ALREADY_SENT+N_PACKET J = SUBSET_ROW( JSUB ) DO ISUB = 1, NSUBSET_COL_EFF I = SUBSET_COL( ISUB ) CALL MPI_PACK( VAL_SON( J, I ), 1, & MPI_DOUBLE_PRECISION, & BUF_CB%CONTENT( IPOS ), & SIZE_PACK, POSITION, COMM, IERR_MPI ) END DO END DO END IF ENDIF END IF KEEP(266)=KEEP(266)+1 CALL MPI_ISEND( BUF_CB%CONTENT( IPOS ), POSITION, MPI_PACKED, & PDEST, TAG, COMM, BUF_CB%CONTENT( IREQ ), & IERR_MPI ) IF ( SIZE_PACK .LT. POSITION ) THEN WRITE(*,*) ' Error sending contribution to root:Size 0) THEN SCALED(1:BLR(I)%K,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%R(1:BLR(I)%K,J) J = J+1 CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%K) = BLR(I)%R(1:BLR(I)%K,J) SCALED(1:BLR(I)%K,1) = PIV1 * BLR(I)%R(1:BLR(I)%K,J) & + OFFDIAG * BLR(I)%R(1:BLR(I)%K,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%K, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%K,2) = OFFDIAG * BLOCK(1:BLR(I)%K) & + PIV2 * BLR(I)%R(1:BLR(I)%K,J+1) J =J+2 CALL MPI_PACK( SCALED(1,2), BLR(I)%K, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) ENDIF END DO ENDIF ELSE J = 1 DO WHILE (J <= BLR(I)%N) IF (IPIV(J) > 0) THEN SCALED(1:BLR(I)%M,1) = A(POSELTD+LD_DIAG*(J-1)+J-1) & * BLR(I)%Q(1:BLR(I)%M,J) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J = J+1 ELSE PIV1 = A(POSELTD+LD_DIAG*(J-1)+J-1) PIV2 = A(POSELTD+LD_DIAG*J+J) OFFDIAG = A(POSELTD+LD_DIAG*(J-1)+J) BLOCK(1:BLR(I)%M) = BLR(I)%Q(1:BLR(I)%M,J) SCALED(1:BLR(I)%M,1) = PIV1 * BLR(I)%Q(1:BLR(I)%M,J) & + OFFDIAG * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,1), BLR(I)%M, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) SCALED(1:BLR(I)%M,2) = OFFDIAG * BLOCK(1:BLR(I)%M) & + PIV2 * BLR(I)%Q(1:BLR(I)%M,J+1) CALL MPI_PACK( SCALED(1,2), BLR(I)%M, & MPI_DOUBLE_PRECISION, & BUF(1), LBUF, POSITION, COMM, IERR_MPI ) J=J+2 ENDIF END DO ENDIF ENDDO 500 CONTINUE IF (allocated(BLOCK)) deallocate(BLOCK) IF (allocated(SCALED)) deallocate(SCALED) RETURN END SUBROUTINE MUMPS_MPI_PACK_SCALE_LR END MODULE DMUMPS_BUF MUMPS_5.4.1/src/zmumps_save_restore.F0000664000175000017500000126553314102210525017747 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_SAVE_RESTORE USE ZMUMPS_STRUC_DEF USE ZMUMPS_SAVE_RESTORE_FILES USE ZMUMPS_LR_DATA_M USE MUMPS_FRONT_DATA_MGT_M IMPLICIT NONE CONTAINS SUBROUTINE ZMUMPS_REMOVE_SAVED(id) USE ZMUMPS_OOC INCLUDE 'mpif.h' INTEGER MASTER PARAMETER ( MASTER = 0 ) TYPE (ZMUMPS_STRUC) :: id CHARACTER(len=LEN_SAVE_FILE) :: RESTOREFILE, INFOFILE INTEGER :: fileunit, ierr, SIZE_INT, SIZE_INT8 INTEGER(8) :: size_read, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE INTEGER :: READ_OOC_FILE_NAME_LENGTH,READ_SYM,READ_PAR,READ_NPROCS CHARACTER(len=LEN_SAVE_FILE) :: READ_OOC_FIRST_FILE_NAME CHARACTER :: READ_ARITH LOGICAL :: READ_INT_TYPE_64 CHARACTER(len=23) :: READ_HASH LOGICAL :: FORTRAN_VERSION_OK,UNIT_OK,UNIT_OP LOGICAL :: SAME_OOC INTEGER :: ICNTL34, MAX_LENGTH, FLAG_SAME, SUM_FLAG_SAME TYPE (ZMUMPS_STRUC) :: localid ierr = 0 call ZMUMPS_GET_SAVE_FILES(id,RESTOREFILE,INFOFILE) CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN fileunit = 40 inquire (UNIT=fileunit,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = fileunit ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=fileunit,FILE=RESTOREFILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',FORM='unformatted',IOSTAT=ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) size_read = 0 call MUMPS_READ_HEADER(fileunit,ierr,size_read,SIZE_INT, & SIZE_INT8, TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, & READ_ARITH, READ_INT_TYPE_64, & READ_OOC_FILE_NAME_LENGTH, READ_OOC_FIRST_FILE_NAME, & READ_HASH,READ_SYM,READ_PAR,READ_NPROCS, & FORTRAN_VERSION_OK) close(fileunit) if (ierr.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_CHECK_HEADER(id,.TRUE.,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF ( id%INFO(1) .LT. 0 ) RETURN ICNTL34 = -99998 IF (id%MYID.EQ.MASTER) THEN ICNTL34 = id%ICNTL(34) ENDIF CALL MPI_BCAST( ICNTL34, 1, MPI_INTEGER, MASTER, id%COMM, ierr ) CALL ZMUMPS_CHECK_FILE_NAME(id, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME, SAME_OOC) CALL MPI_ALLREDUCE(READ_OOC_FILE_NAME_LENGTH,MAX_LENGTH,1, & MPI_INTEGER,MPI_MAX,id%COMM,ierr) IF (MAX_LENGTH.NE.-999) THEN FLAG_SAME = 0 IF (SAME_OOC) THEN FLAG_SAME = 1 ENDIF CALL MPI_ALLREDUCE(FLAG_SAME,SUM_FLAG_SAME,1, & MPI_INTEGER,MPI_SUM,id%COMM,ierr) IF (SUM_FLAG_SAME.NE.0) THEN IF (ICNTL34 .EQ. 1) THEN id%ASSOCIATED_OOC_FILES = .TRUE. ELSE id%ASSOCIATED_OOC_FILES = .FALSE. ENDIF ELSE IF (ICNTL34 .NE. 1) THEN localid%COMM = id%COMM localid%INFO(1) = 0 localid%MYID = id%MYID localid%NPROCS = id%NPROCS localid%KEEP(10) = id%KEEP(10) localid%SAVE_PREFIX = id%SAVE_PREFIX localid%SAVE_DIR = id%SAVE_DIR call ZMUMPS_RESTORE_OOC(localid) IF ( localid%INFO(1) .EQ. 0 ) THEN localid%ASSOCIATED_OOC_FILES = .FALSE. IF (READ_OOC_FILE_NAME_LENGTH.NE.-999) THEN call ZMUMPS_OOC_CLEAN_FILES(localid,ierr) IF ( ierr.ne.0 ) THEN id%INFO(1) = -90 id%INFO(2) = id%MYID ENDIF ENDIF ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN ENDIF ENDIF ENDIF call MUMPS_CLEAN_SAVED_DATA(id%MYID,ierr,RESTOREFILE,INFOFILE) IF (ierr.ne.0) THEN id%INFO(1) = -76 id%INFO(2) = id%MYID ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) END SUBROUTINE ZMUMPS_REMOVE_SAVED SUBROUTINE ZMUMPS_RESTORE_OOC(localid) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file_ooc,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: UNIT_OK,UNIT_OP TYPE (ZMUMPS_STRUC) :: localid NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN localid%INFO(1) =-13 localid%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL ZMUMPS_GET_SAVE_FILES(localid,restore_file_ooc,INFO_FILE) IF ( localid%INFO(1) .LT. 0 ) RETURN IN=50 inquire(UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN localid%INFO(1) = -79 localid%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file_ooc #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN localid%INFO(1) = -74 localid%INFO(2) = 0 endif CALL MUMPS_PROPINFO( localid%ICNTL(1), localid%INFO(1), & localid%COMM, localid%MYID ) IF ( localid%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(localid,IN,"restore_ooc" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE ZMUMPS_RESTORE_OOC SUBROUTINE ZMUMPS_COMPUTE_MEMORY_SAVE(id, & TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE) INCLUDE 'mpif.h' INTEGER::NBVARIABLES,NBVARIABLES_ROOT INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER :: INFO1,INFO2,INFOG1,INFOG2,allocok INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE TYPE (ZMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) RETURN END SUBROUTINE ZMUMPS_COMPUTE_MEMORY_SAVE SUBROUTINE ZMUMPS_SAVE(id) INCLUDE 'mpif.h' INTEGER::ierr,OUT,NBVARIABLES,NBVARIABLES_ROOT,OUTINFO CHARACTER(len=LEN_SAVE_FILE):: SAVE_FILE,INFO_FILE LOGICAL:: SAVE_FILE_exist,INFO_FILE_exist INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (ZMUMPS_STRUC) :: id INFO1 = id%INFO(1) INFO2 = id%INFO(2) INFOG1 = id%INFO(1) INFOG2 = id%INFO(1) id%INFO(1)=0 id%INFO(2)=0 id%INFOG(1)=0 id%INFOG(2)=0 MPG= id%ICNTL(3) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,0,"memory_save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) CALL ZMUMPS_GET_SAVE_FILES(id,SAVE_FILE,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=SAVE_FILE, EXIST=SAVE_FILE_exist) IF(SAVE_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUT=60 inquire (UNIT=OUT,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUT ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUT,FILE=SAVE_FILE #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='new',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN inquire(FILE=INFO_FILE, EXIST=INFO_FILE_exist) IF(INFO_FILE_exist) THEN id%INFO(1) = -70 id%INFO(2) = 0 ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN OUTINFO=70 inquire (UNIT=OUTINFO,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = OUTINFO ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=OUTINFO,FILE=INFO_FILE,STATUS='new',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -71 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,OUT,"save" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 CLOSE(OUT) if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"saved instance has negative INFO(1):" & , id%INFO(1) endif IF(PROKG) THEN write(MPG,*) "Save done successfully" IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF write(OUTINFO,*) "Save done by ZMUMPS ", & trim(adjustl(id%VERSION_NUMBER)), & " after JOB=",id%KEEP(40)+456789, & " With SYM, PAR =",id%KEEP(50),id%KEEP(46) write(OUTINFO,*) "On ",id%NPROCS," processes" if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(OUTINFO,*) "with N, NNZ ", id%N, id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(OUTINFO,*) "with N, NNZ_loc=", id%N, id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(OUTINFO,*) "with N, NELT=", id%N, id%NELT endif IF(id%KEEP(10).EQ.1) THEN write(OUTINFO,*) "With a default integer size of 64 bits" ELSE write(OUTINFO,*) "With a default integer size of 32 bits" ENDIF #if defined(MUMPS_F2003) write(OUTINFO,*) "Using MUMPS_F2003" #endif write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding save file is:" write(OUTINFO,*) trim(adjustl(SAVE_FILE)) write(OUTINFO,*) "of size",TOTAL_FILE_SIZE, " Bytes" IF(id%KEEP(201).EQ.1) THEN write(OUTINFO,*) '' write(OUTINFO,*) "The corresponding OOC files are:" K=1 DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(OUTINFO,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF CLOSE(OUTINFO) else CLOSE(OUT,STATUS='delete') CLOSE(OUTINFO,STATUS='delete') endif deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_SAVE SUBROUTINE ZMUMPS_RESTORE(id) INCLUDE 'mpif.h' INTEGER::ierr,IN,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=LEN_SAVE_FILE):: restore_file,INFO_FILE INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES INTEGER(8),allocatable, dimension(:)::SIZE_VARIABLES_ROOT INTEGER,allocatable, dimension(:)::SIZE_GEST INTEGER,allocatable, dimension(:)::SIZE_GEST_ROOT INTEGER:: INFO1,INFO2,INFOG1,INFOG2,MPG,MP,JOB INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE LOGICAL :: PROKG,UNIT_OK,UNIT_OP INTEGER :: I,J,K,H,allocok CHARACTER(len=1) :: TMP_OOC_NAMES(350) TYPE (ZMUMPS_STRUC) :: id NBVARIABLES=186 NBVARIABLES_ROOT=35 allocate(SIZE_VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN allocate(SIZE_GEST_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN SIZE_VARIABLES(:)=0_8 SIZE_VARIABLES_ROOT(:)=0_8 SIZE_GEST(:)=0 SIZE_GEST_ROOT(:)=0 TOTAL_FILE_SIZE=0_8 TOTAL_STRUC_SIZE=0_8 TMP_OOC_NAMES(:)="?" INFO1 = -999 INFO2 = -999 INFOG1 = -999 INFOG2 = -999 CALL ZMUMPS_GET_SAVE_FILES(id,restore_file,INFO_FILE) IF ( id%INFO(1) .LT. 0 ) RETURN IN=80 inquire (UNIT=IN,exist=UNIT_OK,opened=UNIT_OP) IF(.NOT.UNIT_OK .OR. UNIT_OP) THEN id%INFO(1) = -79 id%INFO(2) = IN ENDIF CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN open(UNIT=IN,FILE=restore_file #if defined(MUMPS_F2003) & ,ACCESS="stream" #endif & ,STATUS='old',form='unformatted',iostat=ierr) if(ierr.ne.0) THEN id%INFO(1) = -74 id%INFO(2) = 0 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) RETURN MP= id%ICNTL(2) MPG= id%ICNTL(3) CALL ZMUMPS_SAVE_RESTORE_STRUCTURE(id,IN,"restore" & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) PROKG = ( MPG .GT. 0 .and. id%MYID .eq. 0 ) if(id%INFO(1).EQ.0) then id%INFO(1)=INFO1 id%INFO(2)=INFO2 id%INFOG(1)=INFOG1 id%INFOG(2)=INFOG2 if(id%INFO(1).NE.0) then write(MPG,*) "Warning: " & ,"restored instance has negative INFO(1):" & , id%INFO(1) endif if(MP.GT.0) then JOB=id%KEEP(40)+456789 write(MP,*) "Restore done successfully" write(MP,*) "From file ",trim(adjustl(restore_file)) if((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ.0)) then write(MP,*) "with JOB, N, NNZ ",JOB, id%N,id%NNZ elseif((id%ICNTL(18).EQ.1).AND.(id%ICNTL(5).EQ. 0)) then write(MP,*) "with JOB, N, NNZ_loc=", JOB, id%N, & id%NNZ_loc elseif((id%ICNTL(18).EQ.0).AND.(id%ICNTL(5).EQ. 1)) then write(MP,*) "with JOB, N, NELT=", JOB, id%N, id%NELT endif endif IF(PROKG) THEN IF(id%KEEP(201).EQ.1) THEN K=1 write(MPG,*) "The corresponding OOC files are:" DO I=1,id%OOC_NB_FILE_TYPE DO J=1,id%OOC_NB_FILES(I) DO H=1,id%OOC_FILE_NAME_LENGTH(K)-2 TMP_OOC_NAMES(H)=id%OOC_FILE_NAMES(K,H) ENDDO write(MPG,*) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(K)-2) K=K+1 ENDDO ENDDO ENDIF ENDIF else id%root%gridinit_done=.FALSE. id%KEEP(140)=1 endif CLOSE(IN) deallocate(SIZE_VARIABLES,SIZE_VARIABLES_ROOT) deallocate(SIZE_GEST,SIZE_GEST_ROOT) if (id%KEEP(201) .GT. 0) THEN id%ASSOCIATED_OOC_FILES=.TRUE. ENDIF RETURN END SUBROUTINE ZMUMPS_RESTORE SUBROUTINE ZMUMPS_SAVE_RESTORE_STRUCTURE(id,unit,mode & ,NBVARIABLES,SIZE_VARIABLES,SIZE_GEST & ,NBVARIABLES_ROOT,SIZE_VARIABLES_ROOT,SIZE_GEST_ROOT & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,INFO1,INFO2,INFOG1,INFOG2) USE ZMUMPS_FACSOL_L0OMP_M, ONLY : ZMUMPS_SAVE_RESTORE_L0FACARRAY IMPLICIT NONE INCLUDE 'mpif.h' INTEGER,intent(in)::unit,NBVARIABLES,NBVARIABLES_ROOT CHARACTER(len=*),intent(in) :: mode INTEGER(8),dimension(NBVARIABLES)::SIZE_VARIABLES INTEGER(8),dimension(NBVARIABLES_ROOT)::SIZE_VARIABLES_ROOT INTEGER,dimension(NBVARIABLES)::SIZE_GEST INTEGER,dimension(NBVARIABLES_ROOT)::SIZE_GEST_ROOT INTEGER(8) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER:: INFO1,INFO2,INFOG1,INFOG2 INTEGER:: j,i1,i2,err,ierr CHARACTER(len=30), allocatable, dimension(:)::VARIABLES CHARACTER(len=30), allocatable, dimension(:)::VARIABLES_ROOT CHARACTER(len=30) :: TMP_STRING1, TMP_STRING2 CHARACTER :: ARITH,READ_ARITH INTEGER(8) :: size_written,gest_size,WRITTEN_STRUC_SIZE INTEGER:: SIZE_INT, SIZE_INT8, SIZE_RL_OR_DBL, SIZE_ARITH_DEP INTEGER:: SIZE_DOUBLE_PRECISION, SIZE_LOGICAL, SIZE_CHARACTER INTEGER:: READ_NPROCS, READ_PAR, READ_SYM INTEGER,dimension(NBVARIABLES)::NbRecords INTEGER,dimension(NBVARIABLES_ROOT)::NbRecords_ROOT INTEGER:: size_array1,size_array2,dummy,allocok INTEGER(8):: size_array_INT8_1,size_array_INT8_2 LOGICAL:: INT_TYPE_64, READ_INT_TYPE_64 INTEGER:: tot_NbRecords,NbSubRecords INTEGER(8):: size_read,size_allocated INTEGER(8),dimension(NBVARIABLES)::DIFF_SIZE_ALLOC_READ INTEGER(8),dimension(NBVARIABLES_ROOT)::DIFF_SIZE_ALLOC_READ_ROOT INTEGER::READ_OOC_FILE_NAME_LENGTH CHARACTER(len=LEN_SAVE_FILE):: READ_OOC_FIRST_FILE_NAME INTEGER,dimension(4)::OOC_INDICES CHARACTER(len=8) :: date CHARACTER(len=10) :: time CHARACTER(len=5) :: zone INTEGER,dimension(8):: values CHARACTER(len=23) :: hash,READ_HASH LOGICAL:: BASIC_CHECK LOGICAL :: FORTRAN_VERSION_OK CHARACTER(len=1) :: TMP_OOC_NAMES(350) INTEGER(8)::SIZE_VARIABLES_BLR,SIZE_VARIABLES_FRONT_DATA, & SIZE_VARIABLES_L0FAC INTEGER::SIZE_GEST_BLR,SIZE_GEST_FRONT_DATA,SIZE_GEST_L0FAC TYPE (ZMUMPS_STRUC) :: id allocate(VARIABLES(NBVARIABLES), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES(186)="ASSOCIATED_OOC_FILES" VARIABLES(185)="pad16" VARIABLES(184)="Deficiency" VARIABLES(183)="NB_SINGULAR_VALUES" VARIABLES(182)="SINGULAR_VALUES" VARIABLES(181)="MPITOOMP_PROCS_MAP" VARIABLES(180)="L0_OMP_MAPPING" VARIABLES(179)="PTR_LEAFS_L0_OMP" VARIABLES(178)="PERM_L0_OMP" VARIABLES(177)="VIRT_L0_OMP_MAPPING" VARIABLES(176)="VIRT_L0_OMP" VARIABLES(175)="PHYS_L0_OMP" VARIABLES(174)="IPOOL_A_L0_OMP" VARIABLES(173)="IPOOL_B_L0_OMP" VARIABLES(172)="I8_L0_OMP" VARIABLES(171)="I4_L0_OMP" VARIABLES(170)="THREAD_LA" VARIABLES(169)="LL0_OMP_FACTORS" VARIABLES(168)="LL0_OMP_MAPPING" VARIABLES(167)="L_VIRT_L0_OMP" VARIABLES(166)="L_PHYS_L0_OMP" VARIABLES(165)="LPOOL_B_L0_OMP" VARIABLES(164)="LPOOL_A_L0_OMP" VARIABLES(163)="L0_OMP_FACTORS" VARIABLES(162)="BLRARRAY_ENCODING" VARIABLES(161)="FDM_F_ENCODING" VARIABLES(160)="pad13" VARIABLES(159)="NBGRP" VARIABLES(158)="LRGROUPS" VARIABLES(157)="root" VARIABLES(156)="WORKING" VARIABLES(155)="IPTR_WORKING" VARIABLES(154)="pad14" VARIABLES(153)="SUP_PROC" VARIABLES(152)="PIVNUL_LIST" VARIABLES(151)="OOC_FILE_NAMES" VARIABLES(150)="OOC_FILE_NAME_LENGTH" VARIABLES(149)="pad12" VARIABLES(148)="OOC_NB_FILE_TYPE" VARIABLES(147)="OOC_NB_FILES" VARIABLES(146)="OOC_TOTAL_NB_NODES" VARIABLES(145)="OOC_VADDR" VARIABLES(144)="OOC_SIZE_OF_BLOCK" VARIABLES(143)="OOC_INODE_SEQUENCE" VARIABLES(142)="OOC_MAX_NB_NODES_FOR_ZONE" VARIABLES(141)="INSTANCE_NUMBER" VARIABLES(140)="CB_SON_SIZE" VARIABLES(139)="DKEEP" VARIABLES(138)="LWK_USER" VARIABLES(137)="NBSA_LOCAL" VARIABLES(136)="WK_USER" VARIABLES(135)="CROIX_MANU" VARIABLES(134)="SCHED_SBTR" VARIABLES(133)="SCHED_GRP" VARIABLES(132)="SCHED_DEP" VARIABLES(131)="SBTR_ID" VARIABLES(130)="DEPTH_FIRST_SEQ" VARIABLES(129)="DEPTH_FIRST" VARIABLES(128)="MY_NB_LEAF" VARIABLES(127)="MY_FIRST_LEAF" VARIABLES(126)="MY_ROOT_SBTR" VARIABLES(125)="COST_TRAV" VARIABLES(124)="MEM_SUBTREE" VARIABLES(123)="RHSCOMP" VARIABLES(122)="POSINRHSCOMP_COL" VARIABLES(121)="pad11" VARIABLES(120)="POSINRHSCOMP_COL_ALLOC" VARIABLES(119)="POSINRHSCOMP_ROW" VARIABLES(118)="MEM_DIST" VARIABLES(117)="I_AM_CAND" VARIABLES(116)="TAB_POS_IN_PERE" VARIABLES(115)="FUTURE_NIV2" VARIABLES(114)="ISTEP_TO_INIV2" VARIABLES(113)="CANDIDATES" VARIABLES(112)="ELTPROC" VARIABLES(111)="LELTVAR" VARIABLES(110)="NELT_loc" VARIABLES(109)="DBLARR" VARIABLES(108)="INTARR" VARIABLES(107)="PROCNODE" VARIABLES(106)="S" VARIABLES(105)="PTRFAC" VARIABLES(104)="PTLUST_S" VARIABLES(103)="Step2node" VARIABLES(102)="PROCNODE_STEPS" VARIABLES(101)="NA" VARIABLES(100)="PTRAR" VARIABLES(99)="FRTELT" VARIABLES(98)="FRTPTR" VARIABLES(97)="FILS" VARIABLES(96)="DAD_STEPS" VARIABLES(95)="FRERE_STEPS" VARIABLES(94)="ND_STEPS" VARIABLES(93)="NE_STEPS" VARIABLES(92)="STEP" VARIABLES(91)="NBSA" VARIABLES(90)="LNA" VARIABLES(89)="KEEP" VARIABLES(88)="IS" VARIABLES(87)="ASS_IRECV" VARIABLES(86)="NSLAVES" VARIABLES(85)="NPROCS" VARIABLES(84)="MYID" VARIABLES(83)="COMM_LOAD" VARIABLES(82)="MYID_NODES" VARIABLES(81)="COMM_NODES" VARIABLES(80)="INST_Number" VARIABLES(79)="MAX_SURF_MASTER" VARIABLES(78)="KEEP8" VARIABLES(77)="pad7" VARIABLES(76)="SAVE_PREFIX" VARIABLES(75)="SAVE_DIR" VARIABLES(74)="WRITE_PROBLEM" VARIABLES(73)="OOC_PREFIX" VARIABLES(72)="OOC_TMPDIR" VARIABLES(71)="VERSION_NUMBER" VARIABLES(70)="MAPPING" VARIABLES(69)="LISTVAR_SCHUR" VARIABLES(68)="SCHUR_CINTERFACE" VARIABLES(67)="SCHUR" VARIABLES(66)="SIZE_SCHUR" VARIABLES(65)="SCHUR_LLD" VARIABLES(64)="SCHUR_NLOC" VARIABLES(63)="SCHUR_MLOC" VARIABLES(62)="NBLOCK" VARIABLES(61)="MBLOCK" VARIABLES(60)="NPCOL" VARIABLES(59)="NPROW" VARIABLES(58)="UNS_PERM" VARIABLES(57)="SYM_PERM" VARIABLES(56)="METIS_OPTIONS" VARIABLES(55)="RINFOG" VARIABLES(54)="RINFO" VARIABLES(53)="CNTL" VARIABLES(52)="COST_SUBTREES" VARIABLES(51)="INFOG" VARIABLES(50)="INFO" VARIABLES(49)="ICNTL" VARIABLES(48)="pad6" VARIABLES(47)="LSOL_loc" VARIABLES(46)="LREDRHS" VARIABLES(45)="LRHS_loc" VARIABLES(44)="Nloc_RHS" VARIABLES(43)="NZ_RHS" VARIABLES(42)="NRHS" VARIABLES(41)="LRHS" VARIABLES(40)="IRHS_loc" VARIABLES(39)="ISOL_loc" VARIABLES(38)="IRHS_PTR" VARIABLES(37)="IRHS_SPARSE" VARIABLES(36)="RHS_loc" VARIABLES(35)="SOL_loc" VARIABLES(34)="RHS_SPARSE" VARIABLES(33)="REDRHS" VARIABLES(32)="RHS" VARIABLES(31)="BLKVAR" VARIABLES(30)="BLKPTR" VARIABLES(29)="pad5" VARIABLES(28)="NBLK" VARIABLES(27)="PERM_IN" VARIABLES(26)="pad4" VARIABLES(25)="A_ELT" VARIABLES(24)="ELTVAR" VARIABLES(23)="ELTPTR" VARIABLES(22)="pad3" VARIABLES(21)="NELT" VARIABLES(20)="pad2" VARIABLES(19)="A_loc" VARIABLES(18)="JCN_loc" VARIABLES(17)="IRN_loc" VARIABLES(16)="NNZ_loc" VARIABLES(15)="pad1" VARIABLES(14)="NZ_loc" VARIABLES(13)="pad0" VARIABLES(12)="ROWSCA" VARIABLES(11)="COLSCA" VARIABLES(10)="JCN" VARIABLES(9)="IRN" VARIABLES(8)="A" VARIABLES(7)="NNZ" VARIABLES(6)="NZ" VARIABLES(5)="N" VARIABLES(4)="JOB" VARIABLES(3)="PAR" VARIABLES(2)="SYM" VARIABLES(1)="COMM" allocate(VARIABLES_ROOT(NBVARIABLES_ROOT), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) =-13 id%INFO(2) = NBVARIABLES_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 VARIABLES_ROOT(35)="rootpad4" VARIABLES_ROOT(34)="NB_SINGULAR_VALUES" VARIABLES_ROOT(33)="SINGULAR_VALUES" VARIABLES_ROOT(32)="SVD_VT" VARIABLES_ROOT(31)="SVD_U" VARIABLES_ROOT(30)="gridinit_done" VARIABLES_ROOT(29)="yes" VARIABLES_ROOT(28)="rootpad3" VARIABLES_ROOT(27)="QR_RCOND" VARIABLES_ROOT(26)="rootpad" VARIABLES_ROOT(25)="RHS_ROOT" VARIABLES_ROOT(24)="rootpad2" VARIABLES_ROOT(23)="QR_TAU" VARIABLES_ROOT(22)="SCHUR_POINTER" VARIABLES_ROOT(21)="RHS_CNTR_MASTER_ROOT" VARIABLES_ROOT(20)="rootpad1" VARIABLES_ROOT(19)="IPIV" VARIABLES_ROOT(18)="RG2L_COL" VARIABLES_ROOT(17)="RG2L_ROW" VARIABLES_ROOT(16)="rootpad0" VARIABLES_ROOT(15)="LPIV" VARIABLES_ROOT(14)="CNTXT_BLACS" VARIABLES_ROOT(13)="DESCRIPTOR" VARIABLES_ROOT(12)="TOT_ROOT_SIZE" VARIABLES_ROOT(11)="ROOT_SIZE" VARIABLES_ROOT(10)="RHS_NLOC" VARIABLES_ROOT(9)="SCHUR_LLD" VARIABLES_ROOT(8)="SCHUR_NLOC" VARIABLES_ROOT(7)="SCHUR_MLOC" VARIABLES_ROOT(6)="MYCOL" VARIABLES_ROOT(5)="MYROW" VARIABLES_ROOT(4)="NPCOL" VARIABLES_ROOT(3)="NPROW" VARIABLES_ROOT(2)="NBLOCK" VARIABLES_ROOT(1)="MBLOCK" OOC_INDICES=(/147,148,150,151/) SIZE_INT = id%KEEP(34) SIZE_INT8 = id%KEEP(34)*id%KEEP(10) SIZE_RL_OR_DBL = id%KEEP(16) SIZE_ARITH_DEP = id%KEEP(35) SIZE_DOUBLE_PRECISION = 8 SIZE_LOGICAL = 4 SIZE_CHARACTER = 1 size_written=int(0,kind=8) tot_NbRecords=0 NbRecords(:)=0 NbRecords_ROOT(:)=0 size_read=int(0,kind=8) size_allocated=int(0,kind=8) DIFF_SIZE_ALLOC_READ(:)=0 DIFF_SIZE_ALLOC_READ_ROOT(:)=0 WRITTEN_STRUC_SIZE=int(0,kind=8) TMP_OOC_NAMES(:)="?" SIZE_VARIABLES_BLR=0_8 SIZE_GEST_BLR=0 SIZE_VARIABLES_FRONT_DATA=0_8 SIZE_GEST_FRONT_DATA=0 SIZE_VARIABLES_L0FAC=0 SIZE_GEST_L0FAC=0 if(trim(mode).EQ."memory_save") then elseif(trim(mode).EQ."save") then write(unit,iostat=err) "MUMPS" if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(5*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%MYID.EQ.0) THEN call date_and_time(date,time,zone,values) hash=trim(date)//trim(time)//trim(zone) ENDIF CALL MPI_BCAST( hash, 23, MPI_CHARACTER, 0, id%COMM, ierr ) write(unit,iostat=err) hash if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(23*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(2*SIZE_INT8,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ARITH="ZMUMPS"(1:1) write(unit,iostat=err) ARITH if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(1,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) id%SYM,id%PAR,id%NPROCS if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(3*SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(id%KEEP(10).EQ.1) THEN INT_TYPE_64=.TRUE. ELSE INT_TYPE_64=.FALSE. ENDIF write(unit,iostat=err) INT_TYPE_64 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_LOGICAL,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH(1) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1))= & id%OOC_FILE_NAMES(1,1:id%OOC_FILE_NAME_LENGTH(1)) write(unit,iostat=err) & TMP_OOC_NAMES(1:id%OOC_FILE_NAME_LENGTH(1)) if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ELSE write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif write(unit,iostat=err) -999 if(err.ne.0) THEN id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 size_written=size_written+int(SIZE_INT,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*1,kind=8) #endif ENDIF elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then CALL MUMPS_READ_HEADER(unit,err,size_read,SIZE_INT,SIZE_INT8, & TOTAL_FILE_SIZE, TOTAL_STRUC_SIZE, READ_ARITH, & READ_INT_TYPE_64, READ_OOC_FILE_NAME_LENGTH, & READ_OOC_FIRST_FILE_NAME,READ_HASH, & READ_SYM,READ_PAR,READ_NPROCS,FORTRAN_VERSION_OK) if (err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) elseif (.NOT.FORTRAN_VERSION_OK) THEN id%INFO(1) = -73 id%INFO(2) = 1 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 BASIC_CHECK = .false. IF (trim(mode).EQ."restore_ooc") THEN BASIC_CHECK = .true. ENDIF CALL ZMUMPS_CHECK_HEADER(id,BASIC_CHECK,READ_INT_TYPE_64, & READ_HASH, READ_NPROCS, & READ_ARITH, READ_SYM, READ_PAR) IF (id%INFO(1) .LT. 0) GOTO 100 elseif(trim(mode).EQ."fake_restore") then read(unit,iostat=err) READ_HASH if(err.ne.0) GOTO 100 read(unit,iostat=err) TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE if(err.ne.0) GOTO 100 IF ( id%INFO(1) .LT. 0 ) GOTO 100 GOTO 200 else CALL MUMPS_ABORT() endif DO j=1,size(OOC_INDICES) i1=OOC_INDICES(j) TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("OOC_NB_FILES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_NB_FILES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%OOC_NB_FILES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_NB_FILES)) THEN write(unit,iostat=err) size(id%OOC_NB_FILES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_NB_FILES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_NB_FILES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_NB_FILES(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_NB_FILES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILE_TYPE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_NB_FILE_TYPE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAMES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAMES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_FILE_NAMES,1) & *size(id%OOC_FILE_NAMES,2)*SIZE_CHARACTER ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAMES)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAMES,1) & ,size(id%OOC_FILE_NAMES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAMES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAMES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2 & *SIZE_CHARACTER allocate(id%OOC_FILE_NAMES(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAMES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_FILE_NAME_LENGTH") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_FILE_NAME_LENGTH,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_FILE_NAME_LENGTH)) THEN write(unit,iostat=err) size(id%OOC_FILE_NAME_LENGTH,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_FILE_NAME_LENGTH ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif((trim(mode).EQ."restore").OR. & (trim(mode).EQ."restore_ooc")) then nullify(id%OOC_FILE_NAME_LENGTH) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_FILE_NAME_LENGTH(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_FILE_NAME_LENGTH endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE DEFAULT END SELECT ENDDO if(trim(mode).EQ."restore_ooc") then goto 200 endif DO i1=1,NBVARIABLES TMP_STRING1 = VARIABLES(i1) SELECT CASE(TMP_STRING1) CASE("COMM") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("SYM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SYM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SYM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%PAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%PAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("JOB") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("N") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%N if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%N if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ICNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ICNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%ICNTL,1) read(unit,iostat=err) id%ICNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFO,1) read(unit,iostat=err) INFO1,INFO2 & ,id%INFO(3:size(id%INFO,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%INFOG,1) read(unit,iostat=err) INFOG1,INFOG2 & ,id%INFOG(3:size(id%INFOG,1)) if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_SUBTREES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL read(unit,iostat=err) id%COST_SUBTREES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%CNTL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%CNTL,1) read(unit,iostat=err) id%CNTL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFO") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFO if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFO,1) read(unit,iostat=err) id%RINFO if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RINFOG") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%RINFOG if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%RINFOG,1) read(unit,iostat=err) id%RINFOG if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP8") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP8 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8*size(id%KEEP8,1) read(unit,iostat=err) id%KEEP8 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("KEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%KEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%KEEP,1) read(unit,iostat=err) id%KEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DKEEP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%DKEEP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_RL_OR_DBL*size(id%DKEEP,1) read(unit,iostat=err) id%DKEEP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("A") CASE("IRN") CASE("JCN") CASE("COLSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COLSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%COLSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COLSCA)) THEN write(unit,iostat=err) size(id%COLSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%COLSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COLSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%COLSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COLSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("ROWSCA") IF(id%KEEP(52).NE.-1) THEN NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ROWSCA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ROWSCA,1)*SIZE_RL_OR_DBL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ROWSCA)) THEN write(unit,iostat=err) size(id%ROWSCA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%ROWSCA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ROWSCA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_RL_OR_DBL allocate(id%ROWSCA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ROWSCA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif ELSE ENDIF CASE("NZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NNZ_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NNZ_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%NNZ_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IRN_loc") CASE("JCN_loc") CASE("A_loc") CASE("NELT") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPTR") CASE("ELTVAR") CASE("A_ELT") CASE("PERM_IN") CASE("BLKPTR") CASE("BLKVAR") CASE("RHS") CASE("REDRHS") CASE("RHS_SPARSE") CASE("SOL_loc") CASE("RHS_loc") CASE("IRHS_SPARSE") CASE("IRHS_PTR") CASE("ISOL_loc") CASE("IRHS_loc") CASE("LRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NZ_RHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NZ_RHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NZ_RHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRHS_loc") CASE("Nloc_RHS") CASE("LSOL_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LSOL_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LSOL_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LREDRHS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LREDRHS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LREDRHS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SYM_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%SYM_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SYM_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SYM_PERM)) THEN write(unit,iostat=err) size(id%SYM_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SYM_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SYM_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SYM_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SYM_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("UNS_PERM") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%UNS_PERM)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%UNS_PERM,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%UNS_PERM)) THEN write(unit,iostat=err) size(id%UNS_PERM,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%UNS_PERM ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%UNS_PERM) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%UNS_PERM(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%UNS_PERM endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SIZE_SCHUR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%SIZE_SCHUR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR") CASE("SCHUR_CINTERFACE") CASE("LISTVAR_SCHUR") CASE("MAPPING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MAPPING)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(28)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MAPPING)) THEN write(unit,iostat=err) id%KEEP8(28) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MAPPING ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MAPPING) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT+SIZE_INT8 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%MAPPING(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MAPPING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("VERSION_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%VERSION_NUMBER) & *SIZE_CHARACTER read(unit,iostat=err) id%VERSION_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TMPDIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_TMPDIR) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_TMPDIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=1 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%OOC_PREFIX) & *SIZE_CHARACTER read(unit,iostat=err) id%OOC_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WRITE_PROBLEM") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%WRITE_PROBLEM) & *SIZE_CHARACTER read(unit,iostat=err) id%WRITE_PROBLEM if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MAX_SURF_MASTER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%MAX_SURF_MASTER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("INST_Number") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INST_Number if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INST_Number if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_NODES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID_NODES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID_NODES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID_NODES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COMM_LOAD") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("MYID") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%MYID if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%MYID if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROCS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NPROCS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NPROCS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NSLAVES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NSLAVES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NSLAVES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASS_IRECV") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%ASS_IRECV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%ASS_IRECV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IS)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=id%KEEP(32)*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IS)) THEN write(unit,iostat=err) size(id%IS,1),id%KEEP(32) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IS(1:id%KEEP(32)) DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size(id%IS,1)-id%KEEP(32)) ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IS) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array2*SIZE_INT DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT* & (size_array1-size_array2) allocate(id%IS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IS(1:size_array2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Deficiency") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%Deficiency if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%Deficiency if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LNA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LNA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LNA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBSA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("STEP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%STEP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%STEP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%STEP)) THEN write(unit,iostat=err) size(id%STEP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%STEP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%STEP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES(i1),id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%STEP(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%STEP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NE_STEPS)) THEN write(unit,iostat=err) size(id%NE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%NE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ND_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ND_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ND_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ND_STEPS)) THEN write(unit,iostat=err) size(id%ND_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ND_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ND_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ND_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ND_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("Step2node") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%Step2node)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%Step2node,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%Step2node)) THEN write(unit,iostat=err) size(id%Step2node,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%Step2node ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%Step2node) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%Step2node(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%Step2node endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRERE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRERE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRERE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRERE_STEPS)) THEN write(unit,iostat=err) size(id%FRERE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRERE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRERE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRERE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRERE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DAD_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DAD_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DAD_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DAD_STEPS)) THEN write(unit,iostat=err) size(id%DAD_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DAD_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DAD_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DAD_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DAD_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FILS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FILS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FILS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FILS)) THEN write(unit,iostat=err) size(id%FILS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FILS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FILS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FILS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FILS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRAR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRAR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRAR,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRAR)) THEN write(unit,iostat=err) size(id%PTRAR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTRAR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 NbRecords(i1)=2 elseif(trim(mode).EQ."restore") then nullify(id%PTRAR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRAR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRAR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTPTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTPTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTPTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTPTR)) THEN write(unit,iostat=err) size(id%FRTPTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FRTPTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTPTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTPTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTPTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FRTELT") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FRTELT)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FRTELT,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FRTELT)) THEN write(unit,iostat=err) size(id%FRTELT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%FRTELT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FRTELT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FRTELT(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FRTELT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NA") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%NA)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%NA,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%NA)) THEN write(unit,iostat=err) size(id%NA,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) id%NA ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%NA) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%NA(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%NA endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE_STEPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then NbRecords(i1)=2 IF(associated(id%PROCNODE_STEPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PROCNODE_STEPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PROCNODE_STEPS)) THEN write(unit,iostat=err) size(id%PROCNODE_STEPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PROCNODE_STEPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PROCNODE_STEPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PROCNODE_STEPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PROCNODE_STEPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTLUST_S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTLUST_S)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTLUST_S,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTLUST_S)) THEN write(unit,iostat=err) size(id%PTLUST_S,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PTLUST_S ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTLUST_S) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PTLUST_S(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTLUST_S endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PTRFAC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PTRFAC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PTRFAC,1)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PTRFAC)) THEN write(unit,iostat=err) size(id%PTRFAC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%PTRFAC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PTRFAC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT8 allocate(id%PTRFAC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PTRFAC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("S") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%S)) THEN SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=id%KEEP8(31)*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%S)) THEN write(unit,iostat=err) id%KEEP8(23),id%KEEP8(31) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%S(1:id%KEEP8(31)) DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP*(id%KEEP8(23)-id%KEEP8(31)) ELSE write(unit,iostat=err) int(-999,kind=8) & ,int(-998,kind=8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%S) read(unit,iostat=err) size_array_INT8_1,size_array_INT8_2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,kind=8)) then SIZE_GEST(i1)=SIZE_INT8*2+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8*2 SIZE_VARIABLES(i1)=size_array_INT8_2*SIZE_ARITH_DEP DIFF_SIZE_ALLOC_READ(i1)= & SIZE_ARITH_DEP* & (size_array_INT8_1-size_array_INT8_2) allocate(id%S(1:size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array_INT8_1,id%INFO(2)) endif read(unit,iostat=err) id%S(1:size_array_INT8_2) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("PROCNODE") CASE("INTARR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%INTARR)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(27)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%INTARR)) THEN write(unit,iostat=err) id%KEEP8(27) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%INTARR ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%INTARR) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_INT allocate(id%INTARR(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%INTARR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DBLARR") CASE("NELT_loc") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NELT_loc if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NELT_loc if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LELTVAR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LELTVAR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LELTVAR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ELTPROC") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ELTPROC)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ELTPROC,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ELTPROC)) THEN write(unit,iostat=err) size(id%ELTPROC,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ELTPROC ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ELTPROC) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ELTPROC(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ELTPROC endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I4_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I4_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I4_L0_OMP,1) & *size(id%I4_L0_OMP,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I4_L0_OMP)) THEN write(unit,iostat=err) size(id%I4_L0_OMP,1) & ,size(id%I4_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I4_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I4_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%I4_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I4_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I8_L0_OMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I8_L0_OMP)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%I8_L0_OMP,1) & *size(id%I8_L0_OMP,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I8_L0_OMP)) THEN write(unit,iostat=err) size(id%I8_L0_OMP,1) & ,size(id%I8_L0_OMP,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I8_L0_OMP ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I8_L0_OMP) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%I8_L0_OMP(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%I8_L0_OMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CANDIDATES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%CANDIDATES)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%CANDIDATES,1) & *size(id%CANDIDATES,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%CANDIDATES)) THEN write(unit,iostat=err) size(id%CANDIDATES,1) & ,size(id%CANDIDATES,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%CANDIDATES ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%CANDIDATES) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%CANDIDATES(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%CANDIDATES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ISTEP_TO_INIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%ISTEP_TO_INIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%ISTEP_TO_INIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%ISTEP_TO_INIV2)) THEN write(unit,iostat=err) size(id%ISTEP_TO_INIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%ISTEP_TO_INIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%ISTEP_TO_INIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%ISTEP_TO_INIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%ISTEP_TO_INIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FUTURE_NIV2") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%FUTURE_NIV2)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%FUTURE_NIV2,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FUTURE_NIV2)) THEN write(unit,iostat=err) size(id%FUTURE_NIV2,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%FUTURE_NIV2 ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FUTURE_NIV2) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%FUTURE_NIV2(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%FUTURE_NIV2 endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TAB_POS_IN_PERE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%TAB_POS_IN_PERE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%TAB_POS_IN_PERE,1) & *size(id%TAB_POS_IN_PERE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%TAB_POS_IN_PERE)) THEN write(unit,iostat=err) size(id%TAB_POS_IN_PERE,1) & ,size(id%TAB_POS_IN_PERE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%TAB_POS_IN_PERE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%TAB_POS_IN_PERE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%TAB_POS_IN_PERE(size_array1,size_array2) & , stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%TAB_POS_IN_PERE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("I_AM_CAND") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%I_AM_CAND)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%I_AM_CAND,1)*SIZE_LOGICAL ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%I_AM_CAND)) THEN write(unit,iostat=err) size(id%I_AM_CAND,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%I_AM_CAND ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%I_AM_CAND) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_LOGICAL allocate(id%I_AM_CAND(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%I_AM_CAND endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_DIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_DIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MEM_DIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_DIST)) THEN write(unit,iostat=err) size(id%MEM_DIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) id%MEM_DIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_DIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MEM_DIST(0:size_array1-1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_DIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_ROW") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_ROW,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_ROW)) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_ROW,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_ROW ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_ROW) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_ROW(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_ROW endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL_ALLOC") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_LOGICAL read(unit,iostat=err) id%POSINRHSCOMP_COL_ALLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("POSINRHSCOMP_COL") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%POSINRHSCOMP_COL,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%POSINRHSCOMP_COL)) THEN IF(id%POSINRHSCOMP_COL_ALLOC) THEN write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%POSINRHSCOMP_COL ELSE write(unit,iostat=err) size(id%POSINRHSCOMP_COL,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%POSINRHSCOMP_COL) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else if(id%POSINRHSCOMP_COL_ALLOC) then SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%POSINRHSCOMP_COL(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%POSINRHSCOMP_COL else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy id%POSINRHSCOMP_COL=>id%POSINRHSCOMP_ROW endif endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHSCOMP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%RHSCOMP)) THEN SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=id%KEEP8(25)*SIZE_ARITH_DEP ELSE SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%RHSCOMP)) THEN write(unit,iostat=err) id%KEEP8(25) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%RHSCOMP ELSE write(unit,iostat=err) int(-999,8) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%RHSCOMP) read(unit,iostat=err) size_array_INT8_1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array_INT8_1.EQ.int(-999,8)) then SIZE_GEST(i1)=SIZE_INT8+SIZE_INT SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT8 SIZE_VARIABLES(i1)=size_array_INT8_1*SIZE_ARITH_DEP allocate(id%RHSCOMP(size_array_INT8_1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%RHSCOMP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MEM_SUBTREE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MEM_SUBTREE)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MEM_SUBTREE,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MEM_SUBTREE)) THEN write(unit,iostat=err) size(id%MEM_SUBTREE,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MEM_SUBTREE ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MEM_SUBTREE) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%MEM_SUBTREE(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MEM_SUBTREE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("COST_TRAV") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%COST_TRAV)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%COST_TRAV,1)*SIZE_DOUBLE_PRECISION ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%COST_TRAV)) THEN write(unit,iostat=err) size(id%COST_TRAV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%COST_TRAV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%COST_TRAV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_DOUBLE_PRECISION allocate(id%COST_TRAV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%COST_TRAV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_ROOT_SBTR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_ROOT_SBTR)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_ROOT_SBTR,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_ROOT_SBTR)) THEN write(unit,iostat=err) size(id%MY_ROOT_SBTR,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_ROOT_SBTR ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_ROOT_SBTR) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_ROOT_SBTR(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_ROOT_SBTR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_FIRST_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_FIRST_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_FIRST_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_FIRST_LEAF)) THEN write(unit,iostat=err) size(id%MY_FIRST_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_FIRST_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_FIRST_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_FIRST_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_FIRST_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MY_NB_LEAF") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MY_NB_LEAF)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%MY_NB_LEAF,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MY_NB_LEAF)) THEN write(unit,iostat=err) size(id%MY_NB_LEAF,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MY_NB_LEAF ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MY_NB_LEAF) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MY_NB_LEAF(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MY_NB_LEAF endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DEPTH_FIRST_SEQ") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%DEPTH_FIRST_SEQ,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%DEPTH_FIRST_SEQ)) THEN write(unit,iostat=err) size(id%DEPTH_FIRST_SEQ,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%DEPTH_FIRST_SEQ ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%DEPTH_FIRST_SEQ) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%DEPTH_FIRST_SEQ(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%DEPTH_FIRST_SEQ endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SBTR_ID") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%SBTR_ID)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%SBTR_ID,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%SBTR_ID)) THEN write(unit,iostat=err) size(id%SBTR_ID,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%SBTR_ID ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%SBTR_ID) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%SBTR_ID(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%SBTR_ID endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHED_DEP") CASE("SCHED_GRP") CASE("CROIX_MANU") CASE("WK_USER") CASE("NBSA_LOCAL") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBSA_LOCAL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LWK_USER") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_INT endif CASE("CB_SON_SIZE") CASE("INSTANCE_NUMBER") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%INSTANCE_NUMBER if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_MAX_NB_NODES_FOR_ZONE") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%OOC_MAX_NB_NODES_FOR_ZONE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_INODE_SEQUENCE") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_INODE_SEQUENCE,1) & *size(id%OOC_INODE_SEQUENCE,2)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_INODE_SEQUENCE)) THEN write(unit,iostat=err) size(id%OOC_INODE_SEQUENCE,1) & ,size(id%OOC_INODE_SEQUENCE,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_INODE_SEQUENCE ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_INODE_SEQUENCE) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT allocate(id%OOC_INODE_SEQUENCE(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_INODE_SEQUENCE endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_SIZE_OF_BLOCK") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_SIZE_OF_BLOCK,1) & *size(id%OOC_SIZE_OF_BLOCK,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_SIZE_OF_BLOCK)) THEN write(unit,iostat=err) size(id%OOC_SIZE_OF_BLOCK,1) & ,size(id%OOC_SIZE_OF_BLOCK,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_SIZE_OF_BLOCK ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_SIZE_OF_BLOCK) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_SIZE_OF_BLOCK(size_array1 & ,size_array2), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_SIZE_OF_BLOCK endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_VADDR") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_VADDR)) THEN SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size(id%OOC_VADDR,1) & *size(id%OOC_VADDR,2)*SIZE_INT8 ELSE SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_VADDR)) THEN write(unit,iostat=err) size(id%OOC_VADDR,1) & ,size(id%OOC_VADDR,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_VADDR ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_VADDR) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*3 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=size_array1*size_array2*SIZE_INT8 allocate(id%OOC_VADDR(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_VADDR endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_TOTAL_NB_NODES") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%OOC_TOTAL_NB_NODES,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%OOC_TOTAL_NB_NODES)) THEN write(unit,iostat=err) size(id%OOC_TOTAL_NB_NODES,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%OOC_TOTAL_NB_NODES ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%OOC_TOTAL_NB_NODES) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%OOC_TOTAL_NB_NODES(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%OOC_TOTAL_NB_NODES endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("OOC_NB_FILES") CASE("OOC_NB_FILE_TYPE") CASE("OOC_FILE_NAMES") CASE("OOC_FILE_NAME_LENGTH") CASE("PIVNUL_LIST") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%PIVNUL_LIST)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%PIVNUL_LIST,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%PIVNUL_LIST)) THEN write(unit,iostat=err) size(id%PIVNUL_LIST,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%PIVNUL_LIST ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%PIVNUL_LIST) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%PIVNUL_LIST(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%PIVNUL_LIST endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SUP_PROC") CASE("IPTR_WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%IPTR_WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%IPTR_WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%IPTR_WORKING)) THEN write(unit,iostat=err) size(id%IPTR_WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%IPTR_WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%IPTR_WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%IPTR_WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%IPTR_WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("WORKING") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%WORKING)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%WORKING,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%WORKING)) THEN write(unit,iostat=err) size(id%WORKING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%WORKING ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%WORKING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%WORKING(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%WORKING endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("root") DO i2=1,NBVARIABLES_ROOT TMP_STRING2 = VARIABLES_ROOT(i2) SELECT CASE(TMP_STRING2) CASE("MBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NBLOCK") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NBLOCK if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NBLOCK if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("NPCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NPCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NPCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYROW") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then NbRecords_ROOT(i2)=1 SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYROW if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYROW if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MYCOL") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%MYCOL if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%MYCOL if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_MLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_MLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_LLD") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%SCHUR_LLD if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_NLOC") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%RHS_NLOC if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("TOT_ROOT_SIZE") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%TOT_ROOT_SIZE if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("DESCRIPTOR") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=size(id%root%DESCRIPTOR,1) & *SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT* & size(id%root%DESCRIPTOR,1) read(unit,iostat=err) id%root%DESCRIPTOR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("CNTXT_BLACS") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%CNTXT_BLACS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPIV") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%LPIV if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%LPIV if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RG2L_ROW") CASE("RG2L_COL") CASE("IPIV") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%IPIV)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%IPIV,1)*SIZE_INT ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%IPIV)) THEN write(unit,iostat=err) size(id%root%IPIV,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%IPIV ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%IPIV) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_INT allocate(id%root%IPIV(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%IPIV endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("RHS_CNTR_MASTER_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)= & size(id%root%RHS_CNTR_MASTER_ROOT,1) & *SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_CNTR_MASTER_ROOT)) THEN write(unit,iostat=err) & size(id%root%RHS_CNTR_MASTER_ROOT,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_CNTR_MASTER_ROOT) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT SIZE_VARIABLES_ROOT(i2)=size_array1*SIZE_ARITH_DEP allocate(id%root%RHS_CNTR_MASTER_ROOT(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_CNTR_MASTER_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SCHUR_POINTER") CASE("QR_TAU") CASE("RHS_ROOT") NbRecords_ROOT(i2)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%root%RHS_ROOT)) THEN SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size(id%root%RHS_ROOT,1) & *size(id%root%RHS_ROOT,2)*SIZE_ARITH_DEP ELSE SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%root%RHS_ROOT)) THEN write(unit,iostat=err) size(id%root%RHS_ROOT,1) & ,size(id%root%RHS_ROOT,2) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%root%RHS_ROOT ELSE write(unit,iostat=err) -999,-998 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4( & TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%root%RHS_ROOT) read(unit,iostat=err) size_array1,size_array2 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST_ROOT(i2)=SIZE_INT*3 SIZE_VARIABLES_ROOT(i2)=0_8 read(unit,iostat=err) dummy else SIZE_GEST_ROOT(i2)=SIZE_INT*2 SIZE_VARIABLES_ROOT(i2)=size_array1*size_array2 & *SIZE_ARITH_DEP allocate(id%root%RHS_ROOT(size_array1,size_array2), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4(size_array1*size_array2 & ,id%INFO(2)) endif read(unit,iostat=err) id%root%RHS_ROOT endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("QR_RCOND") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_RL_OR_DBL read(unit,iostat=err) id%root%QR_RCOND if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("yes") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%yes if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%yes if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("gridinit_done") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%gridinit_done if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_LOGICAL read(unit,iostat=err) id%root%gridinit_done if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2), & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SVD_U") CASE("SVD_VT") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords_ROOT(i2)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES_ROOT(i2)=SIZE_INT read(unit,iostat=err) id%root%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(SIZE_VARIABLES_ROOT(i2) & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("rootpad0","rootpad1","rootpad2","rootpad", & "rootpad3","rootpad4") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES_ROOT(i2)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords_ROOT(i2)=NbRecords_ROOT(i2)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES_ROOT(i2) & +SIZE_GEST_ROOT(i2) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES_ROOT(i2)+ & DIFF_SIZE_ALLOC_READ_ROOT(i2) size_read=size_read+SIZE_VARIABLES_ROOT(i2) & +int(SIZE_GEST_ROOT(i2),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords_ROOT(i2),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO CASE("NBGRP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NBGRP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NBGRP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LRGROUPS") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%LRGROUPS)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size(id%LRGROUPS,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%LRGROUPS)) THEN write(unit,iostat=err) size(id%LRGROUPS,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%LRGROUPS ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%LRGROUPS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%LRGROUPS(size_array1), stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%LRGROUPS endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("FDM_F_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%FDM_F_ENCODING)) THEN CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%FDM_F_ENCODING)) THEN write(unit,iostat=err) size(id%FDM_F_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%FDM_F_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL MUMPS_SAVE_RESTORE_FRONT_DATA(id%FDM_F_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_FRONT_DATA,SIZE_VARIABLES_FRONT_DATA & ,SIZE_INT,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("BLRARRAY_ENCODING") NbRecords(i1)=1 SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=0_8 if(trim(mode).EQ."memory_save") then IF(associated(id%BLRARRAY_ENCODING)) THEN CALL ZMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"memory_save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%BLRARRAY_ENCODING)) THEN write(unit,iostat=err) size(id%BLRARRAY_ENCODING,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 CALL ZMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"save" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%BLRARRAY_ENCODING) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.NE.-999) then CALL ZMUMPS_SAVE_RESTORE_BLR(id%BLRARRAY_ENCODING & ,unit,id%MYID,"restore" & ,SIZE_GEST_BLR,SIZE_VARIABLES_BLR & ,SIZE_INT, SIZE_ARITH_DEP, SIZE_LOGICAL & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,id%INFO(1)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L0_OMP_FACTORS") CASE("SCHED_SBTR") CASE("LPOOL_A_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_A_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LPOOL_B_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LPOOL_B_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_PHYS_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_PHYS_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("L_VIRT_L0_OMP") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%L_VIRT_L0_OMP if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_MAPPING") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_MAPPING if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("LL0_OMP_FACTORS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%LL0_OMP_FACTORS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("THREAD_LA") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT8 elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%THREAD_LA if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT8 read(unit,iostat=err) id%THREAD_LA if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("IPOOL_A_L0_OMP") CASE("IPOOL_B_L0_OMP") CASE("PHYS_L0_OMP") CASE("VIRT_L0_OMP") CASE("VIRT_L0_OMP_MAPPING") CASE("PERM_L0_OMP") CASE("PTR_LEAFS_L0_OMP") CASE("L0_OMP_MAPPING") CASE("SINGULAR_VALUES") CASE("NB_SINGULAR_VALUES") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT read(unit,iostat=err) id%NB_SINGULAR_VALUES if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("ASSOCIATED_OOC_FILES") if(trim(mode).EQ."memory_save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."save") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL elseif(trim(mode).EQ."restore") then DIFF_SIZE_ALLOC_READ(i1)=SIZE_LOGICAL endif CASE("SAVE_DIR") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_DIR if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_DIR)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_DIR if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("SAVE_PREFIX") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=len(id%SAVE_PREFIX)*SIZE_CHARACTER read(unit,iostat=err) id%SAVE_PREFIX if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("MPITOOMP_PROCS_MAP") NbRecords(i1)=2 if(trim(mode).EQ."memory_save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)= & size(id%MPITOOMP_PROCS_MAP,1)*SIZE_INT ELSE SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 ENDIF elseif(trim(mode).EQ."save") then IF(associated(id%MPITOOMP_PROCS_MAP)) THEN write(unit,iostat=err) size(id%MPITOOMP_PROCS_MAP,1) if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) id%MPITOOMP_PROCS_MAP ELSE write(unit,iostat=err) -999 if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 ENDIF if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then nullify(id%MPITOOMP_PROCS_MAP) read(unit,iostat=err) size_array1 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then SIZE_GEST(i1)=SIZE_INT*2 SIZE_VARIABLES(i1)=0_8 read(unit,iostat=err) dummy else SIZE_GEST(i1)=SIZE_INT SIZE_VARIABLES(i1)=size_array1*SIZE_INT allocate(id%MPITOOMP_PROCS_MAP(size_array1), & stat=allocok) if (allocok .GT. 0) THEN id%INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,id%INFO(2)) endif read(unit,iostat=err) id%MPITOOMP_PROCS_MAP endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("METIS_OPTIONS") NbRecords(i1)=1 if(trim(mode).EQ."memory_save") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) elseif(trim(mode).EQ."save") then write(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) then id%INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 elseif(trim(mode).EQ."restore") then SIZE_VARIABLES(i1)=SIZE_INT*size(id%METIS_OPTIONS,1) read(unit,iostat=err) id%METIS_OPTIONS if(err.ne.0) THEN id%INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,id%INFO(2)) endif CALL MUMPS_PROPINFO( id%ICNTL(1), id%INFO(1), & id%COMM, id%MYID ) IF ( id%INFO(1) .LT. 0 ) GOTO 100 endif CASE("pad0","pad1","pad2","pad3","pad4","pad5","pad6","pad7", & "pad11","pad111", "pad12","pad13","pad14","pad15","pad16") CASE DEFAULT END SELECT if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES(i1)/huge(0)) IF(NbSubRecords.GT.0) then NbRecords(i1)=NbRecords(i1)+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES(i1)+ & DIFF_SIZE_ALLOC_READ(i1) size_read=size_read+SIZE_VARIABLES(i1) & +int(SIZE_GEST(i1),kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*id%KEEP(34)*NbRecords(i1),kind=8) #endif elseif(trim(mode).EQ."fake_restore") then endif ENDDO 200 continue if(trim(mode).EQ."memory_save") then WRITTEN_STRUC_SIZE=sum(SIZE_VARIABLES)+sum(SIZE_VARIABLES_ROOT) & +SIZE_VARIABLES_BLR+SIZE_VARIABLES_FRONT_DATA+ & SIZE_VARIABLES_L0FAC TOTAL_STRUC_SIZE=WRITTEN_STRUC_SIZE & +sum(DIFF_SIZE_ALLOC_READ) & +sum(DIFF_SIZE_ALLOC_READ_ROOT) gest_size=sum(SIZE_GEST)+sum(SIZE_GEST_ROOT) & +SIZE_GEST_BLR+SIZE_GEST_FRONT_DATA & +SIZE_GEST_L0FAC & +int(5*SIZE_CHARACTER,kind=8) & +int(23*SIZE_CHARACTER,kind=8) & +int(2*SIZE_INT8,kind=8)+int(1,kind=8) & +int(3*SIZE_INT,kind=8) & +int(SIZE_LOGICAL,kind=8) IF(associated(id%OOC_FILE_NAME_LENGTH).AND. & associated(id%OOC_FILE_NAMES)) THEN gest_size=gest_size+int(SIZE_INT,kind=8) & +int(id%OOC_FILE_NAME_LENGTH(1)*SIZE_CHARACTER,kind=8) ELSE gest_size=gest_size+int(2*SIZE_INT,kind=8) ENDIF #if !defined(MUMPS_F2003) tot_NbRecords=sum(NbRecords)+sum(NbRecords_ROOT)+8 gest_size=gest_size+int(2*id%KEEP(34)*tot_NbRecords,kind=8) #endif TOTAL_FILE_SIZE=WRITTEN_STRUC_SIZE+gest_size elseif(trim(mode).EQ."save") then elseif(trim(mode).EQ."restore") then if(id%root%gridinit_done) then id%root%CNTXT_BLACS = id%COMM_NODES CALL blacs_gridinit( id%root%CNTXT_BLACS, 'R', & id%root%NPROW, id%root%NPCOL ) id%root%gridinit_done = .TRUE. endif elseif(trim(mode).EQ."fake_restore") then elseif(trim(mode).EQ."restore_ooc") then endif 100 continue deallocate(VARIABLES, VARIABLES_ROOT) RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_STRUCTURE END MODULE ZMUMPS_SAVE_RESTORE MUMPS_5.4.1/src/zfac_mem_free_block_cb.F0000664000175000017500000000600014102210524020207 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_FREE_BLOCK_CB_STATIC( & SSARBR, MYID, N, IPOSBLOCK, & IW, LIW, & LRLU, LRLUS, IPTRLU, & IWPOSCB, LA, KEEP, KEEP8, IN_PLACE_STATS & ) !$ USE OMP_LIB USE ZMUMPS_LOAD IMPLICIT NONE INTEGER IPOSBLOCK, & LIW, IWPOSCB, N INTEGER(8) :: LA, LRLU, LRLUS, IPTRLU LOGICAL IN_PLACE_STATS INTEGER IW( LIW ), KEEP(500) INTEGER(8) KEEP8(150) INTEGER MYID LOGICAL SSARBR INTEGER SIZFI_BLOCK, SIZFI INTEGER IPOSSHIFT INTEGER(8) :: SIZFR, SIZFR_BLOCK, SIZFR_BLOCK_EFF, & SIZEHOLE, MEM_INC, DYNSIZE_BLOCK INCLUDE 'mumps_headers.h' IPOSSHIFT = IPOSBLOCK + KEEP(IXSZ) SIZFI_BLOCK=IW(IPOSBLOCK+XXI) CALL MUMPS_GETI8( SIZFR_BLOCK, IW(IPOSBLOCK+XXR) ) CALL MUMPS_GETI8( DYNSIZE_BLOCK,IW(IPOSBLOCK+XXD) ) IF (DYNSIZE_BLOCK .GT. 0_8) THEN SIZFR_BLOCK_EFF = 0_8 ELSE IF (KEEP(216).eq.3 & ) THEN SIZFR_BLOCK_EFF = SIZFR_BLOCK ELSE CALL ZMUMPS_SIZEFREEINREC( IW(IPOSBLOCK), & LIW-IPOSBLOCK+1, & SIZEHOLE, KEEP(IXSZ)) SIZFR_BLOCK_EFF = SIZFR_BLOCK - SIZEHOLE ENDIF IF (.NOT. IN_PLACE_STATS) THEN LRLUS = LRLUS + SIZFR_BLOCK_EFF IF (KEEP(405) .EQ. 0) THEN KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF ELSE !$OMP ATOMIC UPDATE KEEP8(69) = KEEP8(69) - SIZFR_BLOCK_EFF !$OMP END ATOMIC ENDIF ENDIF IF ( IPOSBLOCK .eq. IWPOSCB + 1 ) THEN IPTRLU = IPTRLU + SIZFR_BLOCK IWPOSCB = IWPOSCB + SIZFI_BLOCK LRLU = LRLU + SIZFR_BLOCK MEM_INC = -SIZFR_BLOCK_EFF IF (IN_PLACE_STATS) THEN MEM_INC= 0_8 ENDIF CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,MEM_INC,KEEP,KEEP8,LRLUS) 90 IF ( IWPOSCB .eq. LIW ) GO TO 100 IPOSSHIFT = IWPOSCB + KEEP(IXSZ) SIZFI = IW( IWPOSCB+1+XXI ) CALL MUMPS_GETI8( SIZFR, IW(IWPOSCB+1+XXR) ) IF ( IW( IWPOSCB+1+XXS ) .EQ. S_FREE ) THEN IPTRLU = IPTRLU + SIZFR LRLU = LRLU + SIZFR IWPOSCB = IWPOSCB + SIZFI GO TO 90 ENDIF 100 CONTINUE IW( IWPOSCB+1+XXP)=TOP_OF_STACK ELSE IW( IPOSBLOCK +XXS)=S_FREE CALL ZMUMPS_LOAD_MEM_UPDATE(SSARBR,.FALSE., & LA-LRLUS,0_8,-SIZFR_BLOCK_EFF,KEEP,KEEP8,LRLUS) END IF RETURN END SUBROUTINE ZMUMPS_FREE_BLOCK_CB_STATIC MUMPS_5.4.1/src/zini_driver.F0000664000175000017500000002222214102210526016141 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_INI_DRIVER( id ) USE ZMUMPS_STRUC_DEF C C Purpose: C ======= C C Initialize an instance of the ZMUMPS package. C USE ZMUMPS_BUF IMPLICIT NONE INCLUDE 'mpif.h' TYPE (ZMUMPS_STRUC) id INTEGER MASTER, IERR,PAR_loc,SYM_loc PARAMETER( MASTER = 0 ) INTEGER color C ----------------------------- C Initialize MPI related data C ----------------------------- CALL MPI_COMM_SIZE(id%COMM, id%NPROCS, IERR ) C Now done in the main MUMPS driver: C CALL MPI_COMM_RANK(id%COMM, id%MYID, IERR ) C PAR_loc=id%PAR SYM_loc=id%SYM C Broadcasting PAR/SYM (KEEP(46)/KEEP(50)) in order to C have only one value available: the one from the master CALL MPI_BCAST(PAR_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) CALL MPI_BCAST(SYM_loc,1,MPI_INTEGER,MASTER,id%COMM,IERR) C Initialize a subcommunicator C for slave nodes C IF ( PAR_loc .eq. 0 ) THEN C ------------------- C Host is not working C ------------------- IF ( id%MYID .eq. MASTER ) THEN color = MPI_UNDEFINED ELSE color = 0 END IF CALL MPI_COMM_SPLIT( id%COMM, color, 0, & id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS - 1 ELSE C ---------------- C Host is working C ---------------- CALL MPI_COMM_DUP( id%COMM, id%COMM_NODES, IERR ) id%NSLAVES = id%NPROCS END IF C --------------------------- C Use same slave communicator C for load information C --------------------------- IF (PAR_loc .ne. 0 .or. id%MYID .NE. MASTER) THEN CALL MPI_COMM_DUP( id%COMM_NODES, id%COMM_LOAD, IERR ) ENDIF C ---------------------------------------------- C Initialize default values for CNTL,ICNTL,KEEP,KEEP8 C potentially depending on id%SYM and id%NSLAVES C ---------------------------------------------- CALL ZMUMPSID( id%NSLAVES, id%LWK_USER, & id%CNTL(1), id%ICNTL(1), & id%KEEP(1), id%KEEP8(1), id%INFO(1), id%INFOG(1), & id%RINFO(1), id%RINFOG(1), & SYM_loc, PAR_loc, id%DKEEP(1), id%MYID ) id%WRITE_PROBLEM="NAME_NOT_INITIALIZED" CALL MUMPS_SET_VERSION( id%VERSION_NUMBER ) id%OOC_TMPDIR="NAME_NOT_INITIALIZED" id%OOC_PREFIX="NAME_NOT_INITIALIZED" id%SAVE_DIR="NAME_NOT_INITIALIZED" id%SAVE_PREFIX="NAME_NOT_INITIALIZED" C Default value for NRHS is 1 id%NRHS = 1 C Leading dimension will be reset to id%N is ZMUMPS_SOL_DRIVER C if id%NRHS remains equal to 1. Otherwise id%LRHS must be C set by user. id%LRHS = 0 ! Value will be checked in ZMUMPS_CHECK_DENSE_RHS ! Not accessed if id%NRHS=1 C Similar behaviour for LREDRHS (value will C be checked in ZMUMPS_CHECK_REDRHS) id%LREDRHS = 0 C C Module needs to know the size of an INTEGER CALL ZMUMPS_BUF_INIT( id%KEEP( 34 ), id%KEEP(35) ) C id%INST_Number = -1 C C Define the options for Metis C id%METIS_OPTIONS(:) = 0 #if defined(metis) || defined(parmetis) || defined(metis4) || defined(parmetis3) #if defined(metis4) || defined(parmetis3) C Useful size is 8 C set to default options id%METIS_OPTIONS(1) = 0 #else C Useful size is 40 C This sets the default values CALL METIS_SETDEFAULTOPTIONS(id%METIS_OPTIONS) C This number, 18, corresponds to METIS_OPTIONS_NUMBERING which C tells METIS to use fortran numbering and is found in metis.h C In Metis 5.0.3 and Parmetis 4.0.2, METIS_OPTIONS_NUMBERING C was METIS_OPTIONS(17). MUMPS doesnot support those versions anymore. C To use them, just change METIS_OPTIONS(18) into METIS_OPTIONS(17) C like that: METIS_OPTIONS(17) = 1 id%METIS_OPTIONS(18) = 1 #endif #endif C C Nullify a few pointers and integers C id%N = 0; id%NZ = 0; id%NNZ = 0_8 NULLIFY(id%IRN) NULLIFY(id%JCN) NULLIFY(id%A) id%NZ_loc = 0; id%NNZ_loc = 0_8 NULLIFY(id%IRN_loc) NULLIFY(id%JCN_loc) NULLIFY(id%A_loc) NULLIFY(id%MAPPING) NULLIFY(id%RHS) NULLIFY(id%REDRHS) id%NZ_RHS=0 NULLIFY(id%RHS_SPARSE) NULLIFY(id%IRHS_SPARSE) NULLIFY(id%IRHS_PTR) NULLIFY(id%ISOL_loc) NULLIFY(id%IRHS_loc) id%LSOL_loc=0 id%LRHS_loc=0 id%Nloc_RHS=0 NULLIFY(id%SOL_loc) NULLIFY(id%RHS_loc) NULLIFY(id%COLSCA) NULLIFY(id%ROWSCA) NULLIFY(id%PERM_IN) NULLIFY(id%IS) NULLIFY(id%STEP) C Info for analysis by block id%NBLK = 0 NULLIFY(id%BLKPTR) NULLIFY(id%BLKVAR) C Info for pruning tree NULLIFY(id%Step2node) NULLIFY(id%DAD_STEPS) NULLIFY(id%NE_STEPS) NULLIFY(id%ND_STEPS) NULLIFY(id%FRERE_STEPS) NULLIFY(id%SYM_PERM) NULLIFY(id%UNS_PERM) NULLIFY(id%PIVNUL_LIST) NULLIFY(id%FILS) NULLIFY(id%PTRAR) NULLIFY(id%FRTPTR) NULLIFY(id%FRTELT) NULLIFY(id%NA) id%LNA=0 NULLIFY(id%PROCNODE_STEPS) NULLIFY(id%S) NULLIFY(id%PTLUST_S) NULLIFY(id%PTRFAC) NULLIFY(id%INTARR) NULLIFY(id%DBLARR) NULLIFY(id%DEPTH_FIRST) NULLIFY(id%DEPTH_FIRST_SEQ) NULLIFY(id%SBTR_ID) NULLIFY(id%SCHED_DEP) NULLIFY(id%SCHED_SBTR) NULLIFY(id%SCHED_GRP) NULLIFY(id%CROIX_MANU) NULLIFY(id%WK_USER) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MEM_SUBTREE) NULLIFY(id%MY_ROOT_SBTR) NULLIFY(id%MY_FIRST_LEAF) NULLIFY(id%MY_NB_LEAF) NULLIFY(id%COST_TRAV) NULLIFY(id%RHSCOMP) NULLIFY(id%POSINRHSCOMP_ROW) NULLIFY(id%POSINRHSCOMP_COL) id%POSINRHSCOMP_COL_ALLOC = .FALSE. C C Out of Core management related data C NULLIFY(id%OOC_INODE_SEQUENCE) NULLIFY(id%OOC_TOTAL_NB_NODES) NULLIFY(id%OOC_SIZE_OF_BLOCK) NULLIFY(id%OOC_FILE_NAME_LENGTH) NULLIFY(id%OOC_FILE_NAMES) NULLIFY(id%OOC_VADDR) NULLIFY(id%OOC_NB_FILES) NULLIFY(id%LRGROUPS) NULLIFY(id%FDM_F_ENCODING) NULLIFY(id%BLRARRAY_ENCODING) NULLIFY(id%MPITOOMP_PROCS_MAP) C Must be nullified because of routine C ZMUMPS_SIZE_IN_STRUCT NULLIFY(id%CB_SON_SIZE) C C Components of the root C NULLIFY(id%root%RHS_CNTR_MASTER_ROOT) NULLIFY(id%root%RHS_ROOT) NULLIFY(id%root%RG2L_ROW) NULLIFY(id%root%RG2L_COL) NULLIFY(id%root%IPIV) NULLIFY(id%root%SCHUR_POINTER) NULLIFY(id%SCHUR_CINTERFACE) C C Element-entry C id%NELT=0 NULLIFY(id%ELTPTR) NULLIFY(id%ELTVAR) NULLIFY(id%A_ELT) NULLIFY(id%ELTPROC) C C Schur C id%SIZE_SCHUR = 0 NULLIFY( id%LISTVAR_SCHUR ) NULLIFY( id%SCHUR ) C -- Distributed Schur id%NPROW = 0 id%NPCOL = 0 id%MBLOCK = 0 id%NBLOCK = 0 id%SCHUR_MLOC = 0 ! Exit from analysis id%SCHUR_NLOC = 0 ! Exit from analysis id%SCHUR_LLD = 0 C C Candidates and node partitionning C NULLIFY(id%ISTEP_TO_INIV2) NULLIFY(id%I_AM_CAND) NULLIFY(id%FUTURE_NIV2) NULLIFY(id%TAB_POS_IN_PERE) NULLIFY(id%CANDIDATES) id%OOC_NB_FILE_TYPE=-123456 C C Initializations for L0_OMP mechanisms C NULLIFY(id%IPOOL_B_L0_OMP) NULLIFY(id%IPOOL_A_L0_OMP) NULLIFY(id%PHYS_L0_OMP) NULLIFY(id%VIRT_L0_OMP) NULLIFY(id%VIRT_L0_OMP_MAPPING) NULLIFY(id%PERM_L0_OMP) NULLIFY(id%PTR_LEAFS_L0_OMP) NULLIFY(id%L0_OMP_MAPPING) NULLIFY(id%L0_OMP_FACTORS) NULLIFY(id%I4_L0_OMP) NULLIFY(id%I8_L0_OMP) id%LPOOL_B_L0_OMP = 0 id%LPOOL_A_L0_OMP = 0 id%L_VIRT_L0_OMP = 0 id%L_PHYS_L0_OMP = 0 id%THREAD_LA = 0 C C Mapping information used during solve. C NULLIFY(id%IPTR_WORKING) NULLIFY(id%WORKING) C C Initializations for Rank detection/null space C NULLIFY(id%SINGULAR_VALUES) CALL ZMUMPS_RR_INIT_POINTERS(id) C Architecture data NULLIFY(id%MEM_DIST) C Must be nullified because of routine C ZMUMPS_SIZE_IN_STRUCT NULLIFY(id%SUP_PROC) id%Deficiency = 0 id%root%LPIV = -1 id%root%yes = .FALSE. id%root%gridinit_done = .FALSE. C NOT IN SAVE/RESTORE id%ASSOCIATED_OOC_FILES=.FALSE. C C ---------------------------------------- C Find MYID_NODES relatively to COMM_NODES C If the calling processor is not inside C COMM_NODES, MYID_NODES will not be C significant / used anyway C ---------------------------------------- IF ( id%KEEP( 46 ) .ne. 0 .OR. & id%MYID .ne. MASTER ) THEN CALL MPI_COMM_RANK & (id%COMM_NODES, id%MYID_NODES, IERR ) ELSE id%MYID_NODES = -464646 ENDIF RETURN END SUBROUTINE ZMUMPS_INI_DRIVER MUMPS_5.4.1/src/mumps_metis.h0000664000175000017500000000307014102210474016223 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_METIS_H #define MUMPS_METIS_H /* Interfacing with 32-bit (par)metis, for METIS 4 or METIS 5 */ #include "mumps_common.h" /* includes mumps_compat.h and mumps_c_types.h */ #if defined(parmetis) || defined(parmetis3) #include "mpi.h" #define MUMPS_PARMETIS \ F_SYMBOL(parmetis,PARMETIS) void MUMPS_CALL MUMPS_PARMETIS(MUMPS_INT *first, MUMPS_INT *vertloctab, MUMPS_INT *edgeloctab, MUMPS_INT *numflag, MUMPS_INT *options, MUMPS_INT *order, MUMPS_INT *sizes, MUMPS_INT *comm, MUMPS_INT *ierr); #endif #if defined(parmetis) || defined(metis) || defined(parmetis3) || defined(metis4) #define MUMPS_METIS_KWAY \ F_SYMBOL(metis_kway,METIS_KWAY) void MUMPS_CALL MUMPS_METIS_KWAY(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part); #define MUMPS_METIS_KWAY_AB \ F_SYMBOL(metis_kway_ab,METIS_KWAY_AB) void MUMPS_CALL MUMPS_METIS_KWAY_AB(MUMPS_INT *n, MUMPS_INT *iptr, MUMPS_INT *jcn, MUMPS_INT *k, MUMPS_INT *part, MUMPS_INT *vwgt); #endif #endif MUMPS_5.4.1/src/zfac_asm_ELT.F0000664000175000017500000002376114102210524016113 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_ELT_ASM_S_2_S_INIT( & NELT, FRT_PTR, FRT_ELT, & N, INODE, IW, LIW, A, LA, & NBROWS, NBCOLS, & OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC, & RHS_MUMPS, & FILS, PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP, KEEP8, MYID, LRGROUPS) USE ZMUMPS_DYNAMIC_MEMORY_M, ONLY : ZMUMPS_DM_SET_DYNPTR IMPLICIT NONE INTEGER NELT, N,LIW INTEGER(8) :: LA INTEGER KEEP(500), ICNTL(60) INTEGER(8) KEEP8(150) INTEGER INODE, MYID INTEGER NBROWS, NBCOLS INTEGER(8) :: PTRAST(KEEP(28)) INTEGER IW(LIW), ITLOC(N+KEEP(253)), STEP(N), & PTRIST(KEEP(28)), FILS(N) INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1) COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) INTEGER INTARR(KEEP8(27)) INTEGER FRT_PTR(N+1), FRT_ELT(NELT) COMPLEX(kind=8) :: A(LA) COMPLEX(kind=8) :: DBLARR(KEEP8(26)) DOUBLE PRECISION OPASSW, OPELIW INTEGER, INTENT(IN) :: LRGROUPS(N) INTEGER(8) :: POSELT COMPLEX(kind=8), DIMENSION(:), POINTER :: A_PTR INTEGER(8) :: LA_PTR INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF, & K1,K2,K,J,JPOS,NASS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) INCLUDE 'mumps_headers.h' IOLDPS = PTRIST(STEP(INODE)) CALL ZMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES = IW(IOLDPS+5+KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) IF (NASS.LT.0) THEN NASS = -NASS IW(IOLDPS+1+KEEP(IXSZ)) = NASS CALL ZMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, FILS, & PTRAIW, PTRARW, & INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT, & RHS_MUMPS, LRGROUPS) ENDIF IF (NBROWS.GT.0) THEN K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = JPOS JPOS = JPOS + 1 ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_ELT_ASM_S_2_S_INIT SUBROUTINE ZMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW, &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW, &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS, &LRGROUPS) !$ USE OMP_LIB USE ZMUMPS_ANA_LR, ONLY : GET_CUT USE ZMUMPS_LR_CORE, ONLY : MAX_CLUSTER USE MUMPS_LR_COMMON, ONLY : COMPUTE_BLR_VCS IMPLICIT NONE INTEGER, intent(in) :: N, NELT, LIW, IOLDPS, INODE INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR INTEGER, intent(in) :: IW(LIW) INTEGER, intent(in) :: KEEP(500) INTEGER(8), intent(in) :: KEEP8(150) INTEGER, intent(inout) :: ITLOC(N+KEEP(253)) COMPLEX(kind=8), intent(inout) :: A(LA) COMPLEX(kind=8), intent(in) :: RHS_MUMPS(KEEP(255)) INTEGER, intent(in) :: INTARR(LINTARR) COMPLEX(kind=8), intent(in) :: DBLARR(LDBLARR) INTEGER, intent(in) :: FRT_PTR(N+1), FRT_ELT(NELT) INTEGER, intent(in) :: FILS(N) INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1) INTEGER, INTENT(IN) :: LRGROUPS(N) !$ INTEGER :: NOMP !$ INTEGER(8) :: CHUNK8 !$ INTEGER :: CHUNK INCLUDE 'mumps_headers.h' INTEGER :: HF, NBROWF, NBCOLF, NASS, NSLAVES INTEGER :: ILOC, IELL, ELTI, ELBEG, NUMELT INTEGER(8) :: SIZE_ELTI8 INTEGER :: I, J, K, K1, K2 INTEGER :: IPOS, IPOS1, IPOS2, JPOS, IJROW INTEGER :: IN INTEGER(8) :: II8, JJ8, J18, J28 INTEGER(8) :: AINPUT8 INTEGER(8) :: AII8 INTEGER(8) :: APOS, APOS2, ICT12 INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_LS INTEGER :: NB_BLR_LS, NPARTSCB, NPARTSASS, MAXI_CLUSTER, & IBCKSZ2, MINSIZE, TOPDIAG INTEGER(8) :: JJ3 INTEGER :: K1RHS, K2RHS, JFirstRHS COMPLEX(kind=8) ZERO PARAMETER( ZERO = (0.0D0,0.0D0) ) NBCOLF = IW(IOLDPS+KEEP(IXSZ)) NBROWF = IW(IOLDPS+2+KEEP(IXSZ)) NASS = IW(IOLDPS+1+KEEP(IXSZ)) NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ)) HF = 6 + NSLAVES + KEEP(IXSZ) !$ NOMP = OMP_GET_MAX_THREADS() IF (KEEP(50) .EQ. 0 .OR. NBROWF .LT. KEEP(63)) THEN !$ CHUNK8 = int(KEEP(361),8) !$OMP PARALLEL DO PRIVATE(JJ8) SCHEDULE(STATIC, CHUNK8) !$OMP& IF (int(NBROWF,8)*int(NBCOLF,8) > int(KEEP(361),8) !$OMP& .AND. NOMP .GT. 1) DO JJ8=POSELT, POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8 A(JJ8) = ZERO ENDDO !$OMP END PARALLEL DO ELSE TOPDIAG = 0 IF (IW(IOLDPS+XXLR).GE.1) THEN CALL GET_CUT(IW(IOLDPS+HF:IOLDPS+HF+NBROWF-1), 0, & NBROWF, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_LS) NB_BLR_LS = NPARTSCB call MAX_CLUSTER(BEGS_BLR_LS,NB_BLR_LS+1,MAXI_CLUSTER) DEALLOCATE(BEGS_BLR_LS) CALL COMPUTE_BLR_VCS(KEEP(472), IBCKSZ2, KEEP(488), NASS) MINSIZE = int(IBCKSZ2 / 2) TOPDIAG = max(2*MINSIZE + MAXI_CLUSTER-1, TOPDIAG) ENDIF !$ CHUNK = max( KEEP(360)/2, !$ & ((NBROWF+NOMP-1)/NOMP +2) / 3 ) !$OMP PARALLEL DO PRIVATE(APOS,JJ3,JJ8) SCHEDULE(STATIC,CHUNK) !$OMP& IF (NBROWF .GT. KEEP(360) .AND. NOMP .GT. 1) DO JJ8 = 0_8, int(NBROWF-1,8) APOS = POSELT+ JJ8*int(NBCOLF,8) JJ3 = min( int(NBCOLF,8) - 1_8, & JJ8 + int(NBCOLF-NBROWF,8) + TOPDIAG ) A(APOS: APOS+JJ3) = ZERO ENDDO !$OMP END PARALLEL DO ENDIF K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 JPOS = 1 DO K = K1, K2 J = IW(K) ITLOC(J) = -JPOS JPOS = JPOS + 1 END DO K1 = IOLDPS + HF K2 = K1 + NBROWF - 1 JPOS = 1 IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN K1RHS = 0 K2RHS = -1 DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN K1RHS = K JFirstRHS=J-N ENDIF JPOS = JPOS + 1 ENDDO IF (K1RHS.GT.0) K2RHS=K2 IF ( K2RHS.GE.K1RHS ) THEN IN = INODE DO WHILE (IN.GT.0) IJROW = -ITLOC(IN) DO K = K1RHS, K2RHS J = IW(K) I = ITLOC(J) ILOC = mod(I,NBCOLF) APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) + & int(IJROW-1,8) A(APOS) = A(APOS) + RHS_MUMPS( & (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN) ENDDO IN = FILS(IN) ENDDO ENDIF ELSE DO K = K1, K2 J = IW(K) ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS JPOS = JPOS + 1 END DO ENDIF ELBEG = FRT_PTR(INODE) NUMELT = FRT_PTR(INODE+1) - ELBEG DO IELL=ELBEG,ELBEG+NUMELT-1 ELTI = FRT_ELT(IELL) J18= PTRAIW(ELTI) J28= PTRAIW(ELTI+1)-1_8 AII8 = PTRARW(ELTI) SIZE_ELTI8 = J28 - J18 + 1_8 DO II8=J18,J28 I = ITLOC(INTARR(II8)) IF (KEEP(50).EQ.0) THEN IF (I.LE.0) CYCLE AINPUT8 = AII8 + II8 - J18 IPOS = mod(I,NBCOLF) ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8) DO JJ8 = J18, J28 JPOS = ITLOC(INTARR(JJ8)) IF (JPOS.LE.0) THEN JPOS = -JPOS ELSE JPOS = JPOS/NBCOLF END IF APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AINPUT8) AINPUT8 = AINPUT8 + SIZE_ELTI8 END DO ELSE IF ( I .EQ. 0 ) THEN AII8 = AII8 + J28 - II8 + 1_8 CYCLE ENDIF IF ( I .LE. 0 ) THEN IPOS1 = -I IPOS2 = 0 ELSE IPOS1 = I/NBCOLF IPOS2 = mod(I,NBCOLF) END IF ICT12 = POSELT + int(IPOS2-1,8)*int(NBCOLF,8) DO JJ8=II8,J28 AII8 = AII8 + 1_8 J = ITLOC(INTARR(JJ8)) IF ( J .EQ. 0 ) CYCLE IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE IF ( J .LE. 0 ) THEN JPOS = -J ELSE JPOS = J/NBCOLF END IF IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN APOS2 = ICT12 + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN IPOS = mod(J,NBCOLF) JPOS = IPOS1 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8) & + int(JPOS - 1,8) A(APOS2) = A(APOS2) + DBLARR(AII8-1_8) END IF END DO END IF END DO END DO K1 = IOLDPS + HF + NBROWF K2 = K1 + NBCOLF - 1 DO K = K1, K2 J = IW(K) ITLOC(J) = 0 END DO END SUBROUTINE ZMUMPS_ASM_SLAVE_ELEMENTS MUMPS_5.4.1/src/cfac_mem_stack_aux.F0000664000175000017500000001546414102210523017420 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE CMUMPS_COMPACT_FACTORS(A, LDA, NPIV, NBROW, K50, & SIZEA ) IMPLICIT NONE INTEGER LDA, NPIV, NBROW, K50 INTEGER(8), INTENT(IN) :: SIZEA COMPLEX A(SIZEA) INTEGER(8) :: IOLD, INEW, J8 INTEGER I , ILAST INTEGER NBROW_L_RECTANGLE_TO_MOVE IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500 IF ( K50.NE.0 ) THEN IOLD = int(LDA + 1,8) INEW = int(NPIV + 1,8) IF (IOLD .EQ. INEW ) THEN INEW = INEW + int(NPIV,8) * int(NPIV - 1,8) IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8) ELSE DO I = 1, NPIV - 1 IF ( I .LE. NPIV-2 ) THEN ILAST = I+1 ELSE ILAST = I ENDIF DO J8 = 0_8, int(ILAST,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) END DO ENDIF NBROW_L_RECTANGLE_TO_MOVE = NBROW ELSE INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8) IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8) NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1 ENDIF DO I = 1, NBROW_L_RECTANGLE_TO_MOVE DO J8 = 0_8, int(NPIV - 1,8) A( INEW + J8 ) = A( IOLD + J8 ) END DO INEW = INEW + int(NPIV,8) IOLD = IOLD + int(LDA,8) ENDDO 500 RETURN END SUBROUTINE CMUMPS_COMPACT_FACTORS SUBROUTINE CMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, & SIZEA ) IMPLICIT NONE INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA INTEGER(8), INTENT(IN) :: SIZEA COMPLEX, INTENT(INOUT) :: A(SIZEA) INTEGER I, J INTEGER(8) :: INEW, IOLD INEW = int(NPIV+1,8) IOLD = int(LDA+1,8) DO I = 2, NCONTIG DO J = 1, NPIV A(INEW)=A(IOLD) INEW = INEW + 1_8 IOLD = IOLD + 1_8 ENDDO IOLD = IOLD + int(LDA - NPIV,8) ENDDO RETURN END SUBROUTINE CMUMPS_COMPACT_FACTORS_UNSYM SUBROUTINE CMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB, & LAST_ALLOWED, NBROW_ALREADY_STACKED ) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER, intent(inout) :: NBROW_ALREADY_STACKED INTEGER(8), intent(in) :: LAST_ALLOWED INTEGER(8) :: APOS, NPOS INTEGER NBROW INTEGER(8) :: J INTEGER I, KEEP(500) #if defined(ZERO_TRIANGLE) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) #endif NBROW = NBROW_STACK + NBROW_SEND IF (NBROW_STACK .NE. 0 ) THEN NPOS = IPTRLU + SIZECB APOS = POSELT + int(NPIV+NBROW,8) & * int(LDA,8) - 1_8 IF ( KEEP(50) .EQ. 0 .OR. .NOT. PACKED_CB ) THEN APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) ELSE APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 ENDIF DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 IF (KEEP(50).EQ.0) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF DO J= 1_8,int(NBCOL_STACK,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(NBCOL_STACK,8) ELSE IF (.NOT. PACKED_CB) THEN IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. & LAST_ALLOWED ) THEN EXIT ENDIF #if defined(ZERO_TRIANGLE) DO J = 1_8, int(NBCOL_STACK - I,8) A(NPOS - J + 1_8) = ZERO END DO #endif NPOS = NPOS + int(- NBCOL_STACK + I,8) ENDIF IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN EXIT ENDIF DO J =1_8, int(I,8) A(NPOS-J+1_8) = A(APOS-J+1_8) ENDDO NPOS = NPOS - int(I,8) ENDIF IF (KEEP(50).EQ.0) THEN APOS = APOS - int(LDA,8) ELSE APOS = APOS - int(LDA + 1,8) ENDIF NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 ENDDO END IF RETURN END SUBROUTINE CMUMPS_COPY_CB_RIGHT_TO_LEFT SUBROUTINE CMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, & IPTRLU, NPIV, & NBCOL_STACK, NBROW_STACK, & NBROW_SEND, SIZECB, KEEP, PACKED_CB) IMPLICIT NONE INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB LOGICAL, intent (in) :: PACKED_CB COMPLEX A(LA) INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, & NBROW_SEND INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini INTEGER I, KEEP(500) INTEGER(8) :: J, LDA8 #if defined(ZERO_TRIANGLE) COMPLEX ZERO PARAMETER( ZERO = (0.0E0,0.0E0) ) #endif LDA8 = int(LDA,8) NPOS_ini = IPTRLU + 1_8 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) !$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > KEEP(360)) DO I = 1, NBROW_STACK IF (PACKED_CB) THEN NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + & int(I-1,8) * int(NBROW_SEND,8) ELSE NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) ENDIF APOS = APOS_ini + int(I-1,8) * LDA8 IF (KEEP(50).EQ.0) THEN DO J = 1_8, int(NBCOL_STACK,8) A(NPOS+J-1_8) = A(APOS+J-1_8) ENDDO ELSE DO J = 1_8, int(I + NBROW_SEND,8) A(NPOS+J-1_8)=A(APOS+J-1_8) ENDDO #if defined(ZERO_TRIANGLE) IF (.NOT. PACKED_CB) THEN A(NPOS+int(I+NBROW_SEND,8): & NPOS+int(NBCOL_STACK-1,8))=ZERO ENDIF #endif ENDIF ENDDO !$OMP END PARALLEL DO RETURN END SUBROUTINE CMUMPS_COPY_CB_LEFT_TO_RIGHT MUMPS_5.4.1/src/zomp_tps_m.F0000664000175000017500000000101714102210525016002 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C SUBROUTINE ZMUMPS_TPS_M_RETURN() RETURN END SUBROUTINE ZMUMPS_TPS_M_RETURN MUMPS_5.4.1/src/dfac_process_blocfacto.F0000664000175000017500000010005414102210522020260 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C RECURSIVE SUBROUTINE DMUMPS_PROCESS_BLOCFACTO( & COMM_LOAD, ASS_IRECV, & BUFR, LBUFR, & LBUFR_BYTES, PROCNODE_STEPS, MSGSOU, & SLAVEF, IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, N, IW, LIW, & A, LA, PTRIST, PTRAST, NSTK_S, PERM, & COMP, STEP, PIMASTER, PAMASTER, POSFAC, & MYID, COMM, IFLAG, IERROR, NBFIN, & & PTLUST_S, PTRFAC, root, OPASSW, OPELIW, & ITLOC, RHS_MUMPS, FILS, DAD, & PTRARW, PTRAIW, INTARR, DBLARR, & ICNTL, KEEP,KEEP8, DKEEP, & IPOOL, LPOOL, LEAF, ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) USE DMUMPS_OOC, ONLY : IO_BLOCK USE MUMPS_OOC_COMMON, ONLY : TYPEF_L, & STRAT_WRITE_MAX, & STRAT_TRY_WRITE USE DMUMPS_LOAD USE DMUMPS_LR_CORE USE DMUMPS_LR_TYPE USE DMUMPS_LR_STATS USE DMUMPS_FAC_LR USE DMUMPS_ANA_LR, ONLY : GET_CUT USE DMUMPS_LR_DATA_M USE DMUMPS_STRUC_DEF, ONLY : DMUMPS_ROOT_STRUC USE DMUMPS_DYNAMIC_MEMORY_M, ONLY : DMUMPS_DM_SET_DYNPTR !$ USE OMP_LIB IMPLICIT NONE INCLUDE 'mumps_headers.h' TYPE (DMUMPS_ROOT_STRUC) :: root INTEGER ICNTL( 60 ), KEEP( 500 ) INTEGER(8) KEEP8(150) DOUBLE PRECISION DKEEP(230) INTEGER LBUFR, LBUFR_BYTES INTEGER COMM_LOAD, ASS_IRECV INTEGER BUFR( LBUFR ) INTEGER N, SLAVEF, IWPOS, IWPOSCB, LIW INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA INTEGER(8) :: POSFAC INTEGER COMP INTEGER IFLAG, IERROR, NBFIN, MSGSOU INTEGER PROCNODE_STEPS(KEEP(28)), PTRIST(KEEP(28)), & NSTK_S(KEEP(28)) INTEGER(8) :: PAMASTER(KEEP(28)) INTEGER(8) :: PTRAST(KEEP(28)) INTEGER(8) :: PTRFAC(KEEP(28)) INTEGER PERM(N), STEP(N), & PIMASTER(KEEP(28)) INTEGER IW( LIW ) DOUBLE PRECISION A( LA ) INTEGER, intent(in) :: LRGROUPS(N) INTEGER COMM, MYID INTEGER NELT, LPTRAR INTEGER FRTPTR( N+1 ), FRTELT( NELT ) INTEGER PTLUST_S(KEEP(28)), & ITLOC(N+KEEP(253)), FILS(N), DAD(KEEP(28)), ND(KEEP(28)) DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) INTEGER(8), INTENT(IN) :: PTRAIW( LPTRAR ), PTRARW( LPTRAR ) INTEGER FRERE_STEPS(KEEP(28)) DOUBLE PRECISION OPASSW, OPELIW DOUBLE PRECISION FLOP1 INTEGER INTARR( KEEP8(27) ) DOUBLE PRECISION DBLARR( KEEP8(26) ) INTEGER LEAF, LPOOL INTEGER IPOOL( LPOOL ) INTEGER ISTEP_TO_INIV2(KEEP(71)), & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' INTEGER :: STATUS(MPI_STATUS_SIZE) LOGICAL :: I_HAVE_SET_K117 INTEGER INODE, POSITION, NPIV, IERR, LP INTEGER NCOL INTEGER(8) :: POSBLOCFACTO INTEGER :: LD_BLOCFACTO INTEGER(8) :: LA_BLOCFACTO INTEGER(8) :: LA_PTR INTEGER(8) :: POSELT DOUBLE PRECISION, DIMENSION(:), POINTER :: A_PTR INTEGER IOLDPS, LCONT1, NASS1, NROW1, NCOL1, NPIV1 INTEGER NSLAV1, HS, ISW INTEGER (8) :: LPOS, UPOS, LPOS2, IPOS, KPOS INTEGER ICT11 INTEGER I, IPIV, FPERE LOGICAL LASTBL, KEEP_BEGS_BLR_L LOGICAL BLOCKING, SET_IRECV, MESSAGE_RECEIVED DOUBLE PRECISION ONE,ALPHA PARAMETER (ONE = 1.0D0, ALPHA=-1.0D0) INTEGER LIWFAC, STRAT, NextPivDummy TYPE(IO_BLOCK) :: MonBloc LOGICAL LAST_CALL INTEGER LRELAY_INFO INTEGER :: INFO_TMP(2) INTEGER :: NELIM, NPARTSASS_MASTER, NPARTSASS_MASTER_AUX, & IPANEL, & CURRENT_BLR, & NB_BLR_L, NB_BLR_U, NB_BLR_COL TYPE (LRB_TYPE), POINTER, DIMENSION(:,:) :: CB_LRB TYPE (LRB_TYPE), DIMENSION(:), POINTER :: BLR_U, BLR_L LOGICAL :: LR_ACTIVATED, COMPRESS_CB, COMPRESS_PANEL LOGICAL OOCWRITE_COMPATIBLE_WITH_BLR INTEGER :: LR_ACTIVATED_INT INTEGER, POINTER, DIMENSION(:) :: BEGS_BLR_L, BEGS_BLR_U, & BEGS_BLR_COL DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: WORK, TAU INTEGER, ALLOCATABLE, DIMENSION(:) :: JPVT DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: RWORK DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: BLOCK INTEGER :: OMP_NUM INTEGER NPARTSASS, NPARTSCB, MAXI_CLUSTER, LWORK, & MAXI_CLUSTER_L, MAXI_CLUSTER_U, MAXI_CLUSTER_COL DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: DYN_BLOCFACTO INTEGER, DIMENSION(:), ALLOCATABLE :: DYN_PIVINFO LOGICAL :: DYNAMIC_ALLOC INTEGER :: allocok INTEGER MUMPS_PROCNODE EXTERNAL MUMPS_PROCNODE KEEP_BEGS_BLR_L = .FALSE. nullify(BEGS_BLR_L) NB_BLR_U = -7654321 NULLIFY(BEGS_BLR_U) I_HAVE_SET_K117 = .FALSE. DYNAMIC_ALLOC = .FALSE. FPERE = -1 POSITION = 0 CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, INODE, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NPIV, 1, & MPI_INTEGER, COMM, IERR ) LASTBL = (NPIV.LE.0) IF (LASTBL) THEN NPIV = -NPIV CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, FPERE, 1, & MPI_INTEGER, COMM, IERR ) ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NCOL, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, NELIM, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NPARTSASS_MASTER , 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, IPANEL, & 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, LR_ACTIVATED_INT, & 1, MPI_INTEGER, COMM, IERR ) LR_ACTIVATED = (LR_ACTIVATED_INT.EQ.1) IF ( LR_ACTIVATED ) THEN LA_BLOCFACTO = int(NPIV,8) * int(NPIV+NELIM,8) ELSE LA_BLOCFACTO = int(NPIV,8) * int(NCOL,8) ENDIF CALL DMUMPS_GET_SIZE_NEEDED( & NPIV, LA_BLOCFACTO, .FALSE., & KEEP(1), KEEP8(1), & N, KEEP(28), IW, LIW, A, LA, & LRLU, IPTRLU, & IWPOS, IWPOSCB, PTRIST, PTRAST, & STEP, PIMASTER, PAMASTER, KEEP(216),LRLUS, & KEEP(IXSZ),COMP,DKEEP(97),MYID,SLAVEF, PROCNODE_STEPS, & DAD, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 LRLU = LRLU - LA_BLOCFACTO LRLUS = LRLUS - LA_BLOCFACTO KEEP8(67) = min(LRLUS, KEEP8(67)) KEEP8(69) = KEEP8(69) + LA_BLOCFACTO KEEP8(68) = max(KEEP8(69), KEEP8(68)) POSBLOCFACTO = POSFAC POSFAC = POSFAC + LA_BLOCFACTO CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE., .FALSE., & LA-LRLUS,0_8,LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IF ((NPIV .EQ. 0) & ) THEN IPIV=1 ELSE IPIV = IWPOS IWPOS = IWPOS + NPIV IF (NPIV .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & IW( IPIV ), NPIV, & MPI_INTEGER, COMM, IERR ) ENDIF IF ( LR_ACTIVATED ) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*(NPIV+NELIM), & MPI_DOUBLE_PRECISION, & COMM, IERR ) LD_BLOCFACTO = NPIV+NELIM CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & NB_BLR_U, 1, MPI_INTEGER, & COMM, IERR ) ALLOCATE(BLR_U(max(NB_BLR_U,1)), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = max(NB_BLR_U,1) LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ALLOCATE(BEGS_BLR_U(NB_BLR_U+2), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_U+2 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CALL DMUMPS_MPI_UNPACK_LR(BUFR, LBUFR, LBUFR_BYTES, & POSITION, NPIV, NELIM, 'H', & BLR_U(1), NB_BLR_U, & BEGS_BLR_U(1), & KEEP8, COMM, IERR, IFLAG, IERROR) IF (IFLAG.LT.0) GOTO 700 ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & A(POSBLOCFACTO), NPIV*NCOL, & MPI_DOUBLE_PRECISION, & COMM, IERR ) LD_BLOCFACTO = NCOL ENDIF ENDIF CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & LRELAY_INFO, 1, & MPI_INTEGER, COMM, IERR ) IF (PTRIST(STEP( INODE )) .EQ. 0) THEN CALL DMUMPS_TREAT_DESCBAND( INODE, COMM_LOAD, & ASS_IRECV, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 ENDIF IF ( IW( PTRIST(STEP(INODE)) + 3 +KEEP(IXSZ)) .EQ. 0 ) THEN DO WHILE ( IW(PTRIST(STEP(INODE)) + XXNBPR) .NE. 0) BLOCKING = .TRUE. SET_IRECV = .FALSE. MESSAGE_RECEIVED = .FALSE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, & ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, CONTRIB_TYPE2, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR, ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IF ( IFLAG .LT. 0 ) GOTO 600 END DO ENDIF SET_IRECV = .TRUE. BLOCKING = .FALSE. MESSAGE_RECEIVED = .TRUE. CALL DMUMPS_TRY_RECVTREAT( COMM_LOAD, ASS_IRECV, & BLOCKING, SET_IRECV, MESSAGE_RECEIVED, & MPI_ANY_SOURCE, MPI_ANY_TAG, & STATUS, & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, & PTLUST_S, PTRFAC, & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, & IFLAG, IERROR, COMM, & PERM, IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF, & & root, OPASSW, OPELIW, ITLOC, RHS_MUMPS, & FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. & , LRGROUPS & ) IOLDPS = PTRIST(STEP(INODE)) CALL DMUMPS_DM_SET_DYNPTR( IW(IOLDPS+XXS), A, LA, & PTRAST(STEP(INODE)), IW(IOLDPS+XXD), IW(IOLDPS+XXR), & A_PTR, POSELT, LA_PTR ) LCONT1 = IW( IOLDPS + KEEP(IXSZ)) NASS1 = IW( IOLDPS + 1 + KEEP(IXSZ)) COMPRESS_PANEL = (IW(IOLDPS+XXLR).GE.2) OOCWRITE_COMPATIBLE_WITH_BLR = & ( .NOT.LR_ACTIVATED.OR. (.NOT.COMPRESS_PANEL).OR. & (KEEP(486).NE.2) & ) IF ( NASS1 < 0 ) THEN NASS1 = -NASS1 IW( IOLDPS + 1 + KEEP(IXSZ)) = NASS1 IF (KEEP(55) .EQ. 0) THEN CALL DMUMPS_ASM_SLAVE_ARROWHEADS(INODE, N, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), RHS_MUMPS, & LRGROUPS) ELSE CALL DMUMPS_ASM_SLAVE_ELEMENTS(INODE, N, NELT, IW, LIW, & IOLDPS, A_PTR(POSELT), LA_PTR, 1_8, KEEP, KEEP8, ITLOC, & FILS, PTRAIW, & PTRARW, INTARR, DBLARR, KEEP8(27), KEEP8(26), & FRTPTR, FRTELT, RHS_MUMPS, LRGROUPS) ENDIF ENDIF NROW1 = IW( IOLDPS + 2 +KEEP(IXSZ)) NPIV1 = IW( IOLDPS + 3 +KEEP(IXSZ)) NSLAV1 = IW( IOLDPS + 5 + KEEP(IXSZ)) HS = 6 + NSLAV1 + KEEP(IXSZ) NCOL1 = LCONT1 + NPIV1 IF (NPIV.GT.0) THEN ICT11 = IOLDPS+HS+NROW1+NPIV1 - 1 IF (DYNAMIC_ALLOC) THEN DO I = 1, NPIV IF (DYN_PIVINFO(I).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+DYN_PIVINFO(I)) IW(ICT11+DYN_PIVINFO(I)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + DYN_PIVINFO(I) - 1,8) CALL dswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ELSE DO I = 1, NPIV IF (IW(IPIV+I-1).EQ.I) CYCLE ISW = IW(ICT11+I) IW(ICT11+I) = IW(ICT11+IW(IPIV+I-1)) IW(ICT11+IW(IPIV+I-1)) = ISW IPOS = POSELT + int(NPIV1 + I - 1,8) KPOS = POSELT + int(NPIV1 + IW(IPIV+I-1) - 1,8) CALL dswap(NROW1, A_PTR(IPOS), NCOL1, A_PTR(KPOS), NCOL1) ENDDO ENDIF LPOS2 = POSELT + int(NPIV1,8) LPOS = LPOS2 + int(NPIV,8) IF ((.NOT. LR_ACTIVATED).OR.KEEP(475).EQ.0) THEN IF (DYNAMIC_ALLOC) THEN CALL dtrsm('L','L','N','N',NPIV, NROW1, ONE, & DYN_BLOCFACTO, LD_BLOCFACTO, A_PTR(LPOS2), NCOL1) ELSE CALL dtrsm('L','L','N','N',NPIV, NROW1, ONE, & A(POSBLOCFACTO), LD_BLOCFACTO, & A_PTR(LPOS2), NCOL1) ENDIF ENDIF ENDIF COMPRESS_CB = .FALSE. IF ( LR_ACTIVATED) THEN COMPRESS_CB = ((IW(IOLDPS+XXLR).EQ.1).OR. & (IW(IOLDPS+XXLR).EQ.3)) IF (COMPRESS_CB.AND.NPIV.EQ.0) THEN COMPRESS_CB = .FALSE. IW(IOLDPS+XXLR) = IW(IOLDPS+XXLR) -1 ENDIF IF (NPIV.NE.0) THEN IF ( (NPIV1.EQ.0) & ) THEN IOLDPS = PTRIST(STEP(INODE)) CALL GET_CUT(IW(IOLDPS+HS:IOLDPS+HS+NROW1-1), 0, & NROW1, LRGROUPS, NPARTSCB, & NPARTSASS, BEGS_BLR_L) CALL REGROUPING2(BEGS_BLR_L, NPARTSASS, 0, NPARTSCB, & NROW1-0, KEEP(488), .TRUE., KEEP(472)) NB_BLR_L = NPARTSCB IF (IPANEL.EQ.1) THEN BEGS_BLR_COL=>BEGS_BLR_U ELSE ALLOCATE(BEGS_BLR_COL(size(BEGS_BLR_U)+IPANEL-1), & stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = size(BEGS_BLR_U)+IPANEL-1 LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF BEGS_BLR_COL(1:IPANEL-1) = 1 DO I=1,size(BEGS_BLR_U) BEGS_BLR_COL(IPANEL+I-1) = BEGS_BLR_U(I) ENDDO ENDIF INFO_TMP(1) = IFLAG INFO_TMP(2) = IERROR IF (IFLAG.LT.0) GOTO 700 CALL DMUMPS_BLR_SAVE_INIT(IW(IOLDPS+XXF), & .FALSE., & .TRUE., & .TRUE., & NPARTSASS_MASTER, & BEGS_BLR_L, & BEGS_BLR_COL, & huge(NPARTSASS_MASTER), & INFO_TMP) IFLAG = INFO_TMP(1) IERROR = INFO_TMP(2) IF (IPANEL.NE.1) THEN DEALLOCATE(BEGS_BLR_COL) ENDIF IF (IFLAG.LT.0) GOTO 700 ELSE CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_L (IW(IOLDPS+XXF), & BEGS_BLR_L) KEEP_BEGS_BLR_L = .TRUE. NB_BLR_L = size(BEGS_BLR_L) - 2 NPARTSASS = 1 NPARTSCB = NB_BLR_L ENDIF ENDIF ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_U,NB_BLR_U+1,MAXI_CLUSTER_U) IF (LASTBL.AND.COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_U+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_U,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF CURRENT_BLR=1 ALLOCATE(BLR_L(NB_BLR_L), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = NB_BLR_L LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_COMPRESS_PANEL_I_NOOPT & (A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), NB_BLR_L+1, & DKEEP(8), KEEP(466), KEEP(473), & BLR_L(1), & CURRENT_BLR, 'V', WORK, TAU, JPVT, LWORK, RWORK, & BLOCK, MAXI_CLUSTER, NELIM, & .TRUE., & NPIV, NPIV1, & 2, KEEP(483), KEEP8, OMP_NUM & ) #if defined(BLR_MT) !$OMP MASTER #endif IF ( (KEEP(486).EQ.2) & ) THEN CALL DMUMPS_BLR_SAVE_PANEL_LORU ( & IW(IOLDPS+XXF), & 0, & IPANEL, BLR_L) ENDIF #if defined(BLR_MT) !$OMP END MASTER !$OMP BARRIER #endif IF (IFLAG.LT.0) GOTO 300 IF (KEEP(475).GE.1) THEN IF (DYNAMIC_ALLOC) THEN CALL DMUMPS_BLR_PANEL_LRTRSM( & DYN_BLOCFACTO, LA_BLOCFACTO, 1_8, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ELSE CALL DMUMPS_BLR_PANEL_LRTRSM(A, LA, POSBLOCFACTO, & LD_BLOCFACTO, -6666, & NB_BLR_L+1, & BLR_L, CURRENT_BLR, CURRENT_BLR+1, NB_BLR_L+1, & 2, 0, 0, & .TRUE.) ENDIF #if defined(BLR_MT) !$OMP BARRIER #endif IF (KEEP(486).NE.2) THEN CALL DMUMPS_DECOMPRESS_PANEL_I_NOOPT( & A_PTR(POSELT), LA_PTR, 1_8, & NCOL1, NCOL1, & .TRUE., & NPIV1+1, & 1, & NB_BLR_L+1, BLR_L(1), CURRENT_BLR, 'V', 1) ENDIF ENDIF 300 CONTINUE #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF ENDIF IF ( (KEEP(201).eq.1) .AND. & (OOCWRITE_COMPATIBLE_WITH_BLR .OR. NPIV.EQ.0) ) THEN MonBloc%INODE = INODE MonBloc%MASTER = .FALSE. MonBloc%Typenode = 2 MonBloc%NROW = NROW1 MonBloc%NCOL = NCOL1 MonBloc%NFS = NASS1 MonBloc%LastPiv = NPIV1 + NPIV MonBloc%LastPanelWritten_L = -9999 MonBloc%LastPanelWritten_U = -9999 NULLIFY(MonBloc%INDICES) MonBloc%Last = LASTBL STRAT = STRAT_TRY_WRITE NextPivDummy = -8888 LIWFAC = IW(IOLDPS+XXI) LAST_CALL = .FALSE. CALL DMUMPS_OOC_IO_LU_PANEL_I( STRAT, TYPEF_L, & A_PTR(POSELT), & LA_PTR, MonBloc, NextPivDummy, NextPivDummy, & IW(IOLDPS), LIWFAC, MYID, KEEP8(31), IFLAG,LAST_CALL) ENDIF IF ( (NPIV .GT. 0) & ) THEN IF (LR_ACTIVATED) THEN IF (NELIM.GT.0) THEN UPOS = 1_8+int(NPIV,8) IF (DYNAMIC_ALLOC) THEN CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & DYN_BLOCFACTO, LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ELSE CALL DMUMPS_BLR_UPD_NELIM_VAR_L_I( & A(POSBLOCFACTO), LA_BLOCFACTO, UPOS, & A_PTR(POSELT), LA_PTR, LPOS-POSELT+1_8, & IFLAG, IERROR, LD_BLOCFACTO, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & CURRENT_BLR, BLR_L(1), NB_BLR_L+1, & CURRENT_BLR+1, NELIM, 'N') ENDIF ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif CALL DMUMPS_BLR_UPDATE_TRAILING_I( & A_PTR(POSELT), LA_PTR, 1_8, & IFLAG, IERROR, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_U(1), size(BEGS_BLR_U), CURRENT_BLR, & BLR_L(1), NB_BLR_L+1, & BLR_U(1), NB_BLR_U+1, & 0, & .TRUE., & NPIV1, & 2, 0, & KEEP(481), DKEEP(11), KEEP(466), KEEP(477) & ) #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ELSE IF (DYNAMIC_ALLOC) THEN UPOS = int(NPIV+1,8) CALL dgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,DYN_BLOCFACTO(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ELSE UPOS = POSBLOCFACTO+int(NPIV,8) CALL dgemm('N','N', NCOL-NPIV, NROW1, NPIV, & ALPHA,A(UPOS), NCOL, & A_PTR(LPOS2), NCOL1, ONE, A_PTR(LPOS), NCOL1) ENDIF ENDIF ENDIF IW(IOLDPS+KEEP(IXSZ) ) = IW(IOLDPS+KEEP(IXSZ) ) - NPIV IW(IOLDPS + 3+KEEP(IXSZ) ) = IW(IOLDPS+3+KEEP(IXSZ) ) + NPIV IF (LASTBL) THEN IW(IOLDPS+1+KEEP(IXSZ) ) = IW(IOLDPS + 3+KEEP(IXSZ) ) ENDIF IF ( .not. LASTBL .AND. & (IW(IOLDPS+1+KEEP(IXSZ)) .EQ. IW(IOLDPS + 3+KEEP(IXSZ))) ) THEN write(*,*) 'Internal ERROR 1 **** IN BLACFACTO ' CALL MUMPS_ABORT() ENDIF IF (LR_ACTIVATED) THEN IF ((NPIV.GT.0) & ) THEN CALL DEALLOC_BLR_PANEL( BLR_U, NB_BLR_U, KEEP8) DEALLOCATE(BLR_U) IF (KEEP(486).EQ.3) THEN CALL DEALLOC_BLR_PANEL( BLR_L, NB_BLR_L, KEEP8) DEALLOCATE(BLR_L) ELSE CALL UPD_MRY_LU_LRGAIN(BLR_L, 0, NPARTSCB, 'V') ENDIF ENDIF ENDIF IF (DYNAMIC_ALLOC) THEN DEALLOCATE(DYN_BLOCFACTO) DEALLOCATE(DYN_PIVINFO) ELSE LRLU = LRLU + LA_BLOCFACTO LRLUS = LRLUS + LA_BLOCFACTO KEEP8(69) = KEEP8(69) - LA_BLOCFACTO POSFAC = POSFAC - LA_BLOCFACTO CALL DMUMPS_LOAD_MEM_UPDATE(.FALSE.,.FALSE., & LA-LRLUS,0_8,-LA_BLOCFACTO,KEEP,KEEP8,LRLUS) IWPOS = IWPOS - NPIV ENDIF FLOP1 = dble( NPIV1*NROW1 ) + & dble(NROW1*NPIV1)*dble(2*NCOL1-NPIV1-1) & - & dble((NPIV1+NPIV)*NROW1 ) - & dble(NROW1*(NPIV1+NPIV))*dble(2*NCOL1-NPIV1-NPIV-1) CALL DMUMPS_LOAD_UPDATE( 1, .FALSE., FLOP1, KEEP,KEEP8 ) IF (LASTBL) THEN IF (KEEP(486).NE.0) THEN IF (LR_ACTIVATED) THEN CALL STATS_COMPUTE_FLOP_SLAVE_TYPE2(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ELSE CALL UPD_FLOP_FRFRONT_SLAVE(NROW1, NCOL1, NASS1, & KEEP(50), INODE) ENDIF ENDIF IF (LR_ACTIVATED) THEN IF (COMPRESS_CB) THEN CALL DMUMPS_BLR_RETRIEVE_BEGS_BLR_C (IW(IOLDPS+XXF), & BEGS_BLR_COL, NPARTSASS_MASTER_AUX) BEGS_BLR_COL(1+NPARTSASS_MASTER) = & BEGS_BLR_COL(1+NPARTSASS_MASTER) - NELIM NB_BLR_COL = size(BEGS_BLR_COL) - 1 IF (NPIV.EQ.0) THEN call MAX_CLUSTER(BEGS_BLR_L,NB_BLR_L+1,MAXI_CLUSTER_L) call MAX_CLUSTER(BEGS_BLR_COL,NB_BLR_COL,MAXI_CLUSTER_COL) IF (COMPRESS_CB) THEN MAXI_CLUSTER=max(MAXI_CLUSTER_COL+NELIM,MAXI_CLUSTER_L) ELSE MAXI_CLUSTER=max(MAXI_CLUSTER_COL,MAXI_CLUSTER_L) ENDIF LWORK = MAXI_CLUSTER*MAXI_CLUSTER OMP_NUM = 1 #if defined(BLR_MT) !$ OMP_NUM = OMP_GET_MAX_THREADS() #endif ALLOCATE(BLOCK(MAXI_CLUSTER, OMP_NUM*MAXI_CLUSTER), & RWORK(2*MAXI_CLUSTER*OMP_NUM), & TAU(MAXI_CLUSTER*OMP_NUM), & JPVT(MAXI_CLUSTER*OMP_NUM), & WORK(LWORK*OMP_NUM), stat=allocok) IF (allocok > 0 ) THEN IFLAG = -13 IERROR = MAXI_CLUSTER*OMP_NUM*MAXI_CLUSTER & + 2*MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + MAXI_CLUSTER*OMP_NUM & + LWORK*OMP_NUM LP = ICNTL(1) IF (ICNTL(4) .LE. 0) LP=-1 IF (LP > 0) WRITE(LP,*) MYID, & ': ERROR allocation during DMUMPS_PROCESS_BLOCFACTO' GOTO 700 ENDIF ENDIF allocate(CB_LRB(NB_BLR_L,NB_BLR_COL-NPARTSASS_MASTER), & stat=allocok) IF (allocok > 0) THEN IFLAG = -13 IERROR = NB_BLR_L*(NB_BLR_COL-NPARTSASS_MASTER) GOTO 700 ENDIF CALL DMUMPS_BLR_SAVE_CB_LRB(IW(IOLDPS+XXF),CB_LRB) ENDIF #if defined(BLR_MT) !$OMP PARALLEL #endif IF (COMPRESS_CB) THEN CALL DMUMPS_COMPRESS_CB_I( & A_PTR(POSELT), LA_PTR, 1_8, NCOL1, & BEGS_BLR_L(1), size(BEGS_BLR_L), & BEGS_BLR_COL(1), size(BEGS_BLR_COL), & NB_BLR_L, NB_BLR_COL-NPARTSASS_MASTER, & NPARTSASS_MASTER, & NROW1, NCOL1-NPIV1-NPIV, INODE, & IW(IOLDPS+XXF), 0, 2, IFLAG, IERROR, & DKEEP(12), KEEP(466), KEEP(484), KEEP(489), & CB_LRB(1,1), & WORK, TAU, JPVT, LWORK, RWORK, BLOCK, & MAXI_CLUSTER, KEEP8, OMP_NUM, & -9999, -9999, -9999, KEEP(1) & ) #if defined(BLR_MT) !$OMP BARRIER #endif ENDIF #if defined(BLR_MT) !$OMP END PARALLEL #endif IF (IFLAG.LT.0) GOTO 700 ENDIF CALL DMUMPS_END_FACTO_SLAVE( & COMM_LOAD, ASS_IRECV, & N, INODE, FPERE, & root, & MYID, COMM, & & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, IW, LIW, A, LA, & PTRIST, PTLUST_S, PTRFAC, PTRAST, STEP, PIMASTER, & PAMASTER, & NSTK_S, COMP, IFLAG, IERROR, PERM, & IPOOL, LPOOL, LEAF, NBFIN, SLAVEF, & OPASSW, OPELIW, ITLOC, RHS_MUMPS, FILS, DAD, PTRARW, PTRAIW, & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, FRERE_STEPS, & LPTRAR, NELT, FRTPTR, FRTELT, & ISTEP_TO_INIV2, TAB_POS_IN_PERE & , LRGROUPS & ) ENDIF IF (LR_ACTIVATED) THEN IF (allocated(RWORK)) DEALLOCATE(RWORK) IF (allocated(WORK)) DEALLOCATE(WORK) IF (allocated(TAU)) DEALLOCATE(TAU) IF (allocated(JPVT)) DEALLOCATE(JPVT) IF (allocated(BLOCK)) DEALLOCATE(BLOCK) IF (associated(BEGS_BLR_L)) THEN IF (.NOT. KEEP_BEGS_BLR_L) DEALLOCATE(BEGS_BLR_L) ENDIF IF ((NPIV.GT.0) & ) THEN IF (associated(BEGS_BLR_U)) DEALLOCATE(BEGS_BLR_U) ENDIF ENDIF 600 CONTINUE RETURN 700 CONTINUE CALL DMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP ) RETURN END SUBROUTINE DMUMPS_PROCESS_BLOCFACTO SUBROUTINE DMUMPS_MPI_UNPACK_LR( & BUFR, LBUFR, LBUFR_BYTES, POSITION, & NPIV, NELIM, DIR, & BLR_U, NB_BLOCK_U, & BEGS_BLR_U, KEEP8, & COMM, IERR, IFLAG, IERROR) USE DMUMPS_LR_CORE, ONLY : LRB_TYPE, ALLOC_LRB USE DMUMPS_LR_TYPE IMPLICIT NONE INTEGER, INTENT(IN) :: LBUFR INTEGER, INTENT(IN) :: LBUFR_BYTES INTEGER, INTENT(IN) :: BUFR(LBUFR) INTEGER, INTENT(INOUT) :: POSITION INTEGER, INTENT(IN) :: NB_BLOCK_U, NELIM, NPIV CHARACTER(len=1) :: DIR INTEGER, INTENT(IN) :: COMM INTEGER, INTENT(INOUT) :: IFLAG, IERROR INTEGER, INTENT(OUT) :: IERR TYPE (LRB_TYPE), INTENT(OUT), & DIMENSION(max(NB_BLOCK_U,1)):: BLR_U INTEGER, INTENT(OUT), DIMENSION(NB_BLOCK_U+2) :: BEGS_BLR_U INTEGER(8) :: KEEP8(150) LOGICAL :: ISLR INTEGER :: ISLR_INT, I INTEGER :: K, M, N INCLUDE 'mpif.h' INCLUDE 'mumps_tags.h' IERR = 0 IF (size(BLR_U) .NE. & MAX(NB_BLOCK_U,1) ) THEN WRITE(*,*) "Internal error 1 in DMUMPS_MPI_UNPACK", & NB_BLOCK_U,size(BLR_U) CALL MUMPS_ABORT() ENDIF BEGS_BLR_U(1) = 1 BEGS_BLR_U(2) = NPIV+NELIM+1 DO I = 1, NB_BLOCK_U CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & ISLR_INT, 1, MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & K, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & M, 1, & MPI_INTEGER, COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & N, 1, & MPI_INTEGER, COMM, IERR ) BEGS_BLR_U(I+2) = BEGS_BLR_U(I+1) + M IF (ISLR_INT .eq. 1) THEN ISLR = .TRUE. ELSE ISLR = .FALSE. ENDIF CALL ALLOC_LRB( BLR_U(I), K, M, N, ISLR, & IFLAG, IERROR, KEEP8 ) IF (IFLAG.LT.0) RETURN IF (ISLR) THEN IF (K .GT. 0) THEN CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*K, MPI_DOUBLE_PRECISION, & COMM, IERR ) CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%R(1,1), N*K, MPI_DOUBLE_PRECISION, & COMM, IERR) ENDIF ELSE CALL MPI_UNPACK( BUFR, LBUFR_BYTES, POSITION, & BLR_U(I)%Q(1,1), M*N, MPI_DOUBLE_PRECISION, & COMM, IERR) ENDIF ENDDO RETURN END SUBROUTINE DMUMPS_MPI_UNPACK_LR MUMPS_5.4.1/src/zfac_sol_l0omp_m.F0000664000175000017500000003332614102210525017046 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE ZMUMPS_FACSOL_L0OMP_M PRIVATE PUBLIC :: ZMUMPS_INIT_L0_OMP_FACTORS & , ZMUMPS_FREE_L0_OMP_FACTORS & , ZMUMPS_SAVE_RESTORE_L0FACARRAY CONTAINS SUBROUTINE ZMUMPS_INIT_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDDO ENDIF RETURN END SUBROUTINE ZMUMPS_INIT_L0_OMP_FACTORS SUBROUTINE ZMUMPS_FREE_L0_OMP_FACTORS(id_L0_OMP_FACTORS) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: & id_L0_OMP_FACTORS INTEGER I IF (associated(id_L0_OMP_FACTORS)) THEN DO I=1, size(id_L0_OMP_FACTORS) IF (associated(id_L0_OMP_FACTORS(I)%A)) THEN DEALLOCATE(id_L0_OMP_FACTORS(I)%A) NULLIFY(id_L0_OMP_FACTORS(I)%A) ENDIF ENDDO DEALLOCATE(id_L0_OMP_FACTORS) NULLIFY(id_L0_OMP_FACTORS) ENDIF RETURN END SUBROUTINE ZMUMPS_FREE_L0_OMP_FACTORS SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FACARRAY(L0_OMP_FACTORS & ,unit,MYID,mode & ,SIZE_GEST,SIZE_VARIABLES & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T), DIMENSION(:), POINTER :: L0_OMP_FACTORS INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: SIZE_GEST INTEGER(8),intent(OUT) :: SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: j1,NbRecords,NbSubRecords,size_array1,dummy,allocok,err INTEGER:: SIZE_GEST_L0FAC_ARRAY, & SIZE_GEST_L0FAC_ARRAY_j1 INTEGER(8):: SIZE_VARIABLES_L0FAC_ARRAY, & SIZE_VARIABLES_L0FAC_ARRAY_j1 SIZE_GEST = 0 SIZE_VARIABLES = 0_8 SIZE_GEST_L0FAC_ARRAY=0 SIZE_VARIABLES_L0FAC_ARRAY=0 SIZE_GEST_L0FAC_ARRAY_j1=0 SIZE_VARIABLES_L0FAC_ARRAY_j1=0 NbRecords = 0 IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 DO j1=1,size(L0_OMP_FACTORS) CALL ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"memory_save" & ,SIZE_GEST_L0FAC_ARRAY_j1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO ELSE NbRecords = 2 SIZE_GEST = 2*SIZE_INT SIZE_VARIABLES = 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS)) THEN NbRecords = 1 SIZE_GEST = SIZE_INT SIZE_VARIABLES = 0 write(unit,iostat=err) size(L0_OMP_FACTORS) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 DO j1=1,size(L0_OMP_FACTORS) CALL ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"save" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT,SIZE_INT8,SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) ENDDO ELSE NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 write(unit,iostat=err) -999 if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 ENDIF ELSE IF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS) read(unit,iostat=err) size_array1 if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 if(size_array1.EQ.-999) then NbRecords=2 SIZE_GEST=SIZE_INT*2 SIZE_VARIABLES=0 read(unit,iostat=err) dummy if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) endif IF ( INFO(1) .LT. 0 ) GOTO 100 else NbRecords=1 SIZE_GEST=SIZE_INT SIZE_VARIABLES=0 allocate(L0_OMP_FACTORS(size_array1), stat=allocok) if (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) endif DO j1=1,size(L0_OMP_FACTORS) CALL ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS(j1) & ,unit,MYID,"restore" & ,SIZE_GEST_L0FAC_ARRAY_J1 & ,SIZE_VARIABLES_L0FAC_ARRAY_J1 & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) SIZE_GEST_L0FAC_ARRAY=SIZE_GEST_L0FAC_ARRAY+ & SIZE_GEST_L0FAC_ARRAY_j1 SIZE_VARIABLES_L0FAC_ARRAY=SIZE_VARIABLES_L0FAC_ARRAY+ & SIZE_VARIABLES_L0FAC_ARRAY_j1 IF ( INFO(1) .LT. 0 ) GOTO 100 ENDDO endif ENDIF if(trim(mode).EQ."memory_save") then NbSubRecords=int(SIZE_VARIABLES/huge(0)) IF(NbSubRecords.GT.0) then NbRecords=NbRecords+NbSubRecords ENDIF elseif(trim(mode).EQ."save") then size_written=size_written+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_written=size_written & +int(2*SIZE_INT*NbRecords,kind=8) #endif elseif(trim(mode).EQ."restore") then size_allocated=size_allocated+SIZE_VARIABLES size_read=size_read+SIZE_VARIABLES & +int(SIZE_GEST,kind=8) #if !defined(MUMPS_F2003) size_read=size_read & +int(2*SIZE_INT*NbRecords,kind=8) #endif endif if(trim(mode).EQ."memory_save") then SIZE_VARIABLES=SIZE_VARIABLES+SIZE_VARIABLES_L0FAC_ARRAY SIZE_GEST=SIZE_GEST+SIZE_GEST_L0FAC_ARRAY #if !defined(MUMPS_F2003) SIZE_GEST=SIZE_GEST+2*SIZE_INT*NbRecords #endif endif 100 continue RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FACARRAY SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FAC( & L0_OMP_FACTORS_1THREAD & ,unit,MYID,mode & ,Local_SIZE_GEST, Local_SIZE_VARIABLES & ,SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP & ,TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE & ,size_read,size_allocated,size_written & ,INFO) USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_L0OMPFAC_T IMPLICIT NONE TYPE (ZMUMPS_L0OMPFAC_T) :: L0_OMP_FACTORS_1THREAD INTEGER,intent(IN)::unit,MYID CHARACTER(len=*),intent(IN) :: mode INTEGER,INTENT(OUT) :: Local_SIZE_GEST INTEGER(8),intent(OUT) :: Local_SIZE_VARIABLES INTEGER,intent(INOUT):: INFO(2) INTEGER,intent(IN):: SIZE_INT, SIZE_INT8, SIZE_ARITH_DEP INTEGER(8),intent(IN) :: TOTAL_FILE_SIZE,TOTAL_STRUC_SIZE INTEGER(8),intent(INOUT):: size_read,size_allocated,size_written INTEGER:: Local_NbRecords, allocok, err INTEGER(8) :: itmp Local_NbRecords = 0 Local_SIZE_GEST = 0 Local_SIZE_VARIABLES = 0_8 Local_NbRecords = Local_NbRecords+1 IF (trim(mode) .EQ. "memory_save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 ELSE IF (trim(mode) .EQ. "save") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 WRITE(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1)=-72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 ENDIF size_written=size_written+SIZE_INT8 ELSE IF (trim(mode) .EQ. "restore") THEN Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + SIZE_INT8 READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%LA IF (err .NE. 0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read, & INFO(2)) GOTO 100 ENDIF size_read=size_read+SIZE_INT8 ENDIF IF (trim(mode).EQ."memory_save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 Local_SIZE_GEST = Local_SIZE_GEST + SIZE_INT8 Local_SIZE_VARIABLES = Local_SIZE_VARIABLES + 0 ENDIF ELSEIF (trim(mode).EQ."save") THEN IF (associated(L0_OMP_FACTORS_1THREAD%A)) THEN Local_NbRecords = Local_NbRecords + 2 write(unit,iostat=err) int(0,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 write(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written = size_written + & max(L0_OMP_FACTORS_1THREAD%LA,1_8)*SIZE_ARITH_DEP ELSE Local_NbRecords = Local_NbRecords + 1 write(unit,iostat=err) int(-999,8) if(err.ne.0) then INFO(1) = -72 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_written, & INFO(2)) GOTO 100 endif size_written=size_written+SIZE_INT8 ENDIF ELSEIF (trim(mode).EQ."restore") THEN NULLIFY(L0_OMP_FACTORS_1THREAD%A) READ(unit,iostat=err) itmp if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + SIZE_INT8 size_allocated = size_allocated + SIZE_INT8 IF (itmp .eq. -999) THEN Local_NbRecords = Local_NbRecords + 1 ELSE Local_NbRecords = Local_NbRecords + 2 ALLOCATE(L0_OMP_FACTORS_1THREAD%A( & max(L0_OMP_FACTORS_1THREAD%LA,1_8)), & stat=allocok) IF (allocok .GT. 0) THEN INFO(1) = -78 CALL MUMPS_SETI8TOI4( & TOTAL_STRUC_SIZE-size_allocated & ,INFO(2)) GOTO 100 ENDIF READ(unit,iostat=err) L0_OMP_FACTORS_1THREAD%A if(err.ne.0) THEN INFO(1) = -75 CALL MUMPS_SETI8TOI4(TOTAL_FILE_SIZE-size_read & ,INFO(2)) GOTO 100 endif size_read = size_read + & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP size_allocated = size_allocated+ & max(1_8,L0_OMP_FACTORS_1THREAD%LA)*SIZE_ARITH_DEP ENDIF ENDIF #if !defined(MUMPS_F2003) IF (trim(mode).EQ."memory_save") THEN Local_SIZE_GEST = Local_SIZE_GEST+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."save") THEN size_written = size_written+2*SIZE_INT*Local_NbRecords ELSE IF (trim(mode).EQ."restore") THEN size_read = size_read+2*SIZE_INT*Local_NbRecords ENDIF #endif 100 CONTINUE RETURN END SUBROUTINE ZMUMPS_SAVE_RESTORE_L0FAC END MODULE ZMUMPS_FACSOL_L0OMP_M MUMPS_5.4.1/src/cfac_omp_m.F0000664000175000017500000000076214102210524015703 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C MODULE CMUMPS_FAC_OMP_M END MODULE CMUMPS_FAC_OMP_M MUMPS_5.4.1/libseq/0000775000175000017500000000000014102210473014177 5ustar jylexceljylexcelMUMPS_5.4.1/libseq/elapse.h0000664000175000017500000000166014102210473015624 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifndef MUMPS_CALL #if defined(_WIN32) /* Modify/choose between next 2 lines depending * * on your Windows calling conventions */ /* #define MUMPS_CALL __stdcall */ #define MUMPS_CALL #else #define MUMPS_CALL #endif #endif #if (defined(_WIN32) && ! defined(__MINGW32__)) || defined(UPPER) #define mumps_elapse MUMPS_ELAPSE #elif defined(Add__) #define mumps_elapse mumps_elapse__ #elif defined(Add_) #define mumps_elapse mumps_elapse_ #endif void MUMPS_CALL mumps_elapse(double *val); MUMPS_5.4.1/libseq/Makefile0000664000175000017500000000067414102210473015646 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # all: libmpiseq .PHONY: all libmpiseq clean topdir = .. include $(topdir)/Makefile.inc libmpiseq: libmpiseq$(PLAT)$(LIBEXT) libmpiseq$(PLAT)$(LIBEXT): mpi.o mpic.o elapse.o $(AR)$@ mpi.o mpic.o elapse.o $(RANLIB) $@ .f.o: $(FC) $(OPTF) -c $*.f $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(CDEFS) -I. -c $*.c $(OUTC)$*.o clean: $(RM) *.o *$(LIBEXT) MUMPS_5.4.1/libseq/README0000664000175000017500000000032114102210473015053 0ustar jylexceljylexcel This directory contains dummy MPI/BLACS/ScaLAPACK symbols to allow linking/running MUMPS on a platform where MPI is not installed. It is used by the main Makefile to build a sequential version of MUMPS. MUMPS_5.4.1/libseq/elapse.c0000664000175000017500000000164614102210473015623 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #if defined(_WIN32) #include "elapse.h" #include #include void MUMPS_CALL mumps_elapse(double *val) { time_t ltime; struct _timeb tstruct; time (<ime); _ftime(&tstruct); *val = (double) ltime + (double) tstruct.millitm*(0.001); } #else #include "elapse.h" #include void mumps_elapse(double *val) { struct timeval time; gettimeofday(&time,(struct timezone *)0); *val=time.tv_sec+time.tv_usec*1.e-6; } #endif MUMPS_5.4.1/libseq/mpi.f0000664000175000017500000016073214102210473015144 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C C C Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, C Mumps Technologies, University of Bordeaux. C C This version of MUMPS is provided to you free of charge. It is C released under the CeCILL-C license C (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and C https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) C C******************************************************************* C C This file contains stub MPI/BLACS/ScaLAPACK library functions for C linking/running MUMPS on a platform where MPI is not installed. C C******************************************************************* C C MPI C C****************************************************************** SUBROUTINE MPI_BSEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR INTEGER BUF(*) WRITE(*,*) 'Error. MPI_BSEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_BSEND C*********************************************************************** SUBROUTINE MPI_BUFFER_ATTACH(BUF, CNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_BUFFER_ATTACH C*********************************************************************** SUBROUTINE MPI_BUFFER_DETACH(BUF, CNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_BUFFER_DETACH SUBROUTINE MPI_GATHER( SENDBUF, CNT, & DATATYPE, RECVBUF, RECCNT, RECTYPE, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, RECCNT, RECTYPE, ROOT, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) IF ( RECCNT .NE. CNT ) THEN WRITE(*,*) 'ERROR in MPI_GATHER, RECCNT != CNT' STOP ELSE CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_GATHER, DATATYPE=',DATATYPE STOP END IF END IF IERR = 0 RETURN END SUBROUTINE MPI_GATHER C*********************************************************************** SUBROUTINE MPI_GATHERV( SENDBUF, CNT, & DATATYPE, RECVBUF, RECCNT, DISPLS, RECTYPE, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, RECTYPE, ROOT, COMM, IERR INTEGER RECCNT(1) INTEGER SENDBUF(*), RECVBUF(*) INTEGER DISPLS(*) C C Note that DISPLS is ignored in this version. One may C want to copy in reception buffer with a shift DISPLS(1). C This requires passing the offset DISPLS(1) to C "MUMPS_COPY_DATATYPE" routines. C IF ( RECCNT(1) .NE. CNT ) THEN WRITE(*,*) 'ERROR in MPI_GATHERV, RECCNT(1) != CNT' STOP ELSE CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_GATHERV, DATATYPE=',DATATYPE STOP END IF END IF IERR = 0 RETURN END SUBROUTINE MPI_GATHERV C*********************************************************************** SUBROUTINE MPI_ALLREDUCE( SENDBUF, RECVBUF, CNT, DATATYPE, & OPERATION, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, OPERATION, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_ALLREDUCE, DATATYPE=',DATATYPE STOP END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_ALLREDUCE C*********************************************************************** SUBROUTINE MPI_REDUCE( SENDBUF, RECVBUF, CNT, DATATYPE, OP, & ROOT, COMM, IERR ) IMPLICIT NONE INTEGER CNT, DATATYPE, OP, ROOT, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN CALL MUMPS_COPY( CNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_REDUCE, DATATYPE=',DATATYPE STOP END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_REDUCE C*********************************************************************** SUBROUTINE MPI_REDUCE_SCATTER( SENDBUF, RECVBUF, RCVCNT, & DATATYPE, OP, COMM, IERR ) IMPLICIT NONE INTEGER RCVCNT, DATATYPE, OP, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, RCVCNT)) THEN CALL MUMPS_COPY( RCVCNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_REDUCE_SCATTER, DATATYPE=',DATATYPE STOP END IF ENDIF IERR = 0 RETURN END SUBROUTINE MPI_REDUCE_SCATTER C*********************************************************************** SUBROUTINE MPI_ABORT( COMM, IERRCODE, IERR ) IMPLICIT NONE INTEGER COMM, IERRCODE, IERR WRITE(*,*) "** MPI_ABORT called" STOP END SUBROUTINE MPI_ABORT C*********************************************************************** SUBROUTINE MPI_ALLTOALL( SENDBUF, SENDCNT, SENDTYPE, & RECVBUF, RECVCNT, RECVTYPE, COMM, IERR ) IMPLICIT NONE INTEGER SENDCNT, SENDTYPE, RECVCNT, RECVTYPE, COMM, IERR INTEGER SENDBUF(*), RECVBUF(*) IF ( RECVCNT .NE. SENDCNT ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, RECVCNT != SENDCNT' STOP ELSE IF ( RECVTYPE .NE. SENDTYPE ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, RECVTYPE != SENDTYPE' STOP ELSE CALL MUMPS_COPY( SENDCNT, SENDBUF, RECVBUF, SENDTYPE, IERR ) IF ( IERR .NE. 0 ) THEN WRITE(*,*) 'ERROR in MPI_ALLTOALL, SENDTYPE=',SENDTYPE STOP END IF END IF IERR = 0 RETURN END SUBROUTINE MPI_ALLTOALL C*********************************************************************** SUBROUTINE MPI_ATTR_PUT( COMM, KEY, VAL, IERR ) IMPLICIT NONE INTEGER COMM, KEY, VAL, IERR RETURN END SUBROUTINE MPI_ATTR_PUT C*********************************************************************** SUBROUTINE MPI_BARRIER( COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, IERR IERR = 0 RETURN END SUBROUTINE MPI_BARRIER C*********************************************************************** SUBROUTINE MPI_GET_PROCESSOR_NAME( NAME, RESULTLEN, IERROR) CHARACTER (LEN=*) NAME INTEGER RESULTLEN,IERROR RESULTLEN = 1 IERROR = 0 NAME = 'X' RETURN END SUBROUTINE MPI_GET_PROCESSOR_NAME C*********************************************************************** SUBROUTINE MPI_BCAST( BUFFER, CNT, DATATYPE, ROOT, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, ROOT, COMM, IERR INTEGER BUFFER( * ) IERR = 0 RETURN END SUBROUTINE MPI_BCAST C*********************************************************************** SUBROUTINE MPI_CANCEL( IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR IERR = 0 RETURN END SUBROUTINE MPI_CANCEL C*********************************************************************** SUBROUTINE MPI_COMM_CREATE( COMM, GROUP, COMM2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, GROUP, COMM2, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_CREATE C*********************************************************************** SUBROUTINE MPI_COMM_DUP( COMM, COMM2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, COMM2, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_DUP C*********************************************************************** SUBROUTINE MPI_COMM_FREE( COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_FREE C*********************************************************************** SUBROUTINE MPI_COMM_GROUP( COMM, GROUP, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, GROUP, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_GROUP C*********************************************************************** SUBROUTINE MPI_COMM_RANK( COMM, RANK, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, RANK, IERR RANK = 0 IERR = 0 RETURN END SUBROUTINE MPI_COMM_RANK C*********************************************************************** SUBROUTINE MPI_COMM_SIZE( COMM, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, SIZE, IERR SIZE = 1 IERR = 0 RETURN END SUBROUTINE MPI_COMM_SIZE C*********************************************************************** SUBROUTINE MPI_COMM_SPLIT( COMM, COLOR, KEY, COMM2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER COMM, COLOR, KEY, COMM2, IERR IERR = 0 RETURN END SUBROUTINE MPI_COMM_SPLIT C*********************************************************************** c SUBROUTINE MPI_ERRHANDLER_SET( COMM, ERRHANDLER, IERR ) c IMPLICIT NONE c INCLUDE 'mpif.h' c INTEGER COMM, ERRHANDLER, IERR c IERR = 0 c RETURN c END SUBROUTINE MPI_ERRHANDLER_SET C*********************************************************************** SUBROUTINE MPI_FINALIZE( IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR IERR = 0 RETURN END SUBROUTINE MPI_FINALIZE C*********************************************************************** SUBROUTINE MPI_GET_COUNT( STATUS, DATATYPE, CNT, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER DATATYPE, CNT, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_GET_CNT should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_GET_COUNT C*********************************************************************** SUBROUTINE MPI_GROUP_FREE( GROUP, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER GROUP, IERR IERR = 0 RETURN END SUBROUTINE MPI_GROUP_FREE C*********************************************************************** SUBROUTINE MPI_GROUP_RANGE_EXCL( GROUP, N, RANGES, GROUP2, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER GROUP, N, GROUP2, IERR INTEGER RANGES(*) IERR = 0 RETURN END SUBROUTINE MPI_GROUP_RANGE_EXCL C*********************************************************************** SUBROUTINE MPI_GROUP_SIZE( GROUP, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER GROUP, SIZE, IERR SIZE = 1 ! Or should it be zero ? IERR = 0 RETURN END SUBROUTINE MPI_GROUP_SIZE C*********************************************************************** SUBROUTINE MPI_INIT(IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IERR IERR = 0 RETURN END SUBROUTINE MPI_INIT C*********************************************************************** SUBROUTINE MPI_INITIALIZED( FLAG, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL FLAG INTEGER IERR FLAG = .TRUE. IERR = 0 RETURN END SUBROUTINE MPI_INITIALIZED C*********************************************************************** SUBROUTINE MPI_IPROBE( SOURCE, TAG, COMM, FLAG, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER SOURCE, TAG, COMM, IERR INTEGER STATUS(MPI_STATUS_SIZE) LOGICAL FLAG FLAG = .FALSE. IERR = 0 RETURN END SUBROUTINE MPI_IPROBE C*********************************************************************** SUBROUTINE MPI_IRECV( BUF, CNT, DATATYPE, SOURCE, TAG, COMM, & IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, SOURCE, TAG, COMM, IREQ, IERR INTEGER BUF(*) IERR = 0 RETURN END SUBROUTINE MPI_IRECV C*********************************************************************** SUBROUTINE MPI_ISEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, & IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR, IREQ INTEGER BUF(*) WRITE(*,*) 'Error. MPI_ISEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_ISEND C*********************************************************************** SUBROUTINE MPI_TYPE_COMMIT( NEWTYP, IERR_MPI ) IMPLICIT NONE INTEGER NEWTYP, IERR_MPI RETURN END SUBROUTINE MPI_TYPE_COMMIT C*********************************************************************** SUBROUTINE MPI_TYPE_FREE( NEWTYP, IERR_MPI ) IMPLICIT NONE INTEGER NEWTYP, IERR_MPI RETURN END SUBROUTINE MPI_TYPE_FREE C*********************************************************************** SUBROUTINE MPI_TYPE_CONTIGUOUS( LENGTH, DATATYPE, NEWTYPE, & IERR_MPI ) IMPLICIT NONE INTEGER LENGTH, DATATYPE, NEWTYPE, IERR_MPI RETURN END SUBROUTINE MPI_TYPE_CONTIGUOUS C*********************************************************************** SUBROUTINE MPI_OP_CREATE( FUNC, COMMUTE, OP, IERR ) IMPLICIT NONE EXTERNAL FUNC LOGICAL COMMUTE INTEGER OP, IERR OP = 0 RETURN END SUBROUTINE MPI_OP_CREATE C*********************************************************************** SUBROUTINE MPI_OP_FREE( OP, IERR ) IMPLICIT NONE INTEGER OP, IERR RETURN END SUBROUTINE MPI_OP_FREE C*********************************************************************** SUBROUTINE MPI_PACK( INBUF, INCNT, DATATYPE, OUTBUF, OUTCNT, & POSITION, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INCNT, DATATYPE, OUTCNT, POSITION, COMM, IERR INTEGER INBUF(*), OUTBUF(*) WRITE(*,*) 'Error. MPI_PACKED should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_PACK C*********************************************************************** SUBROUTINE MPI_PACK_SIZE( INCNT, DATATYPE, COMM, SIZE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INCNT, DATATYPE, COMM, SIZE, IERR WRITE(*,*) 'Error. MPI_PACK_SIZE should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_PACK_SIZE C*********************************************************************** SUBROUTINE MPI_PROBE( SOURCE, TAG, COMM, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER SOURCE, TAG, COMM, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_PROBE should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_PROBE C*********************************************************************** SUBROUTINE MPI_RECV( BUF, CNT, DATATYPE, SOURCE, TAG, COMM, & STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, SOURCE, TAG, COMM, IERR INTEGER BUF(*), STATUS(MPI_STATUS_SIZE) WRITE(*,*) 'Error. MPI_RECV should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_RECV C*********************************************************************** SUBROUTINE MPI_REQUEST_FREE( IREQ, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR IERR = 0 RETURN END SUBROUTINE MPI_REQUEST_FREE C*********************************************************************** SUBROUTINE MPI_SEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR INTEGER BUF(*) WRITE(*,*) 'Error. MPI_SEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_SEND C*********************************************************************** SUBROUTINE MPI_SSEND( BUF, CNT, DATATYPE, DEST, TAG, COMM, IERR) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR INTEGER BUF(*) WRITE(*,*) 'Error. MPI_SSEND should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_SSEND C*********************************************************************** SUBROUTINE MPI_TEST( IREQ, FLAG, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR INTEGER STATUS( MPI_STATUS_SIZE ) LOGICAL FLAG FLAG = .FALSE. IERR = 0 RETURN END SUBROUTINE MPI_TEST C*********************************************************************** SUBROUTINE MPI_UNPACK( INBUF, INSIZE, POSITION, OUTBUF, OUTCNT, & DATATYPE, COMM, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER INSIZE, POSITION, OUTCNT, DATATYPE, COMM, IERR INTEGER INBUF(*), OUTBUF(*) WRITE(*,*) 'Error. MPI_UNPACK should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_UNPACK C*********************************************************************** SUBROUTINE MPI_WAIT( IREQ, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER IREQ, IERR INTEGER STATUS( MPI_STATUS_SIZE ) WRITE(*,*) 'Error. MPI_WAIT should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAIT C*********************************************************************** SUBROUTINE MPI_WAITALL( CNT, ARRAY_OF_REQUESTS, STATUS, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, IERR INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER ARRAY_OF_REQUESTS( CNT ) WRITE(*,*) 'Error. MPI_WAITALL should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAITALL C*********************************************************************** SUBROUTINE MPI_WAITANY( CNT, ARRAY_OF_REQUESTS, INDEX, STATUS, & IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, INDEX, IERR INTEGER STATUS( MPI_STATUS_SIZE ) INTEGER ARRAY_OF_REQUESTS( CNT ) WRITE(*,*) 'Error. MPI_WAITANY should not be called.' STOP IERR = 0 RETURN END SUBROUTINE MPI_WAITANY C*********************************************************************** DOUBLE PRECISION FUNCTION MPI_WTIME( ) C elapsed time DOUBLE PRECISION VAL C write(*,*) 'Entering MPI_WTIME' CALL MUMPS_ELAPSE( VAL ) MPI_WTIME = VAL C write(*,*) 'Exiting MPI_WTIME' RETURN END FUNCTION MPI_WTIME C*********************************************************************** C C Utilities to copy data C C*********************************************************************** SUBROUTINE MUMPS_COPY( CNT, SENDBUF, RECVBUF, DATATYPE, IERR ) IMPLICIT NONE INCLUDE 'mpif.h' INTEGER CNT, DATATYPE, IERR INTEGER SENDBUF(*), RECVBUF(*) IF ( DATATYPE .EQ. MPI_INTEGER ) THEN CALL MUMPS_COPY_INTEGER( SENDBUF, RECVBUF, CNT ) ELSEIF ( DATATYPE .EQ. MPI_LOGICAL ) THEN CALL MUMPS_COPY_LOGICAL( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_REAL ) THEN CALL MUMPS_COPY_REAL( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_DOUBLE_PRECISION .OR. & DATATYPE .EQ. MPI_REAL8 ) THEN CALL MUMPS_COPY_DOUBLE_PRECISION( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_COMPLEX ) THEN CALL MUMPS_COPY_COMPLEX( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_DOUBLE_COMPLEX ) THEN CALL MUMPS_COPY_DOUBLE_COMPLEX( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_2DOUBLE_PRECISION) THEN CALL MUMPS_COPY_2DOUBLE_PRECISION( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_2INTEGER) THEN CALL MUMPS_COPY_2INTEGER( SENDBUF, RECVBUF, CNT ) ELSE IF ( DATATYPE .EQ. MPI_INTEGER8) THEN CALL MUMPS_COPY_INTEGER8( SENDBUF, RECVBUF, CNT ) ELSE IERR=1 RETURN END IF IERR=0 RETURN END SUBROUTINE MUMPS_COPY SUBROUTINE MUMPS_COPY_INTEGER( S, R, N ) IMPLICIT NONE INTEGER N INTEGER S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_INTEGER SUBROUTINE MUMPS_COPY_INTEGER8( S, R, N ) IMPLICIT NONE INTEGER N INTEGER(8) S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_INTEGER8 SUBROUTINE MUMPS_COPY_LOGICAL( S, R, N ) IMPLICIT NONE INTEGER N LOGICAL S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_2INTEGER( S, R, N ) IMPLICIT NONE INTEGER N INTEGER S(N+N),R(N+N) INTEGER I DO I = 1, N+N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_2INTEGER SUBROUTINE MUMPS_COPY_REAL( S, R, N ) IMPLICIT NONE INTEGER N REAL S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_2DOUBLE_PRECISION( S, R, N ) IMPLICIT NONE INTEGER N DOUBLE PRECISION S(N+N),R(N+N) INTEGER I DO I = 1, N+N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_2DOUBLE_PRECISION SUBROUTINE MUMPS_COPY_DOUBLE_PRECISION( S, R, N ) IMPLICIT NONE INTEGER N DOUBLE PRECISION S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_COMPLEX( S, R, N ) IMPLICIT NONE INTEGER N COMPLEX S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END SUBROUTINE MUMPS_COPY_COMPLEX SUBROUTINE MUMPS_COPY_DOUBLE_COMPLEX( S, R, N ) IMPLICIT NONE INTEGER N C DOUBLE COMPLEX S(N),R(N) COMPLEX(kind=kind(0.0D0)) :: S(N),R(N) INTEGER I DO I = 1, N R(I) = S(I) END DO RETURN END LOGICAL FUNCTION MUMPS_IS_IN_PLACE( SENDBUF, CNT ) INTEGER SENDBUF(*), CNT INCLUDE 'mpif.h' INTEGER :: I C Check address using C code MUMPS_IS_IN_PLACE = .FALSE. IF ( CNT .GT. 0 ) THEN CALL MUMPS_CHECKADDREQUAL(SENDBUF(1), MPI_IN_PLACE, I) IF (I .EQ. 1) THEN MUMPS_IS_IN_PLACE = .TRUE. ENDIF ENDIF C Begin old code which requires the MPI_IN_PLACE C variable to have the F2003 attribute VOLATILE C IF ( CNT .GT. 0 ) THEN C MPI_IN_PLACE = -1 C IF (SENDBUF(1) .EQ. MPI_IN_PLACE) THEN C MPI_IN_PLACE = -9876543 C IF (MUMPS_CHECK_EQUAL(SENDBUF(1), MPI_IN_PLACE)) THEN C MUMPS_IS_IN_PLACE = .TRUE. C ENDIF C ENDIF C ENDIF C End old code RETURN END FUNCTION MUMPS_IS_IN_PLACE C Begin old code C LOGICAL FUNCTION MUMPS_CHECK_EQUAL(I,J) C INTEGER :: I,J C IF (I.EQ.J) THEN C MUMPS_CHECK_EQUAL = .TRUE. C ELSE C MUMPS_CHECK_EQUAL = .FALSE. C ENDIF C END FUNCTION MUMPS_CHECK_EQUAL C End old code C*********************************************************************** C C BLACS C C*********************************************************************** SUBROUTINE blacs_gridinit( CNTXT, C, NPROW, NPCOL ) IMPLICIT NONE INTEGER CNTXT, NPROW, NPCOL CHARACTER C WRITE(*,*) 'Error. BLACS_GRIDINIT should not be called.' STOP RETURN END SUBROUTINE blacs_gridinit C*********************************************************************** SUBROUTINE blacs_gridinfo( CNTXT, NPROW, NPCOL, MYROW, MYCOL ) IMPLICIT NONE INTEGER CNTXT, NPROW, NPCOL, MYROW, MYCOL WRITE(*,*) 'Error. BLACS_GRIDINFO should not be called.' STOP RETURN END SUBROUTINE blacs_gridinfo C*********************************************************************** SUBROUTINE blacs_gridexit( CNTXT ) IMPLICIT NONE INTEGER CNTXT WRITE(*,*) 'Error. BLACS_GRIDEXIT should not be called.' STOP RETURN END SUBROUTINE blacs_gridexit C*********************************************************************** C C ScaLAPACK C C*********************************************************************** SUBROUTINE DESCINIT( DESC, M, N, MB, NB, IRSRC, ICSRC, & ICTXT, LLD, INFO ) IMPLICIT NONE INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB INTEGER DESC( * ) WRITE(*,*) 'Error. DESCINIT should not be called.' STOP RETURN END SUBROUTINE DESCINIT C*********************************************************************** INTEGER FUNCTION numroc( N, NB, IPROC, ISRCPROC, NPROCS ) INTEGER N, NB, IPROC, ISRCPROC, NPROCS C Can be called IF ( NPROCS .ne. 1 ) THEN WRITE(*,*) 'Error. Last parameter from NUMROC should be 1' STOP ENDIF IF ( IPROC .ne. 0 ) THEN WRITE(*,*) 'Error. IPROC should be 0 in NUMROC.' STOP ENDIF NUMROC = N RETURN END FUNCTION numroc C*********************************************************************** SUBROUTINE pcpotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) COMPLEX A( * ) WRITE(*,*) 'Error. PCPOTRF should not be called.' STOP RETURN END SUBROUTINE pcpotrf C*********************************************************************** SUBROUTINE pcgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) COMPLEX A( * ) WRITE(*,*) 'Error. PCGETRF should not be called.' STOP RETURN END SUBROUTINE pcgetrf C*********************************************************************** SUBROUTINE pctrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCTRTRS should not be called.' STOP RETURN END SUBROUTINE pctrtrs C*********************************************************************** SUBROUTINE pzpotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) C DOUBLE COMPLEX A( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ) WRITE(*,*) 'Error. PZPOTRF should not be called.' STOP RETURN END SUBROUTINE pzpotrf C*********************************************************************** SUBROUTINE pzgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) C DOUBLE COMPLEX A( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ) WRITE(*,*) 'Error. PZGETRF should not be called.' STOP RETURN END SUBROUTINE pzgetrf C*********************************************************************** SUBROUTINE pztrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) C DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZTRTRS should not be called.' STOP RETURN END SUBROUTINE pztrtrs C*********************************************************************** SUBROUTINE pspotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) REAL A( * ) WRITE(*,*) 'Error. PSPOTRF should not be called.' STOP RETURN END SUBROUTINE pspotrf C*********************************************************************** SUBROUTINE psgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) REAL A( * ) WRITE(*,*) 'Error. PSGETRF should not be called.' STOP RETURN END SUBROUTINE psgetrf C*********************************************************************** SUBROUTINE pstrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSTRTRS should not be called.' STOP RETURN END SUBROUTINE pstrtrs C*********************************************************************** SUBROUTINE pdpotrf( UPLO, N, A, IA, JA, DESCA, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, INFO, JA, N INTEGER DESCA( * ) DOUBLE PRECISION A( * ) WRITE(*,*) 'Error. PDPOTRF should not be called.' STOP RETURN END SUBROUTINE pdpotrf C*********************************************************************** SUBROUTINE pdgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO ) IMPLICIT NONE INTEGER IA, INFO, JA, M, N INTEGER DESCA( * ), IPIV( * ) DOUBLE PRECISION A( * ) WRITE(*,*) 'Error. PDGETRF should not be called.' STOP RETURN END SUBROUTINE pdgetrf C*********************************************************************** SUBROUTINE pdtrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, & B, IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDTRTRS should not be called.' STOP RETURN END SUBROUTINE pdtrtrs C*********************************************************************** SUBROUTINE INFOG2L( GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, & MYCOL, LRINDX, LCINDX, RSRC, CSRC ) IMPLICIT NONE INTEGER CSRC, GCINDX, GRINDX, LRINDX, LCINDX, MYCOL, & MYROW, NPCOL, NPROW, RSRC INTEGER DESC( * ) WRITE(*,*) 'Error. INFOG2L should not be called.' STOP RETURN END SUBROUTINE INFOG2L C*********************************************************************** INTEGER FUNCTION INDXG2P( INDXGLOB, NB, IPROC, ISRCPROC, NPROCS ) INTEGER INDXGLOB, IPROC, ISRCPROC, NB, NPROCS INDXG2P = 0 WRITE(*,*) 'Error. INFOG2L should not be called.' STOP RETURN END FUNCTION INDXG2P C*********************************************************************** SUBROUTINE pcscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX COMPLEX ALPHA COMPLEX X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PCSCAL should not be called.' STOP RETURN END SUBROUTINE pcscal C*********************************************************************** SUBROUTINE pzscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX C DOUBLE COMPLEX ALPHA C DOUBLE COMPLEX X( * ) COMPLEX(kind=kind(0.0D0)) :: ALPHA, X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PZSCAL should not be called.' STOP RETURN END SUBROUTINE pzscal C*********************************************************************** SUBROUTINE pdscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX DOUBLE PRECISION ALPHA DOUBLE PRECISION X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PDSCAL should not be called.' STOP RETURN END SUBROUTINE pdscal C*********************************************************************** SUBROUTINE psscal(N, ALPHA, X, IX, JX, DESCX, INCX) IMPLICIT NONE INTEGER INCX, N, IX, JX REAL ALPHA REAL X( * ) INTEGER DESCX( * ) WRITE(*,*) 'Error. PSSCAL should not be called.' STOP RETURN END SUBROUTINE psscal C*********************************************************************** SUBROUTINE pzdot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) C DOUBLE COMPLEX X(*), Y(*) COMPLEX(kind=kind(0.0D0)) :: X(*), Y(*) DOUBLE PRECISION DOT DOT = 0.0d0 WRITE(*,*) 'Error. PZDOT should not be called.' STOP RETURN END SUBROUTINE pzdot C*********************************************************************** SUBROUTINE pcdot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) COMPLEX X(*), Y(*) REAL DOT DOT = 0.0e0 WRITE(*,*) 'Error. PCDOT should not be called.' STOP RETURN END SUBROUTINE pcdot C*********************************************************************** SUBROUTINE pddot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) DOUBLE PRECISION X(*), Y(*), DOT DOT = 0.0d0 WRITE(*,*) 'Error. PDDOT should not be called.' STOP RETURN END SUBROUTINE pddot C*********************************************************************** SUBROUTINE psdot & ( N, DOT, X, IX, JX, DESCX, INCX, Y, IY, JY, DESCY, INCY ) IMPLICIT NONE INTEGER N, IX, JX, IY, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) REAL X(*), Y(*), DOT DOT = 0.0e0 WRITE(*,*) 'Error. PSDOT should not be called.' STOP RETURN END SUBROUTINE psdot C*********************************************************************** SUBROUTINE zgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA C DOUBLE COMPLEX A(*) COMPLEX(kind=kind(0.0D0)) :: A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. ZGEBS2D should not be called.' STOP RETURN END SUBROUTINE zgebs2d C*********************************************************************** SUBROUTINE cgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA COMPLEX A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. CGEBS2D should not be called.' STOP RETURN END SUBROUTINE cgebs2d C*********************************************************************** SUBROUTINE sgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA REAL A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. SGEBS2D should not be called.' STOP RETURN END SUBROUTINE sgebs2d C*********************************************************************** SUBROUTINE dgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA DOUBLE PRECISION A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. DGEBS2D should not be called.' STOP RETURN END SUBROUTINE dgebs2d C*********************************************************************** SUBROUTINE zgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA C DOUBLE COMPLEX A(*) COMPLEX(kind=kind(0.0D0)) :: A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. ZGEBR2D should not be called.' STOP RETURN END SUBROUTINE zgebr2d C*********************************************************************** SUBROUTINE cgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA COMPLEX A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. CGEBR2D should not be called.' STOP RETURN END SUBROUTINE cgebr2d C*********************************************************************** SUBROUTINE sgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA REAL A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. SGEBR2D should not be called.' STOP RETURN END SUBROUTINE sgebr2d C*********************************************************************** SUBROUTINE dgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA ) IMPLICIT NONE INTEGER CONTXT, M, N, LDA DOUBLE PRECISION A(*) CHARACTER SCOPE, TOP WRITE(*,*) 'Error. DGEBR2D should not be called.' STOP RETURN END SUBROUTINE dgebr2d C*********************************************************************** SUBROUTINE pcgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCGETRS should not be called.' STOP RETURN END SUBROUTINE pcgetrs C*********************************************************************** SUBROUTINE pzgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) c DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZGETRS should not be called.' STOP RETURN END SUBROUTINE pzgetrs C*********************************************************************** SUBROUTINE psgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSGETRS should not be called.' STOP RETURN END SUBROUTINE psgetrs C*********************************************************************** SUBROUTINE pdgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B, & IB, JB, DESCB, INFO ) IMPLICIT NONE CHARACTER TRANS INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ), IPIV( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDGETRS should not be called.' STOP RETURN END SUBROUTINE pdgetrs C*********************************************************************** SUBROUTINE pcpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCPOTRS should not be called.' STOP RETURN END SUBROUTINE pcpotrs C*********************************************************************** SUBROUTINE pzpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) c DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZPOTRS should not be called.' STOP RETURN END SUBROUTINE pzpotrs C*********************************************************************** SUBROUTINE pspotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSPOTRS should not be called.' STOP RETURN END SUBROUTINE pspotrs C*********************************************************************** SUBROUTINE pdpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, & DESCB, INFO ) IMPLICIT NONE CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS INTEGER DESCA( * ), DESCB( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDPOTRS should not be called.' STOP RETURN END SUBROUTINE pdpotrs C*********************************************************************** SUBROUTINE pscnrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) REAL NORM2 COMPLEX X( * ) WRITE(*,*) 'Error. PCNRM2 should not be called.' STOP RETURN END SUBROUTINE pscnrm2 C*********************************************************************** SUBROUTINE pdznrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) DOUBLE PRECISION NORM2 C DOUBLE COMPLEX X( * ) COMPLEX(kind=kind(0.0D0)) :: X( * ) WRITE(*,*) 'Error. PZNRM2 should not be called.' STOP RETURN END SUBROUTINE pdznrm2 C*********************************************************************** SUBROUTINE psnrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) REAL NORM2, X( * ) WRITE(*,*) 'Error. PSNRM2 should not be called.' STOP RETURN END SUBROUTINE psnrm2 C*********************************************************************** SUBROUTINE pdnrm2( N, NORM2, X, IX, JX, DESCX, INCX ) IMPLICIT NONE INTEGER N, IX, JX, INCX INTEGER DESCX(*) DOUBLE PRECISION NORM2, X( * ) WRITE(*,*) 'Error. PDNRM2 should not be called.' STOP RETURN END SUBROUTINE pdnrm2 C*********************************************************************** REAL FUNCTION pclange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) COMPLEX A( * ), WORK( * ) PCLANGE = 0.0e0 WRITE(*,*) 'Error. PCLANGE should not be called.' STOP RETURN END FUNCTION pclange C*********************************************************************** DOUBLE PRECISION FUNCTION pzlange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) REAL A( * ), WORK( * ) PZLANGE = 0.0d0 WRITE(*,*) 'Error. PZLANGE should not be called.' STOP RETURN END FUNCTION pzlange C*********************************************************************** REAL FUNCTION pslange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) REAL A( * ), WORK( * ) PSLANGE = 0.0e0 WRITE(*,*) 'Error. PSLANGE should not be called.' STOP RETURN END FUNCTION pslange C*********************************************************************** DOUBLE PRECISION FUNCTION pdlange( NORM, M, N, A, IA, JA, & DESCA, WORK ) CHARACTER NORM INTEGER IA, JA, M, N INTEGER DESCA( * ) DOUBLE PRECISION A( * ), WORK( * ) PDLANGE = 0.0d0 WRITE(*,*) 'Error. PDLANGE should not be called.' STOP RETURN END FUNCTION pdlange C*********************************************************************** SUBROUTINE pcgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N REAL ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) COMPLEX A( * ), WORK( * ) WRITE(*,*) 'Error. PCGECON should not be called.' STOP RETURN END SUBROUTINE pcgecon C*********************************************************************** SUBROUTINE pzgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N DOUBLE PRECISION ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) C DOUBLE COMPLEX A( * ), WORK( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), WORK( * ) WRITE(*,*) 'Error. PZGECON should not be called.' STOP RETURN END SUBROUTINE pzgecon C*********************************************************************** SUBROUTINE psgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N REAL ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) REAL A( * ), WORK( * ) WRITE(*,*) 'Error. PSGECON should not be called.' STOP RETURN END SUBROUTINE psgecon C*********************************************************************** SUBROUTINE pdgecon( NORM, N, A, IA, JA, DESCA, ANORM, & RCOND, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE CHARACTER NORM INTEGER IA, INFO, JA, LIWORK, LWORK, N DOUBLE PRECISION ANORM, RCOND INTEGER DESCA( * ), IWORK( * ) DOUBLE PRECISION A( * ), WORK( * ) WRITE(*,*) 'Error. PDGECON should not be called.' STOP RETURN END SUBROUTINE pdgecon C*********************************************************************** SUBROUTINE pcgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) COMPLEX A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PCGEQPF should not be called.' STOP RETURN END SUBROUTINE pcgeqpf C*********************************************************************** SUBROUTINE pzgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) C DOUBLE COMPLEX A( * ), TAU( * ), WORK( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PZGEQPF should not be called.' STOP RETURN END SUBROUTINE pzgeqpf C*********************************************************************** SUBROUTINE psgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) REAL A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PSGEQPF should not be called.' STOP RETURN END SUBROUTINE psgeqpf C*********************************************************************** SUBROUTINE pdgeqpf( M, N, A, IA, JA, DESCA, IPIV, TAU, & WORK, LWORK, INFO ) IMPLICIT NONE INTEGER IA, JA, INFO, LWORK, M, N INTEGER DESCA( * ), IPIV( * ) DOUBLE PRECISION A( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PDGEQPF should not be called.' STOP RETURN END SUBROUTINE pdgeqpf C*********************************************************************** SUBROUTINE pcaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) COMPLEX A(*),X(*),Y(*) WRITE(*,*) 'Error. PCAXPY should not be called.' STOP RETURN END SUBROUTINE pcaxpy C*********************************************************************** SUBROUTINE pzaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) C DOUBLE COMPLEX A(*),X(*),Y(*) COMPLEX(kind=kind(0.0D0)) :: A(*),X(*),Y(*) WRITE(*,*) 'Error. PZAXPY should not be called.' STOP RETURN END SUBROUTINE pzaxpy C*********************************************************************** SUBROUTINE psaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) REAL A(*),X(*),Y(*) WRITE(*,*) 'Error. PSAXPY should not be called.' STOP RETURN END SUBROUTINE psaxpy C*********************************************************************** SUBROUTINE pdaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY, & DESCY, INCY) IMPLICIT NONE INTEGER N, IX, IY, JX, JY, INCX, INCY INTEGER DESCX(*), DESCY(*) DOUBLE PRECISION A(*),X(*),Y(*) WRITE(*,*) 'Error. PDAXPY should not be called.' STOP RETURN END SUBROUTINE pdaxpy C*********************************************************************** SUBROUTINE pctrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB COMPLEX ALPHA INTEGER DESCA( * ), DESCB( * ) COMPLEX A( * ), B( * ) WRITE(*,*) 'Error. PCTRSM should not be called.' STOP RETURN END SUBROUTINE pctrsm C*********************************************************************** SUBROUTINE pztrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB C DOUBLE COMPLEX ALPHA COMPLEX(kind=kind(0.0D0)) :: ALPHA INTEGER DESCA( * ), DESCB( * ) C DOUBLE COMPLEX A( * ), B( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), B( * ) WRITE(*,*) 'Error. PZTRSM should not be called.' STOP RETURN END SUBROUTINE pztrsm C*********************************************************************** SUBROUTINE pstrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB REAL ALPHA INTEGER DESCA( * ), DESCB( * ) REAL A( * ), B( * ) WRITE(*,*) 'Error. PSTRSM should not be called.' STOP RETURN END SUBROUTINE pstrsm C*********************************************************************** SUBROUTINE pdtrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA, $ JA, DESCA, B, IB, JB, DESCB ) IMPLICIT NONE CHARACTER SIDE, UPLO, TRANSA, DIAG INTEGER M, N, IA, JA, IB, JB DOUBLE PRECISION ALPHA INTEGER DESCA( * ), DESCB( * ) DOUBLE PRECISION A( * ), B( * ) WRITE(*,*) 'Error. PDTRSM should not be called.' STOP RETURN END SUBROUTINE pdtrsm C*********************************************************************** SUBROUTINE pcunmqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) COMPLEX A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PCUNMQR should not be called.' STOP RETURN END SUBROUTINE pcunmqr C*********************************************************************** SUBROUTINE pzunmqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) C DOUBLE COMPLEX A( * ), C( * ), TAU( * ), WORK( * ) COMPLEX(kind=kind(0.0D0)) :: A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PZUNMQR should not be called.' STOP RETURN END SUBROUTINE pzunmqr C*********************************************************************** SUBROUTINE psormqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) REAL A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PSORMQR should not be called.' STOP RETURN END SUBROUTINE psormqr C*********************************************************************** SUBROUTINE pdormqr( SIDE, TRANS, M, N, K, A, IA, JA, & DESCA, TAU, C, IC, JC, DESCC, WORK, & LWORK, INFO ) IMPLICIT NONE CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N INTEGER DESCA( * ), DESCC( * ) DOUBLE PRECISION A( * ), C( * ), TAU( * ), WORK( * ) WRITE(*,*) 'Error. PDORMQR should not be called.' STOP RETURN END SUBROUTINE pdormqr C*********************************************************************** SUBROUTINE chk1mat( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA, & DESCAPOS0, INFO ) IMPLICIT NONE INTEGER DESCAPOS0, IA, INFO, JA, MA, MAPOS0, NA, NAPOS0 INTEGER DESCA( * ) WRITE(*,*) 'Error. CHK1MAT should not be called.' STOP RETURN END SUBROUTINE chk1mat C*********************************************************************** SUBROUTINE pchk2mat( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA, & DESCAPOS0, MB, MBPOS0, NB, NBPOS0, IB, JB, & DESCB, DESCBPOS0, NEXTRA, EX, EXPOS, INFO ) IMPLICIT NONE INTEGER DESCAPOS0, DESCBPOS0, IA, IB, INFO, JA, JB, MA, & MAPOS0, MB, MBPOS0, NA, NAPOS0, NB, NBPOS0, & NEXTRA INTEGER DESCA( * ), DESCB( * ), EX( NEXTRA ), & EXPOS( NEXTRA ) WRITE(*,*) 'Error. PCHK2MAT should not be called.' STOP RETURN END SUBROUTINE pchk2mat C*********************************************************************** SUBROUTINE pxerbla( CONTXT, SRNAME, INFO ) IMPLICIT NONE INTEGER CONTXT, INFO CHARACTER SRNAME WRITE(*,*) 'Error. PXERBLA should not be called.' STOP RETURN END SUBROUTINE pxerbla C*********************************************************************** SUBROUTINE descset( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, & LLD ) IMPLICIT NONE INTEGER ICSRC, ICTXT, IRSRC, LLD, M, MB, N, NB INTEGER DESC( * ) WRITE(*,*) 'Error. DESCSET should not be called.' STOP RETURN END SUBROUTINE descset MUMPS_5.4.1/libseq/mpic.c0000664000175000017500000000232514102210473015275 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #include "mpi.h" LIBSEQ_INT LIBSEQ_CALL MPI_Init(LIBSEQ_INT *pargc, char ***pargv) { return 0; } LIBSEQ_INT LIBSEQ_CALL MPI_Comm_rank( MPI_Comm comm, LIBSEQ_INT *rank) { *rank=0; return 0; } LIBSEQ_INT LIBSEQ_CALL MPI_Finalize(void) { return 0; } /* Internal: for MPI_IS_IN_PLACE tests from Fortran */ void LIBSEQ_CALL MUMPS_CHECKADDREQUAL(char *a, char*b, LIBSEQ_INT *i) { if (a - b == 0) { *i=1; } else { *i=0; } } void LIBSEQ_CALL MUMPS_CHECKADDREQUAL_(char *a, char*b, LIBSEQ_INT *i) { MUMPS_CHECKADDREQUAL(a,b,i); } void LIBSEQ_CALL mumps_checkaddrequal_(char *a, char*b, LIBSEQ_INT *i) { MUMPS_CHECKADDREQUAL(a,b,i); } void LIBSEQ_CALL mumps_checkaddrequal__(char *a, char*b, LIBSEQ_INT *i) { MUMPS_CHECKADDREQUAL(a,b,i); } MUMPS_5.4.1/libseq/mpif.h0000664000175000017500000000536414102210473015313 0ustar jylexceljylexcel! ! This file is part of MUMPS 5.4.1, released ! on Tue Aug 3 09:49:43 UTC 2021 ! ! ! Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, ! Mumps Technologies, University of Bordeaux. ! ! This version of MUMPS is provided to you free of charge. It is ! released under the CeCILL-C license ! (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and ! https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) ! ! ! Stub mpif.h file including symbols used by MUMPS. ! INTEGER MPI_2DOUBLE_PRECISION INTEGER MPI_2INTEGER INTEGER MPI_2REAL INTEGER MPI_ANY_SOURCE INTEGER MPI_ANY_TAG INTEGER MPI_BYTE INTEGER MPI_CHARACTER INTEGER MPI_COMM_NULL INTEGER MPI_COMM_WORLD INTEGER MPI_COMPLEX INTEGER MPI_DOUBLE_COMPLEX INTEGER MPI_DOUBLE_PRECISION INTEGER MPI_INTEGER INTEGER MPI_LOGICAL INTEGER MPI_MAX INTEGER MPI_MAX_PROCESSOR_NAME INTEGER MPI_MAXLOC INTEGER MPI_MIN INTEGER MPI_MINLOC INTEGER MPI_PACKED INTEGER MPI_PROD INTEGER MPI_REAL INTEGER MPI_REPLACE INTEGER MPI_REQUEST_NULL INTEGER MPI_SOURCE INTEGER MPI_STATUS_SIZE INTEGER MPI_SUM INTEGER MPI_TAG INTEGER MPI_UNDEFINED INTEGER MPI_WTIME_IS_GLOBAL INTEGER MPI_LOR INTEGER MPI_LAND INTEGER MPI_INTEGER8 INTEGER MPI_REAL8 INTEGER MPI_COMM_SELF INTEGER MPI_BSEND_OVERHEAD PARAMETER (MPI_2DOUBLE_PRECISION=1) PARAMETER (MPI_2INTEGER=2) PARAMETER (MPI_2REAL=3) PARAMETER (MPI_ANY_SOURCE=4) PARAMETER (MPI_ANY_TAG=5) PARAMETER (MPI_BYTE=6) PARAMETER (MPI_CHARACTER=7) PARAMETER (MPI_COMM_NULL=8) PARAMETER (MPI_COMM_WORLD=9) PARAMETER (MPI_COMPLEX=10) PARAMETER (MPI_DOUBLE_COMPLEX=11) PARAMETER (MPI_DOUBLE_PRECISION=12) PARAMETER (MPI_INTEGER=13) PARAMETER (MPI_LOGICAL=14) PARAMETER (MPI_MAX=15) PARAMETER (MPI_MAX_PROCESSOR_NAME=31) PARAMETER (MPI_MAXLOC=16) PARAMETER (MPI_MIN=17) PARAMETER (MPI_MINLOC=18) PARAMETER (MPI_PACKED=19) PARAMETER (MPI_PROD=20) PARAMETER (MPI_REAL=21) PARAMETER (MPI_REPLACE=22) PARAMETER (MPI_REQUEST_NULL=23) PARAMETER (MPI_SOURCE=1) PARAMETER (MPI_STATUS_SIZE=2) PARAMETER (MPI_SUM=26) PARAMETER (MPI_TAG=2) PARAMETER (MPI_UNDEFINED=28) PARAMETER (MPI_WTIME_IS_GLOBAL=30) PARAMETER (MPI_LOR=31) PARAMETER (MPI_LAND=32) PARAMETER (MPI_INTEGER8=33) PARAMETER (MPI_REAL8=34) PARAMETER (MPI_COMM_SELF=35) INTEGER MPI_IN_PLACE COMMON/mpif_libseq/MPI_IN_PLACE PARAMETER (MPI_BSEND_OVERHEAD=0) DOUBLE PRECISION MPI_WTIME EXTERNAL MPI_WTIME MUMPS_5.4.1/libseq/mpi.h0000664000175000017500000000360214102210473015136 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * * * Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, * Mumps Technologies, University of Bordeaux. * * This version of MUMPS is provided to you free of charge. It is * released under the CeCILL-C license * (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and * https://cecill.info/licences/Licence_CeCILL-C_V1-en.html) * */ #ifdef INTSIZE64 #include #define LIBSEQ_INT int64_t #else #define LIBSEQ_INT int #endif #if ! defined(LIBSEQ_CALL) #if defined(_WIN32) && ! defined(__MINGW32__) /* Choose between next lines or modify according * to your Windows calling conventions: #define LIBSEQ_CALL #define LIBSEQ_CALL __declspec(dllexport) #define LIBSEQ_CALL __declspec(dllexport) */ #define LIBSEQ_CALL #else #define LIBSEQ_CALL #endif #endif #ifndef MUMPS_MPI_H #define MUMPS_MPI_H /* We define all symbols as extern "C" for users who call MUMPS with its libseq from a C++ driver. */ #ifdef __cplusplus extern "C" { #endif /* This is the minimum to have the C interface to MUMPS work with the * C example provided. Other stub functions of the MPI standard may be * added if needed. */ typedef LIBSEQ_INT MPI_Comm; /* Simple type for MPI communicator */ static MPI_Comm MPI_COMM_WORLD=(MPI_Comm)0; LIBSEQ_INT LIBSEQ_CALL MPI_Init(LIBSEQ_INT *pargc, char ***pargv); LIBSEQ_INT LIBSEQ_CALL MPI_Comm_rank(LIBSEQ_INT comm, LIBSEQ_INT *rank); LIBSEQ_INT LIBSEQ_CALL MPI_Finalize(void); /* For MPI_IS_IN_PLACE tests */ void LIBSEQ_CALL MUMPS_CHECKADDREQUAL(char *a, char*b, LIBSEQ_INT *i); void LIBSEQ_CALL MUMPS_CHECKADDREQUAL_(char *a, char*b, LIBSEQ_INT *i); void LIBSEQ_CALL mumps_checkaddrequal_(char *a, char*b, LIBSEQ_INT *i); void LIBSEQ_CALL mumps_checkaddrequal__(char *a, char*b, LIBSEQ_INT *i); #ifdef __cplusplus } #endif #endif /* MUMPS_MPI_H */ MUMPS_5.4.1/MATLAB/0000775000175000017500000000000014102210473013660 5ustar jylexceljylexcelMUMPS_5.4.1/MATLAB/Makefile0000664000175000017500000000135614102210473015325 0ustar jylexceljylexcel# Please only change make.inc, not this Makefile include make.inc # MUMPS include files INCMUMPS = -I$(MUMPS_DIR)/include # MUMPS libraries LIBMUMPS = -L$(MUMPS_DIR)/lib -l$(ARITH)mumps -lmumps_common # Stub MPI/BLACS/ScaLAPACK INCSEQ = -I$(MUMPS_DIR)/libseq LIBSEQ = -L$(MUMPS_DIR)/libseq -lmpiseq # MUMPS includes INC = $(INCMUMPS) $(IORDERINGS) $(INCSEQ) LIB = $(LIBMUMPS) $(LORDERINGS) $(LIBSEQ) $(LIBBLAS) $(LIBFORT) all: d z d: $(MAKE) ARITH=d dmumpsmex.stamp z: $(MAKE) ARITH=z zmumpsmex.stamp clean: rm -f dmumpsmex.* zmumpsmex* $(ARITH)mumpsmex.stamp: mumpsmex.c cp -f mumpsmex.c $(ARITH)mumpsmex.c $(MEX) $(OPTC) $(ARITH)mumpsmex.c -DMUMPS_ARITH=MUMPS_ARITH_$(ARITH) $(INC) $(LIB) rm -f $(ARITH)mumpsmex.c touch $@ MUMPS_5.4.1/MATLAB/sparserhs_example.m0000664000175000017500000000112314102210473017560 0ustar jylexceljylexcel%Example of using MUMPS in matlab with sparse right hansd side % initialization of a matlab MUMPS structure id = initmumps; id = dmumps(id); load lhr01; mat = Problem.A; % JOB = 6 means analysis+facto+solve id.JOB = 6; % we set the rigth hand side id.RHS = ones(size(mat,1),2); id.RHS(:,2) = 2*id.RHS(:,2); id.RHS = sparse(id.RHS); %call to mumps id = dmumps(id,mat); if(norm(mat*id.SOL - id.RHS,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - id.RHS,'inf') % solution OK % destroy mumps instance id.JOB = -2; id = dmumps(id) MUMPS_5.4.1/MATLAB/mumps_help.m0000664000175000017500000001142514102210473016212 0ustar jylexceljylexcel%**************************************** %This help menu gives details about the use of dmumps, zmumps and initmumps %**************************************** % %--------------- Input Parameters --------------- % % - mat: sparse matrix which has to be provided as the second argument of dmumps if id.JOB is strictly larger than 0. % % - id.SYM: controls the matrix type (symmetric positive definite, symmetric indefinite or unsymmetric) and it has do be initialized by the user before the initialization phase of MUMPS (see id.JOB). Its value is set to 0 after the call of initmumps. % % - id.JOB: defines the action that will be realized by MUMPS: initialize, analyze and/or factorize and/or solve and release MUMPS internal C/Fortran data. It has to be set by the user before any call to MUMPS (except after a call to initmumps, which sets its value to -1). % % - id.ICNTL and id.CNTL: define control parameters that can be set after the initialization call (id.JOB = -1). See Section ``Control parameters'' of the MUMPS user's guide for more details. If the user does not modify an entry in id.ICNTL then MUMPS uses the default parameter. For example, if the user wants to use the AMD ordering, he/she should set id.ICNTL(7) = 0. Note that the following parameters are inhibited because they are automatically set within the interface: id.ICNTL(19) which controls the Schur complement option and id.ICNTL(20) which controls the format of the right-hand side. Note that parameters id.ICNTL(1:4) may not work properly depending on your compiler and your environment. In case of problem, we recommand to swith printing off by setting id.ICNL(1:4)=-1. % % - id.PERM\_IN: corresponds to the given ordering option (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). Note that this permutation is only accessed if the parameter id.ICNTL(7) is set to 1. % % - id.COLSCA and id.ROWSCA: are optional scaling arrays (see Section ``Input and output parameters'' of the MUMPS user's guide for more details) % % - id.RHS: defines the right-hand side. The parameter id.ICNTL(20) related to its format (sparse or dense) is automatically set within the interface. Note that id.RHS is not modified (as in MUMPS), the solution is returned in id.SOL. % % - id.VAR\_SCHUR: corresponds to the list of variables that appear in the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). % % - id.REDRHS(input parameter only if id.VAR\_SCHUR was provided during the factorization and if ICNTL(26)=2 on entry to the solve phase): partial solution on the variables corresponding to the Schur complement. It is provided by the user and normally results from both the Schur complement and the reduced right-hand side that were returned by MUMPS in a previous call. When ICNTL(26)=2, MUMPS uses this information to build the solution id.SOL on the complete problem. See Section ``Schur complement'' of the MUMPS user's guide for more details. % %--------------- Output Parameters --------------- % % - id.SCHUR: if id.VAR\_SCHUR is provided of size SIZE\_SCHUR, then id.SCHUR corresponds to a dense array of size (SIZE\_SCHUR,SIZE\_SCHUR) that holds the Schur complement matrix (see Section ``Input and output parameters'' of the MUMPS user's guide for more details). The user does not have to initialize it. % % - id.REDRHS(output parameter only if ICNTL(26)=1 and id.VAR\_SCHUR was defined): Reduced right-hand side (or condensed right-hand side on the variables associated to the Schur complement). It is computed by MUMPS during the solve stage if ICNTL(26)=1. It can then be used outside MUMPS, together with the Schur complement, to build a solution on the interface. See Section ``Schur complement'' of the MUMPS user's guide for more details. % % - id.INFOG and id.RINFOG: information parameters (see Section ``Information parameters'' of the MUMPS user's guide ). % % - id.SYM\_PERM: corresponds to a symmetric permutation of the variables (see discussion regarding ICNTL(7) in Section ``Control parameters'' of the MUMPS user's guide ). This permutation is computed during the analysis and is followed by the numerical factorization except when numerical pivoting occurs. % % - id.UNS\_PERM: column permutation (if any) on exit from the analysis phase of MUMPS (see discussion regarding ICNTL(6) in Section ``Control parameters'' of the MUMPS user's guide ). % % - id.SOL: dense vector or matrix containing the solution after MUMPS solution phase. Also contains the nullspace in case of null space computation, or entries of the inverse, in case of computation of inverse entries. % %--------------- Internal Parameters --------------- % % - id.INST: (MUMPS reserved component) MUMPS internal parameter. % % - id.TYPE: (MUMPS reserved component) defines the arithmetic (complex or double precision). % MUMPS_5.4.1/MATLAB/README0000664000175000017500000001107514102210473014544 0ustar jylexceljylexcelREADME ************************************************************************ * This MATLAB interface to MUMPS is part of the MUMPS package * * (see ../LICENSE for the conditions of use) * * Up-to-date copies of MUMPS can be obtained from the web * * page http://mumps-solver.org * * * * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY * * EXPRESSED OR IMPLIED. ANY USE IS AT YOUR OWN RISK. * * * * More information is available in the main MUMPS userguide and in: * * * * [2006] Aurelia Fevre, Jean-Yves L'Excellent and Stephane Pralet * * MATLAB and Scilab interfaces to MUMPS. LIP Report RR2006-06. * * Also available as INRIA and ENSEEIHT-IRIT Technical Reports. * * * ************************************************************************ ************************************************************************ COMPATIBILITY WITH OCTAVE: Thanks to the Octave MEX compatibility, it is pretty straightforward to generate an Octave interface for MUMPS. Please refer to the comments inside the make.inc file for instructions on how to do it. Everything said below applies for both cases where a MATLAB or an Octave interface is needed. Thanks to Carlo De Falco from "Politecnico di Milano" for support provided on the usage of Octave. ************************************************************************ CONTENT OF DIRECTORY: README Makefile make.inc initmumps.m mumps.m other *.m files: examples of usage mumpsmex.c : MATLAB CMEX-file to let you use sequential MUMPS in double precision from MATLAB. USAGE: see example below and MUMPS documentation INSTALLATION: You need 1- to have compiled/linked a sequential version of MUMPS with both double precision and double complex arithmetics ("make d" and "make z", or "make all"). The code must be position-independent (with gfortran, please add the option -fPIC in both FC, CC, and FL of the main Makefile.inc). Note that this also applies to other external libraries, such as METIS, SCOTCH, BLAS, etc. 2- to specify an adequate BLAS library. Unless you compile with the option -DINTSIZE64, MUMPS expects 32-bit integers by default (see the MUMPS_INT datatype in mumps_c_types.h). In that case, you should specify a BLAS library relying on 32-bit integers. Otherwise, an error at execution time is likely to occur (e.g., "segmentation fault in idamax"). If you use a shared library, make sure that Matlab will not override your default BLAS library (One way to do that is to issue LD_PRELOAD=my_blas_library.so matlab instead matlab) 2- to edit make.inc. Modify paths for orderings and BLAS. You should also give the path to the runtime libraries of your FORTRAN 90 compiler. Some commented examples are provided. You can use something like nm -o /opt/intel/compiler80/lib/*.a | grep to help finding which libraries should be added 3- to run the "make" command 4- We advise you to run the 4 examples simple_example.m, multiplerhs_example.m, sparserhs_example.m and schur_example.m and to check that everything runs smoothly. ****************************************************************************** LIMITATION: This interface enables you to call MUMPS from MATLAB only in sequential for double precision and double complex versions. For example it does not support: - other versions (single precision arithmetic, parallel version...) - elemental format for the input matrix ****************************************************************************** %Example of using MUMPS in matlab % initialization of a matlab MUMPS structure id = initmumps; % here JOB = -1, the call to MUMPS will initialize C and fortran MUMPS structure id = dmumps(id); % load a sparse matrix load lhr01; mat = Problem.A; % JOB = 6 means analysis+factorization+solve id.JOB = 6; id.ICNTL(6) = 0; % we set the rigth hand side id.RHS = ones(size(mat,1),1); %call to mumps id = dmumps(id,mat); % we see that there is a memory problem in INFO(1) and INFO(2) id.INFOG(1) id.INFOG(2) % we activate the numerical maximum transversal id.ICNTL(6) = 6; id = dmumps(id,mat); norm(mat*id.SOL - ones(size(mat,1),1),'inf') % solution OK % destroy mumps instance id.JOB = -2; id = dmumps(id) MUMPS_5.4.1/MATLAB/make.inc0000664000175000017500000000367114102210473015277 0ustar jylexceljylexcel# It is possible to generate a MATLAB or an Octave interface thanks to # the Octave MEX file compatibility. Comment/uncomment the lines below # depending on whether you want to generate the MATLAB or the Octave # interface # To generate the MATLAB interface uncomment the following line # ( the use of -largeArrayDims is necessary to work with sparse # matrices since R2006b) MEX = /opt/matlab/matlab/bin/mex -g -largeArrayDims # To generate the Octave interface uncomment the following line # MEX = mkoctfile -g --mex # Main MUMPS_DIR MUMPS_DIR = $(HOME)/MUMPS_5.4.1 # Orderings (see main Makefile.inc file from MUMPS) LMETISDIR = ${HOME}/parmetis-4.0.3/build/Linux-x86_64/libmetis LMETIS = -L$(LMETISDIR) -lmetis LPORDDIR = $(MUMPS_DIR)/PORD/lib LPORD = -L$(LPORDDIR) -lpord LORDERINGS = $(LPORD) $(LMETIS) # Fortran runtime library # Please find out the path and name of your # Fortran runtime, examples below: # g95: # LIBFORT = /usr/lib/libf95.a /usr/lib/libgcc.a # Intel: # LIBFORT = /opt/intel80/lib/libifcore.a /opt/intel80/lib/libifport.a /opt/intel80/lib/libirc.a # PGI: # LIBFORT = -L/usr/local/pgi/linux86/5.2/lib -llapack -lblas -lpgf90 -lpgc -lpgf90rtl -lpgftnrtl -lpgf902 -lpgf90_rpm1 -lpghpf2 # SGI 32-bit # LIBFORT = -L/usr/lib32 -lblas -L/usr/lib32/mips4 -lfortran # Sun # LIBFORT = -L/opt2/SUNWspro7/lib -lsunperf -lfminvai -lfai2 -lfsu -lfmaxvai -lfmaxlai -lfai -lfsumai -lLIBFORT = /usr/local/lib/libgfortran.a # gfortran LIBFORT = /usr/lib/gcc/x86_64-linux-gnu/4.7/libgfortran.so # BLAS library: # LIBBLAS = -L/usr/lib/atlas -lblas # LIBBLAS = -lsunperf -lf77compat # LIBBLAS = -lblas LIBBLAS = /home/jylexcel/libs_courge/libgoto_opteronp-r1.26.a # LIBBLAS = /home/jylexcel/libs_courge/libblas.a # -fPIC missing # LIBBLAS = /usr/lib/libblas.so # extra options passed via mex command # Add -DINTSIZE64 if MUMPS was compiled with 64-bit integers (BLAS # library should then have 64-bit integers as well) OPTC = -g MUMPS_5.4.1/MATLAB/mumpsmex.c0000664000175000017500000006471514102210473015714 0ustar jylexceljylexcel#include "mex.h" #define MUMPS_ARITH_d 2 #define MUMPS_ARITH_z 8 #if MUMPS_ARITH == MUMPS_ARITH_z # include "zmumps_c.h" # define dmumps_c zmumps_c # define dmumps_par zmumps_par # define DMUMPS_STRUC_C ZMUMPS_STRUC_C # define DMUMPS_alloc ZMUMPS_alloc # define DMUMPS_free ZMUMPS_free # define double2 mumps_double_complex # define mxREAL2 mxCOMPLEX #elif MUMPS_ARITH == MUMPS_ARITH_d # include "dmumps_c.h" # define double2 double # define mxREAL2 mxREAL # define EXTRACT_CMPLX_FROM_C_TO_MATLAB EXTRACT_FROM_C_TO_MATLAB # define EXTRACT_CMPLX_FROM_MATLAB_TOPTR EXTRACT_FROM_MATLAB_TOPTR #else # error "Only d and z arithmetics are supported" #endif #define SYM (prhs[0]) #define JOB (prhs[1]) #define ICNTL_IN (prhs[2]) #define CNTL_IN (prhs[3]) #define PERM_IN (prhs[4]) #define COLSCA_IN (prhs[5]) #define ROWSCA_IN (prhs[6]) #define RHS_IN (prhs[7]) #define VAR_SCHUR (prhs[8]) #define INST (prhs[9]) #define REDRHS_IN (prhs[10]) #define KEEP_IN (prhs[11]) #define DKEEP_IN (prhs[12]) #define A_IN (prhs[13]) #define INFO_OUT (plhs[0]) #define RINFO_OUT (plhs[1]) #define RHS_OUT (plhs[2]) #define INST_OUT (plhs[3]) #define SCHUR_OUT (plhs[4]) #define REDRHS_OUT (plhs[5]) #define PIVNUL_LIST (plhs[6]) #define PERM_OUT (plhs[7]) #define UNS_PERM (plhs[8]) #define ICNTL_OUT (plhs[9]) #define CNTL_OUT (plhs[10]) #define COLSCA_OUT (plhs[11]) #define ROWSCA_OUT (plhs[12]) #define KEEP_OUT (plhs[13]) #define DKEEP_OUT (plhs[14]) #define MYMALLOC(ptr,l,type) \ if(!(ptr = (type *) malloc(l*sizeof(type)))){ \ mexErrMsgTxt ("Malloc failed in mumpsmex.c"); \ } #define MYFREE(ptr) \ if(ptr){ \ free(ptr); \ ptr = 0; \ } #define EXTRACT_FROM_MATLAB_TOPTR(mxcomponent,mumpspointer,type,length) \ ptr_matlab = mxGetPr(mxcomponent); \ if(ptr_matlab[0] != -9999){ \ MYFREE(mumpspointer); \ MYMALLOC(mumpspointer,length,type); \ for(i=0;iirn ); MYFREE( (*dmumps_par)->jcn ); MYFREE( (*dmumps_par)->a ); MYFREE( (*dmumps_par)->irn_loc ); MYFREE( (*dmumps_par)->jcn_loc ); MYFREE( (*dmumps_par)->a_loc ); MYFREE( (*dmumps_par)->eltptr ); MYFREE( (*dmumps_par)->eltvar ); MYFREE( (*dmumps_par)->a_elt ); MYFREE( (*dmumps_par)->perm_in ); /* colsca/rowsca might have been allocated by * MUMPS but in that case the corresponding pointer * is already equal to 0 so line below will do nothing */ MYFREE( (*dmumps_par)->colsca ); MYFREE( (*dmumps_par)->rowsca ); MYFREE( (*dmumps_par)->pivnul_list ); MYFREE( (*dmumps_par)->listvar_schur ); MYFREE( (*dmumps_par)->sym_perm ); MYFREE( (*dmumps_par)->uns_perm ); MYFREE( (*dmumps_par)->irhs_ptr); MYFREE( (*dmumps_par)->irhs_sparse); MYFREE( (*dmumps_par)->rhs_sparse); MYFREE( (*dmumps_par)->rhs); MYFREE( (*dmumps_par)->redrhs); MYFREE(*dmumps_par); } } void DMUMPS_alloc(DMUMPS_STRUC_C **dmumps_par){ MYMALLOC((*dmumps_par),1,DMUMPS_STRUC_C); (*dmumps_par)->irn = NULL; (*dmumps_par)->jcn = NULL; (*dmumps_par)->a = NULL; (*dmumps_par)->irn_loc = NULL; (*dmumps_par)->jcn_loc = NULL; (*dmumps_par)->a_loc = NULL; (*dmumps_par)->eltptr = NULL; (*dmumps_par)->eltvar = NULL; (*dmumps_par)->a_elt = NULL; (*dmumps_par)->perm_in = NULL; (*dmumps_par)->colsca = NULL; (*dmumps_par)->rowsca = NULL; (*dmumps_par)->rhs = NULL; (*dmumps_par)->redrhs = NULL; (*dmumps_par)->rhs_sparse = NULL; (*dmumps_par)->irhs_sparse = NULL; (*dmumps_par)->irhs_ptr = NULL; (*dmumps_par)->pivnul_list = NULL; (*dmumps_par)->listvar_schur = NULL; (*dmumps_par)->schur = NULL; (*dmumps_par)->sym_perm = NULL; (*dmumps_par)->uns_perm = NULL; } void mexFunction(int nlhs, mxArray *plhs[ ], int nrhs, const mxArray *prhs[ ]) { int i,j,pos; int *ptr_int; double *ptr_matlab; #if MUMPS_ARITH == MUMPS_ARITH_z double *ptri_matlab; #endif mwSize tmp_m,tmp_n; /* C pointer for input parameters */ size_t inst_address; mwSize n,m,ne, netrue ; int job; mwIndex *irn_in,*jcn_in; /* variable for multiple and sparse rhs */ int posrhs; mwSize nbrhs,ldrhs, nz_rhs; mwIndex *irhs_ptr, *irhs_sparse; double *rhs_sparse; #if MUMPS_ARITH == MUMPS_ARITH_z double *im_rhs_sparse; #endif DMUMPS_STRUC_C *dmumps_par; int dosolve = 0; int donullspace = 0; int doanalysis = 0; int dofactorize = 0; EXTRACT_FROM_MATLAB_TOVAL(JOB,job); doanalysis = (job == 1 || job == 4 || job == 6); dofactorize = (job == 2 || job == 4 || job == 5 || job == 6); dosolve = (job == 3 || job == 5 || job == 6); if(job == -1){ DMUMPS_alloc(&dmumps_par); EXTRACT_FROM_MATLAB_TOVAL(SYM,dmumps_par->sym); dmumps_par->job = -1; dmumps_par->par = 1; dmumps_c(dmumps_par); dmumps_par->nz = -1; dmumps_par->nz_alloc = -1; }else{ EXTRACT_FROM_MATLAB_TOVAL(INST,inst_address); ptr_int = (int *) inst_address; dmumps_par = (DMUMPS_STRUC_C *) ptr_int; if(job == -2){ dmumps_par->job = -2; dmumps_c(dmumps_par); /* If colsca/rowsca were freed by MUMPS, dmumps_par->colsca/rowsca are now null. Application of MYFREE in call below thus ok */ DMUMPS_free(&dmumps_par); }else{ /* check of input arguments */ n = mxGetN(A_IN); m = mxGetM(A_IN); if (!mxIsSparse(A_IN) || n != m ) mexErrMsgTxt("Input matrix must be a sparse square matrix"); jcn_in = mxGetJc(A_IN); ne = jcn_in[n]; irn_in = mxGetIr(A_IN); dmumps_par->n = (int)n; if(dmumps_par->n != n) mexErrMsgTxt("Input is too big; will not work...barfing out\n"); if(dmumps_par->sym != 0) netrue = (n+ne)/2; else netrue = ne; if(dmumps_par->nz_alloc < netrue || dmumps_par->nz_alloc >= 2*netrue){ MYFREE(dmumps_par->jcn); MYFREE(dmumps_par->irn); MYFREE(dmumps_par->a); MYMALLOC((dmumps_par->jcn),(int)netrue,int); MYMALLOC((dmumps_par->irn),(int)netrue,int); MYMALLOC((dmumps_par->a),(int)netrue,double2); dmumps_par->nz_alloc = (int)netrue; if (dmumps_par->nz_alloc != netrue) mexErrMsgTxt("Input is too big; will not work...barfing out\n"); } if(dmumps_par->sym == 0){ /* if analysis already performed then we only need to read numerical values Note that we suppose that matlab did not change the internal format of the matrix between the 2 calls */ if(doanalysis){ /* || dmumps_par->info[22] == 0 */ for(i=0;in;i++){ for(j=jcn_in[i];jjcn)[j] = i+1; (dmumps_par->irn)[j] = ((int)irn_in[j])+1; } } } dmumps_par->nz = (int)ne; if( dmumps_par->nz != ne) mexErrMsgTxt("Input is too big; will not work...barfing out\n"); #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab = mxGetPr(A_IN); for(i=0;inz;i++){ ((dmumps_par->a)[i]).r = ptr_matlab[i]; } ptr_matlab = mxGetPi(A_IN); if(ptr_matlab){ for(i=0;inz;i++){ ((dmumps_par->a)[i]).i = ptr_matlab[i]; } }else{ for(i=0;inz;i++){ ((dmumps_par->a)[i]).i = 0.0; } } #else ptr_matlab = mxGetPr(A_IN); for(i=0;inz;i++){ (dmumps_par->a)[i] = ptr_matlab[i]; } #endif }else{ /* in the symmetric case we do not need to check doanalysis */ pos = 0; ptr_matlab = mxGetPr(A_IN); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi(A_IN); #endif for(i=0;in;i++){ for(j=jcn_in[i];j= i){ if(pos >= netrue) mexErrMsgTxt("Input matrix must be symmetric"); (dmumps_par->jcn)[pos] = i+1; (dmumps_par->irn)[pos] = (int)irn_in[j]+1; #if MUMPS_ARITH == MUMPS_ARITH_z ((dmumps_par->a)[pos]).r = ptr_matlab[j]; if(ptri_matlab){ ((dmumps_par->a)[pos]).i = ptri_matlab[j]; }else{ ((dmumps_par->a)[pos]).i = 0.0; } #else (dmumps_par->a)[pos] = ptr_matlab[j]; #endif pos++; } } } dmumps_par->nz = pos; } EXTRACT_FROM_MATLAB_TOVAL(JOB,dmumps_par->job); EXTRACT_FROM_MATLAB_TOARR(ICNTL_IN,dmumps_par->icntl,int,60); EXTRACT_FROM_MATLAB_TOARR(CNTL_IN,dmumps_par->cntl,double,15); EXTRACT_FROM_MATLAB_TOPTR(PERM_IN,(dmumps_par->perm_in),int,((int)n)); /* colsca and rowsca are treated differently: it may happen that dmumps_par-> colsca is nonzero because it was set to a nonzero value on output (COLSCA_OUT) from MUMPS. Unfortunately if scaling was on output, one cannot currently provide scaling on input afterwards without reinitializing the instance */ EXTRACT_SCALING_FROM_MATLAB_TOPTR(COLSCA_IN,(dmumps_par->colsca),(dmumps_par->colsca_from_mumps),((int)n)); /* type always double */ EXTRACT_SCALING_FROM_MATLAB_TOPTR(ROWSCA_IN,(dmumps_par->rowsca),(dmumps_par->rowsca_from_mumps),((int)n)); /* type always double */ EXTRACT_FROM_MATLAB_TOARR(KEEP_IN,dmumps_par->keep,int,500); EXTRACT_FROM_MATLAB_TOARR(DKEEP_IN,dmumps_par->dkeep,double,230); dmumps_par->size_schur = (int)mxGetN(VAR_SCHUR); EXTRACT_FROM_MATLAB_TOPTR(VAR_SCHUR,(dmumps_par->listvar_schur),int,dmumps_par->size_schur); if(!dmumps_par->listvar_schur) dmumps_par->size_schur = 0; ptr_matlab = mxGetPr (RHS_IN); /* * To follow the "spirit" of the Matlab/Scilab interfaces, treat case of null * space separately. In that case, we initialize lrhs and nrhs, automatically * allocate the space needed, and do not rely on what is provided by the user * in component RHS, that is not touched. * * Note that, at the moment, the user should not call the solution step combined * with the factorization step when he/she sets icntl[25-1] to a non-zero value. * Hence we suppose in the following that infog[28-1] is available and that we * can use it. * * For users of scilab/matlab, it would still be nice to be able to set ICNTL(25)=-1, * and use JOB=6. If we want to make such a feature available, we should * call separately job=2 and job=3 even if job=5 or 6 and set nbrhs (and allocate * space correctly) between job=2 and job=3 calls to MUMPS. * */ if ( dmumps_par->icntl[25-1] == -1 && dmumps_par->infog[28-1] > 0 ) { dmumps_par->nrhs=dmumps_par->infog[28-1]; donullspace = dosolve; } else if ( dmumps_par->icntl[25-1] > 0 && dmumps_par->icntl[25-1] <= dmumps_par->infog[28-1] ) { dmumps_par->nrhs=1; donullspace = dosolve; } else { donullspace=0; } if (donullspace) { nbrhs=dmumps_par->nrhs; ldrhs=n; dmumps_par->lrhs=(int)n; MYMALLOC((dmumps_par->rhs),((dmumps_par->n)*(dmumps_par->nrhs)),double2); } else if((!dosolve) || ptr_matlab[0] == -9999 ) { /* rhs not already provided, or not used */ /* Case where dosolve is true and ptr_matlab[0]=-9999, this could cause problems: * 1/ RHS was not initialized while it should have been * 2/ RHS was explicitely initialized to -9999 but is not allocated of the right size */ EXTRACT_CMPLX_FROM_MATLAB_TOPTR(RHS_IN,(dmumps_par->rhs),double,1); }else{ nbrhs = mxGetN(RHS_IN); ldrhs = mxGetM(RHS_IN); dmumps_par->nrhs = (int)nbrhs; dmumps_par->lrhs = (int)ldrhs; if(ldrhs != n){ mexErrMsgTxt ("Incompatible number of rows in RHS"); } if (!mxIsSparse(RHS_IN)){ /* full rhs */ dmumps_par->icntl[20-1] = 0; EXTRACT_CMPLX_FROM_MATLAB_TOPTR(RHS_IN,(dmumps_par->rhs),double,(int)( dmumps_par->nrhs*ldrhs)); }else{ /* sparse rhs */ /* printf("sparse RHS ldrhs = %d nrhs = %d\n",ldrhs,nbrhs); */ if (dmumps_par->icntl[30-1] == 0) { /* A-1 feature was not requested => we are in the standard * sparse RHS case and thus we set ICNTL(20) accordingly. */ dmumps_par->icntl[20-1] = 1; } irhs_ptr = mxGetJc(RHS_IN); irhs_sparse = mxGetIr(RHS_IN); rhs_sparse = mxGetPr(RHS_IN); #if MUMPS_ARITH == MUMPS_ARITH_z im_rhs_sparse = mxGetPi(RHS_IN); #endif nz_rhs = irhs_ptr[nbrhs]; dmumps_par->nz_rhs = (int)nz_rhs; MYMALLOC((dmumps_par->irhs_ptr),(dmumps_par->nrhs+1),int); MYMALLOC((dmumps_par->irhs_sparse), dmumps_par->nz_rhs,int); MYMALLOC((dmumps_par->rhs_sparse), dmumps_par->nz_rhs,double2); /* dmumps_par->rhs will store the solution*/ MYMALLOC((dmumps_par->rhs),((dmumps_par->nrhs*dmumps_par->lrhs)),double2); for(i=0;i< dmumps_par->nrhs;i++){ for(j=irhs_ptr[i];jirhs_sparse)[j] = irhs_sparse[j]+1; } (dmumps_par->irhs_ptr)[i] = irhs_ptr[i]+1; } (dmumps_par->irhs_ptr)[dmumps_par->nrhs] = dmumps_par->nz_rhs+1; #if MUMPS_ARITH == MUMPS_ARITH_z if(im_rhs_sparse){ for(i=0;inz_rhs;i++){ ((dmumps_par->rhs_sparse)[i]).r = rhs_sparse[i]; ((dmumps_par->rhs_sparse)[i]).i = im_rhs_sparse[i]; } }else{ for(i=0;inz_rhs;i++){ ((dmumps_par->rhs_sparse)[i]).r = rhs_sparse[i]; ((dmumps_par->rhs_sparse)[i]).i = 0.0; } } #else for(i=0;inz_rhs;i++){ (dmumps_par->rhs_sparse)[i] = rhs_sparse[i]; } #endif } } if(dmumps_par->size_schur > 0){ if (dofactorize) { MYMALLOC((dmumps_par->schur),((dmumps_par->size_schur)*(dmumps_par->size_schur)),double2); } dmumps_par->icntl[18] = 1; }else{ dmumps_par->icntl[18] = 0; } /* Reduced RHS */ if ( dmumps_par->size_schur > 0 && dosolve ) { if ( dmumps_par->icntl[26-1] == 2 ) { /* REDRHS is on input */ tmp_m= mxGetM(REDRHS_IN); tmp_n= mxGetN(REDRHS_IN); if (tmp_m != dmumps_par->size_schur || tmp_n != dmumps_par->nrhs) { mexErrMsgTxt ("bad dimensions for REDRHS in mumpsmex.c"); } EXTRACT_CMPLX_FROM_MATLAB_TOPTR(REDRHS_IN,(dmumps_par->redrhs),double,((int)tmp_m*tmp_n)); dmumps_par->lredrhs=dmumps_par->size_schur; } if ( dmumps_par->icntl[26-1] == 1 ) { /* REDRHS on output. Must be allocated before the call */ MYFREE(dmumps_par->redrhs); if(!(dmumps_par->redrhs=(double2 *)malloc((dmumps_par->size_schur*dmumps_par->nrhs)*sizeof(double2)))){ mexErrMsgTxt("malloc redrhs failed in intmumpsc.c"); } } } dmumps_c(dmumps_par); } } if(nlhs > 0){ EXTRACT_FROM_C_TO_MATLAB( INFO_OUT ,(dmumps_par->infog),80); EXTRACT_FROM_C_TO_MATLAB( RINFO_OUT ,(dmumps_par->rinfog),40); /* A-1 on output */ if ( dmumps_par->icntl[30-1] != 0 && dosolve ) { RHS_OUT = mxCreateSparse(dmumps_par->n, dmumps_par->n,dmumps_par->nz_rhs,mxREAL2); irhs_ptr = mxGetJc(RHS_OUT); irhs_sparse = mxGetIr(RHS_OUT); for(j=0;jnrhs+1;j++){ irhs_ptr[j] = (mwIndex) ((dmumps_par->irhs_ptr)[j]-1); } ptr_matlab = mxGetPr(RHS_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi(RHS_OUT); #endif for(i=0;inz_rhs;i++){ #if MUMPS_ARITH == MUMPS_ARITH_z /* complex arithmetic */ ptr_matlab[i] = (dmumps_par->rhs_sparse)[i].r; ptri_matlab[i] = (dmumps_par->rhs_sparse)[i].i; #else /* real arithmetic */ ptr_matlab[i] = (dmumps_par->rhs_sparse)[i]; #endif irhs_sparse[i] = (mwIndex)((dmumps_par->irhs_sparse)[i]-1); } } else if(dmumps_par->rhs && dosolve){ /* nbrhs may not have been set (case of null space) */ nbrhs=dmumps_par->nrhs; RHS_OUT = mxCreateDoubleMatrix (dmumps_par->n,dmumps_par->nrhs,mxREAL2); ptr_matlab = mxGetPr (RHS_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi (RHS_OUT); for(j=0;jnrhs;j++){ posrhs = j*(int)n; for(i=0;in;i++){ ptr_matlab[posrhs+i]= (dmumps_par->rhs)[posrhs+i].r; ptri_matlab[posrhs+i]= (dmumps_par->rhs)[posrhs+i].i; } } #else for(j=0;jnrhs;j++){ posrhs = j*dmumps_par->n; for(i=0;in;i++){ ptr_matlab[posrhs+i]= (dmumps_par->rhs)[posrhs+i]; } } #endif }else{ EXTRACT_CMPLX_FROM_C_TO_MATLAB( RHS_OUT,(dmumps_par->rhs),1); } ptr_int = (int *)dmumps_par; inst_address = (size_t) ptr_int; EXTRACT_FROM_C_TO_MATLAB( INST_OUT ,&inst_address,1); EXTRACT_FROM_C_TO_MATLAB( PIVNUL_LIST,dmumps_par->pivnul_list,dmumps_par->infog[27]); EXTRACT_FROM_C_TO_MATLAB( PERM_OUT ,dmumps_par->sym_perm,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( UNS_PERM ,dmumps_par->uns_perm,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( ICNTL_OUT ,dmumps_par->icntl,60); EXTRACT_FROM_C_TO_MATLAB( CNTL_OUT ,dmumps_par->cntl,15); EXTRACT_FROM_C_TO_MATLAB( ROWSCA_OUT ,dmumps_par->rowsca,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( COLSCA_OUT ,dmumps_par->colsca,dmumps_par->n); EXTRACT_FROM_C_TO_MATLAB( KEEP_OUT ,dmumps_par->keep,500); EXTRACT_FROM_C_TO_MATLAB( DKEEP_OUT ,dmumps_par->dkeep,230); if(dmumps_par->size_schur > 0 && dofactorize){ SCHUR_OUT = mxCreateDoubleMatrix(dmumps_par->size_schur,dmumps_par->size_schur,mxREAL2); ptr_matlab = mxGetPr (SCHUR_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi (SCHUR_OUT); for(i=0;isize_schur;i++){ pos = i*(dmumps_par->size_schur); for(j=0;jsize_schur;j++){ ptr_matlab[j+pos] = ((dmumps_par->schur)[j+pos]).r; ptri_matlab[j+pos] = ((dmumps_par->schur)[j+pos]).i; } } #else for(i=0;isize_schur;i++){ pos = i*(dmumps_par->size_schur); for(j=0;jsize_schur;j++){ ptr_matlab[j+pos] = (dmumps_par->schur)[j+pos]; } } #endif }else{ SCHUR_OUT = mxCreateDoubleMatrix(1,1,mxREAL2); ptr_matlab = mxGetPr (SCHUR_OUT); ptr_matlab[0] = -9999; #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab = mxGetPi (SCHUR_OUT); ptr_matlab[0] = -9999; #endif } /* REDRHS on output */ if ( dmumps_par->icntl[26-1]==1 && dmumps_par->size_schur > 0 && dosolve ) { REDRHS_OUT = mxCreateDoubleMatrix(dmumps_par->size_schur,dmumps_par->nrhs,mxREAL2); ptr_matlab = mxGetPr(REDRHS_OUT); #if MUMPS_ARITH == MUMPS_ARITH_z ptri_matlab = mxGetPi (REDRHS_OUT); #endif for(i=0;inrhs*dmumps_par->size_schur;i++){ #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab[i] = ((dmumps_par->redrhs)[i]).r; ptri_matlab[i] = ((dmumps_par->redrhs)[i]).i; #else ptr_matlab[i] = ((dmumps_par->redrhs)[i]); #endif } }else{ REDRHS_OUT = mxCreateDoubleMatrix(1,1,mxREAL2); ptr_matlab = mxGetPr (REDRHS_OUT); ptr_matlab[0] = -9999; #if MUMPS_ARITH == MUMPS_ARITH_z ptr_matlab = mxGetPi (REDRHS_OUT); ptr_matlab[0] = -9999; #endif } MYFREE(dmumps_par->redrhs); MYFREE(dmumps_par->schur); MYFREE(dmumps_par->irhs_ptr); MYFREE(dmumps_par->irhs_sparse); MYFREE(dmumps_par->rhs_sparse); MYFREE(dmumps_par->rhs); } } MUMPS_5.4.1/MATLAB/lhr01.mat0000664000175000017500000074250014102210473015321 0ustar jylexceljylexcelMATLAB 5.0 MAT-file, Platform: SOL2, Created on: Thu Oct 4 19:03:15 2001 MIĸProblem  titleAZerosbnameÀHLight hydrocarbon recovery. OK if illconditioned,from a nonlinear solvr y¸H¡ÅÅ"„>ST?ST@STASTBSTCSTDSTESTFST GST HST IST JST KSTLSTMSTNSTOSTPSTST=STTWTX>QRZ?QR[@QR\AQR]BQR^CQR_DQR`EQRaFQRbGQRcHQRdIQReJQRfKQRgLQRhMQRiNQRjOQRkPQRlQR=QYRRWoRXpZmnr[mns\mnt]mnu^mnv_mnw`mnxamnybmnzcmn{dmn|emn}fmn~gmnhmn€imnjmn‚kmnƒlmn„mnYmqnno‡np¢r…†¤s…†¥t…†¦u…†§v…†¨w…†©x…†ªy…†«z…†¬{…†­|…†®}…†¯~…†°…†±€…†²…†³‚…†´ƒ…†µ„…†¶…†q…£†¡¸†‡¹†¢º¤·¼¥·½¦·¾§·¿¨·À©·Áª·Â«·Ã¬·Ä­·Å®·Æ¯·Ç°·È±·É²·Ê³·Ë´·Ìµ·Í¶·Î·£·»¸¹ºÓ‰œ¼ÔÕÖØÚÜÞàâäæèêìîðòôöøúŠœ½ÔÖ×ØÚÜÞàâäæèêìîðòôöøú‹œ¾ÔÖØÙÚÜÞàâäæèêìîðòôöøúŒœ¿ÔÖØÚÛÜÞàâäæèêìîðòôöøúœÀÔÖØÚÜÝÞàâäæèêìîðòôöøúŽœÁÔÖØÚÜÞßàâäæèêìîðòôöøúœÂÔÖØÚÜÞàáâäæèêìîðòôöøúœÃÔÖØÚÜÞàâãäæèêìîðòôöøú‘œÄÔÖØÚÜÞàâäåæèêìîðòôöøú’œÅÔÖØÚÜÞàâäæçèêìîðòôöøú“œÆÔÖØÚÜÞàâäæèéêìîðòôöøú”œÇÔÖØÚÜÞàâäæèêëìîðòôöøú•œÈÔÖØÚÜÞàâäæèêìíîðòôöøú–œÉÖÚÜÞàâäæèêìîïðòôöøú—œÊÔÖàâäæèñòöú˜œËÔÖØÚÜÞàâäæèêìîðòóôöøú™œÌÔÖØÚÜÞàâäæèêìîðòôõöøúšœÍÔÖØÚÜÞàâäæèêìîðòôö÷øú›œÎÔÖØÚÜÞàâäæèêìîðòôöøùúœÔÖØÚÜÞàâäæèêìîðòôöøúûˆœ»Õ×ÙÛÝßáãåçéëíïñóõ÷ùûÑÔÖØÚÜÞàâäæèêìîðòôöøú ÒÔÖØÚÜÞàâäæèêìîðòôöøú¢Ó¼ÏÐÔÕÖØÚÜÞàâäæèêìîðòôöøúý½ÏÐÔÖ×ØÚÜÞàâäæèêìîðòôöøúþ¾ÏÐÔÖØÙÚÜÞàâäæèêìîðòôöøúÿ¿ÏÐÔÖØÚÛÜÞàâäæèêìîðòôöøúÀÏÐÔÖØÚÜÝÞàâäæèêìîðòôöøúÁÏÐÔÖØÚÜÞßàâäæèêìîðòôöøúÂÏÐÔÖØÚÜÞàáâäæèêìîðòôöøúÃÏÐÔÖØÚÜÞàâãäæèêìîðòôöøúÄÏÐÔÖØÚÜÞàâäåæèêìîðòôöøúÅÏÐÔÖØÚÜÞàâäæçèêìîðòôöøúÆÏÐÔÖØÚÜÞàâäæèéêìîðòôöøúÇÏÐÔÖØÚÜÞàâäæèêëìîðòôöøúÈÏÐÔÖØÚÜÞàâäæèêìíîðòôöøú ÉÏÐÔÖØÚÜÞàâäæèêìîïðòôöøú ÊÏÐÔÖØÚÜÞàâäæèêìîðñòôöøú ËÏÐÔÖØÚÜÞàâäæèêìîðòóôöøú ÌÏÐÔÖØÚÜÞàâäæèêìîðòôõöøú ÍÏÐÔÖØÚÜÞàâäæèêìîðòôö÷øúÎÏÐÔÖØÚÜÞàâäæèêìîðòôöøùúÏÐÔÖØÚÜÞàâäæèêìîðòôöøúû»ÏÕ×ÙÛÝßáãåçéëíïñóõ÷ùûüÐÑÐÒÐÓ-ý/þ0ÿ123456789: ; < = > ?@Aü.,CD-E/BG0BH1BI2BJ3BK4BL5BM6BN7BO8BP9BQ:BR;BS<BT=BU>BV?BW@BXABYB.BFCDE^'(G_`acegikmoqsuwy{}ƒ…'(H_abcegikmoqsuwy{}ƒ…'(I_acdegikmoqsuwy{}ƒ…'(J_acefgikmoqsuwy{}ƒ…'(K_aceghikmoqsuwy{}ƒ…'(L_acegijkmoqsuwy{}ƒ…'(M_acegiklmoqsuwy{}ƒ…'(N_acegikmnoqsuwy{}ƒ…'(O_acegikmopqsuwy{}ƒ…'(P_acegikmoqrsuwy{}ƒ…'(Q_acegikmoqstuwy{}ƒ…'(R_acegikmoqsuvwy{}ƒ… '(S_aegikmoqsuwxy{}ƒ…!'(T_aegikmoqsuwyz{}ƒ…"(Uegikmoqsuwy|}ƒ#'(V_acegikmoqsuwy{}~ƒ…$'(W_acegikmoqsuwy{}€ƒ…%'(X_acegikmoqsuwy{}‚ƒ…&'(Y_acegikmoqsuwy{}ƒ„…'(_acegikmoqsuwy{}ƒ…†'F`bdfhjlnprtvxz|~€‚„†(\_acegikmoqsuwy{}ƒ…(+]_acegikmoqsuwy{}ƒ…(-^GZ[_`acegikmoqsuwy{}ƒ…ˆHZ[_abcegikmoqsuwy{}ƒ…‰IZ[_acdegikmoqsuwy{}ƒ…ŠJZ[_acefgikmoqsuwy{}ƒ…‹KZ[_aceghikmoqsuwy{}ƒ…ŒLZ[_acegijkmoqsuwy{}ƒ…MZ[_acegiklmoqsuwy{}ƒ…ŽNZ[_acegikmnoqsuwy{}ƒ…OZ[_acegikmopqsuwy{}ƒ…PZ[_acegikmoqrsuwy{}ƒ…‘QZ[_acegikmoqstuwy{}ƒ…’RZ[_acegikmoqsuvwy{}ƒ…“SZ[_acegikmoqsuwxy{}ƒ…”TZ[_acegikmoqsuwyz{}ƒ…•UZ[_acegikmoqsuwy{|}ƒ…–VZ[_acegikmoqsuwy{}~ƒ…—WZ[_acegikmoqsuwy{}€ƒ…˜XZ[_acegikmoqsuwy{}‚ƒ…™YZ[_acegikmoqsuwy{}ƒ„…šZ[_acegikmoqsuwy{}ƒ…†FZ`bdfhjlnprtvxz|~€‚„†‡[\œ[][^žˆ› ‰›¡Š›¢‹›£Œ›¤›¥Ž›¦›§›¨‘›©’›ª“›«”›¬•›­–›®—›¯˜›°™›±š›²›‡›Ÿœž¹‰žŸ€ŠžŸ‹žŸ‚ŒžŸƒžŸ„ŽžŸ…žŸ†žŸ‡‘žŸˆ’žŸ‰“žŸŠ”žŸ‹•žŸŒ–žŸ—žŸŽ˜žŸ™žŸšžŸ‘›žŸ’žŸˆžŸ¡Ÿ Ÿ¢–)*€)*)*‚)*ƒ)*„)*…)*†)*‡)*ˆ)*‰)*Š)*‹ )*Œ!)*"*Ž#)*$)*%)*‘&)*’)*)*,*+•*-–€“”­“”®‚“”¯ƒ“”°„“”±…“”²†“”³‡“”´ˆ“”µ‰“”¶Š“”·‹“”¸Œ“”¹“”ºŽ“”»“”¼“”½‘“”¾’“”¿“”“¬””•Â”–Ä­ÀÁ®ÀÁ¯ÀÁ°ÀÁ±ÀÁ²ÀÁ³ÀÁ´ÀÁµÀÁ¶ÀÁ·ÀÁ¸ÀÁ¹ÀÁºÀÁ»ÀÁ¼ÀÁ½ÀÁ¾ÀÁ¿ÀÁÀÁ¬ÀÁÃÁÂÁÄö   "$&(*0247L÷   "$&(*,.248Mø   "$&(*,.0249Nù   "$&(*,.024:Oú   "$&(*,.024;Pû   "$&(*,.024<Qü   "$&(*,.024=Rý   "$&(*,.024>Sþ   "$&(*,.024?Tÿ   !"$&(*,.024@U   "#$&(*,.024AV   "$%&(*,.024BW   "$&'(*,.024CX   "$&()*,.024DY   "$&(*+,.024EZ   "$&(*,-.024F[   "$&(*,./024G\   "$&(*,.0124H]   "$&(*,.0234I^   "$&(*,.0245_õ !#%')+-/1356  cd  ef  `b7J8J9J:J;J<J=J>J?J@JAJBJCJDJEJFJGJHJIJJ6Jceb7KLh8KMi9KNj:KOk;KPl<KQm=KRn>KSo?KTp@KUqAKVrBKWsCKXtDKYuEKZvFK[wGK\xHK]yIK^zK_6Kgdf}`b~h{|˜i{|™j{|šk{|›l{|œm{|n{|žo{|Ÿp{| q{|¡r{|¢s{|£t{|¤u{|¥v{|¦w{|§x{|¨y{|©z{|ª{|g{—8||}«|~Ä>UV˜?UV™@UVšAUV›BUVœCUVDUVžEUVŸFUV GUV¡HUV¢IUV£JUV¤KUV¥LUV¦MUV§NUV¨OUV©PUVªUV=U—VÃV«VXÄ ³´º»¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà㡳´º¼½¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà䢳´º¼¾¿ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà壳´º¼¾ÀÁÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà椳´º¼¾ÀÂÃÄÆÈÊÌÎÐÒÔÖØÚÜÞà祳´º¼¾ÀÂÄÅÆÈÊÌÎÐÒÔÖØÚÜÞà観´º¼¾ÀÂÄÆÇÈÊÌÎÐÒÔÖØÚÜÞà駳´º¼¾ÀÂÄÆÈÉÊÌÎÐÒÔÖØÚÜÞàꨳ´º¼¾ÀÂÄÆÈÊËÌÎÐÒÔÖØÚÜÞà멳´º¼¾ÀÂÄÆÈÊÌÍÎÐÒÔÖØÚÜÞà쪳´º¼¾ÀÂÄÆÈÊÌÎÏÐÒÔÖØÚÜÞàí«³´º¼¾ÀÂÄÆÈÊÌÎÐÑÒÔÖØÚÜÞà´º¼¾ÀÂÄÆÈÊÌÎÐÒÓÔÖØÚÜÞàï­³´º¼¾ÀÂÄÆÈÊÌÎÐÒÔÕÖØÚÜÞà𮳴º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖ×ØÚÜÞàñ¯³´º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÙÚÜÞàò°³´º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÛÜÞàó±³´º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÝÞàô²³´º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞßàõ³´º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà៳»½¿ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáâ´·º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà´¸º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞàú´¹û µ¶º»¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞࡵ¶º¼½¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞࢵ¶º¼¾¿ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà‘£µ¶º¼¾ÀÁÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà’¤µ¶º¼¾ÀÂÃÄÆÈÊÌÎÐÒÔÖØÚÜÞà“¥µ¶º¼¾ÀÂÄÅÆÈÊÌÎÐÒÔÖØÚÜÞà”¦µ¶º¼¾ÀÂÄÆÇÈÊÌÎÐÒÔÖØÚÜÞà•§µ¶º¼¾ÀÂÄÆÈÉÊÌÎÐÒÔÖØÚÜÞà–¨µ¶º¼¾ÀÂÄÆÈÊËÌÎÐÒÔÖØÚÜÞà—©µ¶º¼¾ÀÂÄÆÈÊÌÍÎÐÒÔÖØÚÜÞà˜ªµ¶º¼¾ÀÂÄÆÈÊÌÎÏÐÒÔÖØÚÜÞà™«µ¶º¼¾ÀÂÄÆÈÊÌÎÐÑÒÔÖØÚÜÞàš¬µ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÓÔÖØÚÜÞà›­µ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÕÖØÚÜÞàœ®µ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖ×ØÚÜÞ௵¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÙÚÜÞàž°µ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÛÜÞàŸ±µ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÝÞà ²µ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞßࡵ¶º¼¾ÀÂÄÆÈÊÌÎÐÒÔÖØÚÜÞà៵»½¿ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßᎶ·¶¸¶¹¥ãö÷ýäö÷þåö÷ÿæö÷çö÷èö÷éö÷êö÷ëö÷ìö÷íö÷îö÷ïö÷ ðö÷ ñö÷ òö÷ óö÷ ôö÷õö÷ö÷âöü÷÷ú÷ûýB\]^`bdfhjlnprtvxz|~€‚þC\^_`bdfhjlnprtvxz|~€‚ÿD\^`abdfhjlnprtvxz|~€‚E\^`bcdfhjlnprtvxz|~€‚F\^`bdefhjlnprtvxz|~€‚G\^`bdfghjlnprtvxz|~€‚H\^`bdfhijlnprtvxz|~€‚I\^`bdfhjklnprtvxz|~€‚J\^`bdfhjlmnprtvxz|~€‚K\^`bdfhjlnoprtvxz|~€‚L\^`bdfhjlnpqrtvxz|~€‚M\^`bdfhjlnprstvxz|~€‚ N\^`bdfhjlnprtuvxz|~€‚ O\^`bdfhjlnprtvwxz|~€‚ P\^`bdfhjlnprtvxyz|~€‚ Q\^`bdfhjlnprtvxz{|~€‚ R\^`bdfhjlnprtvxz|}~€‚S\^`bdfhjlnprtvxz|~€‚T\^`bdfhjlnprtvxz|~€‚\^`bdfhjlnprtvxz|~€‚ƒüA]_acegikmoqsuwy{}ƒYZ[ý!#%')+-/13579;=?Bþ!#%')+-/13579;=?Cÿ!#%')+-/13579;=?D !#%')+-/13579;=?E!"#%')+-/13579;=?F!#$%')+-/13579;=?G!#%&')+-/13579;=?H!#%'()+-/13579;=?I!#%')*+-/13579;=?J!#%')+,-/13579;=?K!#%')+-./13579;=?L!#%')+-/013579;=?M !#%')+-/123579;=?N !#%')+-/134579;=?O !#%')+-/135679;=?P !#%')+-/135789;=?Q !#%')+-/13579:;=?R!#%')+-/13579;<=?S!#%')+-/13579;=>?T!#%')+-/13579;=?@ü "$&(*,.02468:<>@A !#%')+-/13579;=?!!#%')+-/13579;=?[ý!#%')+-/13579;=?þ!#%')+-/13579;=?ÿ!#%')+-/13579;=?‘ !#%')+-/13579;=?’!"#%')+-/13579;=?“!#$%')+-/13579;=?”!#%&')+-/13579;=?•!#%'()+-/13579;=?–!#%')*+-/13579;=?—!#%')+,-/13579;=?˜!#%')+-./13579;=?™!#%')+-/013579;=?š !#%')+-/123579;=?› !#%')+-/134579;=?œ !#%')+-/135679;=? !#%')+-/135789;=?ž !#%')+-/13579:;=?Ÿ!#%')+-/13579;<=? !#%')+-/13579;=>?¡!#%')+-/13579;=?@ü "$&(*,.02468:<>@Ž¤¥§º»ê   "$&(*¨º»ë   "$&(*©º»ì    "$&(*ªº»í    "$&(*«º»î    "$&(*¬º»ï   "$&(*­º»ð   "$&(*®º»ñ   "$&(*¯º»ò   "$&(*°º»ó   "$&(*±º»ô   "$&(*²º»õ   "$&(*³º»ö   "$&(*´º»÷   "$&(*µº»ø   !"$&(*¶º»ù   "#$&(*·º»ú   "$%&(*¸º»û   "$&'(*¹º»ü   "$&()*º»   "$&(*+¦ºé   !#%')+.»   "$&(*/»   "$&(*»À¢£§¢£¨‘¢£©’¢£ª“¢£«”¢£¬•¢£­–¢£®—¢£¯˜¢£°™¢£±š¢£²›¢£³œ¢£´¢£µž¢£¶Ÿ¢£· ¢£¸¡¢£¹¢£Ž¢¦££¤£¥Àãøù§ÁÂÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåçäøù¨ÁÃÄÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåçåøù©ÁÃÅÆÇÉËÍÏÑÓÕ×ÙÛÝßáãåçæøùªÁÃÅÇÈÉËÍÏÑÓÕ×ÙÛÝßáãåççøù«ÁÃÅÇÉÊËÍÏÑÓÕ×ÙÛÝßáãåçèøù¬ÁÃÅÇÉËÌÍÏÑÓÕ×ÙÛÝßáãåçéøù­ÁÃÅÇÉËÍÎÏÑÓÕ×ÙÛÝßáãåçêøù®ÁÃÅÇÉËÍÏÐÑÓÕ×ÙÛÝßáãåçëøù¯ÁÃÅÇÉËÍÏÑÒÓÕ×ÙÛÝßáãåçìøù°ÁÃÅÇÉËÍÏÑÓÔÕ×ÙÛÝßáãåçíøù±ÁÃÅÇÉËÍÏÑÓÕÖ×ÙÛÝßáãåçîøù²ÁÃÅÇÉËÍÏÑÓÕ×ØÙÛÝßáãåçïøù³ÁÃÅÇÉËÍÏÑÓÕ×ÙÚÛÝßáãåçðøù´ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÜÝßáãåçñøùµÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝÞßáãåçòøù¶ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßàáãåçóøù·ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáâãåçôøù¸ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãäåçõøù¹ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåæçøùÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåçèâø¦ÂÄÆÈÊÌÎÐÒÔÖØÚÜÞàâäæè,ù¾ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåç-ù¿ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåçùûÀ§¼½ÁÂÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåç꨼½ÁÃÄÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåç멼½ÁÃÅÆÇÉËÍÏÑÓÕ×ÙÛÝßáãåç쪼½ÁÃÅÇÈÉËÍÏÑÓÕ×ÙÛÝßáãåçí«¼½ÁÃÅÇÉÊËÍÏÑÓÕ×ÙÛÝßáãåç½ÁÃÅÇÉËÌÍÏÑÓÕ×ÙÛÝßáãåçï­¼½ÁÃÅÇÉËÍÎÏÑÓÕ×ÙÛÝßáãåç𮼽ÁÃÅÇÉËÍÏÐÑÓÕ×ÙÛÝßáãåçñ¯¼½ÁÃÅÇÉËÍÏÑÒÓÕ×ÙÛÝßáãåçò°¼½ÁÃÅÇÉËÍÏÑÓÔÕ×ÙÛÝßáãåçó±¼½ÁÃÅÇÉËÍÏÑÓÕÖ×ÙÛÝßáãåçô²¼½ÁÃÅÇÉËÍÏÑÓÕ×ØÙÛÝßáãåçõ³¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÚÛÝßáãåçö´¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÜÝßáãåç÷µ¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝÞßáãåçø¶¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßàáãåçù·¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáâãåçú¸¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãäåçû¹¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåæçü¼½ÁÃÅÇÉËÍÏÑÓÕ×ÙÛÝßáãåç覼ÂÄÆÈÊÌÎÐÒÔÖØÚÜÞàâäæèé½¾½¿½ÀBWX\]^`bdfhjlnprtvxz|~€‚…CWX\^_`bdfhjlnprtvxz|~€‚†DWX\^`abdfhjlnprtvxz|~€‚‡EWX\^`bcdfhjlnprtvxz|~€‚ˆFWX\^`bdefhjlnprtvxz|~€‚‰GWX\^`bdfghjlnprtvxz|~€‚ŠHWX\^`bdfhijlnprtvxz|~€‚‹IWX\^`bdfhjklnprtvxz|~€‚ŒJWX\^`bdfhjlmnprtvxz|~€‚KWX\^`bdfhjlnoprtvxz|~€‚ŽLWX\^`bdfhjlnpqrtvxz|~€‚MWX\^`bdfhjlnprstvxz|~€‚NWX\^`bdfhjlnprtuvxz|~€‚‘OWX\^`dfhjlnprtvwxz|~€‚’PX^bdhltvy“QWX\^`bdfhjlnprtvxz{|~€‚”RWX\^`bdfhjlnprtvxz|}~€‚•SWX\^`bdfhjlnprtvxz|~€‚–TWX\^`bdfhjlnprtvxz|~€‚—WX\^`bdfhjlnprtvxz|~€‚ƒAW]_acegikmoqsuwy{}ƒ„"XY\^`bdfhjlnprtvxz|~€‚#XZ\^`bdfhjlnprtvxz|~€‚X[ž…˜™Èâãäæèêìîðòôöøúüþ†˜™Éâäåæèêìîðòôöøúüþ‡˜™Êâäæçèêìîðòôöøúüþˆ˜™Ëâäæèéêìîðòôöøúüþ‰˜™ÌâäæèêëìîðòôöøúüþŠ˜™Íâäæèêìíîðòôöøúüþ‹˜™ÎâäæèêìîïðòôöøúüþŒ˜™Ïâäæèêìîðñòôöøúüþ˜™ÐâäæèêìîðòóôöøúüþŽ˜™Ñâäæèêìîðòôõöøúüþ˜™Òâäæèêìîðòôö÷øúüþ˜™Óâäæèêìîðòôöøùúüþ‘˜™Ôâäæèêìîðòôöøúûüþ’˜™Õäæèêìîðòôöøüýþ“˜™Öâäæèêìîðòôöøúüþÿ”˜™×âäæèêìîðòôöøúüþ•˜™Øâäæèêìîðòôöøúüþ–˜™Ùâäæèêìîðòôöøúüþ—˜™Úâäæèêìîðòôöøúüþ˜™âäæèêìîðòôöøúüþ „˜Çãåçéëíïñóõ÷ùûýÿ ™ß™à™žá…š›Ÿ ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅȆš›Ÿ¡¢£¥§©«­¯±³µ·¹»½¿ÁÃÅɇš›Ÿ¡£¤¥§©«­¯±³µ·¹»½¿ÁÃÅʈš›Ÿ¡£¥¦§©«­¯±³µ·¹»½¿ÁÃÅˉš›Ÿ¡£¥§¨©«­¯±³µ·¹»½¿ÁÃÅÌŠš›Ÿ¡£¥§©ª«­¯±³µ·¹»½¿ÁÃÅÍ‹š›Ÿ¡£¥§©«¬­¯±³µ·¹»½¿ÁÃÅÎŒš›Ÿ¡£¥§©«­®¯±³µ·¹»½¿ÁÃÅÏš›Ÿ¡£¥§©«­¯°±³µ·¹»½¿ÁÃÅÐŽš›Ÿ¡£¥§©«­¯±²³µ·¹»½¿ÁÃÅÑš›Ÿ¡£¥§©«­¯±³´µ·¹»½¿ÁÃÅÒš›Ÿ¡£¥§©«­¯±³µ¶·¹»½¿ÁÃÅÓ‘š¥§©«­¯±³·¸¹½¿ÃÅÔ’›ºÕ“š›Ÿ¡£¥§©«­¯±³µ·¹»¼½¿ÁÃÅÖ”š›Ÿ¡£¥§©«­¯±³µ·¹»½¾¿ÁÃÅוš›Ÿ¡£¥§©«­¯±³µ·¹»½¿ÀÁÃÅØ–š›Ÿ¡£¥§©«­¯±³µ·¹»½¿ÁÂÃÅÙ—š›Ÿ¡£¥§©«­¯±³µ·¹»½¿ÁÃÄÅÚš›Ÿ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅÆ„š ¢¤¦¨ª¬®°²´¶¸º¼¾ÀÂÄÆÇ$›œŸ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅ%›Ÿ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅ›žáBUV…Ÿ ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅCUV†Ÿ¡¢£¥§©«­¯±³µ·¹»½¿ÁÃÅDUV‡Ÿ¡£¤¥§©«­¯±³µ·¹»½¿ÁÃÅEUVˆŸ¡£¥¦§©«­¯±³µ·¹»½¿ÁÃÅFUV‰Ÿ¡£¥§¨©«­¯±³µ·¹»½¿ÁÃÅGUVŠŸ¡£¥§©ª«­¯±³µ·¹»½¿ÁÃÅHUV‹Ÿ¡£¥§©«¬­¯±³µ·¹»½¿ÁÃÅIUVŒŸ¡£¥§©«­®¯±³µ·¹»½¿ÁÃÅJUVŸ¡£¥§©«­¯°±³µ·¹»½¿ÁÃÅKUVŽŸ¡£¥§©«­¯±²³µ·¹»½¿ÁÃÅLUVŸ¡£¥§©«­¯±³´µ·¹»½¿ÁÃÅMUVŸ¡£¥§©«­¯±³µ¶·¹»½¿ÁÃÅNUV‘Ÿ¡£¥§©«­¯±³µ·¸¹»½¿ÁÃÅOUV’Ÿ¡£¥§©«­¯±³µ·¹º»½¿ÃÅPUV“Ÿ¡¥§©«­¯³µ·¹»¼½¿ÁÃÅQUV”Ÿ¡£¥§©«­¯±³µ·¹»½¾¿ÁÃÅRUV•Ÿ¡£¥§©«­¯±³µ·¹»½¿ÀÁÃÅSUV–Ÿ¡£¥§©«­¯±³µ·¹»½¿ÁÂÃÅTUV—Ÿ¡£¥§©«­¯±³µ·¹»½¿ÁÃÄÅUVŸ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅÆAU„ ¢¤¦¨ª¬®°²´¶¸º¼¾ÀÂÄÆVœVV[ž-@ApŠ‹ŒŽ’”–˜šœž ¢¤¦¨ª¬®°.@AqŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°/@ArŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°0@AsŠŒŽ‘’”–˜šœž ¢¤¦¨ª¬®°1@AtŠŒŽ’“”–˜šœž ¢¤¦¨ª¬®°2@AuŠŒŽ’”•–˜šœž ¢¤¦¨ª¬®°3@AvŠŒŽ’”–—˜šœž ¢¤¦¨ª¬®°4@AwŠŒŽ’”–˜™šœž ¢¤¦¨ª¬®°5@AxŠŒŽ’”–˜š›œž ¢¤¦¨ª¬®°6@AyŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°7@AzŠŒŽ’”–˜šœžŸ ¢¤¦¨ª¬®°8@A{ŠŒŽ’”–˜šœž ¡¢¤¦¨ª¬®°9@A|ŠŒŽ’”–˜šœž ¢£¤¦¨ª¬®°:@A}ŠŒŽ’”–˜šœž ¢¤¥¦¨ª¬®°;@A~ŠŒŽ’”–˜šœž ¢¤¦§¨ª¬®°<@AŠŒŽ’”–˜šœž ¢¤¦¨©ª¬®°=@A€ŠŒŽ’”–˜šœž ¢¤¦¨ª«¬®°>@AŠŒŽ’”–˜šœž ¢¤¦¨ª¬­®°?@A‚ŠŒŽ’”–˜šœž ¢¤¦¨ª¬®¯°@AŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°±,@o‹‘“•—™›Ÿ¡£¥§©«­¯±2A‡ŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°3AˆŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°AF‰êÿ   "$&(*-ëÿ   "$&(*.ìÿ    "$&(*/íÿ    "$&(*0îÿ    "$&(*1ïÿ   "$&(*2ðÿ   "$&(*3ñÿ   "$&(*4òÿ   "$&(*5óÿ   "$&(*6ôÿ   "$&(*7õÿ   "$&(*8öÿ   "$&(*9÷ÿ   "$&(*:øÿ   !"$&(*;ùÿ   "#$&(*<úÿ   "$%&(*=ûÿ   "$&'(*>üÿ   "$&()*?ÿ   "$&(*+éÿ   !#%')+,Fêýþ-GHIKMOQSUWY[]_acegikmëýþ.GIJKMOQSUWY[]_acegikmìýþ/GIKLMOQSUWY[]_acegikmíýþ0GIKMNOQSUWY[]_acegikmîýþ1GIKMOPQSUWY[]_acegikmïýþ2GIKMOQRSUWY[]_acegikmðýþ3GIKMOQSTUWY[]_acegikmñýþ4GIKMOQSUVWY[]_acegikmòýþ5GIKMOQSUWXY[]_acegikmóýþ6GIKMOQSUWYZ[]_acegikmôýþ7GIKMOQSUWY[\]_acegikmõýþ8GIKMOQSUWY[]^_acegikmöýþ9GIKMOQSUWY[]_`acegikm÷ýþ:GIKMOQSUWY[]_abcegikmøýþ;GIKMOQSUWY[]_acdegikmùýþ<GIKMOQSUWY[]_acefgikmúýþ=GIKMOQSUWY[]_aceghikmûýþ>GIKMOQSUWY[]_acegijkmüýþ?GIKMOQSUWY[]_acegiklmýþGIKMOQSUWY[]_acegikmnéý,HJLNPRTVXZ\^`bdfhjln0þDGIKMOQSUWY[]_acegikm1þEGIKMOQSUWY[]_acegikmþF-BCGHIKMOQSUWY[]_acegikmp.BCGIJKMOQSUWY[]_acegikmq/BCGIKLMOQSUWY[]_acegikmr0BCGIKMNOQSUWY[]_acegikms1BCGIKMOPQSUWY[]_acegikmt2BCGIKMOQRSUWY[]_acegikmu3BCGIKMOQSTUWY[]_acegikmv4BCGIKMOQSUVWY[]_acegikmw5BCGIKMOQSUWXY[]_acegikmx6BCGIKMOQSUWYZ[]_acegikmy7BCGIKMOQSUWY[\]_acegikmz8BCGIKMOQSUWY[]^_acegikm{9BCGIKMOQSUWY[]_`acegikm|:BCGIKMOQSUWY[]_abcegikm};BCGIKMOQSUWY[]_acdegikm~<BCGIKMOQSUWY[]_acefgikm=BCGIKMOQSUWY[]_aceghikm€>BCGIKMOQSUWY[]_acegijkm?BCGIKMOQSUWY[]_acegiklm‚BCGIKMOQSUWY[]_acegikmn,BHJLNPRTVXZ\^`bdfhjlnoCDCECF‰ÈÝÞâãäæèêìîðòôöøúüþ ÉÝÞâäåæèêìîðòôöøúüþ ÊÝÞâäæçèêìîðòôöøúüþ ËÝÞâäæèéêìîðòôöøúüþÌÝÞâäæèêëìîðòôöøúüþÍÝÞâäæèêìíîðòôöøúüþÎÝÞâäæèêìîïðòôöøúüþÏÝÞâäæèêìîðñòôöøúüþÐÝÞâäæèêìîðòóôöøúüþÑÝÞâäæèêìîðòôõöøúüþÒÝÞâäæèêìîðòôö÷øúüþÓÝÞâæèêìîðòôöøùúüþÔäìîðûüÕÝÞâäæèêìîðòôöøúüýþÖÝÞâäæèêìîðòôöøúüþÿ×ÝÞâäæèêìîðòôöøúüþØÝÞâäæèêìîðòôöøúüþÙÝÞâäæèêìîðòôöøúüþÚÝÞâäæèêìîðòôöøúüþÝÞâäæèêìîðòôöøúüþ ÇÝãåçéëíïñóõ÷ùûýÿ  &Þßâäæèêìîðòôöøúüþ'ÞàâäæèêìîðòôöøúüþÞá$ Nfghjlnprtvxz|~€‚„†ˆŠŒ Ofhijlnprtvxz|~€‚„†ˆŠŒ Pfhjklnprtvxz|~€‚„†ˆŠŒQfhjlmnprtvxz|~€‚„†ˆŠŒRfhjlnoprtvxz|~€‚„†ˆŠŒSfhjlnpqrtvxz|~€‚„†ˆŠŒTfhjlnprstvxz|~€‚„†ˆŠŒUfhjlnprtuvxz|~€‚„†ˆŠŒVfhjlnprtvwxz|~€‚„†ˆŠŒWfhjlnprtvxyz|~€‚„†ˆŠŒXfhjlnprtvxz{|~€‚„†ˆŠŒYfjnprtvxz|}~€‚„†ˆŒZfhjlnprtvxz|~€‚„†ˆŠŒ[fhjlnprtvxz|~€‚„†ˆŠŒ\fhjlnprtvxz|~€‚ƒ„†ˆŠŒ]fhjlnprtvxz|~€‚„…†ˆŠŒ^fhjlnprtvxz|~€‚„†‡ˆŠŒ_fhjlnprtvxz|~€‚„†ˆ‰ŠŒ`fhjlnprtvxz|~€‚„†ˆŠ‹Œfhjlnprx|~€‚„ŠŒ Mgikmoqsuwy{}ƒ…‡‰‹cd$e  !%&')+-/13579;=?ACEGIKN  !%'()+-/13579;=?ACEGIKO  !%')*+-/13579;=?ACEGIKP !%')+,-/13579;=?ACEGIKQ !%')+-./13579;=?ACEGIKR !%')+-/013579;=?ACEGIKS !%')+-/123579;=?ACEGIKT !%')+-/134579;=?ACEGIKU !%')+-/135679;=?ACEGIKV !%')+-/135789;=?ACEGIKW !%')+-/13579:;=?ACEGIKX<Y !%')+-/13579;=>?ACEGIKZ !%')+-/13579;=?@ACEGIK[ !%')+-/13579;=?ABCEGIK\ !%')+-/13579;=?ACDEGIK] !%')+-/13579;=?ACEFGIK^ !%')+-/13579;=?ACEGHIK_ !%')+-/13579;=?ACEGIJK` !'+-/379;?CEL  &(*,.02468:<>@BDFHJLM(!"%')+-/13579;=?ACEGIK)!#%')+-/13579;=?ACEGIK!$eÈÛÜ %&')+-/13579;=?ACEGIKÉÛÜ %'()+-/13579;=?ACEGIKÊÛÜ %')*+-/13579;=?ACEGIKËÛÜ%')+,-/13579;=?ACEGIKÌÛÜ%')+-./13579;=?ACEGIKÍÛÜ%')+-/013579;=?ACEGIKÎÛÜ%')+-/123579;=?ACEGIKÏÛÜ%')+-/134579;=?ACEGIKÐÛÜ%')+-/135679;=?ACEGIKÑÛÜ%')+-/135789;=?ACEGIKÒÛÜ%')+-/13579:;=?ACEGIKÓÛÜ%')+-/13579;<?CEGIKÔÜ%')+-/13579;=>?ACEGIÕÛÜ%')+-/13579;=?@ACEGIKÖÛÜ%')+-/13579;=?ABCEGIK×ÛÜ%')+-/13579;=?ACDEGIKØÛÜ%')+-/13579;=?ACEFGIKÙÛÜ%')+-/13579;=?ACEGHIKÚÛÜ%')+-/13579;=?ACEGIJKÛÜ%')+-/13579;=?ACEGIKLÇÛ &(*,.02468:<>@BDFHJLÜ"Ü#Üá$³ÆÇö "$&(*,.024´ÆÇ÷ "$&(*,.024µÆÇø "$&(*,.024¶ÆÇù "$&(*,.024·ÆÇú "$&(*,.024¸ÆÇû "$&(*,.024¹ÆÇü "$&(*,.024ºÆÇý "$&(*,.024»ÆÇþ "$&(*,.024¼ÆÇÿ !"$&(*,.024½ÆÇ "#$&(*,.024¾ÆÇ "$%&(*,.024¿ÆÇ "$&'(*,.024ÀÆÇ "$&()*,.024ÁÆÇ "$&(*+,.024ÂÆÇ "$&(*,-.024ÃÆÇ "$&(*,./024ÄÆÇ "$&(*,.0124ÅÆÇ "$&(*,.0234ÆÇ "$&(*,.0245²Æõ!#%')+-/1356Ç  "$&(*,.0247Ç  "$&(*,.024ÇÌ p…†Š‹ŒŽ’”–˜šœž ¢¤¦¨ª¬®°³q…†ŠŒŽ’”–˜šœ¢¤¦¨ª¬´r…†ŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°µs…†ŠŒŽ‘’”–˜šœž ¢¤¦¨ª¬®°¶t…†ŠŒŽ’“”–˜šœž ¢¤¦¨ª¬®°·u…†ŠŒŽ’”•–˜šœž ¢¤¦¨ª¬®°¸v…†ŠŒŽ’”–—˜šœž ¢¤¦¨ª¬®°¹w…†ŠŒŽ’”–˜™šœž ¢¤¦¨ª¬®°ºx…†ŠŒŽ’”–˜š›œž ¢¤¦¨ª¬®°»y…†ŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°¼z…†ŠŒŽ’”–˜šœžŸ ¢¤¦¨ª¬®°½{…†ŠŒŽ’”–˜šœž ¡¢¤¦¨ª¬®°¾|…†ŠŒŽ’”–˜šœž ¢£¤¦¨ª¬®°¿}…†ŠŒŽ’”–˜šœž ¢¤¥¦¨ª¬®°À~…†ŠŒŽ’”–˜šœž ¢¤¦§¨ª¬®°Á…†ŠŒŽ’”–˜šœž ¢¤¦¨©ª¬®°Â€…†ŠŒŽ’”–˜šœž ¢¤¦¨ª«¬®°Ã…†ŠŒŽ’”–˜šœž ¢¤¦¨ª¬­®°Ä‚…†ŠŒŽ’”–˜šœž ¢¤¦¨ª¬®¯°Å…†ŠŒŽ’”–˜šœž ¢¤¦¨ª¬®°±o…‹‘“•—™›Ÿ¡£¥§©«­¯±²†‡†ˆ†‰Ìpƒ„³ÍÎÏÑÓÕ×ÙÛÝßáãåçéëíïñóqƒ„´ÍÏÐÑÓÕ×ÙÛÝßáãåçéëíïñórƒ„µÍÏÑÒÓÕ×ÙÛÝßáãåçéëíïñósƒ„¶ÍÏÑÓÔÕ×ÙÛÝßáãåçéëíïñótƒ„·ÍÏÑÓÕÖ×ÙÛÝßáãåçéëíïñóuƒ„¸ÍÏÑÓÕ×ØÙÛÝßáãåçéëíïñóvƒ„¹ÍÏÑÓÕ×ÙÚÛÝßáãåçéëíïñówƒ„ºÍÏÑÓÕ×ÙÛÜÝßáãåçéëíïñóxƒ„»ÍÏÑÓÕ×ÙÛÝÞßáãåçéëíïñóyƒ„¼ÍÏÑÓÕ×ÙÛÝßàáãåçéëíïñózƒ„½ÍÏÑÓÕ×ÙÛÝßáâãåçéëíïñó{ƒ„¾ÍÏÑÓÕ×ÙÛÝßáãäåçéëíïñó|ƒ„¿ÍÏÑÓÕ×ÙÛÝßáãåæçéëíïñó}ƒ„ÀÍÏÑÓÕ×ÙÛÝßáãåçèéëíïñó~ƒ„ÁÍÏÑÓÕ×ÙÛÝßáãåçéêëíïñóƒ„ÂÍÏÑÓÕ×ÙÛÝßáãåçéëìíïñ󀃄ÃÍÏÑÓÕ×ÙÛÝßáãåçéëíîïñóƒ„ÄÍÏÑÓÕ×ÙÛÝßáãåçéëíïðñ󂃄ÅÍÏÑÓÕ×ÙÛÝßáãåçéëíïñòóƒ„ÍÏÑÓÕ×ÙÛÝßáãåçéëíïñóôoƒ²ÎÐÒÔÖØÚÜÞàâäæèêìîðòô4„ÊÍÏÑÓÕ×ÙÛÝßáãåçéëíïñó5„ËÍÏÑÓÕ×ÙÛÝßáãåçéëíïñó„‰Ì³ÈÉÍÎÏÑÓÕÙÝßáãåçéëíïñóö´ÈÉÍÏÐÑÓ×ÙÛÝßáãåçëíïñó÷µÈÉÍÏÑÒÓÕ×ÙÛÝßáãåçéëíïñóø¶ÈÉÍÏÑÓÔÕ×ÙÛÝßáãåçéëíïñóù·ÈÉÍÏÑÓÕÖ×ÙÛÝßáãåçéëíïñóú¸ÈÉÍÏÑÓÕ×ØÙÛÝßáãåçéëíïñóû¹ÈÉÍÏÑÓÕ×ÙÚÛÝßáãåçéëíïñóüºÈÉÍÏÑÓÕ×ÙÛÜÝßáãåçéëíïñóý»ÈÉÍÏÑÓÕ×ÙÛÝÞßáãåçéëíïñóþ¼ÈÉÍÏÑÓÕ×ÙÛÝßàáãåçéëíïñóÿ½ÈÉÍÏÑÓÕ×ÙÛÝßáâãåçéëíïñó¾ÈÉÍÏÑÓÕ×ÙÛÝßáãäåçéëíïñó¿ÈÉÍÏÑÓÕ×ÙÛÝßáãåæçéëíïñóÀÈÉÍÏÑÓÕ×ÙÛÝßáãåçèéëíïñóÁÈÉÍÏÑÓÕ×ÙÛÝßáãåçéêëíïñóÂÈÉÍÏÑÓÕ×ÙÛÝßáãåçéëìíïñóÃÈÉÍÏÑÓÕ×ÙÛÝßáãåçéëíîïñóÄÈÉÍÏÑÓÕ×ÙÛÝßáãåçéëíïðñóÅÈÉÍÏÑÓÕ×ÙÛÝßáãåçéëíïñòóÈÉÍÏÑÓÕ×ÙÛÝßáãåçéëíïñóô²ÈÎÐÒÔÖØÚÜÞàâäæèêìîðòôõÉÊÉËÉÌ Nabfghjlnprtvxz|~€‚„†ˆŠŒOabfhijlnprtvxz|~€‚„†ˆŠŒPabfhjklnprtvxz|~€‚„†ˆŠŒQabfhjlmnprtvxz|~€‚„†ˆŠŒRabfhjlnoprtvxz|~€‚„†ˆŠŒSabfhjlnpqrtvxz|~€‚„†ˆŠŒTabfhjlnprstvxz|~€‚„†ˆŠŒUabfhjlnprtuvxz|~€‚„†ˆŠŒVabfhjlnprtvwxz|~€‚„†ˆŠŒWabfhjlnprtvxyz|~€‚„†ˆŠŒXabfhjlnprtvxz{|~€‚„†ˆŠŒYabfhjlnprtvxz|}~€‚„†ˆŠŒZabfhjlnprtvxz|~€‚„†ˆŠŒ[abfhjlnprtvxz|~€‚„†ˆŠŒ\abfhjlnprtvxz|~€‚ƒ„†ˆŠŒ]abfhjlnprtvxz|~€‚„…†ˆŠŒ^abfhjlnprtvxz|~€‚„†‡ˆŠŒ_abfhjlnprtvxz|~€‚„†ˆ‰ŠŒ`abfhjlnprtvxz|~€‚„†ˆŠ‹ŒbpŒMagikmoqsuwy{}ƒ…‡‰‹*bcfhjlnprtvxz|~€‚„†ˆŠŒ+bdfhjlnprtvxz|~€‚„†ˆŠŒbep9¡¹ÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúû:,D^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàá !"#$%&'()*+,-./0123456789:;<=>?@[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿ $%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçè      !"#$%&'()*+FGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmn‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±ÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóô  !"#$%&'()*+,-./012345;aLMNOPQRSTUVWXYZ[\]^_`a~<ÃÄ  $(,048<@DHLOQSVX\`dhlptx|€„ˆŒ”˜œ ¤¦©ª­°´¸¼ÀÄÈÌÐÔØÜàäèìðôøüþ  !%)-159=AEIMQUWZ]`cfilorux{~„‡Š“–™œ ¡£¥¾×ð ";Tm†Ÿ¸Ñê)B[t‹¢¹ÑÔí8QjƒœµÎç2Kd}–¯ÆÝßâåéíñõùý  !%)-1369<?BEHKNQTWZ]`cfiloruxy|}š³Ìåþ0Ib{”­ÅÝð ";Tk‚™±´Íæÿ  1 J c | • ® Ç à ù  + D ] v ¦ ½ À Ã Æ É Ì Ï Ò Õ Ø Û Þ á ä ç ê í ð ó ö ù ü ÿ         $ ( , 0 4 8 < @ D H L P T V Y [ ] ` d h l p t x | € „ ˆ Œ ” ˜ › Ÿ £ § « ­ ° ² µ ¸ ¼ À Ä È Ì Ð Ô Ø Ü à ä è ì ð ô ø ü         " % ( + . 1 4 7 : = @ C F I K M O Q S k ƒ · Ñ ë   9 S m ‡ ¡ » Õ ï #=Ulptxz|~€‚„†ˆŠŒŽ’”–˜šœžŸ¡¢£¤¨¬°´¸¼ÀÄÈÌÐÔØÜàäèìðòõöøûÿ #'+/37;?CGILNQTX\`dhlptx|€„ˆŒ”˜œ ¢¥§©¬ÅÞ÷)B[t¦¿Øñ #<Un‡žµÌäç2Kd}–¯Èáú,E^w©ÂÙðòô÷ûÿ #'+/37;?CEHIKNg€™²Ëäý/Haz“¬ÅÞ÷)@WY[^w©ÂÛô &?XqŠ£¼Õî 9Pg~•˜±Êãü.G`y’«ÄÝö(AZsŠ¡£¦©ÂÛô &?XqŠ£¼Õî 9Rk„›²Éàãçëïó÷ûÿ #'+/1457:Sl…ž·Ðé4Mf˜±Êãü,CZqt¦¿Øñ # < U n ‡   ¹ Ò ë!!!6!O!f!}!!!„!!¶!Ï!è"""3"L"e"~"—"°"É"á"ì###7#P#g#~#•#¬#¯#È#á#ú$$,$E$^$w$$©$Â$Û$ó% %#%<%U%n%‡%ž%µ%·%¹%¼%Õ%î&& &9&R&k&„&&¶&Ï&è&ú&þ''0'I'b'{'’'©'À'×'Ú'ó( (%(>(W(p(‰(¢(»(Ô(í)))7)N)g)€)™)²)É)à)â)ä)ç***2*K*d*}*–*¯*È*á*ú++,+E+^+w++©+Â+Ù+ð,,,!,:,S,l,…,ž,·,Ð,é---4-M-f--˜-±-Ê-ã-ü..*.,...1.J.c.|.•.®.Ç.à.ù//+/D/]/v//¨/Á/Ú/ó0 0#0:0Q0h0k0„00¶0Ï0è11131L1e1~1—1°1É1â1û22-2F2]2t2v2x2{2”2­2Æ2ß2ø33*3C3\3u3Ž3¦3¯3È3á3ú44,4E4\4s4Š4¡4¤4½4Ö4ï55!5:5S5l5…5ž5·5Í5æ5ÿ6616J6c6|6Ž6¥6§6©6¬6Å6Þ6÷77)7B7[7t77¦7¿7Â7Û7ô8 8&8?8X8q88–8­8Ä8Ç8à8ù99+9D9]9v99¨9Á9Ú9ñ::!:::S:l:…:ž:µ:Ì:Î:Ð:Ó:ì;;;7;P;i;‚;›;´;Í;æ;ÿ<<1>>5>N>g>€>™>²>Ë>ä>û?????2?K?d?}?–?¯?È?á?ú@@,@E@^@w@@©@Â@Û@ôA A"A9APASAjAAšA³AÌAåAþBB0BIBbB{B”B­BÆBßBøCC*CACXCZC\C_CwCC§C¿C×CïDDD7DODgDD—D¯DÇDßD÷EE'E+EAEXEoEqErEtEuEvExEzE|E~E€E‚E„E†EˆEŠEŒEŽEE’E”E–E˜EšEœEžE E¡E¢E¤E¦E¨EªE¬E®E°E²E´E¶E¸EºE¼E¾EÀEÂEÄEÆEÈEÊEËEÌEÎEÐEÒEÔEÖEØEÚEÜEÞEàEâEäEæEèEêEìEîEðEòEôEõE÷EùEûEýEÿFFFFF F F FFFFFFFFFF F"F$F&F(F*F,F.F0F2F4F6F8F:F<F>F@FBFDFFFGFIFKFMFOFQFSFUFWFYF[F]F_FaFcFeFgFiFkFmFoFpFrFtFvFxFzF|F~F€F‚F„F†FˆFŠFŒFŽFF’F”F–F˜F™F›FFŸF¡F£F¥F§F©F«F­F¯F±F³FµF·F¹F»F½F¿FÁFÂFÄFÆFÈFÊFÌFÎFÐFÒFÔFÖFØFÚFÜFÞFàFâFäFæFèFêFëFíFïFñFóFõF÷FùFûFýFÿGGGGG G G GGGGGGGGGG G"G$G&G(G*G,G.G0G2G4G6G8G:G<G=G?GAGCGEGGGIGKGMGOGQGSGUGWGYG[G]G_GaGcGeGfGhGjGlGnGpGrGtGvGxGzG|G~G€G‚G„G†GˆGŠGŒGŽGG‘G“G•G—G™G›GGŸG¡G£G¥G§G©G«G­G¯G±G³GµG·G¸GºG¼G¾GÀGÂGÄGÆGÈGÊGÌGÎGÐGÒGÔGÖGØGÚGÜGÞGàGâGøGùGû ?Ø¿ð?îUÑøº'?ïÿÿéž?es?¨÷¿ð?åÕz@›?ïÿÿçjÝ?RN¨ÉßV%¿ð?ð?ïÿÿäf¬ü?b¨ܱ;~¿ð?ð?ïÿÿæ `Y?\âÁÀs¿ð?ïÿÿýíÞ?ïÿÿêCÆ?_§Ûíˆ-Ø¿ð?ð?ïÿÿóZY¿?f Vßšá}¿ð?ð?ïÿÿå6{Á?dCw=`¿ð?ð?ïÿÿèèÀ(?gBWOcÛ¿ð?ð?ïÿÿâÃ6H?ezæó¥ù¿ð?ïÿÿÿ®Æ ?ð?j˜¸ðø¿ð?ð?ïÿÿþ b?gOv…kοð?ð?ïÿÿþ b?l(')õJ¿ð?ð?ïÿþʼn1Ñ?X˜@;SÏÓ¿ð?ð?ïÿÿþ b?o®6²®²¿ð?ð?ïÿÿþ b?pÝt½ie¿ð?ð?ïÿÿþ b?kšX°ïпð?ð?ïÿÿþ b?kuêçK¿ð?ð?ïÿþʼn1Ñ?mê<è5Ï%¿ð?ð?ïÿÿþ b?mɸz¥õë¿ð?ïÿÿþ b?mó”áªÉÄ?ïÿÿíÞ•¿ïÿÿäf¬ü¿ð?ð¿ð¿¤Ê¹N¨?ð¿€µ.é¶Ê?ð¿îÀß´Tx?ïÿÿº™D8?eAêÇkâá¿ð¿éMÂÝI~?ïÿÿä?c\u{=“1¿ð¿ïý¨V“ñÕ?ïÿÿÂ|u?fˆ<•º ³¿ð¿ïÿÿûl2 ?ïÿÿ‘"¬?kˆ¶5Ûô)¿ð¿ïÿÿýàš?ïÿÿÁûvä?rP`tafÿ¿ð¿ïÿÿÿÈ3%?ïÿÿ¸yŽØ?xsaPì¿ð¿ïÿÿÿûš?ïÿÿ¿”ù?xEv2خɿð¿ïÿÿÿâ–‹?ïÿÿÒЖ‚?|ð,5¤Eü¿ð¿ïÿÿÿô ö?ïÿÿȾ^ß?|ç ¿€¿ð¿ïÿÿÿÈã?ïÿÿ¥Ì›G?ƒ3²Ëï¿ð¿ïÿÿÿë?)?ïÿÿ€½ã?€ôÊ,/F˜¿ð¿ïÿÿÿêÕ›?ïÿÿ]vÄç?†íϼ¯7¿ð¿ïÿÿÿà†Ç?ïÿÿˆÍ͵?„?l‹¢°¿ð¿ïÿÿÿÖ7ó?ïÿÿÑE–Ÿ?‹N+A¿ð¿ïÿÿÿõý?ïÿÿљ֤?œVÊ¡£p¿ð¿ïÿÿÿ×Qm?ïÿÿ€“Ó“?€ —è³q¿ð¿ïÿÿÿÌ™ ?ïÿÿ)µÊž?ZmÇÐ`¿ð¿ïÿÿÿêÕ›?ð\ˆ?„~˜ôa¿ð¿ïÿÿÿà:?ïÿÿŠþV?ƒéô½`½¿ð?ïÿÿ›îWU?†#µ¦Çê¿ïÿÿïx‡¿ïÿÿ¯#¿ð?ï±ÎÍü¿¦Éa¿ð¿ð¿€± çE–Ú¿ð_Ø¿ðŠ ¸?ð?ïÿÿº™D8¿dÙî‚¿ð?ð?ïÿÿä¿w‡þ.ò´¿ð?ð?ïÿÿÂ|u¿kÆŠ¢)„û¿ð?ð?ïÿÿ‘"¬¿`&TŒ¿ð?ð?ïÿÿÁûvä¿–8j²·ºA¿ð?ð?ïÿÿ¸yŽØ¿¨Oƒ»w ¿ð?ð?ïÿÿ¿”ù¿¯)IzĹ¿ð?ð?ïÿÿÒЖ‚¿¸).âÍŽj¿ð?ð?ïÿÿȾ^ß¿ºvĽ$‘¿ð?ð?ïÿÿ¥Ì›G¿Ã o1æ¿ð?ð?ïÿÿ€½ã¿ÀRkÕ…‹¿ð?ð?ïÿÿ]vÄç¿ÄÃ"™“ªŽ¿ð?ð?ïÿÿˆÍ͵¿ÆŒÎ;‚À†¿ð?ð?ïÿÿÑE–Ÿ¿Èà"T5?¿ð?ð?ïÿÿљ֤¿Êä> í(F¿ð?ð?ïÿÿ€“Ó“¿¿8؆å¿ð?ð?ïÿÿ)µÊž¿¿¤»H¨¢¿ð?ð?ð\ˆ¿Â$èJÚx¿ð?ð?ïÿÿŠþV¿Â uqSÇü¿ð?ïÿÿ›îWU¿Ä`| z?ð¿ïÿÿ¯#¿ð¿ð?ð¿²d‹ô…P›?ð¿ð¿{UbXïr?ïÿÿ¾s@è¿ïÿÿÿpƒ„?ð?ïÿÿº™D8?@…)È}•¿ð?ð?ïÿÿä¿C3™¿ð?ð?ïÿÿÂ|u?(t±][ƒ¿ð?ð?ïÿÿ‘"¬¿Nw² Ì•t¿ð?ð?ïÿÿÁûvä¿k×`C2Ã÷¿ð?ð?ïÿÿ¸yŽØ¿€ô­Üƒ7Ü¿ð?ð?ïÿÿ¿”ù¿ˆ@\ÊhÅï¿ð?ð?ïÿÿÒЖ‚¿Ë Zv4{¿ð?ð?ïÿÿȾ^ß¿£:Îí2å¿ð?ð?ïÿÿ¥Ì›G¿¿ Y2*¿ð?ð?ïÿÿ€½ã¿´Ã yÛm4¿ð?ð?ïÿÿ]vÄç¿Â ¿CYé¿ð?ð?ïÿÿˆÍ͵¿Äê« ©Ú¡¿ð?ð?ïÿÿÑE–Ÿ¿ÆÄpDr²¿ð?ð?ïÿÿљ֤¿È€©cK‡¿ð?ð?ïÿÿ€“Ó“¿±pd‚M¿ð?ð?ïÿÿ)µÊž¿²Åþk¿ð?ð?ð\ˆ¿¼$á3Yg~¿ð?ð?ïÿÿŠþV¿¼¤WÛ•@l¿ð?ïÿÿ›îWU¿Á»kWü?ð¿ïÿÿ¯#¿ð?ï@"ݯ탿ð¿ð¿²A÷óLW@?ð?ïÿÿú"äJ¿|Po„?ïÿÿÿzE›¿ïÿþçb¸z?ð?ïÿÿº™D8¿ð?ð?ïÿÿä¿ðÏt?ð?ïÿÿÂ|u¿ðÄ?ð?ïÿÿ‘"¬¿ð?ð?ïÿÿÁûvä¿ð?ð?ïÿÿ¸yŽØ¿ðH?ð?ïÿÿ¿”ù¿ðoœ?ð?ïÿÿÒЖ‚¿ðý€?ð?ïÿÿȾ^ß¿ðŒ¤?ð?ïÿÿ¥Ì›G¿ð*›(?ð?ïÿÿ€½ã¿ðщ'«Œi¾ÐÒ;ãbÁƾ´.d¾è =¾Ÿ­‰TPw¾“t e³d¾yk=~¨­¾pñdˆt<þ¾)¡Ï(’Ž:¾NÏ%£»Ð=¾  …$ä½ãähkp´½ÁˆŒÐ#¤‘½ž¶éÒJç¾Wî ¢i]ì¾T8ÐñŸ8¾5µô‘J[¾3šC™QsJ¾’‚Æ„fP¿ð?ï9ä´äšD¿…Ú¬¨zR?ïÿÿÿE~Ï¿ ªp 0m>ÉÈyª˜[?€=ïüÂí¾Ò*Ðv<ûé>Ñk°b¼¶ø>´çdò> g5&$Ö>”(O2á¿÷>zV¬Y‹>qŽ«€æÌ>*°¹Wò”>OìÃ!Sƒj>{TÔëÝ=äœsS¥S=Â*{¸­d…=ŸÐÝeµo>XËyGb >Tô“°­Ð>6~Üè^»>4P,¶£n>GACþ~¿ð?ï9ä°hp¿Rœš?ïÿÿü ¸>òq¡øÀϾœ6²J¥àá>¤‰x2ú?U¨¬­œ¾£JŽ…ûÐ`¾‡$¼ëƒìÓ¾r*9˜8¾fM¡óà¾M$±?÷9ü¾Cl«Q“d>½ýbæ06tà¾!©KMD½Û6¢¾¬½¶Î„U7x½”x+§ê½q›†&>U¾+o·ŸÕü¾'/IlKê¾ä`é{ûݾyMÜÌÝv½æpðz–•û¿ð?ï9䴛Œ¿ŒEm„Èòï?ïÿÿÿÑÒ ¿,Ä’ýH–÷>ÖAÚx|¯¾ß[©Ú–¹.>Þe3Bó?`ûA!V1>ÂÁ΀Ë>¬Bõy´ÖF>¡j?ïOH^>†Àil™Ú>~Xìÿ#ˆ¹>6ôz¨>[•«~>&¢]Û¸¾=ñÏûH¦›=Ï_d¢›=«u(L=‰*>ej½Ôt >b…q…¢>Cntïòºë>AŽã¾>!‚Œ§­ë!¿ð?ï9䩺øÍ¿”$¦fª¢?ð¿;çÿGäP>åa¡‚ tľîiþu>ìùöƼž>ÑjthÄ?K1ÐYèÃ>»IR¬Ãª´>°î›Œµú!>–Üú©¤ó>‡t¨!€>FVåÈà|>jÓ.dß>$Õ[³òÕ>Qoâ3e‹=Þvy-þ²G=º  °Sâ>tÏÓÿ_EÐ>q Ç“ ö>Râ/V\£Å>QŽ~>1U˜qÄ¿ð?ï9äý>o¿šŠšQ~?ïÿÿÿR–¿C‚‹n->íÜØ<¾õDmÊñ"°>ô]Ðæ¢>Øq¨_»¶ƒ>Ã,É£\g?]lµfåèk>·ž)žÚ÷‹Û’ä>”“…áZq‡>O ì+{˜÷>r´6qU’>,®ûé™ñ3>&œŠ^§(=åF€uŸž=Ÿfæõ¯>} ¿_«‡>xJªuue>ZZ\Q³ ;>WÎ>ï` Œ>7¿´Ùv<¿ð?ï9ä‘Y:¿›Iç‹šhê?ïÿÿÿÍøã¿DŸ Ö!˜ò>ïÒӧ׊¾ö{‡—ÂH•>õ„±kkÆ>ÙÕ(ZŒ|Ø>ÄC7…eβ>¸÷ñfËŽ?Q%(³Ab> O^ðØáÖ>•Á8"i>Pt¬X:G–>sÆG)U!s>.S,¥ T> ˆvd&mí=æ} ½'™¼=ïFºóm">~´êö¡wŽ>y÷tr±>[Ü(I¿ïX>Y+@ç¸ >9þžƒ2Ä¿ð?ï9æ„Áœ¿ IƒU¿?ïÿÿûk;Á¿JJ\£žC¸>ô†ûv¹¾üª›ö™>û{r›{1‘>à|ô¹è|´>ÉàÞT¸î>¿Í[°è>¤ÆëÙÈÑç?aHkË„ö>›³M¯ë—D>Tô;ÎX>y/ úe/f>3OêÄF>BpŒKÓ=ì©@_€%=ÉX =>ƒPFž)>€‡ûðö¨>a¾í.£KŒ>`C1ò >?þMдæK¿ð?ï9çxª9'¿ »Ó%ÐÔØ?ïÿÿöŸÄ ¿K—Ù€¨(¾>õ«ªr¾þ'ƒpã?>üØì ¨>áNxoÀƒ»>Ë)å;Ea>À¯Í¾îÜb>¥ÍæCÖ +>¡ÃN6(?cC»H#">Uý v/‰ë>zmÖÍE­>4D4Øt\>3¸ŸØ™=îCkY—=ÊWjŽƒñ>„†ãX\Ü>YÉh¤|>bŸnèNWò>`ÐíbÚ¬ >@ɷןÓ0¿ð?ï:½M~Ç¿§gbFo…Û?ïÿþUþ0¿¿TÍJ]Æó>ÿÒÂã輿ëóB©B?Á®r¹žò>êV…€ê>Ô}n ¬÷>É&C¯•üo>°nÑŽŽÍø>¥é]Åg»«>`“]=e¥‘?ZzÒ<“è>ƒëzø/%ä>>h§m8 >¼Áhâ=ö°X³=ÓàûÜ¥eä>Žóâ¹ÄØ>Š*qª C¢>l&´$›ù>i\³âɉ>IR5qòq€¿ð?ï:OgZ¿¤ygÑ?ïÿÿËBh׿Qn'ÍÀM>ú¦9ŽS¿1÷sFØ?9Ž¤ô^>åàÄJ´>Ñ*`îùº>ŧso>«Š\ú¦¯®>¢\D’1£ß>[Å®8ë->€±£®ô}?z:ǘ f>9›Øöïô´>Y0ÅÊ2=óÀ‚S|+=Ð¥q§áZ·>‰ðQõ>…ìÉ3Õé>g†š®±>eA?ø ×>E8X8³¿ð?ïL Ëú¿ª±t{ ¯?ïÿ÷Çzà5¿W±ëš™Æ?ÈZbt»+¿ mă ˆk? mÂm[2>îWTYó¨W>×édªaݧ>Ìåwï±í>²ä4 e6>©mÆŸE >c7QR]µ>‡ {HjÌJ>A—5ƒÌ÷À?x¨š5„îu>óœß=úgo6T{=×Bõ-î¼>‘üìi{oÑ>ŽiÖrÍï>pJR„‰¡„>mžh&°>>M&1‹ÀŠ`¿ð?îrrÎt¿ª=§Ã°ô?ïÿþ¨JXT¿UsŽ‘™uÃ>ÿ3¸5à2"¿3¸ë¡Ý?sŽ>èX¤>î:ö–&[>ÕsŽ:î>ÉZÄ“¼>²†µpÍø >§fÊRÅ^d>c„gH<`>„;‰‹Pð•>@²­©Ne½>û³0ð$?x7‹ÊøêÁ=ùZ¬äC=×fÊ t²†>“yç@ >Ž:¶¢í>m@|Å3ôH>n:³?åà>L…F`• ¿ð?ï“´±D²G¿­b‡‰·3?ïý§üÁNè?.ê5s?’±Q[>ð.×æëÍ>Ð.Øólû>Å’±5Zõ3>´9†#ÚùÒ>ª÷]‹jky>Z÷]„úÎû>‚à[)¼Á>D9†&pê>©³®@Õ=öëÜE?í‡?xô+Ö´ì=âŠBç¶>©³¨(f7>’à[žf>hEZp‰x>tæ¶óG)>A‡/÷a¥F¿ð?𿕨3¯5?ïõ܃‰0]?e‚ i©u? e‚¬’ð¾ì±£Ž¢ZJ¾Ðe‚ (¾¾Ä~â‰ç×¾‚r2GiŠZ¾¬±£ŠUa?wæËUUç侤~âˆG¾e‚ tô¾j¤óS¡îQ¿ð?ï:ªÅ™Ý¿£Ý’¢vŸ7?ïÿÿß3š¿P›À)£È>ùc»è)R7¿Fóy äÛ?Z×XÕÝ >äÓÜO›¤>ÐWº3à}¦>ÄIE·ÐŸ>ª;'©Š>¡|ãM¯•>Zup-E>Ë}lPßÑ>8aÍkæ,L>ˆi«:[5=òöc,åb=ϳn£™›->ˆ³Gró‚ß?{#–2I ±>„ßG«V¥>fgZc®Ò>d;a±;‹>D2ÊO.:¿ð?ï:Ebf_i¿£Ñ]©ai+?ïÿÿÌYŒL¿P•‰¾.Ï>ùCVj–¿Gñ­¢lZ?Gn8’Í>äÀ#i'ü>ÐI6üé;ô>ÃÿQÞÇË>ª#h±q{>¡k¹jóÊ>Z\eÂ;¿6>­pô䶜>8K°¤Ï³p>uòÓ¬#š=òa殯=Ï—ÕÇ x,>ˆœBíUfc>„Ì*OR€x?z˳ó‹*§>fRóÊrF™>d(Ë'»þp>D ¤K}ÇJ¿ð?ï:0‰7ª¿¦å/Ê»É÷?ïÿþ„⨋¿Së—\d‚?>þ¦‰ ̼f¿ÐW!´ï?çž Šç>éŠojo>Ó¬ˆÂí×>È,±I¾ü>¯’u§OEã>¥xÎ÷èg>_×õv…Œ>ƒfʦÁÊ>=X_’’…>·¨N~¾=õÍuìÐ=ÓFövŽ/>º¡Vâõˆ>‰#ít”¾‹>jø³q%4?y—µTh4>h]-Ꜧ>HQ׉Ë3ð¿ð?ï;{ó¿6ô¿§¢«t@¹?ïÿÿø4¿SÓÃõBVf>þ5,´Nf¹¿0Zú+HÌ?´°½ÝÀ>èáG Û›>Ó„£ ¥>Çô,äq>¯Qçñá™t>¤âs¯zˆ>_–vý s>‚ü|œ€@@>=%¦,qú½>‡³ÝµL<=õ¦fbõîŠ=ÒöÀ’àe>€'À8v…>ˆñ) àR6>jÂåš´3B>h7½W§v?yEgŠõ>H!¿÷‡ÿ?ï8 v?¿©‹¤W\R¿WOkÍfò?%ǧȸ¿ ˆÃÕ?é?Îk8é‘>í‘fÕ³ßý>×'[áç!T>Ìe 4éð>²‰çô³R>¨­Ý“ò¹é>b¶öîïâŽ>†‚,6U>AAÿ´÷¡i>=¯Ov=ù·0’s=Ÿ=Ö„ªÿëò¡>‘{‘½Á‘S>›oÆït>o¤jòî>l¿)g9øA>LƒƒõBÈ?xë¨m…Eš¿ð¿ï9äجÅ{?ïÿÿÿYý¾ö%¥ç?Øð¿Y†2êοRä 8ŒZÏ¿@}D¸¾ìÑ‚¼T¾qšÙΞ¾#Qföè½ü†øÄQM½Ö .ª½±f+ x;|·Á–оxXÛ}Ç¥¾Uœ–cXϾS¤„"Ž;¾0†ÉÑ›‘·¿ð?ð¿ð?ÇŇq!Å?˜Vá/’"ë?º¸<‚92?’4ýE{|?nÕHè?T7€”ö8a?IYÚà1è¦G?¾ryuTƒ>·–ÍI*>“cÊ-ðM>pq€Ô †y>L"~®=KN? wç~ í?x›®w È>æŠe/G#Ž>ä¢>šàn>ÃcÌ¥ð<¿ð¿±3%Ó@3S¿ð¿ð¿ÈT༮ÿ¿o=Ö²Îo5¿¥Úa…>gr¿gK]°ˆQ¿8í9.; Ï¿XZ ο zFA¦R.¾çÃôp­I–¾Üì¾|x§‡¾~Kc2ºþ¾¯>Â<ö®S¾I’[ü²áS½ùÎf,Ãñ=ö3Ï⼓=â¿ñˆÂ5¾»f2s«¾·[Nî a¾d: ;‹+=-üT¾YçI'9eW¿…^Iÿ¸¿ïÿÿÿk´?ïÿÿîpÒ?ïÿÿõãü?ïÿÿ‰?ཿ­Sëkì•¿¨ó1݋裿ð+ç²\?*§>¼³/п|Ž®¼Û…X¿! ¶Þ>r¾aÈéN¬D¾À÷¼D¹¿©>È6åáEœ'>¦ù|_ëu>©É'ÚDLÙ>^8áb|š>~ƒ -\|>1^ÖºR¬Š> ›­¡Wí†=ËŸµ·»t½xÌ!»ü4p>€Ùö5d4>«ÿñ î>[_1¨ø >f×÷¶Gp >'£WeP†õ¿ð?ïÿÿÿ:9°?ïÿÿþ ¬¿Í‰L¼$ê?‚¶Xw¿èÑ O\ø¿µò kÃ-Ã?Rž a‘>ÒÜà‰£¾Ãø?…æ,4>Š®àÒǾª&Â(ô'5¾€í’n†:ô¾ƒñ”C:û¾&R«Ä¯q¾Iø¸ø×–=âSÂ_‰O¶=Ï¡Oëj†=Ê”‘¶ =¯Ošã¸(c¾C¹ìº}`¾bŠVåàƒq=ûÍQœ5Æ—¾2ôl5‹J>˜HÔN+¿ð?ïÿÿûý_?ïÿÿömv¥¿¼}1´Kó¡¿+í0¯7?ˆ?¤l¿pà×mü©¿ÂýnÕ¦e ¿(CÂB™¾©z[Ò„Úɾµ:ßPÅx>»®å'»ÊÎ>›„Ñ;|.x>ž™o´3>RãI¤“…l>rú„÷õŽ›>'²j™>\1 þµÌ=ÊRM&ÇúA=Ž`½Û$l>uY§Ï˜ÀÊ>ðvCaé‡>R© ‚í>\wB­æ §>"fÌóBâ¿ð?ïÿÿÿÑ®Þ?ïÿÿöQ8¿ÍB k2m`¿}óM°Z¨ >×É^y)´Y¿RlÓ¥ünľÿY·BSš¿‘> 0Tw¾´cªŒ£¾š~rL>”¦IÌ¡œÓ>{k#¸4>}Ñ’ò¿>7…¦2Aee>Vêpãg})>ÙǺáå=ïvØïéÎ=ÃÚÈ¢!wJ= Ìñ†t>[ŒfŠÔë;>cVxkÅÔ>;4òüÔ>Az†×¦•·> ©—QíE¿ð?ð?ïÿÿ÷>^ä¿ÔMÝ€ègL¾ëH†î4å¾ô€ê‰X9¿·§VÈmú¾à¬ÌêŽ$¾®ýÍþÞkÔ¿Qƒpºá2¾q…4ZáÕj¾z†ŽÕž1>¾/ÇÈytϾ-úµrfÒ>¯*\EÑa>,e  QΘ=÷ Ž”› =Ö1ò˜)É=¸só±‘Cï=—ÏCBåü>6žôŸˆ|>"§Æ‡í­b> ¹$d¦¼ã>VÓëp©> †Çûµ¿ð?ïÿÿÿЧ?ïÿÿ÷š¿ØUßQmBL¿dßH´·¾>ØEYfRs¿8å˜G4} ¾â¾…ägì¾3™ 2À­¾€b÷$*E›¿F#û½Š&E>€óKR­Ä>cbë\Ü>eì‡vëa>mgΆ€Q>=?™o¿‘=ôFšð¼'=Ñ€Õ À8=¡÷sÙdÜ=vma‹ Žµ>@ê)Î,›)>Iù~«e5‡>:láW5«>&!¼ÃuQ=ôa:Œ¡ÿ¿ð?ïÿÿÿ÷z’?ïÿÿöâ&-¿ÙüÎöÀ‚ß?y×›ØYf¿˜ûûü™s?L9Ê:þ=>é¿iï ¾¤OÍŸÚ>4Ï“˾Y±À•¥¿.¼¾íl¾wËï QÀr¾{8ܬ+·†¾)¡³¬ؾJÀ>‰ÊüʽôˆÊû%z½ÍšT_õd,=¢âGfF=†ð¾@ú¾K=F_­7¾];øF‹¾!!q_](¹¾3®Þ¹nà=˨Oà%D¿ð?ïÿÿÿÏÂI?ïÿÿö@˺¿Þ,Kh"?wÕ®Â+|Ѿùå+ò¶ÿ‘?Kð¦ý?GK¾Qr¿½:š>3ã" ¨¾—6}|Ræƾu᧔qø¿ðö æؾx—4\ØÍu¾,˜¸è±¾Læv¯¨êK¾F¿§$½Ú¿|‡ìZ罘 ž“Å‚¼=TS5FH'¾OÕ+ì]E°¾\7æ/9 €¾)¬¸´= 2¾5Ÿa£Ôâà½õµ¡Ò/¿ð?ïÿÿÿÁw?ïÿÿùISm¿ß®/?–Xä?…´Š€Î‹¿ ”Jüâv?Wÿ¶¡ÿÛ(>ü•*øú(þ¾‘åÞnYr>›ïœÅ¸Õß¾¤ã‘‡§Ì¾ƒZxÝc¦¾…ËÞâï©o¿ÀdQß¾8Ѿ?>ѾY(,6Ǿ îÂᇽæj¶EhŽŸ²_ÆlH =sš3Ê1|E¾[ƒIÔK›¾hÒ¾ì’ξ5Å*€ß詾BËeer7¾¹H+OÅ$¿ð?ïÿÿÿªÄ?ïÿÿ÷ a}¿å]¼s.ˆ8?ˆÆ¹à`¾úØ<’c›?]©©UÔhô?§\{¤H>³©üž"U@>£tBúù?&¾££ÝœmZB¾†vd n—ö¾ˆË Ôþæ¾A(<Êб¾¿ú›Yzoo¾a=*`ZÈʾU:·^9U½õ‰´Áüô½Æ%Iô!²½œ]:œñÔ¾dªàц¾n¯+0†:ý¾B´vâ@SA¾J&ƒìÀp‹¾ÕÊ ²®3¿ð?ïÿÿÿÂmg?ïÿÿôš¸…¿âƒòÆhþv >åú>§RKê2í>šÁe³)ð]¾œöC:S¾¢õäÔ¾}ˆøȾ8<ßüä¾W¿v濵9‹0[¬¾N…MøT½ì3vÎd½»¾*lØ/£½¡¶…0 ¾[ƒéŠ¤e¾eeVÃ.?ʾ9&10#s€¾Aø„Š†/}¾I_dYJ¿ð?ïÿÿÿ¢gq?ïÿÿû,ù;¿çóx8Q÷ƒ?óEf€ºX>Ûÿ.Àý7?VÍßÎ9Á?£Ët”ÎE>Á@cqüx>¡Ÿ8øþ˾“÷¨ºmB¾€:ñSqÏó¾k’çÿã¾>áFZ6ZÙ¾]µîK‹Þ¾7 ü¹àœ¾¸s¤±†½öŒ‚Ø<¤½Ðµ–ýÝ÷½©Ï!´©ÂR¾bRëZ'F¾gÓ_]¢¿¾CÑXÓÐb¾FÑ1\º¢ô¾ÆZ[æ9¿ð?ïÿÿÿüùò?ïÿÿó«ù¿ê<’5ðÀÌ?„f9•W¯>ðTµNl¦?YàTγ‰? Ø~ ’¹>Æ}\I\)–>£ãKî±¾“}Ÿ|p-E¾‚ùÒéǾƒ:âTSª—¾Bá ’TȾaNäL¾‰Kü:'¦½ûy2vƒîо‘·ÕãUè½Ôl¥Fî,H½°áÅJ7…+¾ežq?AWð¾k:Tý@;G:s»›¯¾J«Rçž¾#ë‚ÁðU”¿ð?ïÿÿþñ…(?ïÿÿùÕf¿íYt5ÀÒ?hßÀ XäØ?§!:øõ?F™¿Hšß?d ,3²>ÏóX õÝQ>šUÿLì>ŽÓRÇ!´j¾dì÷|a†]¨¡…о8‘X½XÏz¾V“ØSj¾ýRB×ý½úZü2‹½ÚØM†Y¾kqêç†åý½¸bíi¾_ƒ¦")-×¾Xˆ­ù»æ¾DŽ#Ä÷‘c¾A™:t(k©¾'»Ï‡_¿ð?ïÿÿÿ Õ#?ïÿÿõ¶ˆ?¿ðרӿ<»1¦‡Äo?c¿xPr?0s5ó9H?ét& >Ó‹+ÏA>”çXƒÛ >¡ÝL§óÝ÷>FëÐÄ}Ê>[ž~‡Øô¾3ÿìÎõî¾PÐDGÿSU¾¨òf-ŒV½û°Å¡…*g½ÞÿÚ-qo¦½¾OÆøܹ¾E£…{ÊÆñ¾[fqÈdH¿¾BÓß°§Ç¾Dº‘¥jµ¾;ÔÄ*`/¾*‹ÂêÓ¿ð?ïÿÿÿÆiÀ?ïÿÿö»Í½¿áÓœÙÉRà?wk¹Þ0s¾ä2oAÁ3?LJY9#É@>ölÞ}[„>¦ÅžCØõA>“òüŸ<Ǿ‘ÔxÒ·¸Ï¾u\QÃÔG¾wtWüýE¾1.¦*bÇľPÝÓ·†¾¨ÿ¯¬Ð ½å|#Ë!½¸G?cº*‘½œÜʗǾS㦟*®¿ÖU;_¢å¾]yè±}†¾2å´+ªg¾9¡I3˰Ⱦ e‹8Ò›¿ð?ïÿÿÿ±?[?ïÿÿý,…w¿âu`ÂÏ?ˆZ¡ œ>¿oŒ·éë?\:ùqZ?›Mx'ÓY>–.““y”e>¡K^iQv¾¦kðóF+¾†TcE/©¾ˆòš;$E¾>ÞgcÛµT¾^ð HÀÛ°¾èb6eÉؽﶛàƒ½µê‰¦}·g½zô#>Ù ¾aaýÊpz¾mLŸR¨ÇU¿°7Óv×¾=‰cFŽáI¾G?í²€iU¾P/s ô¿ð?ïÿÿÿxY?ïÿÿ÷s¨¿äx?T v?yE4£µŽY>à si¡M?OØ׊÷‘>ýq»Ì·=a>¶\UM3>—jK† hp¾ËïÅÌxоvä'½iœÕ¾x¨Ìï­7¾5:¨ ÑɾT{£é90é¾ AN„½î`­€Ý/>½Å ÂŠß ½ ±”À±9Ö¾YD´¾`£ƒHK"¾9ÍüQ5æw¾ë?ÏÊ¡@ª¾?iýI ~O¾MÍ ÈÊ¿ð?ïÿÿÿ°I?ïÿÿû–ª¿äœzv*hæ?‡:ðýŒ™é¾ûl<°5F?[µ{LÄL?Ø¢Á~%È>±,Sq‰® >¢(©q‘†w¾¢Óz¬÷Ú ¾…4þÖ)»¾‡j3\½ãç¾@NøiÖ)m¾`*ZÄþ„¾pÀÖÿ»ö½ó^ÏÃÓ=½ÃÐx¹Âàˆ½˜¨´ï~³S¾b»‡fŠÙ¾lÐÆÉDÊQ¾AGg휾HdêÂKâ¾è»†çt6¾Å‘$ay¿ð?ïÿÿÿûš¿ç?Çë°?lˆ8hk?e¢Ó¥}?E$e‚@€>ý/!ÄÒ«Õ>ÂdI6QD~>“ýß­ZN>_¬²ewe¾i¹äA8ž¾hÃ@¡ã”p¾2oXϔʾQ 5ª¡Ø¾’ùætØͽñ2çUÙLŒ½Îè$A6™õ½«ó'Ä畾VíW¦¿}¾VRfh'c¾;‹Ñ{nZ­¾:À²òv¾Athv è¾Ä?Ìn?ïÿÿÿeË"¿ïÿÿ÷‚Cù?0±òåçJ?X±7šô>?’¼@*ÔÆ?S÷ÑY/hg?%‚¦]ˆ?“ K$>÷ÍÂꤣ¡>Öx|zŸ†b>ËXÛ¿dßÐ>tw fáh> ?Ì^—>HÕÝ6¨å³>A…o@p=ôïjš´Ý=ËcåÀýD>®ˆp,òƒ>¨µÏ,Ž>‚G²“6™l>€Ê÷·‚±]>W'¯R ¿ð?ç«X#ýL¹?ð?hsôlË?ð¿ð¿¡iñ¹ª×?ð¨²f¿ïÿÿÄ•Ò?ð?ïÿÿ‰?ཿøÀ*›í®¿ð?ð?ïÿÿþ ¬¿Êé`£cR¿ð?ð?ïÿÿömv¥¿´=×±Ú¿ð?ð?ïÿÿöQ8¿ÊVá•¿ð?ð?ïÿÿ÷>^ä¿ÓSç›WÑM¿ð?ð?ïÿÿ÷š¿ÖŸ!Št+‹¿ð?ð?ïÿÿöâ&-¿Ø¼¡iOi!¿ð?ð?ïÿÿö@˺¿Ü…þ"×æ¿ð?ð?ïÿÿùISm¿Þ”lîÛD¿ð?ð?ïÿÿ÷ a}¿äÆè ·¿ð?ð?ïÿÿôš¸…¿á~§™à¿ð?ð?ïÿÿû,ù;¿æÂû?-”Ç¿ð?ð?ïÿÿó«ù¿éqãÙœ69¿ð?ð?ïÿÿùÕf¿ëúò:þM‚¿ð?ð?ïÿÿõ¶ˆ?¿îˆÜœŒf«¿ð?ð?ïÿÿö»Í½¿à±Ôò¨¿ð?ð?ïÿÿý,…w¿àõC¥ûp¿ð?ð?ïÿÿ÷s¨¿ãMÜÙÀ ¿ð?ð?ïÿÿû–ª¿ãr•«bÕV¿ð?ïÿÿÿûš¿åÝfC÷Œ?ð¿ïÿÿ÷‚Cù¿ð?ê\›Ôÿ¨¿ð¿ð?fBgóÎ?ð?ð¿¡3òõ‘6*?ïÿÿĀ೿ð0ÚñÜ?ð?ïÿÿ‰?ཿïÿÿÿ–?ð?ïÿÿþ ¬¿ïÿÿÿÝ£è?ð?ïÿÿömv¥¿ïÿÿÿØY?ð?ïÿÿöQ8¿ïÿÿÿ÷Àð?ð?ïÿÿ÷>^ä¿ïÿÿÿÿ ¶?ð?ïÿÿ÷š¿ïÿÿÿüJ?ð?ïÿÿöâ&-¿ïÿÿÿÿÜÑ?ð?ïÿÿö@˺¿ð_Ø?ð?ïÿÿùISm¿ð¯ì?ð?ïÿÿ÷ a}¿ð/L?ð?ïÿÿôš¸…¿ð??ð?ïÿÿû,ù;¿ð ^˜?ð?ïÿÿó«ù¿ðœh?ð?ïÿÿùÕf¿ð!¬,?ð?ïÿÿõ¶ˆ?¿ð(‹d?ð?ïÿÿö»Í½¿ðÄ?ð?ïÿÿý,…w¿ð?ð?ïÿÿ÷s¨¿ð??ð?ïÿÿû–ª¿ðoœ?ïÿÿÿûš?ð¿ïÿÿ÷‚Cù¿ïÿÿþã€Z?ð¿ð¿ïÿÿÿÁw?ïÿÿï †4¿ïÿÿ†xª¿ð?ïÿÿ¿¿û¿º7+#¸uŒ?ïÿÿÿâ¹»?¢c/˜È*•?Ùi¬t¿GoF&?]P:æá³Æ¿P„£"° ¿2§=w@HS¿ßPœE€¿¼VG}ø¾ô¦ãëQ¾êøž×›Ò¾¡‚“‹²ë)¾ÆÁ/ú¸<Á¾~›Yýî ¾WdŽº'¾3å+’uK¾¢[Œl ¾Ò¬íÚ£¾ÎZ‡²gú¾®k´ý²¾«eÐ bﾉs)Ûÿ¿ð?ïÿÿø`Œ¿Â˜ež 1?ïÿÿøfz¿ ° ö>Ï?E@êOl?ð,7«^Y¿Z›Aqé¥A?Mô<Þû¾?0ÝU$7{é?3ld¶?@³î>ò©Õ¤8«T>è`“ú¢&7>Ÿ¥âZ¨i/>Ä!½zZR>{›wŸ>U#Ža à¡>1E£{è#Ý> 'p®ÆÅf>ÐRLÄ WÔ>Ënß—`>«}vÂü<>¨Âi¡ýò>†ÿn8:¿ð?ïÿÿÿ!Âß¿¿°ÌŠ®¥?ïÿÿÿ½ó?}<ÇF!h¿"¸-G縯?7Iö-“Û’?ãXu«Cò¿*o›\hœg¿qÑ€²ÿù¾ö¾”n ‚¾ë_u1S,L¾Ðç)4l„¾Æ 'ì÷¾|©üÒQWh¾¢ œ HÓÖ¾X‘ ܾ3'ÁÜPQ7¾JËøÌ©½è¢ã‹=®¾­’Ç#/0¾¨Ô]ߌêB¾ˆèr s×¾†lÜǪ¾dÕ’Ö(à¿ð?ïÿÿýÑr¶¿È+¢ÜVþ?ïÿÿýáªx¿­ÕÐÐ4ˆ?RóÞ.»¿g˺iIÈ?Z°aõyÍÏõ±>«Þˆ¢å>Òç“)¥A>‡Þ,†K">b›ÿì>ª>>jLqYã>.vàñ†˜>ܽ^4ëz,>Ø)áG˜,>¸3ŸÀð\=>µÍ0oþl°>”?“2’Å¿ð?ïÿÿýÔd¿Ðò±ûZq ?ïÿÿý·C¿½ˆ–~±'ú?bËÛðþò¿w‹ÍzbÆO?j|À:Ã?MÂ=Ia*%?ÐQ_GÍI«?6;Èø÷Î?*®ÄÂŒÈ?uþys?€£ð‹«i>»éÃzFE>â"Ъ0‚8>—é:·ZuD>r¤²Á]”>Nwíê1>(êÏKû¼>ìÊ5Ì›±Ð>è2ƒFqu+>È>´~‡‡k>ÅÖd»T©>¤H‰j­w%¿ð?ïÿÿ{{«¿ÖimXÃ]?ïÿÿ{{ÎA¿ÄͯÃÀ|?j€–áã0Û¿€”¸ã¼5?r®^bƒ¿?U¹ß|??|ûHoËŠ?⸇ö€è¯?2çTn)5G?S×dýh?w‰ˆÛX6>ÃÇZ<®³¹>é³ÏáÈÙz> ñ¼C"ú`>zlFs`>>U–Æs™÷>1‹½K†¡¹>ôf£•žp>ñ$½Ní¸$>Ñ.C&´Lc>Îòw”0Ù8>¬¾ï3á—U¿ð?ïÿÿYÑÕc¿Öþ²¡ à˜?ïÿÿYÑÕc¿Åý¥ÝTÊ?l®Nè¿¿‡¨Ó»uê?sÀé–Óg?VHØŸ!ÅÖ?@¦0¾¢?3ý¡'¡ý?Ö.#-ç;?«S ã?ù?Ø8C>Äê•Psk>ë.Hêà™>¡ë=ì k$>{ñ`XQp>VÔªØr”¸>2Œ®D-l>õ“!D“>ò!!ïþ·¤>Ò+?á`Ú>Ð]’:!>®f7lÐ’¿ð?ïÿüµ¡Q¿ÛXVµÕ‡ÊÃØÙ~¦>ñc÷Eö¬>¦íÛîaZ>à¼áü(2>]6æ*‹Î>7¼6u–« >û›nEçz–>÷2àåŠ*’>×?ô,ÕŹ>Ôðd†9¦>³síâÞ¿ð?ïÿýOrH¿ÜÚ‹{…?ïÿýOrH¿ÍŒ2̱©>òB8§IÊð>¨ j‹'>‚Åm…îÇÉ>^¬€F-ÍT>8ë܃Ãä>üüo!´‹ö>ø[\½Çn•>ØiMXšHÙ>Õü_ú¡>´kÇi§8&¿ð?ïþœ»vúQ¿ã‹I­°a†?ïþœ»vúQ¿Ö^7{Þë"?|­¶¾e7|¿‘§ÂŠM?„-ÛBtì?f¿Z.Ž?Pü}0z?DiC_빉?)+“—Ü? pPq(¿?>ÕY³áNU?á ˜Ëœ>û½BlÕ%>²EPSX—Î>Œ~§bŒŸ‡>gI,òY>Bé·Ð× ‹?gFXS€?}r¿šíV>⌨ØLòÏ>à®›<0ë&>¾øo›[|¿ð?ïÿ¨ýxq¿àÍn/ˆ+Ò?ïÿ¨ýxq¿Ò»Xe:1³?wããø½Á¿¶Š´-Ï?€Ö4ëB?bþñõÆK?L]Ä:5þ?A‹/‹Z!?%äÆ-Kp?tjŒž">ÑÔJ©eð‰>÷'Õ ZrW?î¿m/Zp>®„î©´+>‡ÐPöIª.>csŸ„X;>?–½B]>¯?b7솬Â>þ䵿¬ŒÜ>ÞûÈó5ÈO>Û᱂‚>¹â”ø7‡(¿ð?ï÷<$ ±¿æ8Z‚z”¬?ï÷<$ ±¿Ù˨ÊÄõ?€l;'Rö,¿’ÄÕÏ÷¯Â?‡Á½Ú?j¯à‘÷™4?SÞ^À}¤Ü?H 2}Ø8Ö?-éµv䋺?#¦HúyÂ>ÙpÎj+8?F±Ëa~²>µ_!ö=À ?ìöž‡t‰#>ÓvÈ4³>kOi¿®‰®>EõH#ºÏ ? Rwéð?{I2…Þö>æeå²ü>ãË™÷ÿY—>Áãœ32:n¿ð?ï–ˆÞÊå¿æ¡=ìíÙá?ïš6éê¿à½im–¶ ?„¹ Œƒû?––¤æ?p” (z ?WP1=Z‹?N UúïW>?3+.kÕ?'P1 2ññ>ßš7»Y ?û_[KE>· àÙÉÉ>”4nǼm«?ëÀRz3Û½>pk¾˜ûl>G’¹ßÄ?kÀ4Û?YqË«%c>ì~tÛîoÊ>æ >Ü>Ãò“ã9¿ð?íµÞrE¿ð?íµÞrE¿ðS&Œ?‘Ó…yl"ì?—ı÷Ê_?t̽ «Æ?`W:^lý7?WIJ6¦?:½H?¶©1?6Hfâ;—Ê>ê½HAðüJ?OÐœÄ/x>‘«‹QØ>š½H>qt'>{{mÑ/Í?ë›á©/f.>L9“R²ô«?@ý ÆÕ~? ½H;žò>÷Œqµ*Ç>äÌ»ÒðÛ>ÐW:_ÒËc¿ð¿ì)ä¬W38?âӳѳgÃ?²Ó³ÓI ê?’Ó³Ö×Ĥ?rÓ³Õ"š0?rÓ³×æ°?Wˆ Î.èª?Gˆ ÌüÙ?.*Sžõ¯?.˜A3 >Þ˜>F"ê>µ.*QĤ>Œ=ÀÛ¥^?êâjwi÷?9ãK—˜Á?"Ó³Õ$‰–?Ó³ØËÌ?y=]sD"¿ð?ïÿ¢>òï¿à¬ƒÁÿàê?ïÿÞÕ:¿ÑÖÞ7¦?v±$N\ýÚ¿ŒmM/©6ß?€SÁ?b_uÜh?Jÿ5UW%ç?@6í®‘Î/?$Õ:k•? vˆèŠá>Ð÷ŠL>ö FnÇd>­[vXw>†¨úð:ÛÛ>b„]À:"8>>é]ÇðÈ?~úM¹}?浪÷èɨ>ýeG¥òlY>Ýy˜ŽÏO>Ú‰ˆS:(!>¸¥G뼄M¿ð?ïÿýšD¿à£ùÖ(?ïÿýšD¿ÑÁü›Ãð?v´¬ÓèÅ ¿Œ+ï¿% ?øŠ£YÚ?b"ÔR?Jí­p¿A>?@+à¬ãöÍ?#óånS?QÙŒ[>Ðëj·Qù>õúOÄÛ>¬øø”{ÿ>†—'Ý5Ë÷>bu?L÷ >=ý/²*ë?rxÿ¶Â>ýR%ãá²?ïagˆås>Ýc¢è)ÿ>ÚveÜï\_>¸’Sã¿ð?ïþú¸¾Þ¿ã#^tb=~?ïþú¸¾Þ¿Õˆ¹¡ýk?{Šï›ãÇu¿¦ÇoX¾Ã?ƒbêç˜Ér?eÔµ¤N†ø?PQ—bÈX?Cš¯ÁsÑÁ?(-¶²ó?˜ÂtPœP>Ô„•ð~º>ú¥²Mñf>±è/ù#§>‹ZíL„ó>f`ä—|ÖW>B*ÌJ*?*R°ZðÕ?ÃÌ'À¹×>áѽY2~? j¥>àþ¸^‘>½ÁÞòÂhÉ¿ð?ïÿ{zÑ£á¿ãK\÷s?ïÿ{zÑ£á¿ÕT|¼²‹Õ?{KŒv K¬¿‘–Ø!÷?ƒBghºÁ?e®ì¿Ú o?P9”Y/ü?C‚{à+Ds?(Õå,ê?g¼Éó>ÔdnÛ¹’>ú†EÊBM•>±rµ2e?Ä>‹5¢ÕŸÂ:>f:á “;=>B M$1K/? ]•nX?¦ú¸CWˆ>á¿mæ °>ßÐG»"³ý?îœùÇêR>½Ñ‘#?ïíñŸy¿å>ê¦c ¦¿Ú „ß÷Iq?~¬˜¡‘ ‚¿”9ħÅ?†a0µõc?iFaŸ„œ‹?S Ó˜¤J?G{OG|-?,gªØÇ>Œ?"Ÿ¦M¹%¢>ØæK¸W>ÿšöMV>´”t9ô¶>œ÷»–>j@È““>EM¿m¼rH?Î0ZÓß?¼„vƒ1I>å%¯²eƒ>⟦Oåbø>Á_"ª¼ ?í†ã*ÝF‹¿ð¿ð{±ï?ïÿÿÿÿ¹¢¿`áÌ?$äD¿“Lšjl÷ö¿à½ ÐíØù¿¢/üšè ¿tH¸¿T’s5p ¿F÷œ–bz¿%Ù–\O% ¿ý·xðü¾Æ”àŒe¾ßê¸?MiI¾Žf¹¥~â¾d³ob‚Ãr¾=ÅÔü»æh¾¶h¸L1̾êØû+°ú¾æœ`ý4ȾÂ߉Ïh0¾Á,µsQ¿¾¾š»hÕýRÜ¿ð?¨»|žCl¿ð?Òw–;üÛ?¡\iÄÉ%·?Å_ð¸F:?™È2¾ëŽæ?tIÕyZ1?Y4+nó[ñ?NÙÜŸ«?1)vlÌ)Š?&‰ÝB½­·>ÙÒ»Úu ?j:Œ1ÿ>µŽ¹¡0>m-å~„>i/ÚÅ!°?>CüÂÙ˜ÙÍ? ÃX¦Uê?Àô ù@†>æ9†3¬ê©>äIæoŒí>Á».oSÅì¿ð¿k¼¸Z ·¿ð¿ð¿ÛÚ™QA¿í aÀTQ¿ºùŒR˜¿{=‡’}k‡¿LÌ_¢H5¿,so¦ó±¿raÙbU¾ûßöù‘h¾ðýô©¾–¤MxÝe¾ÃýsO‡°i¾lI½;¿bT¾@/EÕusݾ,L@Ci½ãšÙe×[£¾Ñ)ø? K¾Í€;›,|¾¥UípP(¾£?EJJ5¾y«½ô­°ô¿Ã%Ø”d•‹¿ïÿÿÄ7:?ðH׸?ïÿÿÿ¬©?ïÿþ'Wûy¿®›b…ñòC¿±áNmÒWˆ¿îÉìÞ{ö:?2ò” X\¿… ã™]»¿(³ÜŸ4V§¾Ã4Â/Ý•¾Ìã^FYè0>Ç<óü3Œç>¢‹æ2¼¥`>§iT!¸¾Ú>UÆÇ^]Pc>v·ý%†>#ãè‚2“=ü²j§Õ­È½­˜oc½¨Ï Ó ô>v-¯ÎÕÙ>ˆð/ïŸúl>N•Ú‰ ÊÎ>`ÄZûTÑ=õIܶ‚œ¿ð?ð~ ?ïÿÿ÷©Ù¿Í¡®â•Î?Šÿhp1rþ¿ ‡/ª[x¥¿©à&zà X?\Šà0[Ñ>ß…•.&¾ÆÌåô@¥í>œ,qÖ",£¾¬[ÔŽw€Û¾}çu¹I”¾ƒ…® )ãe¾«0@ ¾A&„g5’8=õ7N\£}=×ÃuÂFA=ÈVç®ÿ=©s'vzL ¾%AI¯„4¾`AÖœâP> Ž³€ Òø¾'‰Eb©‹”>m»<‡¿ð?ïÿÿÿç¡?ïÿÿþ˹t¿¼ì‹nß~¿¥RF·Ä„Ù?#¸×¿z$¾­Î¿×+.\u¡6¿ -º=%6ξÄ&๺…¼é]>•ôõ¢Å´`>›¤Æ„¿è>Kmý»úÉ–>l] ƒÑ/>’î‘h€=ôxŒ3l®ƒ=“­’¼¾…½‘a±:Ÿ>ll¨É"o¦>~·Ó4hy>E1èanë>UŠxc>!MÒ­‚¿ð?ðˆ?ïÿÿþRI¿Í])˜ˆá鿆Hä¹g`á>ãûKIíQå¿]² ¸é°¿ítµá£Z¿—îÈ&8õñ¾Àf§>V¨C¾¦ç3þ ö>’8ñÍ>uûW ©Œ&>{IþÇÛ¼d>2=’|šcf>ROˆþLõ>9Ý’ŸÜ4=ãöfqJIU=´t—mp›=‰ÖK’¦ƒ>T–³§!>`ÄNxRÏ7>3D¸ýh3?>;‰_“Lì>ÐOõ?—¿ð?ð¯ì?ð¯ì¿ÔVÁÊzW¿OlQ=6ßE¾ù{„žjN¿/ó» ˜'ǾìÅ{Àƒ#V¾µ‘‰OÍùR¿V†$y³™–¾‚¸r'ÔWA¾x(ðuňà>34 ‡£:>1gÂ=oIb>¤%–¯>2Lï;c^ß=õ©%#Ñ}2=ÓQÈ1ÿ=±Ô>^”=c‹þ/7>:«_">2ßøeWP>!.º™.#>…_-7¢@>ˆ!<…š¿ð?ðÄ?ïÿÿÿ ¢0¿Ø`02£’£¿u§;%©q?>íˆÉw€Zy¿K51F;ò?^cÿ&'¾¡Ÿ¢û•l¾“QîV#Ž¿J±7Aòä>‡R(clL>e㫦‘Ö>k£¯mu=¨³>?><…Dö=ð쇀Q+X=ÊóíÍc Y=Ž´åäc†|=Gè¸e>þA>@M@·4©>O=·S°>òxñj¨Õ>'.!¶Yz›=çVú7z¿ð?ð?ïÿÿþ‡÷¿Ú=ØÝj?~“Øå6Í»¿ Ri¦Fš?Q`ãêR>êV…tÓT¾¤Ìzg€ˆ>”†€;–Ö¾™£ã#:Ò¿1â¡&ÓWY¾pK[Û•Á¾tüË–²…¾ë^§Yfb¾=t‚Ùß$½Æ¢YÌÔÁ‹½fŒ‰Jg=«Ö¹Ôd =tXÃ×¾6v Î@­¾Sæ°mÞáY½òžLº† 3¾%Mùðp=öýOÜf<¿ð?ïÿÿÿýÍ ?ïÿÿþÚúë¿Þ1/´ R°?y/ßÿoǸ¾ü©6š ç?N>^Œà=²>ð›6?ÿDa>€ ºIV¾>“ý¿Â "©¾áëI’-S¾jY‘˜L¿!Eã¦*'î¾pF”ÞQ´¾vA€¥‡¾>ãCnîr½è R½|/L½Á¡±qÎc=„ž'‰›ð¡=uþ![I¥ø¾=V^ìöå¾QbJ½pu*¾0Ô}º°¾&Îçð/=©v•u‰¬¿ð?ïÿÿÿþYÊ?ïÿÿÿ<¿ß±x£ù?‰´R!ÀD¼¿öÁ6b?^Ãùõào?”ºK}™‰>ˆ4÷µ˶>¤0™Zæ—¾¡xån-»Ü¾zŸ¬o»ˆ¾€ð¤¦©#M¿;¨Iw=¾-¹#[U*¾O……©íy½÷bMXèƒÏ½Ðöp †D–=™1R\ï=ˆOò†“o1¾MHÿå§Z¾a­ò¸¬ÉV¾"«'í/‚¾6õ4Ó›Ìþ=Î’f¿ð?ïÿÿÿôQT?ïÿÿþ»^ƒ¿å^÷Ý–ã?‹ìÒÿ• ¾øù¹s+É[?aÑ l¹T? Ï‚£al>¿¼½Ÿ(Æ&>ª ؇Ì0ð¾š2Þ›©¦¾{Ã$ÿÐ' ¾aqÎä¾5;¹ý 󾻄SÞí±¾Ut æ:ö¥¾ tüG¡½å5"Ä4M?½±Ó{±ƒ}½‚>hÍ‘ ¾W[KGݾd?åÛ¢j¾4½’Ìb¾@w+³4*¾È°Û(¿ð?ïÿÿÿïà?ïÿÿýÚ¿â„órž^?‚¢Q±/Õ]¾óÖsóH?WÊþÆ¿>?»©"7€>³*‹±>¡'ƒù6};’mëÜ‹¾r§! Í¾w_hRPƧ¾+’Up¸º¾Kö÷걜°¾óe;ý¨9@¾eRÀÁ6‰½Úzš¿C;‹½¤‰¹ ½qz7>»¾N3"cÁ·¾[?Ÿ„Ì›¾*zuÎÓû¾4îÍjM­Õ½úý×èìéò¿ð?ïÿÿÿçò¼?ð`¿çó£hƒÀZ?€¡Ä$^>ùðé,Ïhð?WyÛn5H‡?„ÂÊö ">Çý2’§1ÿ>£Üq^ðV-¾nêÜR®Ù¾nØfz…¾rªÏt ø¾1Òà’~¾QlÿÔ"(¾ *@“­¾¡n\SXˆR½èÔDB} v½ÁÛVYŠœ½œ!`‡:óz¾U„Ëöy;î¾[B v%Ì€¾7&/Ó d ¾:‰§7qUR¾¬.6«7è¿ð?ïÿÿÿÀÇ0?ïÿÿûô¬ ¿ê6‚Œü ×?‚=”&ÇŸ?¿÷½ù?Zx$À¹? \ A1€è>Îï´²D$5>§%Tfá,¾4=E·¹}ˆ¾pŒÚÑV µ¾sÑ,BF•L¾534›…ƒ¾T—J5(ó;¾,ÈÿR¼½ï"fÛ²”¾wƒü6^š½Ç™x«>VŸ½£ 2¸½l¾Zxsˆ[¾^ÇìéöÀ¾<× 7Ëꉾ?v†K3Z¾ªÐse؈¿ð?ïÿÿÿ¼ÊØ?ïÿÿúñ¼Å¿íY[boO¿[ÝxOð?tYîü5Í?!$Ô úUÐR>’d03+|˜>¢ê3gðÁ>[ç,˜L†>dˆƒ&࿾(׋Œ2pa¾E¨óg3^о5µlJû½ðp–2Ãòn½Ñº«Çñp<¾PÛwµÍŠ´½°>Ô;(ȾS3†ôDA¾'’çœ$K¾<Õš‰ïh¾1rˆ^Õ(¾!étâ;z‚¿ð?ïÿÿÿ®¢Ú?ïÿÿÿ\,:¿ðSÖx¿~‚'R Ñ?%Æ~kÄ»à¿ETŸÅ™v?~xi‘?>Ø4è:þJ>sÊ;I{ ‰>®–8Péâ“>sÀB2—õ >{ ߨæôR¾!q OßúE¾9êdª@Þœ¾¬*ð½ò64ò AȽÖNÐ"Åñؽµ~4z7¾(Š¡án¤b¾QUR \i>GW¥ßÙºm¾?D‡Œß¾&±ºUö+9¾& ÂINé¿ð?ïÿÿÿü&Ö?ïÿÿù5B‚¿áÖJ–‘?u¨Órë@¾Íb†3²÷?LP£'Zn>öŽ´‚L>°ª.V9J>•–ñ¡¨ ¾€ÚV-u¯¾e>,'’žn¾jaYY(ÍX¾"/Tà}â¾B4EÄ°D½øIX›ç´ý½ÔîæË›½¥B»°k ‡½{˜¤~œf‡¾DdÇÖÄ念{ÀlØÓ¾P]‚üiíÞ¾#LÒüE¾+(;Ug8m½ù‚XŸ'åt¿ð?ïÿÿÿÿ–r?ïÿÿø‰¼j¿â CÕQJû?2ä3_Ål¿ ÀyŸù?aâã’Âzt?Ì©-õŽ>«ø2þCpÞ>¨‡|$^^¾¡±—)• ,¾}ÙF_Œݾ‚ߢwé“à¾2ÄÀj…c¾S^ƒaȧ¾ð|3è5S¡?NCÙ 1î>þD“öä®>¾Ê`Ï‚ï>™–ÊàOä¾c÷—ŽÞRã¾cê…ÑÙ(Œ¾hoF{8¾&î‚ãé¾Flx†™ä¾ºáªF½ë½ßâóUÓ½¶áËð©™Û½’‚‡²Dö¾K¬‘jyöš¾Q’ª[ؾ-¼C-ëãr¾ÖGGf­²¾1,–«V¾ 9!¿KRü¿ð?ïÿÿÿøý™?ïÿÿ÷_Æ¿äìÎ9Ÿ„?Š%L½$¶¾ùÏ.ítƒ¥?`Ÿ‚ÈÆõ¼?Üg˜4>¼.¦-yî>¨D¿ë™9Q¾™C¥Êê]y¾zX{ú(§¾€XH‹ÈÉ~¾3˜80*í¹¾S×…ùåSľ«ÛÅ×ʽã,'ƒÛ½½®‡O˜øfj½|ù¿Criþ¾UwÀÙBÞ¾c.7³€¾2ÓAë]§w¾=º‘üLÆɾÔ@q.M¬¾0t²1¿ð?ïÿÿù0,°¿æþK¹[“?CI1ÚSƒ?w5pTMØ?4=´x¥ìu>û}§m;6I>Çmý ±@>Lš6͵>‘בÌ56>#y=äZo>;v3•i¾"»=Ó¾@]ÞìÃó¾u]ilu‘½ä¡¯PºÊ½Ä Ã7炽¡ý‹›è7¾IÌ! vI?¾8`A„YGa¾1ËS%Ûæ~¾)Ö®·Ä°¾‹ÙŸ6è¾®Äv2Qeý?ïÿÿþ×!¿ïÿÿýé9œ?÷%…ƒ†5?N–ç9>?Gœ$;C?]§gEÀi?.<_ J}? ¿¥[•½,?Nz1E“>Þ1‘˜ø™^>Ò:Þƒ?>y#Éâ¶[>“áyÎÇZ><ŒJ€+>†Ò,û!=åóMîôƒ­=»% KÓº>¡·Éç~ÿ>œêçU¼N˜>unõ-QS>s¯)tDœÕ>JhuxÜ¿ð?æ–m0Ý?h?ð¿ð?gÕ/©?ð?ïÿÿÿÁw¿ Ü ±ä„?ðR#y¿ðfÌÏ‘?ð?ïÿþ'Wûy¿ïÿÿÿûvê?ð?ïÿÿ÷©Ù¿ð2*L?ð?ïÿÿþ˹t¿ðÏt?ð?ïÿÿþRI¿ïÿÿÿÜóü?ð?ð¯ì¿ïÿÿÿË¢Á?ð?ïÿÿÿ ¢0¿ïÿÿÿÉü‹?ð?ïÿÿþ‡÷¿ïÿÿÿë…‡?ð?ïÿÿþÚúë¿ð?ð?ïÿÿÿ<¿ïÿÿÿò«?ð?ïÿÿþ»^ƒ¿ïÿÿÿ÷z’?ð?ïÿÿýÚ¿ïÿÿÿýc?ð?ð`¿ð?ð?ïÿÿûô¬ ¿ð¿°?ð?ïÿÿúñ¼Å¿ð¯ì?ð?ïÿÿÿ\,:¿ð]X?ð?ïÿÿù5B‚¿ïÿÿÿí?ð?ïÿÿø‰¼j¿ïÿÿÿæ¶?ð?ïÿÿø-©¿ïÿÿÿóçÆ?ð?ïÿÿ÷_Æ¿ïÿÿÿù È?ïÿÿù0,°?ð¿ïÿÿýé9œ¿ïÿÿÿæ¶?ð¿ð¿ð?ïÿÿ®`1Ÿ¿ïÿÿUø«Î?ð?ï9䰣ϫ¿2$œ°Á‹i?ïÿÿÙŸsˆ?ð?ï9ä´äšD¿a?EPn,7?ïÿÿ÷‡|ú?ð?ï9ä°hp¿P>—€Z^?ïÿÿý)\:?ð?ï9䴛Œ¿f…«!?ïÿÿÿ4-”?ð?ï9䩺øÍ¿qGŠ-e?ïÿÿÿþÃW?ð?ï9äý>o¿uèôÎ.èX?ïÿÿÿüJ?ð?ï9ä‘Y:¿vï*¼pÄ?ð?ð?ï9æ„Áœ¿{õŸõÔ”…?ð?ð?ï9çxª9'¿},ýIÛ?ð¯ì?ð?ï:½M~Ç¿„ÜaL|©?ðoœ?ð?ï:OgZ¿Ôßc—ëÈ?ð_Ø?ð?ïL Ëú¿ˆDaˤû?ð_Ø?ð?îrrÎt¿Œ/‘·8ê?ðÄ?ð?ï“´±D²G¿)áB½µÙ?ð¯ì?ð?ð¿ì¥@£äç?ð¿°?ð?ï:ªÅ™Ý¿¹g†¤?ð¯ì?ð?ï:Ebf_i¿ßÒ§M6?ð¯ì?ð?ï:0‰7ª¿„3I*põÛ?ð¯ì?ð?ï;{ó¿6ô¿„)P@ ?ð_Ø?ï8 v?¿‡ëµ‹)?ð¿ï9äجÅ{?ïÿÿÏ÷¿È?ïÆ;=³Ð"?ð¿§' iv%?ð¿„!°øp?ïÿÿÿR°‚?ïÿÿÄo²§?ð?ïÿÿ¿¿û¿’RÕôµD0?ïÿÿíkÉŸ?ð?ïÿÿø`Œ¿ÁWyà=_?ïÿÿÿþÃW?ð?ïÿÿÿ!Âß¿°ky¦‘Á?ïÿÿ÷Þ|¯?ð?ïÿÿýÑr¶¿Æ9ÄÉšá?ïÿÿÍtB?ð?ïÿÿýÔd¿Ñ4™Þwƒ?ïÿÿý·C?ð?ïÿÿ{{«¿Ö0¼a½å|?ïÿÿ̤P™?ð?ïÿÿYÑÕc¿×7äß‹n?ïÿÿà)Þ¼?ð?ïÿüµ¡Q¿ÜSGt¢_â?ïÿÿýKþ°?ð?ïÿýOrH¿ÝŒàþÑv?ïÿÿÝU×w?ð?ïþœ»vúQ¿å%zNí?ïÿÿ¦/&y?ð?ïÿ¨ýxq¿âj Tõ?ïÿÿ׃ ”?ð?ï÷<$ ±¿ç=¼½õ?ïÿÿç¨Êð?ð?ï–ˆÞÊå¿äêË)Tÿ3?ïÿÿÝΦ‡?ð?íµÞrE¿Þt†ƒ¸?ïÿÿúmîõ?ð¿×ˆ Æ*÷?ïÿÿÕ£§}?ð?ïÿ¢>òï¿áM•ÖK)!?ïÿÿÞØQë?ð?ïÿýšD¿á>i¿d78?ïÿÿåUh=?ð?ïþú¸¾Þ¿ä_eù†Ï ?ïÿÿêå#&?ð?ïÿ{zÑ£á¿ä-Õçè`Ì?ïÿÿØ_çÝ?ïíñŸy¿çUTÂÖŒ¢?ð¿ð{±ï?ïÿÿÿ³À?Ò èŽIH?ð¿UgG¢ž!?ð?ð¿ñéE‡Ô?ïÿÿÿÿ–r?ð¿ïÿÿ¼‚if?ïXPl¹Ü¿)_ZÕÌ¿ð¿ïÿÿ÷=Ò'?ïXP L¿U¬[6Z]¿ð¿ðFÇô?ïXP ˆ4¿DÅ{×Ù\'¿ð¿ð^Õ7?ïXP+#Ñ!¿[©H¯ùq¿ð¿ð¯ì?ïXPNÓ¿eUŒú˜o#¿ð¿ðÄ?ïXP . 2¿kzDV›ÀQ¿ð¿ð?ïXOÇh²¿l¾„Ädj¯¿ð¿ïÿÿÿÿÜÑ?ïXKN³U¿qƒéñÅ¿ˆ7‚¤…›Á¿¢8ËDÏò¿Ü·,Û§ü¿ƒ8xÿ“¢p¿k8YBY¼>RŒc ¿MV£š¿1ŠA-a€‰¿t' ™ù?$î(d¨cÉ?Z‘'Zv¶?!^˜$l[ê?Å×3o8O?QbÅin? „ˆX<˜>ÿ¥ÎÍ%zÂ? ?ÅI~×? Ùc ?%ŒŽšjÇñ?9INéD=¿ïÿÿÿè9¿É™™™”:?ðoœ?ëI¯:{?œ2 Ä ›[¿˜î怡å¿~Ä,q8»N¿–߉ì«hí¿wê“ZJá¿Èg‹ITþ¿a‰-MVg)¿OX–0IJ¿AÄFšt *¿%ÿÉ䑱¨¿ öbXìç?¾œ(?³2j–Mš?±^tVþ ?'S NÞ‹?ÂCt?€r±³»>ó¶/³€;®?4vd’ˆ?s¤^Áˆ?³l†X?q3„ä„=¿ïÿÿÿ÷z’¿¾ ùȱ¸?ð?ëJ [^9¿€ï£ ts¿a/£Jr¿t‹ýð¿Ž= ê8˜¿p&x¤ìC¿W ˆ<œjx¿·KÔ(u3¦¿E—TtgÚ£¿8ËwŒ"i¿ Cø.D–¿ ~&dÝÙÃ?Ç3„\Ú?5ÔQ™¼? ‘§&GÓŸ?®Êio£€>ÿ‹}Š>õŸÚA%@(>êðìÒè? G};a«? :ŸÚ¨i? ¹jô<ã? ÔÀ³ÔÓ¿ïÿÿÿîhf¿ÄÍ1Ì–?ðß8?ëKÀ­¿…)ô8Ru’¿ˆÇTËWV¿o\Çxmú¿†ìÄ`¯Øì¿hä‹6×h-¿Q6}'Ý,¿@øÈäå¿®@—vÕQ¿3„.:˾¸¿3¹†4°e¿E‘? fIÁëë>þ‘c¶I?Äég¥j?qd­5Þ>÷$vk' ƒ>ï¶IÎæ>ãÜš_-]?ŸÇÁõ÷?Õv}6ý? Ú~ÓÙ}¢?ÃUÅëY¿ïÿÿÿÞš3¿ƒ „,õ%?ïÿÿÿÿ–r?ëK¹|6R¿£ó.êpÊ¿€g‡õõUŒ¿e9û­°¿~›‰r¿`Ýql*–¿GKÿ‰5R”¿7€˜ö]¿+- Ûö¹¥¿¡Io½žÚQ¿+²Ë¾ýšÐµ4ñ?†kí“-¥>ôS>»š¦`>ý˜uúkB>÷Ázr9ú>ïÞŸ©>Œy>åîýrsõ>ÚÒT>ù¬:•ËÐ5>üPÙäÄ?íÎêÓDô>û;Þ÷ ,¿ïÿÿÿâP-¿tæGÑ6?ïÿÿÿúÆþ?ëK{iÉ@}¿¨õ€{ø ¿oí¸Æðš¿T¶v¨ÎÕ5¿mÅø@ë•e¿PIPÊ%¿6äæÇ>±¿&I©ñF…@Ç<>ãÊJ+>íTª"->ç‹.ë£Sù>ß±GÛù[—>ÕÔR߈t>ɾ ï9>èÈDç²Â$>ë~-Ø^Ú>ñžÔJÁ.û>ë#ñŒB¿ïÿÿÿâs\¿_¦Ëé—?ïÿÿÿü§?ëK€‘".y¿±xëD¥°˜¿]Üfƒß¿Dã4r´-ˆ¿\jO–ä|¿?å‡Í^0…¿&â ßwº£¿ŠK—Í–¿ Äy”éÔ¾ðbÂP½£¾áó²q´¿š9øgšX–>àÿdûüÊê>Òº8¡ "}>Ýð8«óþ>Ø!¬UŒ½Î>е8ÜS¼Ë>ÇB- Ò>¸}—åã)2>ÔÿMæ”4>ÜNJB>ábµ#j®>Üu:}%ü&¿ïÿÿÿõ$o¿ƒ(•~Í?ïÿÿÿÈ¿â?ëMIÅ_Œ¿¾U¸Uìâ!?•mÚêÆj?eÍ“<¶¿?€!o8?`„ÃåÇ?HÎF¬O?5¢ó…J8?(<#=*?iŽ×Êé>úC´¶Kè¿@wzàË¿yà¼W`Ú¾õ¢´+Ճȿ'[¹‰¸¾ùÔšûi ¦¾ñ'8kÓêß¾çvX?§]+¾Û­Ù•‚1¾üŽnzä3ç¾ü½ ó&É°¿«ÒôO}¾ý¼ä@°“¿ïÿÿÿÂJ8¿x#'ýK£ ?ïÿÿÿí?ëKÝ«Ë‚¿·„µV?f܉v ?Kþž1i¹Æ?dûBË°º?FI/áò¹ë?/q£l7Ä?ë¥ýN‚\?à*µÄ:>ôOBàÓƒª>àð&>}¤Æ¾è!±ÚL_¾Ü¿,i"¿ŒÿþÍs ¾ãún^Ÿx¾ßôÕ!ïËe¾Õ j¨mc¾Ì½£‡è ¾Â&Ë)ã ¾âÚ^m7‘ˆ¾âsï,œ?¾èÚKÃ9ý—¾áì$>ÉKœ¿ïÿÿÿòa¿˜`[?y)?ïÿÿÿɶ,?ëK+ ÞË·¿Á•ÓÊ=?ˆÝži§; ?ob²œÛŽ6?†øûXe?hplø¹y?Q±·'m'?@3¥/—K ?2®VÍ@CÁ?ð[í§™?‹Õ€½k¿ Nö«•¾þ¶Áž+4.¿Ü%$;°¿r¯Í¯öUé¿Pš¿™o¾ø€;ì7f¹¾ðÑ©3{+¾ãÐ}q°óÇ¿¼q%µ=%¿ß™Í,úq¿ ¢ º)7Í¿ΛUâð±¿ïÿÿÿòñ|¿–çd$„$+?ïÿÿÿy,"?ëK-¢lø„¿Ë»*¢~?‘C[Xy?uÇéšá^ ?ßÙt4SÖ?pÞÅpÑÈ?X¨ÜìV©(?F:VÍ'V·?9›}œ¢š‰?ª¤éß ? x±JøÔ>¿çÚTÃú¿R±”“;¿þ´,ÅvJ¿ ¡¥ $¿e–`°É}6¿*!„ÁP›¾÷’WôQ¾ëw¼TaKè¿ W,b.á¿ ëPs¿EÿtZ`Q¿ Õ`µ¸¿ïÿÿÿЧ¿–Ðxf¥zZ?ïÿÿÿ·µ?ëK.¥xÍ¿Æíº ê³è?“²«˜°Â?y6Ï×½M?’@A€ÖÄ?s_K;m‡„?\Œë‡þz?Io¯µÆž?=•a\ñ:É?"j©D3æÌ?NÐé¿ÖdR„‘¿b΂‡¿¢AÌX1¿ áa&Ÿ_M¿$HE¬o¿XãZWZ£ß¾û¹aa–o¾ïl”f§ðC¿¢˜ØH$¿Û!*ÆQ¸¿-ԹѿsÏ÷À¿ïÿÿÿæ)W¿–Èd©Yüó?ïÿÿÿž÷Õ?ëK.ðá݉¿ÉOÐtã'3?—€wß?}—ÓÚïw¹?•WÛ…ŽÎF?v«Ow?`Ê“øWèá?M=t–?A;v]G?%•Aœb°?#r ¸p ¿²‘ê¿ „W"Òª¿MtÜ¿¦UŽ!cù¿ÛË¢”ì«¿oxƒË¿M"î5‹dî¾ò\\Ýú‹Ò¿Å^ò~¿Ò¤!LTÖ¿ žÁÞu¿4“­)¿ïÿÿÿÝ+¿–Äí>·©?ïÿÿÿÝ+?ëJ÷ C2¿°ÕH÷9c€?IQâ »Š1?/!}åÛ™?GDOråÕ?(ÊÉ£«Í?rHàQ)À?­nl„0>>òÞ²DÉ›{>Ö­ 1Sì>à fÇÇ>ê¾Êºýü6åA¾¿&‘÷.úù‰5>áN<°„¾ìã‚y„ä¾á-9·ë¾ç][=ȶ¾â¡çúË‘¾Ø Yñ•1”¾ÐGø§õçb¾Æ|Ù:òߢpÞîJ¾ø1%V8¾ë›Ðô0¬¸¾ôm=\eÞ%¾ð_ˆO éq¾å뺘ÂA¾Þ•¯s&,¾Ñܘ€Þݾñª¿™€Ô¾òÖvàU$¿ƒ;šâ<’ê¾øµŒ¨²ÍZ¾ò¤É®®e°¿ïÿÿÿò«¿—ls²*¶@?ïÿÿÿõGž?ëK¹‰ÄÜ¿¸ÿ-tA?e¬Ó]?cZASOõ1?|ØÈì•Œ?^‘ë‹gà”?EÍ×]§a3?4eŸorÝ?'â 2BF? ¤Åœî4>÷ßM£ðN¿½azýؾóRwû{Õõ¾ûßÔ¶!ù-¾öMBo€‰¾í€"Zf£E¾ä+H/˜À¾Øìx†©Œ¾ù¥ÍDø´¾ù–ñD[¨2¿1ñíƒÅ¿‚Ž˜vÕŒø¾ùÓ÷øT¿ïÿÿÿÑ‹¯¿—_ÒT„Ac?ëK2xoš¿ºå>1?‚ÙÌÃœ/?h@èïx?‚/oYJU?bÎnÒAãB?K3t<л?9KV³+?->ÊBl?ôÞÚ?š[‰Šs¿²Öl¡¸¾÷YTÛ£ É¿Ÿ²‘é4~¾üEÏ¡Cóþó Nuwî´¾ê8T”£ ¾Þ2®A$Óó¾ýOM³Z€Ã¿)ý|Ï‚i¿÷:W1;¿-Û†¤Å¿v vŽ¿–ö@»Å ?ïÿÿÿæ’ä¿ë= `×)?>D ŒŒ‘Ê>5$<+C"&?ªŽlsl?c×ÇÜÑ»…?Šx;ŠÃ?vÚGÙî«?w=w$8`í?eQžuH´?`<+Ó};­?@õaÒe‡·?6–ne1ÌÃ?Ûøu’E?¸yD&š>õš çúO>åÊWad¸?;ƒœtþ?9»‚øŠ>?+P6¤=†`?* £¯õ?š(» ã¿ïÿÿÿø·:?ð?ð¿ð¿ð¿RAŒIËÀ®?ð¿ð¿ð¿£f ² «?ïÿÿûÀ¸o¿9ê®_sD¿ð×È?ð?çÓΈ?ðÏt?ïÿ@yú.ˆ?ð žè?åÔìïAYÓ•V?ïÿÿÿãÓ4¿ð?ïÿÿÿ=bî?åÔ심l?ïÿÿÿùg&¿ð?ïÿÿÿº (?åÓ—ù¯:ý?âÇ|n©†¿ð?ïÿÿÿoFÛ?åÔ€¦Ö·?£lû?Þ¿ð?ïÿÿþíò]?åÖ”`áz?¨ˆ¥82Zo¿ð?ïÿÿÿÔ(/?åؽ驒?š’0™Åƒ¿ð?ïÿÿÿ k•?å×ÝJ1–?¥·~ä ¿ð?ïÿÿÿ¦ÍX?å׋G.?§òºÝ’5¿ð?ïÿÿþì’…?åÛltc ?ž+ñüžÄÔ¿ð?ïÿÿÿŽyµ?åÖ‚ª¦ô?¾xrWsa¿ð?ïÿÿÿ•Xí?åÖÑqÓ•V¿ïýºöœ—î¿ð?ð?åÔ심l¿³}ŽžpËß¿ð?ð?åÓ—ù¯:ý¿ÉüÔqá¿ð?ð?åÔ€¦Ö·¿Ò™v A¿ð?ð?åÖ”`áz¿ÖOœ™¿ð?ð?åؽ驒¿×èT0#&/¿ð?ð?å×ÝJ1–¿ÛÒÞ:¿¹¿ð?ð?å׋G.¿ÝrRþ&:Ý¿ð?ð?åÛltc ¿ãöT øc¿ð?ð?åÖ‚ª¦ô¿á:Šl¨‘X¿ð?ð?åÖÑqÓ•V¿ï¨¬Ä¶mž?ð?ïýþAÒ›ã?åÔ심l¿£Y1'«“¸?ð?ïÿÿÿÁ½{?åÓ—ù¯:ý¿·"„yô G?ð?ïÿÿÿÿ,å?åÔ€¦Ö·¿Àcu§X®º?ð?ïÿÿýu£?åÖ”`áz¿Ã£¦ïb#Q?ð?ïÿÿÿÎ… ?åؽ驒¿ÅVŽlÝe?ð?ïÿÿÿ òD?å×ÝJ1–¿ÈÍrÅ‹#ž?ð?ïÿÿÿ¦@›?å׋G.¿Ê1Ç.†™}?ð?ïÿÿþë2­?åÛltc ¿ÒVwpŽƒG?ð?ïÿÿÿ“/?åÖ‚ª¦ô¿Î|úOi{c?ð?ïÿÿÿ–ÿ$?åÖÑqoŒX¬ ¿;ÙyK’g¿2Œ÷èö|B¿1Œì…ˆÝÖ¿%æE°ð?ð?ïÿÿÿyOQ?ïÿþyJðf?ÊŒTî?“×@Á[??\ñ‰Ì3²?×¼0„³?|5–[s?D쫦Õ¿3?žiî!g¿;1v´Ú6¿8 *wŒ¿I¿4iæa§ù¿2ts_Ͻ;¿aí æ«¿'ï#fP¿« Ð ©ß¿»©2/›¾ôõ=eZ=ƾç*SÜ™$Í¿+|UáÝ 6¿)u3ÝV…¿ ôhpZÃŽ¿ kxÄ)¿y³m^?ïÿÿû¾…|?ïÿÿÿõ÷Š?ïÿþwB.Ð?Ïž·à9ÌF?¡1ÀOõÃ9?i=ÈD$ÁT?ˆt[€?Åò‚oêÎ?QqõápF,¿>S˜Š¿F>6’ÊT¿DѦn׿Až2J±>€¿@YÄes¿(ánÅî¿4ä×– ×F¿=¦A”¬À¿t3lÄS¿e{«µ?{¾ôVN‹®«0¿7í>¥1˜Ž¿6C·Yéhq¿-£½-5‰K¿,%1I÷€¿!†·€,œ4?ïÿÿþ$×?ïÿÿÿâ,þ?ïÿþwM `?Ò# ¥Xã?‚Ï%*™?Krìï{¤?j¾“?3vÕXÇü?ÌËŽƒ2‚û¿"AâD1¿)«YæøÇ€¿'M%[¾Œ>¿#X_å!r¼¿!I“ËP¿ ìàÑœWn¿³`+¿Çà¾ÿ¡8¡ŠNú¾ñÆž«À›«¾ãâÕ³ݾÕûM3ûF¿S@AFØ¿&=›.œE¿³ãD)¿w‹ …æ¿ÿ6ÑGi?ð¯ì?ïÿÿÿ«yœ?ïÿþvøo?ÖØH­Q9꿃ÜTâͬ¿LÀæ€ò$w¿l9}¥9ç´¿5ˆª·g?%`@gß!?¬zæ™C·ˆ?,ð O3Ñß?)S–A~|?$†aI`?"lÓÒ™´? ˜†¸oƒ?Á4Òþú?s¿+šA>òv©á¬.>ä«&{ßH{>Ö×UôV‹?^2C?6ñ(!úÐ?Í8rº€?ºën=?Ðí ë©Ÿ?ð¯ì?ïÿÿÿ]¯B?ïÿþvÃvÒ?Ý?¸´ ú.¿™ð‰eñÜD¿bÓòˆIŒ¿‚oA‡Ý—¿KMÙ£æÎ1?;_½“$?B†Ö}žŠ?¹õ¸å-þ€?@dª”}}?:ÄŸ)œ µ?8çä1”?"bÛ×ôƒÂ?/ïhb`Ÿ?–¡òP;®?<¿œœ¢>û!ÆyS>íûˆ›ðî?1çL•ÄöÅ?0†3§Šó¬?&Í™ÖÖ®?$Ï.í¶ÛŸ?ûõ^?ïÿÿÿü&Ö?ïÿÿÿußµ?ïÿþw¯ÿ ?Ü®{z š¿œív}Ô¹ö¿dø§Ç=“Ø¿„Ž‡=¥™?¿N‹5ʈê?>ˆJN=¼`?DÔ5€`PÊ?BY‚€´?­d±A­ÂP?=Þ|4i ?:Ù²b‰Â?$w†kž¤?1T÷H?…ŒÈS? øÕGàF>þ1_¾>ž>ð¯A›ò?3ó½láÅ?2fµš³0?(…•#´Sý?'*M³²Ÿ?í—<‹þv?ïÿÿÿôQT?ð?ïÿþ{ † ?àë·®õ&¿¦Í¯e—¿p’¢ãà ¿5H<6¿Wäh[Œä?GBì¤í?P#Pl†«?Lªê&Þk?G‚«Îh5•?ºñ/G”­?E/!WÚ8™?04¶mˆå?;e«t Ov?#æœÞSL?_e¥h‚?ëGUÙ]>úo› %£ ??‚£j‚ý?= ÍXäI?3eñöáÀ?2W1”Ç?&ä€Ðå×?ð?ïÿÿþ¨Cã?ïÿþÛ©?à¿Àâh¿¨’÷@‹²š¿qÝR¹¿R’¿‘w=øáßÙ¿Y¹gàÇh¶?H÷µ¤`â?QL…írW=?N܃á­ÀA?ITÛ§Ny?FÔÅS¸pA?¾ÃH%¹?1yoMËÌ?=ˆ­~)¢?$„ø¡`¦Ì? ¶î…ó@? Êp’+º‰>ü<«­Å“?@ûX¤ ¹µ??bôE?4èϦV€?3ÆAâj5­?(­Ù¬¥@¶?ïÿÿÿÄ6Ì?ïÿÿñK"?ïÿþhy†Â?ååÀ;®Gð¿¶:À}jCæ¿€+¥È  S¿Ÿ™\˜y¿g9’LfO¢?VcD>ç©?_"ˇ‡Ý?[Ú‚*¢ú=?Vçú8úNƒ?T¨KǾ¤??¥Ãhñx?³@°0›ƒ?J¼:þE—Œ?2•dª¤ý?$ßÓˆ_#I?[ûýN? ÑbJN;?N¼ª}„H¾?LjЮRJ?Bíò1%È"?AèLñ ?6X˜`ú¢â?ïÿÿÿðá¸?ïÿÿÿ¥×?ïÿþŠéõÜ?ã=™dÍX¿±†Y,^p[¿y ÑÚÉX¿˜é‚ˆÅ‚¿bNñ $‹?Q¥D<ÕB?XŠÔ j]É?Uôý÷‹Ô?RاþP ?PIÑŸùv?8óJ·üáî?EÎå ­î?Ó¤–j¤é(?-MN(»3? uw:Ã/?jˆv¡A’?Z¾d¸M?H;e¸lÙô?FgL+öFm?=ØÛY…m>?<<]Zº\ß?1þ×Á]?ïÿÿÿˆ×&?ïÿÿÝä¤?ïÿþHÙÕ?èp§6fè¿»?¸ÇçI¿ƒÓ"$9ƨ¿£^.˜…},¿luÓžfD?[cJE# ?c<é?aù ªX?\li2À§?YR³c…çÙ?CfÑ} \?Pc‚~ž?6É)ÕÙh8?ÑÓ\ýyR ?)˜el^Yû?¤SÏÕ\U?¨ãÁ“?R×0÷í7?QkÝ.XQ?G5I,V?EôÒu“´¿?;eÕ¶¢–?ð?ïÿÿÔÄÝŸ?ïÿÿêø„%?æ«®å¿À8f¨h¨¿‡HtIÛúp¿¦¾óZŸ¿pµ£)Ld?`ŠµŽ¾Y?fb8x£Ú?d ·= TŽ?`|Šø­ ?]½}FeK?FÉPü)¤?S?]53«¶?:ÂÁí+ð‡?.€Ó|Ü´?ÑP¦hMj? Ñ¿]Þ]_?–öžh?V Šb¸yI?Tu”·}ˆÔ?KA¸tã^Ò?IÉe‰þ²F?@´4 ä˜?ð?ïÿÿøé²?ïÿý*ïâ ?íqj7w¾J¿Â¤ÛéwÙö¿‹ ›XTŸ5¿ª€ã‹©L‰¿swÌ‚ F‘?b½‚ÿÒÑ?j1FÎÓÒ?gYc/DC;?c5æùÑ?aSÅ8·Y?J{ ´?Vm}:tWÈ??.©Âg›"?1ƒ}‹XÜ×?#™ÀçЮ?Ðì_Oí\?©;™»g„?YÈ‹ËáT;?WÖø8ƒ_ñ?Ož¿¾«?N H^Ð?B¿6|tUh?ïÿÿÿ°l@?ïÿýkŽÜ,?ïÿõô°“?ïÿÿ÷wE9¿ÅÉ60Ü¿Ž»b)Fq“¿®ãúH–¿vý³)ºn?e9VÐ ƒ–?m‹`ã ]à?jr¹K û­?e¬i‰†?c {È?Npý’;F?Yg—9–„q?A©@Nª{º?3Ö²zë6b?&3K’6OØ?‰oÔɘ?ÐŒ„à ¹°?]4âÆzê?[å™ Xk?QüÿX…w?Q•™—ñ?E<_lY$?ð?ïÿÿûuŠ•?ïÿþ‚Ê¥~?ä¯yæ=¿°[4¥ Èü¿w˪Èd¿—@D»Úœ=¿aѪ,?Pzºêwâô?Vê?¨‘~v?T?¡8?PÚº»/~¶?NfÆÚ«¡?7HãGuŸ?C«À °ø?+X‚4 Tú?·dMÖò€?/§šøð?þÕ­l¤?F‘­HL?Ô5=Á&ÍÏ?Dè‚ê€?;Úë©pÂc?:YÒïÚ ?0pøXž?ïÿÿÿÓ¾¢?ïÿÿøn?Š?ïÿþx•a×?ãÆl*¦ã¿°^±Ž9ªæ¿wÐÑ•ŠùR¿—E3­2°»¿aL+fµÐ?P|pìV6?Vížfe~5?T‚à—›.Ù?PÞ7Hðò?Nl–Qù$û?7NýÄq{?C°ÊÒ/t?+^¬K]¬í?¾]ÏZÀI?3¥Y`!a?"U£šÁ?F¢w~Í/?Dí*Žµõº?Óñp‘¤¯"?;áÝvŽ?:_¿„Œ3Ø?0t¢*çp?ïÿÿÿ³O?ïÿÿòùtÄ?ïÿþÈä õ?æÍ  Ye†¿µ&ª/.^ ¿~ÆY¥¬¼É¿ž0pt€¿f¦QPF?UF˜A<¹?]š¶ê²íè?Z~tXÛ¸c?UË3!ïè?S§âɲXV?>ãý1ãÔ?IpÒ˜IŒ _io¿C< _7⎿2Ú%×ñ?ð¿ð?ç,ŽQ‘¹8¿ð¿¤Xpu?¤VµÇ…ò?•Ra6?tø Ü?“Vãà±'?‰{|Ã7ž^?†Fúo‡¶`?{ëó¦¶ÚÃ?xԲɯuó?\ø]*ö+?j±@¡õê3?O/y8z&?@¯<‰Œ&o?1}äÓ}ò?"ªš“êØ„?oHŽ*¨­?m’CÄ=y?aJ Ń€©?`¥æ!žàŒ?R±èçCb¿ð¿§¿'ÃÌ9_¿ð¿ºNi5{`¿’æ ouã鿨3)@X£¿Šâ ya¿t&!çó`!¿cFº“Ê¿]ðj!"p…¿KkÌCð¿F<ãáI­¿j¶áÌz¿/ßleòaf¾ûï¤ùNx¾Ú4U„+¼ë>¡;¼eTðf>¿z1øu¿4Ì·ËØè¿3Df DÂø¿B +2C$¿>btša¿qö¬ËøÆ?ð¿Æ¦+W™‡b?ïÿÿþ\¾?ïÿÿÿ™xu?ïÿÿþj]?ð?µCÿg;÷8¿¶ê¸4Ëtï¿ðgWé„i5¿y sÝø_d¿ŸÿöÚÏU¿v·ó¶Àìý¿Wb¥¥¼[¸¿CÎŽ9N¢¿-ŸBᎾþíüÜ›–?I󺎞? ÆO¥5H`? ç R’Y=>þjÇek¾>ó1ÖP&cÇ>ã!úÐ >ÔÀèÆ'Ñ?Võ~2Û?ûéYã´ò?Cœªh›? ¸ Ÿfêµ>ûòBö¬6?ïÿÿÿ3Ä?ïÿÿüº¸Î?ïÿíýUÞš¿¸¼ ºœ¿žþ²½«{Æ¿c"D!Áª»¿ëy]ŒˆD¿†&á‚W|¿`h˜ì€¿AMš]Šd2¿,NœÅ‚ý¿xMñ“¾ìË–ÆÝa>Ý—Œâ}F>ò_Cïš’>ò¥­-ôÈ©>æÍÿI«_>Üâ›Øò·?>Î3‚ý>Àº;A ·>êbèʤú>ø¾CM?Úé>ïÌ/2þš‚>ô3*fÐs>åîÉpž“…?ð$?ïÿÿÿ5ÓÊ?ïÿîË/?˜[›&¿°¸òüä†^¿r«¼%W±¿—qÔ_é¿íq–˜p"¿pÑÖ˜õI¿QR½´ÎZ¿<êû“J¿&1Ûÿͺ©¾÷§­b­ñí>÷çÍ­'ü?¼TŠ$|?Siì¢ >öe/맇)>ì6:{­Q^>Ü[ë "é“>ÎßÔ‘mí>úÈßÿ\8Ð? á>pœ$>ÿ)9»;]Æ?ÒÁ]oÈ¡>ô¸!a?ïÿÿý–æ+?ïÿÿÿ·?ïÿî6!L¿³@&Œ“`¿¢DQ€ØÓ¿e³h Æ¿‰”»ãú¶-¿b€É¨‡ôó¿Ø°üŸÎ_=¿CmÖí*¤¿0hÚïºp¿`~t8£¾í‹Ç85¡>æt•yþüZ>õ7iá/²>õÄèh]ÅÁ>é BûW`>à@Ø?»i[>О]>&ú>Â:BE ð>îrPÜþÜ>ýÚ8Yl´ >ñôÅaà‰³>÷z…!Ñͨ>è>§Üº9d?ïÿÿÿá„?ïÿÿÿ÷Wb?ïÿîq+Ò¿ÀãµÐ‡›ƒ¿”Àî"ó]¿XïNr—˜Ó¿}t\}¿UBMv¤z¿6ã[Òg·¿£s…Ï-4š¿$}:õe¿—˜ŒùV;¾ãNACW>Øy¸Jšci>鼡r>ê\A;`óu>ß‹©ÇE3ç>ÓêG^Eph>ĕƈs}ƒ>¶®FhÙÔ>âŽõ,áÝ>ñËæ &¢>æ Ídd>ìgà”3–>Þ :’eÎY?ïÿÿþë¿i?ïÿÿÿùg&?ïÿîeÏ¿ÃÉQtº@¿ÃÁjˆÃ¿S~³ý´Š¿w©© \V¿QÙPÓš¿1úç€a¿ÑþS§–¼¿¡ðÆ™HÖ—¿®Ž2Ê$¾ÛwU@ƒ4>Õ}&Y66î>ãâœw}­à>äoùÅó >Ø‚p>>Îd(nè×O>¿Ìn¶Á>°ÿ¶}+2>Ü‘üáWì>ìÄ!F|>àÎüÑãt>æ˜N=ÿ>Ö¦D, ½ë?ð?ð$?ïÿî¶äƒ¿ÇF°5üô¿°jðÕè¿Dåêýý§~¿fïÛ[‘¦v¿A=3[ ‘¿"ªõ¢Wa¿èÈy.¼¾ü&;MØ8¿ñÖ¨¸¹ã¾ÑÍ‚óëZ >´þìXùº>Ô”P¦iV>Ô,µØÆ„>Ér4kmq›>À(È{¼O>±LÒY¶o>£Z¸ÜÝ“>Ì௡ò)>Ù¦¯ÅÌŽa>ÑÊÚR¾>ÕØRCå(R>É\<¨¾?ïÿÿÿßÖÛ?ð?ïÿ¿Ë`Ýqˆ~׿_VVϧƒ¿'ïÅ]Øv¿Gr÷FÝF¿"¥˜ÇaT ¿ŸŸ~6ת¾ð/72c¿¾à·×6_y¾·e ™ÎO¿âAT•¾pÛ"ö«¸>µ¾>ú¼>´¦;ÔÆ^Ë>¬<rÛI>¢‰F‡d>”=ëÁ ا>‡M »È>®†µíð!Æ>·ç/ÌŽ>³Ã†Ú|è•>¶£Øúz>­½àá÷2?ïÿÿÿŒ#“?ð/L?ïÿî>°ñ¿ÎGùæv?dþªA!4ì?…³>Ks?KkxŹn?!<{;=>ÿуØO‚ >îA`èïð¢>ÇPŠG¶¾sõ~÷ľ¾ÅÜÊŒðG¿‹ÃÕcª@ ¾³`&ÚZÕ¾µ~ wϾ£‡Z/ᶾ—>@Ÿe?I¾Ç.-d¾p‘ÞAëR’¾«C8¼#Z¾ÂwÃ- ^¾ªCï3±SÖ¾¶˜ƒp5ľ›C[¸ŒAô?ïÿÿÿùŠV?ðˆ?ïÿîÛ¿ÕÓ4kø?“i aË?Vt%õäj?{iù¾ös‡?TúR”Î^?4Ží!øŒ‹? Ù{8Ûï? P«BÔ‡Y>Ý„OˆéY6¾ÖÄ-b¥íÓ¾å}—f¤ã¿\ºl‚ë( ¾åúxP’šP¾Ú »´þ¾ÐyXHŽ~E¾ÀÐç–S þ¾²oàz P¾Þ«óP¾î7kÒÇ»¹¾â Ÿ³îоçÇ‹NÖ¢ý¾ØzDÂ÷šO?ïÿÿþñ>É?ð_Ø?ïÿîŸMH¿Ñö¨º-#e?ó¥=¾Ä?DoŒGê5?i@ÏGjxÚ?B36ÈÀ?"áa¸¹ƒ‹?•1žž¨V>ø¿vÒäd>ËŸ()žnjyª¾ÔsvKù Ú¾Õ 4oÇ:¿óê1üC˾ȞÌÚU’̾¿ ð“=æ ¾¯r´ÎEø¾¡-:Z $¾ÍGQ‰+|¾Ý7‘?)Êî¾Ñ$ÌûaE¾Ö¯HlÄe¾Æô§Èì|í?ðoœ?ïÿÿÿÿsC?ïÿî ¿×Á%±ÎÅO?—.1%>f?\7»Æç?€…uÝâhZ?Xj$#È)?9•¢Gbõ]?$Öß²j¬?~¸Ì1ÇV>ä ¢„-Q¡¾×U»¾÷ëû¾ëÓQòhܾë„Iïr˜ª¾à·záB]¿icÆ£a]0¾Õ)nX»Œ¾Æji¥É˾¸S¡¨"0o¾ãfùfÔ1¾ògü~Sï°¾çJÚ[é¾í͸¦£¢¾ßü£ +s?ïÿÿÿûS»?ïÿÿÿúÆþ?ïÿî#,¿ÜüïuϬ?ž¦€C¿#É?bÈrz·|?…àÚÞüê?`9ч‰?@ý(_{™?+~¹×qÑ~?:âø©>ë—Jçîݾݼþ€µ<4¾ñÞ½ÄËÆ.¾ò$%â¾æ"]Z—¾Ü>dzM¿W¶ÿ³x¾Í:'Ž‘ÿ¾À+Ü~ôã¾éE-v[¾ø,í^ë5×¾îÕ¡÷f„ù¾ó©%¼wÜÿ¾å9çÎ ï•?ïÿÿÿûš?ïÿÿÿÿ,å?ïÿî#lV²¿Ý[TTê¢?ŸÍŽwÜs?d}“K&?†î˜æÐüB?aMaù?BL“ 9}?-6k DY"?ârõbµd>ðR£ž“k¾×¬ØÛ³oŽ¾óãñôa›¾ó#·KiY¾çû j¾Þsò`}a¾Ð)7ÇΠ¿FwK*¡ ³¾Â}ÍÂ|¾ëK¡^Ú¾øÆη+Žá¾ð·F48¾ô͸5å¾çh[~±Á?ïÿÿ‚×?ïÿÿÿÑ®Þ?ïÿî Z™¤¿à†o?¡µ`2} t?gV# en?‰¨Ü~¯©?c†+–æ™?D¸¼%ƹç?0hw­L×?¬4-…3>òÌ°4Tóæ¾ÖœA>6ò^¾õ_|TŒÞ§¾õo—»ß¾ë-Ê\™U¾áG$üìÛϾÒzd q$½¾Ä«aBµb*¿5º:MÕ¸¾î³ÞS:žû`Ì(ð§¾òóJ§|¬Ë¾÷TÅ®êÞ¾êºÁô{Î+?ïÿÿÿÿ¹¢?ðîü?ïÿî$ðú¿ÐRÜvÁ¤?tçàÅçq?7na"?\]H%Þ’ð?4™ñ»>ùÖ?‚ƒS¡¨?êO*$Óy>ìÖm%§>À7™{Y¾¸A øaA¾Ç4ÙuÛp¾ÇǃdY)¾¼4Õ÷à !¾±ÎY˜ù¨æ¾¢8ª3t}ü¾“þ®¥)¾À¡›w»ö¿”yŠnôhl¾ÐIAô߯“¾Ã¥ý­‹©¾É«ìyy¾º aÂÍ´?ïÿÿþä ?ð ^˜?ïÿîÄ ¹¿ÑÀ¥0П?†l®;/Ž?GÙO6p7Á?o) ¼Ñu?E÷ø$ÇKâ?&rÊÏn«ç?Špã¹>û¼Ù×mYÛ>ËxêlMK¾ÑÉ4¯Eµ¾Ø¯KoÛñÛ¾Ù­hg…£»¾ÌðËeÆÇ ¾Â,-ªtƾ±â,©¦>e¾£FOi_ý¾ÑŸ²ºY• ¾âyãõÒ~’¿’ŒÛ­‹Zð¾Ô#’æÏؾەˆ’Ûu¾Ê9ù³²µv?ïÿÿÿhŠÒ?ð/L?ïÿî"‚[¿Ó÷/S?ˆcŠcµ?MŤ}²Ð?qcõ 2³?I«À*n?*ÿç=× ?"´Á°?¤,æ#º‹>ÖæZS}[¾Èžµ^ ¾Ü¸ÓÄý£¾Ý43—Ì”l¾ÑÀû?EÄQ¾ÆyBÅã{¾·e~Òp¿;¾©Þ‚æ#[˾ԛ-pÀ–¾ãN÷ÅE¾Ø¿®WáoT¿ª/¼ýŠ¾ßž'Qî¾Ñ8o/6?ïÿÿûxú1?ðoœ?ïÿî?È%¿Óª]rÔþ¢?‘g—2,?Sð‘wë;?x„­ –3?Q»ubmiÆ?2`ï›øFo?ˆzm§9Q?l7§ÿ>Ú‡ùµ¼gÛ¾Ö.hߎS¾ãÉÕð· ì¾äSÊQ_…¾×ã-lp0K¾Î"[s{྾œ¨•Þòþ¾°½È¡ýö¾ÜRIs窾ì Ct­wu¾à ³ž¾åîÈ“pì¿€¾Ôhé]Ù¾ÖT†6HüÌ?ðoœ?ïÿî uÐ%¿Õóß9>ñ?ä"D*ѹ?U™’ß«?xP½£‹©ª?R@*ã`?3Z$é\®÷?AP¢s? ‡f·¾;X>àþ>™d‰)¾Ê¡·µ¾äO@u`v¾ä|i׳§ü¾Ù‹R`#Âæ¾Ð5tFn:’¾Á(ê¢ÿù»¾³€A¼”¾Ý-ëyXWD¾ê¢vœúì¾áЇы匾æ>o×ÿó]¾ØàSŸíÕ¿pTóÝÙ2?ð?¿ïÿ×>íÄÒ-yš?‡<¡Ljþö?‘ÀO`dÙ'?’¾À«•ö?z3 T ]\?g1^WÞç?a©“…˜&{?PN.w‰œ?JmÌ.êY? ÊÞ?4»K§Ff…? ¸×­2X)>÷st¥Ãi>ã”Û¡Æäú>Фž8¶H)?;.þr #?89A¡y÷ß?%ãæk@À?$³U#_0o?BŸóCg¯?ïÿÿÿú£Ï?ð?ð?O挑 Q?ð¿¤.Á¬ðÏ?ðYû?ð¿ð?ïÿÿ+Ø?Á€x²þÖ ¿ð ¾p¿ïÿÿúéZ…?ïÿÿë8Ön?ÃÜÊ•nÇ¿¥×Êåõ½Ê¿zxÍ0[rQ¿U‰ósÀÍ€?W!ºÌÖ—?[¿¦çÍ5?_ð’+2n?H–ŒUüZ?So/Õ/Ø?8øœk¬]1?*²'m³Ù˜?%ã½å Ä?éEŸa…b?TZ,[Ó?Wî/¼)· ?I^bÍEh?Kïuä(²>?;>×ào‡*¿ïÿÿÚ4’“?ïÿß©Ò•)¿Æ=ÿëé?ïÿÿÿï¥¿Ï Wþ¼V¿‰¢_—y¿íÓBé©æ¿´€A6ZÛ¤¿†­Ae'¿[E=Oq¿2¨/%†J?6!Šþ ?=}(4ÄÇÝ?@d(V´U+?*ƒÒ‰?5FPÕE?¾î6r£? È­•. ¯>ü×ÑLMWD>ì÷.@²ä?6Yq„½k¤?9#O‹cJA?,0&™q ¶?.* Œ!`z?ê3âžs[¿ïÿÿÿÿÜÑ?ïÿßÍ{†?™sWA7þ,?ïÿÿÿýð<¿åÀG¯µK¿Ÿ¸Gg€bT¿ÌHeÈ·¿íœ4€H»_¿ž3fˆÿdi¿pp`Cqç¿LùT¯ÍjÄ?Oîè_ù€?S|)^ƒKø?V.s&¾#Û?AÚΔë£?Kw- >„Ø?1¿ ¤k¤?"ÿMÚÛ¤?ôðZ|T,?ÕMݤî?LÈ{wÉ?PÐW0DôR?AÿQ߇zÔ?CÅÀ”GÞ?3a-#¬Óó¿ïÿÿÿþYÊ?ïÿßèÝ6Þ¿Ãié„ìuù?ïÿÿý¬À|¿Óüó„^3C¿ŽGEg…Ô5¿º½›.ÏÙ¿Œ'U¯.º¿ð,á^x¿_¥„-¿9ëî0”ol?=)bÕ–ñ?B=ç§*©?D¡1¾_PØ?0¿»&ü?9Ò”krù©? Èë.s/?úÒ”¹?Š >ñ æÐY“?;'Ï7¼A0??b÷¸¼Þ?1Qs±×€?2êËàëÂ?"oíöüO¿ïÿÿþÈ&©?ïÿßì¿ÐºN4_‰?ïÿÿÿüJ¿¾›/a0¿wÕ[zíí¿¤——Ýâ¿uÅCã‡* ¿GÅ››XÓ¿À ¿¥´¿#xÞ¨–·c?&FÕF #?,ZØö£•?/î1¾òÀ??÷"~-¬3?$!Ÿ_AâØ? E*¯‰Ö>ü*|ß*Þ„>êñµF÷Á>Úè¸>‡ë’?%7”ÆÀm•?(XÓÿz?§8Z»ºñ†x^ºÈ>⯠ë>Ñ.ÛhšÎq>ÀÕ‹|"8? ¹,ÆâE»?nÖDz„T?Ä·9ò» 5Á;¹¿ïÿÿÿø·:?ïÿßë¥c¿×$œQb¿?ïÿÿÿÌ O?°¶Ó€‡?f»‹7J®·?•zŠâ¬[?fÆrÇž.?= _‘áhX?÷_UÊ>¿!$!žô ¿¦²^zK‘¿ŒW—¥ÿÈ¿ VƒüNX¿ºê½¯ð–¿öÓõ\•¾ù“À£-Ë¿¾ëRÕu;&'¾Ùžn>ˆ/ú¾ÉUGú ׿Ü{Ð;ðm¿¡ìIã²¾¿ ùf§gô¿ À+àFoO¾ûÆ®µàÚ1¿ð?ïÿßé*—«¿Û’ÂJ¥7?ð?Ãû­³àª?~2ã™áV0?ª q‚\¾?|MŠmv?R%x®Ì?)ž­jFI¿,…Ç'óå^¿2V{FØš¿®¯{üTB@¿4F°SB@Þ¿‘†4Ã^ÿ)~f·³ÁA¿•ÈáÈ"ú¿ÃeÜ‚+l¾ðùSHg~¾àïô”¦‰¿*àð¸ Äÿ.Úè¥$˜N¿ ÚdúyKY¿"JMÁ ú¿IÆ(÷°(¿ïÿÿÿöʦ?ïÿßæOB¿ÝÓø§¬ÕA?ð`?˯§#ˆ?„q=¶ZÚ?±ý< Ѷ£?ƒjuA2Ÿ?XNÌ¥™ýß?2 ‰õ¼^¿3âT,‹sX¿8´÷%Z¬Ý¿;îü YG¿±ÿ º<¿%™ìä])¿1o§ÝÚàà¿šýŠq¼É¿2ö§7‡D¾÷Üëð¾æêd4´Ë¿2VÚ—Ôú¿55Y©¿&ö Ç ¬¾¿) Ær¿Ô.w¸A¿ðÏt?ïÿßízá¿äõΡÃ+A?ïÿÿÿ¬¶E?ÜâÊý ²?–Z©™V?ÂåÇáxíI?”šAd4û?iYï+ÿ‹þ?B=ZûØ3˜¿D°äÕú ¿Ju*–i%¿M´½ýS¡¸¿7?ëßhº´¿ÅcÕ§Ù¿BÄÙõŒë‰¿(~¾Q¯ç]¿@¡_@«=¿ )-k™éë¾ù$徿CÏä£^¿F¥§;÷"¿8áݵ7a;¿:ì×]$3¯¿+^²’v¿ð?ïÿßÔÒ{¿áÓ¯Å/`Â?ðÏt?ÔZÛçW?.LøRÑb?ºRvMóè$?Œ²ëGÞô­?aW¼ó©ö?9aÀ‡þ&M¿<Ô¶¦ÉÜØ¿Qx [¥B¿;…Ü»)¿F9YF´Ø¿-õ#Q0¿®È¢•ù—¿3÷Ï`üÖ¿[}&¾þÕæV‚¿G N1Ë9¿J±ÒR᯿=‘šXOÅû¿?Úõìl¿0"9;„9Ú¿ïÿÿÿìD?ïÿ¼Ï_F:¿ëºòQÏR$?ðH'Ì?ä^è ¿P„^y)Q¿5KA>Æ”¿&Õrˆ¥×P¿C×ÐAÍ¿90>Nu&´õÉ~w¿PºàÜóÔï¿R¬•´¤8¿EÈ7<±ý¿Føöì§ñ¿7ª‡AZˆ9¿ïÿÿÿ°²?ïÿßá®t¿à’‚êôØ?ïÿÿÿò‡î?нD¨¼ãä?ŠQ?û?µóÒsÄ?>?ˆõõyˆÊ?]d8—ÈÎ?4æú¥zyÄ¿7ô2î­7¿>î½lª¿ARÿpI¿+:±9é¼Ð¿5û>Ê›òÖ¿À9™ŽZð¿ÓSˆò™¶¾ýž\8?E¾í¢jGý{¿7;!7Ÿ¿Ê‡Â¯)è¿:sº wˆœ¿-4Î};š%¿/„ñÙ­”M¿Õ°ºNC2¿ð¿°?ïÿß×ûO¿á*óu,?ïÿÿÿû ]?ÕJZ˜}?UŒ?»ÁɆ=¿?Ž KìÊ?b>k q?;xý­áwõ¿>¨WJZ«Ï¿C=îŽÛz¿E´ãüâ響0ÛÊZJÅù¿;6‹³½R¿!¯lÆËR)¿ñ,à勵Ø8}š¼¾òËÈ(˜T¿<§EçX¿@à´Ù¦†¿Ì¤»zf r¿1õ™%ÒÀÛ¿3Š‹¶¡g¿#uö‹Óê¿ðß8?ïÿß«O=¿ãm¹§6çå?ïÿÿÿtÎ?פj Ïˆ¢?’Áyv=?5?¿ ˜«c‰?‘&F ì?e[*Ë—?=G¿üAe¿)‡¨)¢†v?ïÿßN¦ùv¿æGO · Æ?ܶÓfÕjÈ?—C¨Í”–?ÂèÛ Ûp?”ÛŒH{ _?iüÅc£´?Av1¾EðC¿Dj }[C¿JííêXÈÛ¿NPøA{¿7Ç8‰¶È§¿C3ÀuÄæ¿):$±åX¿žŒCßÖ¿ &vSwÆ8¾ú:­Æ¢ƒ¿DY¸”•#%¿F÷§ŠÀßD¿9¢„M9ïÉ¿;]@Uýî¿,}í¬+U¿´•\0|ʤ¿ïÿÿÿþ (¿ïÿß⥫×?ïÿÿÿõÔ[>íãûHˆÿ3?Že áRy›?—$¸gÿê¸?²9·Ä›‹?¢màâP/?fn¶´Á?ˆ’ú¸…NË?tä~º>±?pa À¦Ô(?=JdI¾?Sp]ÖÑAÌ>Ø Z%×RÌ>“^´ ®UŠ>R–Ü)—>Ý;ê:?Z0¥}ʪ?WAƒaîZ?0ßIåÂ*_?,À’þZ~R>ï Ô·R¼?¿ÞŠ]Z ·?ð¿A.ãÔ]?ð¿®öƒÊ”Ÿ?ïÿÿþúº‚?ïÿÿþ§:?ïÿÿÿå3 ?ïô[ðØ(Ø?ÌŽäV? ðÇí!?I/™zEN?jT}­Ÿ?Š’*!§¡?T}kÓ’™C¿<Í[° ü¿EA‡U©(¿Bþ“ë’¿>Öz€Àß8¿;žöš©¿#ÍÒVŒ°È¿1S›R·¿o¦Çð:¿Cʃâ´ù¾úM½EÀk¾ëµf!ÑùE¿4žðJž¿2•—|<Û¿'ï*l0Ñ¿&¬<:·`¿= @ËêÙ¿ïÿÿûD?ïÿÿÛŒR?ïôZk–?År…2^§ˆ?cº-Ð?X=\ôT…K?¤ È£H׸?xd\bCÐ?BÍÞuŬ&¿+ÒÕS¿Œ¿4!¸NÉí¿1¼H'º¤®¿,²!9š®«¿)¨l«ØÅi¿a¾pm逿 Ñma¯¿ÕÉ;Ûö¾ö‰/¿,àD¾è<â™xô±¾ÙÄv£E¬×¿"­Ë˜éH¿!>ÃèÁiÕ¿<„2=>;¿ íë]Ť¿ Pv‚ÑN|¿ïÿÿ÷…³•?ïÿÿÿüÖÂ?ïôZ Äs§?Ë×Ãb6$?™(äM_d?c×Í-ë?ƒÇ䆀è?‰ç\pP?Nt—l?–¿7§Ø~"…º¿B$@u•Õ¿>„c<+úœ¿8fûA/è¿5°Æ0½S¿ý|©п+1‡áë®)¿˜+!…™L¿óÌt ʾôˆ›Ä”ª¾åÜ@ÿ‘‹¿/¤_‰ë%ù¿- š—e·¥¿"ο«Á<¿!»¯ƒw¦¿n4Õ{P¿ïÿÿùÃÈ?ïÿÿÿí•K?ïôZ £½Æ?ËãàfP“?Û|¦#ìÆ?Hæ3Ñô•Ï?iÞyÜ?3FŠT$I?¬[¯ïÞµ˜¿(üŽ6¿%ï]Ž¿"hz¬°ùØ¿µõ•õ¨)¿ˆZ3KCZ¿ÿ;&>„¿£º” ³w¾õŠœi1C¾çL¾-M Ó¾Ùz;ÀS¾ÊªFc³¿RÆRêÇâ¿ѹRÏ¿þüË"¿¾ä’¡¬¾ú/P•ÜÆ¥¿ð¯ì?ïÿÿþÑ¢b?ïôZX«?Ð6³”ÇÝ¿{(QJ=µñ¿Dú žUW¿eF óx¶¿0jér‚º…?ë  %ƒ?-W7f{V?þ5à9˜?ndD&Vb? 쾚AO?žU÷ »Q>ÿ v®rÅ? !®h„Aƒ>ñ‘ŽD ·¾>ã4ƒ¬ÃÎ>Ôby¦è¹à>Ťœ+¯9?lD‡Ù/ù? '#E»µ?ºŽ-lË{?Æø*mî>õM'§ò{ú¿ïÿÿÿ@õ¹?ïÿÿÿø*~?ïôZ _I?ÔQá–U¿’õáZ¢ ì¿]rg\pK¿}»Ìq׿Fîß•h|ž?0I/ëÇÑ?7”5¶.‹?§¾±;/E?5(ð|qŒ?10Ëï¨?.ÏBl!¾?}M’ñ?#SþêcT¶? ¦$;º >û‰>íÌG“ý7>Þæ0ÕŸºÃ?&i« S2û?$¼vKá:†?²]aë¨?Kü½jÍý?a>D…Ó ¿ïÿÿÿSí+?ð_Ø?ïôZ ¨ ?Óiá0&yj¿•uÝYÔïÏ¿`³‡]H6´¿€Õd2…²»¿Iõª®Ì[ú?2k?o(ˆ?;JKFá…Ö?8=•Î»þj?œÈÚ$~ ?3¦+^@ Ü?1–+L*¸?5ÚøÖm™?&ítŸj? }?qùž>þå–Ó6È>ð›\ÍWˆÊ>ᦀĄýz?)˜ßaG?3?'§¹©¡ð×?zç8søÏ?Üt1S-º?X¨J²ð»¿ïÿÿÿñØ?ð?ïôZ ùÄ?Ö?# “¿ Þ [–ÿî¿jF PÝâ¿Šw®wo¿Tg¥|õx ?=<ƒ:Íä?EšéwÖÔ?C ô_åpú?>ü¦ˆO:t?°Š|onj?;¹1Và®?#Ýø5¬è€?1c¬7fâ?ƒS‹…™3?Z›5.G>ú.ÇvÊ>ëÔ«j8á?4-¢ë-{?2£ñP’ŸÚ?(i “Ýv?&¾_3ïæ›?XïÀ“梿ð?ð žè?ïôZ¸Àq?Õ²¿7Ÿ¿¢18«½¿lP²ìœœÁ¿ŒŠ;ÏC*¿V­ng??7ß‘'?G ]+„?D‹kî3Š…?@§k2Þã?=Ïöqå (?²×¿Îe ï?%^Fs{?2³Iîh‡?6Æ~Hl? 0¬™·§>ü&Æß@Vo>íë–^Ûd?5²²á?4 ÔâYYÓ?)Õ¦¯«n?(vqÒד¼?g¬ü¹ØÚ¿ïÿÿÿé˜ó?ïÿÿþ`ï2?ïôZxTØÛ?ÚäWËÂ`=¿°–D{ò¬§¿yÉŠKãót¿š&mÒ :¿dFÞTJ«?L:ñQý?Tמ)tÂG?Rœ÷(îè7?N6äüÇWû?Kz£LV†?3fÕ©§­û%÷yÕ*?C°dùžSS?B4Ý~­Ž²?7rík8x¨?66BÃ$h?*¯Ç|íp¿ïÿÿÿ§æÑ?ð?ïôZüRç?ØkVkæῪ§ƒ(V¿t:-vÌ L¿”hø¿_{9ÆÒ2?F¶UZ¥°?PRžž¦ÜM?M-T…B,?G¯“’+/?E7#­YK¶?.lS¡~o`?:ž '¬K„?ÒÄ- Zº”?!;>±oX?£WÁ}vª?Ht³É>õHqúº=?>ßô)k]?<Œ¥¿fób?2bA¿ êU?1j>›ìb?$ëý‹chõ¿ð?ïÿÿþ´\?ïôs½ˆ˜Ð?ÝkKå°»n¿´]íÎB E¿©Ó—=G¿ŸñvòÔ$¿h¤DûI¶?QNáD̦?YŒ>±‡ã?VÕ@OQ]p?R‰ ‡!ʇ?PšAxSý!?7ÎËV%?DÔk‡ÆI?*ø&v̳?óÏF®ù?,l¶1?XµxGDý?§Ù%s?H(›¡ªè?FWv"¸q.?<ÅÂÇ—úP?;AŒ&çý?0_a·È;Ô¿ïÿÿþÊæY?ïÿÿõ®Õì?ïôKë€*L?×àÜ1VS¿·÷ E—%>¿‚¢ÎþŽô¿¢Ê™¥G‹¿lýJOÆú?T[ñZyö??^oå¥Wƒ?ZÜ|+¬Ç?UÎ*+~ï`?Sˆaâ¯ÞK?<–u`5?H>:¤?/ºµ›ü?!(ìŸûæ?ó‰mãhp?p¢@3„:?˜†Å¾_?Lk„°ª“%?JIv3•b?@ìË´àÜ?@8s‘3¾?3B«)íŽí¿ïÿÿÿe6?ïÿÿñüÈ?ï÷±èè…¿?á2È ©u\¿»ì±••u¿…ÄsyÏÁ¿¥è'=1Êt¿qí â+?Wq?(’a?aaôÖn;'?_-3"zþ`?YKÄ%Ê}2?Vª&Ä<—Y?@BÌãÝã?Lt”óT¿3?2rÛ›j«j?#ô#!üg?mÄ}½n?ó{êxÉ?ÈÇ ãà?PQë#*?N‡IÙ,ä ?C¦QmYÚµ?BŸnA¨x?6\UO²kK¿ïÿÿÿåâø?ïÿÿÓvÀj?ð?âmEºêFÌ¿¿Ì#nÞqÈ¿ˆÅÙ†ý󿨨À'ü x¿s‹§vÐâZ?Yî>õ?cXçMÓÏ?a(Åc­I?\.›É øC?Y:;ìU§H?B'O6Uà?OÂùy®ëÞ?4‘%¬h¾?&M#Vš?ë¯ûxa"? m%rÿÅ?óYIðˆ?RZ8ˆf% ?PýÖ öï?EçQ‚8"þ?DÄg¨3õ?8âö/ç³É¿ïÿÿý^id?ð?ïôZ-ÐÑ?Ù¾ e­ß½¿¨BÚ¿ž#¿rÚ_†³¢¿“à²Õ,¿]WŸMg Ý?Dº­d?Nk’lw?K1è 40?F£ È›?Cžœ­ ˜?,Z«e}ß?8Ιÿ›Eö? ;žÔÜ*?^ÕóÕ×Kà¡Ò?<ŇÍoº›?ÐJ?4Ýž?:›ŸIèá—?1"*@gµ?0; ì¶o ?#°E1ýÿ¿ïÿÿÿ­¬?ïÿÿÿm7?ïôZw"8…?Ùaà„w}¿¨DÁEë‚<¿r܃›•;¿“=E]Œ¿]ZÂlÕ1¼?D ’p­Ó´?Nq`GqØÞ?K5.@ÒÜã?FBJÙeÚ?CÈ€/ÎfŸ?,^ŒÜ”R?8Ò ©E`ü? tN]Sú?a;ª|u?­'‚’{>óؤ2>Í–?<É‘û‡-?:ŸAØ™øî?Ñ h^åì?1$Œñý)?0=FnÄz?#‚kk±”Ê¿ïÿÿÿΨÏ?ïÿÿþTÖù?ïôYÄ h?ÜŸç`owB¿¯€þë;×€¿x|dæP#$¿˜´¶KD€ ¿c ¬X]µø?JÈ ËWå¯?S횊³J?Q©}†ýc ?L¬ËÙ=A;?I¯еº?2jPiŸ³?@™¥Jì˜?$ÜWÙâ›?J g'??Aþ Ið>ùÄÏgzs?B¯Õ†Pz–?AGõ¾í£A?6AM„ý€?ß<òåb‹?50ÅI%B?)T•<år¿ïÿÿÿ\Oj?ïÿÿþæïö?ïôX}D?Ü% 93¿¯W’úOß¿x\Þˆª¿˜”-5I!.¿bô–¼ô ?J¤¨oU_?S©¤µ„¬ú?Q’4GT¡?L‡º”Ä?I4ïrú?2R˜ú?@adum?$Àà¹;ø?r:£CR?J-¼>ù¢& &dx?B—;¶mS‚?A15t¡‘?6$2j \4?4ùk[2­,?à€½ÕzÔ?)2ÄæÂpà¿ïÿÿÿÓxC?ïôX °›D?Þ¬¿>Ú\^¿³Š´Î±çs¿~`þõdú{¿ž¦r¢pûV¿g¤d³K†?P›bß~ù?XƒìöŒÓ?UèxºZt+?QÈê¼üi?OÜ)’´îv?6ØIpUª?CüŒ´…?)à›GÚ÷6?ý–’ÂÓ?íé3ž>ÿöxà{ó?G.?Ì”p|?Eoàå cë?;›¯ñ—×›?:'‡ùd™?/kQj?òfÿ]žç?ïÿÿÿúÆþ¿ïôZ'41¾´¥‚´š,Å¿%趫˜=Ñ¿[áb‘€úÁ¿~ñX—ˆá¿€Ë®@᤿rïè¡9’¿nê- “¾Ó¿`P»eå¹!¿[- o€É¿3ÔdÊ:7¿DS5Æ4Ž¿ ‘{L€¸¾òEÂãO£d¾ÌE Ñ’<¾§È›e¿ILBÝ2,þ¿G›ÕÎ`éú¿8O:% J¿7S³WC=Í¿%%O,V/­¿ïÿÿþ¶²?¿ð?ð¿ð¿©X1fD–‚?¢ X ÄgíŒóØ>Ï!çÙÍä‡>È(b¹¡+4¿(A…І±¿&‡w>É¿ Ž›Ñó;‡¿ ¹0Ï›–!¾å3j€k¿ÆÍKâgwã?ïÿÿþ¸¿ðŠ K?ïÿÿÓY—?ð?ÃQ+¾¿ð F݆¿ðZ“}z›ÿ¿®”wr+ÿ׵iþ“¿¬¦gÃ$ÃÛ¿†o¾¥ ª¿kÿ;„;€?2  ÝÞ?V)º[!èã?]#Ö8#ú?L®F,<ß?T}B¶Yb?>ºx¥%if?1]QH!d~? ýÖ âÄ©?zK)ÛK?T=š¼‰k?Y’× ¼a?L>àþè†G?P=àdž?@qâqT–?ïÿÿÿ÷43?ïÿÿÿÞSÔ?ïÿ´R7!3¿Æ\ë‹C]¿Ò·¸Š,N¿“¥ Ÿ ¶¿ìÈi#×W¿»C[»cØ¿‘Sg2ó‚¿jS|)…'¿Nö ñ¥E“?.ŸUŸÕI?:ªŸFÀ?A+De^Ï?1_ZÊ)s?9iuÆÚ?#v 1Âô?#P0˜?7Ë?žµ>÷C(ؼ—?9Ç\\ ”ºZ?1óPÙ¥Ý?3üÂðÀI?$÷PîÓ?ïÿÿþD5ª?ïÿÿÿG%?ïÿ´+~5-?£çOú¬ÍÔ¿æm¢äŠ‚¿¦ ¢¨+¾²¿Ð´‚…ê%¿ì¡’¢¶Ù¿¤IÐ_vŠ¯¿|ØщuŠ¼¿böí&Âg??) ærM¶?O™•º[âï?Tåhfõ!?D7L™¯ýÁ?Mˆ3HÅŸÈ?6+IÈ@©ß?)ø‡Šþw? =à{T? {rÉâž­?MH÷EeèÏ?RKáá¶?Dc¦kÈö?G1ògƒ¬?7]©ïY—?ïÿÿÿçBÐ?ïÿÿýdÈ?ïÿ´);º'¿Â»wrXd¿ÖE0“õ¿–®Ö9nC¿À¬•÷|ο”sPs¨È9¿ï½ñFa`¿mvˆySjÙ¿R݈ØÖE‘?ÇÒÎ???æ{…Ýù?DëK»†r?4ŠÏ*°zÕ?>mX‹cb?&°VB·d?³ šFž"? nTî%aT>ún¼Õïý?=çÒ98Ý?BjøØ,´®?4âA¾½iÈ?7ràlD4?( éQû?ïÿÿÿ»r?ïÿÿÿþ (?ïÿ´,'α¿Ð„Så˜}¿ÅÀÝ«d‘¿† Õ,LÜ¿¯²`0"3x¿ƒŒÖM$ã¿[ŒÒ›WпÊå"Íì¿A¼çð<.î?<‘ÙàÁ¼?.‘‘i¾ìL?3óîÊê?#ÉŽ´=“?,è¸YÁÖ]?ó’Çÿµƒ?â Ó¯F9>ø¿Võìl\>éÈx:wÒ@?,àJÑÌþÉ?1£1ÿa:`?$5@&§sé?&YdØV¡?g®d¶Y?ïÿÿÿú?ðÏt?ïÿ´,œþ¿Óæâu P9¿¸ÍÁz~Ä¿w°XüÙw¿¢aEX£Æ¿v4ד[¿PʺCìLÑ¿5]"(µÎ¿Æw|šÙ]>þzžSÕà–?!6Áî-+?&Û´Â?ÞþP¨?ø¥½`²?ß¼Žõ>úü 3·>êU°4ƒ0è>Û1$º<×? Ó%]Òl?#êTC‰ë?öµôñ(?±YBܯ? I?ð?ïÿÿÿÉ@?ïÿ´,œçÇ¿ÖøHë³?…ÿÅvNb?2rkWæ)+?mރ؈Ô?>5œg|5?¾à¥ž`Â?U´#ã¾åäi­úpο²â øy™?¾æ|,fÔ]a¾ñyª¿î;H¾Øfç µn¾á¿cñ"f¾ÅÓPdzÂy¾·ãK<#cо ê©æO¾Œµ2» x¾ß :%Ù’ ¾ëLi¼é#¾Ó£%Éi’¾ÝÊü›Â’¾Á°áòÌTÝ?ïÿÿþÛÎ?ð?ïÿ´,Ÿa¿ÛW þ|ð[?¸C}(š@?x—m^Ý|¼?¢!t=,H5?vO•N¶¸?R _¢Z?57J…zGÒ¾õ½‚$—ee¿!M}Ï6^¿´G*0ƒŸ©¿&›–0þ™–¿4;¤Ͽ ?9µ¿b¿Œòdƒ: ¾ûËŽßýÿ7¾ëÔP|å¾Ü§êÁ¥Ñ¿ 7}¶Ä&"¿#ã}£§Þ©¿¡ÊV¢êé¿W&b‹"+¿  ³N`?ïÿÿÿÿ ¶?ð/L?ïÿ´+ŸTœ¿Ý›}*¸ˆ?Ã_wÜ(;è?ƒ'n«r?¬Ò3Ô7D?–&'Á¾D?\9X|¥­?@ïz°µ·‹¿[RmQpô¿+=á=` 6¿1ë­ÞÌa‹¿´édå–€¿!aù!pÈé¿)nî¨uK¿_Üÿ<™¿Fùd ؾõG)À5«¾æË'? $¿)IéoZ ¿/a<û¥]¬¿!š?zç´Î¿#Ý„ÊcD¿6;j[Ÿ?ïÿÿÿkJ‚?ïÿÿÿˆ³÷?ïÿ´-aN?¿äúöµ?וĘe²?˜ž¯L“ób?Á¶ª^ËUì?•îFïºÅG?pø°ËêÚ½?TUŸŸ…¿Kö0˜”¿AYãҤ¿F4¼DD’¿6ÌÿɃ¿¦ûSŒD¿@"íý†º¿(ƒ’hÎœ¿Ç×H8é¿ °÷ |œ¾üßÜÂ0+¿@%Û¥úÛ¿C¡^)5–¿6˜c†Š5¿9&:À,­¿*4ÞFÍÒ?ð?ð?ïÿ´+ •i¿áÑhG„¬?Îì²ÓRÜ?!æ>l ?·9"L.?ŒÃ8õ~8—?fŽØ“cü?J€O#6Å¿íãGd¿6agÍ/ßU¿=§Ë$…’¿,ç¿¿Ž¿5$[õ á(¿Å+/¥‘¡â¿ 36}H¿2ÇHÌ¿$¥¼®$‡¾òë\³9üú¿5)ʬ‘ù:¿9·æ¤Ù`¿-œ1suø¿0y@Š0È¿!+¯gÂ;?ïÿÿþº‹h?ð ^˜?ïÿ´RTѿ稵'ŽÓÁ?ÛémèõhŽ?еÒhõ½?Å Ì…“AM?š=€*ÁB£?tä£#øÈ?X6ôÓH@Ø¿“·›'¿Dn‰ÄUr(¿Jg¦º8¿:;íŸfœ¿CcCFN>¿-•©¾A£Š¿½ãP<Òp¿ ÅÓ‰?ÌÉ¿ÐGrH¿“‚Amß¿Cxý^Á¿Gm©CëTw¿;JsðmÍ¿>, ó…¿/Èê)΄?ïÿÿñ^?ðÌô?ïÿ³äª¶¿ìˆ¶Ž0™?á)Ñv¸Ÿr?¢eI{õ>ë?ÉãÐ%]ç? )å=v§?yÌ沊À?]ÊMrÏ"¿ã×J¢h·¿I,*k« ¿P@ C-¤ ¿@T¯8có¿GæL‰J¡¿2>ï¢#s·¿$°¾×µ˜¿©Æþ,2xÀ¿ÁÍ}!Š–¿´Ò«rJ¿HáÛW§¿LÚd·^tL¿@ÕJƒD;(¿B—·w/ì_¿3Új»¿ ?ïÿÿù*Š!?ð+K?ïÿ³ÒAa7¿íLŒ,(?â4 ÄÙb?¤ßG„>ï?Ë—”>.T/?¡^Ô*W®c?{ÛRz¤¤½?_“¾á8!f¿R•¥Ø¿KÂ,ÌØD¿Q_†îÍ÷¿A­ç ï™S¿Ià«‚±»Ë¿3ÝSžßп&ŠýÙY¼¿†oÊä¿—%eLœœ?¿ÞÇreÜ7¿JÂ0mº¿Nÿ…î€ÁV¿BUÚš@3´¿Då°aX¿5yk:ª›?ïÿÿÿÿÜÑ?ð;H?ïÿ´+ž^R¿ïÿÕçL?Y?äýS:?¦w`4xÍÓ?Î|ÅGr Ä?£D¹yfÞm?~ò²åg·?afqrè‹¿ å“®M/¿Nˆþ¿LM¿S8™åܦ¿C¬Ôv“'ô¿Lͬ„¡¿6)QN.S¿))e½›nL¿yíEÁ1¿ ÁM!µfv¿…l5ý6¿M <¨ ¿Q/õ!ʈ¿Dvˆ¶¨Ýš¿F[–§Às¿83Vª9?ïÿÿÿSƒ?ïÿÿÿ­òî?ïÿ´-gý¿àmPàU«?È™¿ùË\>?ŠöäŽ?²…ƒ¥²i½?‡ ¤³À6?b- i­l0?ELXò¸ô¿Œ©²R³N¿1ñÊGX0¿79†é¿1,NK¿éEºpÑ6¿ _þFn%¡¾ýd™¢¨y^¾î³“aûxd¿1}ô3í:¿Æ°cqº\¿4—äÔúßð¿'åR9&ŒÜ¿*yçÁ.º»¿ÊÚýGS ?ïÿÿÿÿÜÑ?ïÿÿÿûvê?ïÿ´1Š “¿á1ù»?лy¼—To?ßu7Ê®¤?¸ÿ6v£?Ž«]¿L0ï?gì_ËDsj?LúÙ~lß¿ˆ‚ï³à¿7Ò"ö-~¿?5•þóþÏ¿.½Ùô ¿6Zœ #‘l¿ ÞÎâ+2‰¿jAZ庿äß?Œ‹¾ó¡Û¼ë­®¿6GÍõ{:Œ¿;ná×Åš*¿ÆtcÌÒ„Þ¿/²ëV=Õ¿1r°ä†Ì¿!êÍGË8Ž?ïÿÿÿÿÜÑ?ïÿÿÿ”ï`?ïÿ´0É·¿ãI[³x ?ÒŸŸcaú?“öŠ‡?¼Æ`R¢N?‘‡Ëÿì ?k°c»¿Öà?P-×{Bõ¿Ö@¦¨í„¿;Q6 m5Ž¿A¤IÇìÕ„¿1º]~n¤Ä¿9ðÇ”ÛLO¿#ÍÝs¶Ý¿uOnmòª¿†‰£jˆh¾÷Ä;q) ¿:3PvýÆ¿?Sª¿¨cB¿2DÊB¯¿Ä¯1Ji¹¿4/%³.Ç=¿%I+@‘ç?ïÿÿÿÿ¹¢?ïÿÿÿÌR­?ïÿ´2g/;¿ã¼ñ˜<¹?ÖEÜœÅ8?—ÁÁ³ß§?Àµ.C@»Â?”§Óp¬¶á?p5€yé ?SHÏßÖñ¿Ã#Õèäj¿@£ ¹Žœ¿Dê,öÍé¿4¸;Ÿ;N,¿>Oß¾5Ò¿&þÔ;c¿ ¢ q¿ ï‰4{íE¾ûàm·H¿>QNﵿ¿BwTÝý×á¿52u½êr†¿7 F°´;€¿ÄÕá&ƃè¿(Ž,Ê&..?ïÿÿý:Ф?ïÿ´:œYé¿æ%ªŽšž8?×+më"¹/?™f9>Ÿ?Á‰ôê±Ö=?–¾üUÖã?q–ÙÛncv?TÔÍ…t7¿dç¦ÚÕ£¿A.“g”ù?¿Fõ‚w¿6d+)À«€¿@b´)Ç0¿)x»¼Ê ¿ŽåšZ¿ »ý¤ h¡¾þõ_h{”¿@|ªž ¿C«Î/ñÖ¿7/y÷ºk¿9w²šf— ¿+éÏBóâ¿Ã’w Òî>?ïÿÿÿ¬©¿ïÿ´-«bŸ>ì-öAím?ŠK“$T?•÷½á[|?¯×MÖœ¾>?ª30[8`Œ?— rkoïX?‘Š%ßÑ?~©X•íòb?xRù¢dk?I†êè|?`/u—¥se?*& }>µ?ex2!" >Ö> H!´¯>¯]¸n{!?e¹‘°¿¨h?cQ:iÞé?P»tÞ$t}?O«­›®È?7ˆSU–0?ïÿÿÿC?À•Ô#Án?ð¿ Øüàô$?ð?ð¿°ÌÐ8à6‘?ïÿÿÿ1V?ð¿ð¯ì?ð?Ïsq‹‹»?ïÿÿÿ6`‡?Ó×,9FÀ?ÞIÓ5Ý?ªR¶à#?ÁC¦š°±?œ¾?¥Ñ?m2~¹ Ç¿hGY-@-¿kX1kër¿r\T5cÏ¿qÓÃhÆGœ¿eï‘™R­¿n^énDd-¿^k×QåØ¿Sø¨îÚ¿IÛÅ”Ú !¿@l ~2¿pn3þ¥¤¿nÞÖeè ¿¿hÎ4m{¿g©‘áŸ÷Ý¿agò11€¿ðn\?ïÿà¦O’ž?ÌĽô«ÁR?ð>ˆä?Ç ø`(…t?Ÿtì"*™?étm´ŒŒ?´‹ø‡Á?‘'¾N†§?ayúÇš¿]ŸÃKcc`¿ae!mò¿f¸AˆO®¿e¢âóZg¿Zþ0ò¿b,±ÇÍB¿R±/³O¿G·F¹ŸV¿>¸,}àª/¿3ë™4¨X¿cÄBÄ@G¿bk‚ç=ο]Ÿþ´¨«¿\( ¨Sí¿T¾zvò¿ïÿÿÿ/êÜ?ïÿà9*‚$?ÐŽC¶°x%?ïÿÿÿÉoÎ?Ïã£1‰t?¤a‚މȴ?»‘“Áyß?è®tgÉìÐ?–† »ÛKO?g#ØO•¿dL=%Àˆ¿g™ÜŽ-šR¿oJ%Id¿m#A¨K¿a)kÝYï ¿h¢É:¿WÂq7n¿O}hsªí¿D'¹ÓS»¿9“°&LÿjVÇOÌ÷¿hOÄr0­È¿cn!Ðn¿b„ Ãi®•¿[Tßÿ¿,S¿ïÿÿÿи“?ïÿà9VÂ?Ó'?DýðÝ?ð?Àä¦oÐì´?–2šoQÿâ?­b[€´/’?ˆxÊÎ}¸¢?í1Þ‚þ1Õ?XôxJ%üÅ¿Uƒ_zÙ¿Xá“20/¿`#1ñ©¿^Å/Vw¿Rª[ ;„¿YóOÍq> ¿IÞÌak¿@ø«C×)¿5úx+f7¿+眩qÑñ¿\.„ü0S¿ZRcƒþüG¿U)2×+Ðà¿T"Xf&W¿M¦Ü2¿ïÿÿÿxY?ïÿà9J«H?×ÔŸ Ó’ž?ïÿÿÿm}v?¡jL¹jÄ?vå ‰±Ï;?ŽL.e?i:òq^wa?9²Ü9TÑ?з¥V%¿5^B´þ2¿8©×ÌN¿@iŸÃôl¿?”ÿnI¿3?DòèÓt¿:¸Ñ½µ0¿*®mÙÍëm¿!Ë#âr6¿¬?õ—U¿ Éî0iþ¿<üÖ“û:¿;ULPÓ²¿5ÍK |ì¿4ÂÎ먭¿.Và 5z¿ïÿÿÿÙ?ïÿà;'¸=?ÝæŽo%?ïÿÿÿˆ³÷¿¨`·öÒõù¿€ É9„ |¿•7}:ÆVÇ¿q©¡ÊAÖW¿Aê9¶I?=„›U® Œ?ÚP\d²?®?@|GG¨·?F4w¸É‹?E¼ëærÀè?:ö΢{¶¸?BŸ¡#¦m?2³˜PI ?(’_Ø [?Ï”H…»¢?3¤žÃ^?Df¸ÝEI?BòÜ Ì‹?>ss\æ?=âí3–Þ?5`Ì h¨¿ïÿÿþÓƒ?ïÿà9Ók»?ÝVÏŠµ¹‡?ïÿÿþcç¿°œø|ªA>¿…åq¥üÛF¿œíh½Mÿ¿x\X¿ø¿HYØeÈ–?CÓÈ*UÑ;?Eàô”ÆsÚ?Ì׃MâÆ?M•Éœpm*?MNUv$þÔ?BbGAl¥?IOÍCçúF?9‚òèºò?0ÅÏjGÓ?%µ{°ã †?“ðæ\e’?KA 6€pG?IËn—Ñ)?D·ðË/è[?CÓ‚cÖ!??=‹"Ç W¿ïÿÿþ‹ŠZ?ïÿà8z–%?á;D…­*?ïÿÿþˆ„L¿Âäg!ë7¿˜æ­ýFI“¿°r³gP™7¿‹a »¥Õ{¿[±SÖÆ?VŒi-U˜¸?Xá†ì…þ%?`Ò•Ù*zr?Ù­¡†b?`©ç ×p?TèK&öH?\ÈøÝ­3?M%aس*?ClÒ¹?8°¾+?/\ÄcÑ%!?^þyCÿ£?]U„æzŠ#?WÅ„ü}?V‹öPó³à?PRv‘_4¿ïÿÿü ÿÂ?ïÿà6¾?áv2˜Æ?ïÿÿûöu†¿Å?2Ú´ ¿›Ë( ì0¿²\j^†›¿ŽBœs^¿^íù—Qk’?Y<Å1ºá¨?[èëæËò¹?bÛh²ö4=?b£¢O¬%?Ü×?“šM]?WVS³¼÷A?`EvýâŽ?P1ù{ëd?EI“ÃüþE?;³ê@ËY?1€/”jÐ?aQaák(g?``”o–èò?ZOs»ˆ?Y+ {\“?R|ýE*/x¿ïÿÿ× ¸?ïÿà= ×]?æ¶ã¶|V?ïÿÿ×ж¿×ej³hæn¿®Ö€XÕMU¿Ä^Ž×󄨿 ô —žù4¿q%ÍZÌi0?kí¨·Mü?nлÕU[?tÕ¶\~“*?t£ éÉA?iäÿབ?ÓºÉ$,ª?qÒöôé„?aöð¼ÈĽ?WŸ0°{E?N’ì¨yÇ?CkwÞ?s1-¯ísT?r)öÉ `?m-âÓ?U¦?kì3›jõ?d‚…?zˆ>£Œš?pc¤\{¡?vªoþaNñ?f»[;†?ð³„å?]Û…I³’š?STÀ ¡?HŒ4Jü?x€H¾Õyu?w oCrß?r…HΠ?q­>n ¥?iÿ¹ü¦¿ïÿÿ¹šx?ïÿßó‘?æ‘ØÉà‡?ïÿÿ¹T¿áÜ´¾¿·aøk)¿Ï“Æ¿©àÃᶹ¿zGÀJ$7?uóê òÐ?xpª6G¿5?€nÃʶœn?€ê'à8z?s¿Ö»ð5å?{RK97?kcÒ‹¾ÿ?aüÂi( ?ðí"òb!?WIý¬¤ð?M“¼µÑŒ±?}ŠÇ¸LÆY?{ÇN;ß9 ?vRu¹›Ég?uM ÔïZ?oTCh´à¿ïÿþØ£¯T?ïÿà©·Y?í.š‡?ïÿþØ¢ÿh¿å<"dæ\¾¿»ò!<ÞÒzT¿õÎÏ¿®ÄÅnm¿Aóöu?yçºÙùC¬?}‘Ü3?ƒ’0?ÄRÔ?ƒ %–æM‹?w{î?M÷?€>ì=˜ˆ¬?pH2µ™-œ?ebL›Òã?[¯úuÄU?ïãêK®Õ×?Q”É:€BÙ?‘ñ9d/ü?€ƒÿS¥Ž?z‹,ß$îl?ySYÏ ÂO?r %ûÕ D¿ïÿýZ1¬?ïÿÝ”ÄE8?ïÿýÂsã?ïÿýZ1J¿èeÏ„ÊÑ¿À  ÆßC.¿Õ:Á¿b6¿±¬ï¸OO¿õcžé?}É6 êO?€À /l•?†ƒM~h/?…äš^ßÕ?zú2Iúfæ?‚«÷ ?r´Æu?’¦?h‘÷Î6#?_Îý9§f›?T2¨¥¯&?ï¼øøœ<}?„1‡¹Î4ß?‚úµ(©þ?~ðV¾àZ?}ËHUHe?ufoÏ!_>¿ïÿÿôÈb?ïÿàNR±?ä6MA·š:?ïÿÿôyßt¿ÏY{.kp¿¤¢¿Ã³¿»HV¢7‚G¿–¶¡`Ä¿g h€ƒ?c:¾‡B?eJ…°xPÙ?l©KÁ\Íî?l1˜V­?aUôV@àû?gõÃïØ?X £ŸØ$Ù?O–Æ¡MD?DrÌÏ(\Ô?9ø”ÞÛZ?iâÒîØŸê?ð _í—òÌ?h_8âLŽþ?c•8uª_ä?b²‡ºâw’?[~4Ý|E¿ïÿÿý6¼?ïÿàHÈ1ø?ãóë/A8?ïÿÿý-¿Ïqé¾Ï¿¤²¯QÿëR¿»]ŠKAß:¿–Èjã(/¿gü®À3?c‹^gÝ?e\EŸ—cÅ?lÀæПD?l–Ã-¤8?acb›cß?h}P¿2!?X;Ä.‡4?O¯&Ißh?D‚“ü3XŒ?: ›Êùbù?i÷6BTˆg?hr4l/úÅ?ðp°?c¤wœÏ?bÁÕ˜ôZ?[“Š1jªp¿ïÿÿíç?ïÿàIùOG?çK|«Šä?ïÿÿíå%l¿ÕÓt%‘¹6¿¬»±„­¿Âþƒò·Æ¿Ÿ >¦Ùj ¿p >7Éjü?j‚WÈUJ>?m¯l"¿õF?súG“‰a?s‚™?h#g²ŽëÓ?p¯ŠŠÀ?`½vÚoKï?Uý¬œòQ?Lx“û±„D?By4`ï™?r5º°è?pøÔ`µ?kE1¥?ð. §>@­?jÈ7>„ˆ?c$:Ž*þ¿ïÿÿâΞ•?ïÿà@?LV  )Ä?AþåW5_3?qòæ®°q?päà|#?k$÷,¹Ì@?iéßô6¯?ð/UvK+8?c ’.߯v?ïÿà\Ÿ†Ï?éjíL¯LÅ¿Ü>T´N¿²–¤öh€^¿È”E%Ú¿¤vSê§X¿tŦ®-Ôª?q-l¾1?sBR¥>î?yé1š¹Ø?yE»Æì#Ž?o;ô3mâ?u˜uk²&?e©÷À?\s·X«?Rk!yµ8?Gdc4A*e?wW…X"4ä?uö!R%Ó?q¥šäùý§?pØ ¾C5?hÅ\}dxŠ?ð+CÙ’8¿ïÿÿÿý†®¿ïÿàAÅ>?ð¾Ñ^<Çœ¾™¾û¢}òT‡Å¿Š> 0Ųý¿·‰ãuˆ¤¿µ‘MÀp|¤¿©(õ":z¿¥ M Zxµ¿˜ªmÝìð¿•QÑÁî‹¿w’“VT¿Ø܃Öø›¿e¤#< 鶿W«¥Ê€’&¿IÔv‹ ‡"¿<˜6FºDj¿„¶yŠ× j¿ƒ™ó´.}¿w“‰k⛿vŸ¸2`§¿ièùº„†…¿ð?Þ¸ž* ¿ð¿ªM57ƒ4!? _v6ß?vÿ’² ?˜eý\¤P?“q@>€Ôú?Œ±¨YZ²K?ŠmÔ•žé[?‚a$P?!·¸:É?jZ4¾â!?u!"S‰Ñ?`Ψúêá?S¦m´Vf?GqhQª?m9ì6#$?bwÅk¤¢¿ð¿‡v¢;"¿ð¿¸4;¥]K»¿——Þ9L¿¨”xfÈÓÅ¿ŒÆ 2Y¿|@ÂQ«xm¿mVcärS¿g°< þàÚ¿W“ëäq0¿S·?êM,¿')Ø\*ÔÍ¿>ÚÒʼn¼Á¿ tUò·«¾Ú… ”';>åo †¡ž>êšµ@e•¿Cœ¢ 1)¿Bdïjf„¿.‚ó0Žpn¿-¼%g’¿c¸dªÀ“¿½PvkD6 ¿ïÿÿô±Ï~?ð|ª¿ïÿÿþõó?ïÿâ(cÐ?µTÝ\ק7¿ïÿÿÿB›ï¿ïÿÿÿ©F©?ïÿÿd¹Ä¸¿· æNâ{¿ïÿÿþiºÿ¿ïÿÿþ5b?ïÿÿô¹È0?š…LJï¿ïÿÿÿ¹çø¿ð_Ø?ïÿÿþé"鿲ž½0_Þ¿ïÿÿÿÆ°¿ïÿÿþ²ú?ïÿÿúqÀ¿À}ǦY ¿ïÿÿÿÚz«¿ð?ïÿÿü÷1î¿ÃXQ?­©¿ïÿÿÿó~9¿ð??ïÿÿû8Ë¿Æ`–›!¿ïÿÿÿÒ^Ê¿ïÿÿÿ}K?ïÿÿüDïÌ¿Êk”`H-!¿ïÿÿÿÚz«¿ðÄ?ïÿÿùmœ¿Í ·[õN|¿ïÿÿÿǬ¿ïÿÿþõó?ïÿÿú—¿Ô{®Öu9!¿ïÿÿÿ†ê‘¿ïÿÿÿù­…?ïÿÿ÷ „¬¿Ñ`‡8ëí¿ð]X¿ðÄ?ïÿÿüöë¿× xöÉ¿ïÿÿÿâ Ï¿ðÄ?ïÿÿýLôú¿Üx÷¨æ¿ïÿÿÿé˜ó¿ïÿÿÂFÇí?ïÿÿù;A¿Ü‹9îv (¿ïÿÿÿ–O8¿ð?ïÿÿö-±¿ß(óêâ•¿ïÿÿÿ9 7¿ïÿÿþî?ïÿÿü·I2¿Ï˜·U²¿ïÿÿÿ äj¿ïÿÿÿn 2?ïÿÿÿé 6¿Ðw¤…¶¿ðn\¿ïÿÿû’­«?ïÿÿùåÞm¿Ò‡ïã¸Vµ¿ïÿÿÿùŠV¿ïÿÿÿø·:?ïÿÿ÷ʧ¿Óš¹‡Ê¿ïÿÿÿ¬L¸?ïÿÿø5ÂÿÕPžÈaÚ\¿ðÄ¿ïÿÿþlv¿ïÿÿÿbÅ?ïü»Òmp?H †p–©Ñ¿ð¿£xÉbÌÕ÷¿ð?ð/7š?ð?ð?ÎÃ㔿?ïÿÿÿR°‚?Ș×Ã]Xš?Ô“ÂÙ»ý”?œ}ÄO?´oÄ5Ù”?|c•ÁYÀ?FöòŸó’¿e?Ž=@¿eœ ¤Kµo¿hóëˆÓ¿fØU8„¿X·×êGX¿aê7*‹9Ü¿PA=ðoد¿D`Í|8ƒ¿9Ž•óæ¿/RJg­Ã¿c·ZÖŒ Þ¿bqÍ‘Ñ2¿\Hkj++¿ZÅ[û{¿RÖN]š?ïÿÿÿñnu?ïÿ÷ÿܶö?Ëóâ«ØF?ïÿÿþ¡Ð?»Â ÿ"ÂM? Eoä¿?ípQ/÷‚A?§ À©ï´á?€¥O$¥Á?9»¼r¬¿XО4ïži¿ZOÀ‘1Ý¿[¡ðÁ¿â8¿YѨ)\Àç¿Kq{O¢r™¿T "»&¿B2} ­¿6îÀÎPá¿,–žHŽ¢¿!ƒcß~é–¿V.@rBÈ¿T­ŸØ|½¿Oˆ½œ5¿MûYàݽn¿EK‘Špa?ð?ïÿøýŠ[?Ð.‚Ûø“?ïÿÿÿí+¾?Ã-%s‡?–VqVh(?¯±ZÔZœµ?äw‡S=§Š?†å^Â7F?ARÂ/T­¿akðnÕõË¿bì&äÊ¡¿c3íCÓˆL¿aĪƒ“ÿŸ¿RÆUŸ€¸¿[Œ—R¬¿¿Hä1¸ü>.¿?\A3â¿3‹žÛ€Cy¿'ñ@ØMŸ¿^oõô¤ÏÓ¿\P°:"2~¿U–Öcs­Ì¿Tƒ„;b†¿LáÏçÎ/÷?ïÿÿÿÈy„?ïÿøM5?ÒÄév(h˜?ðÏt?²ú|ÄŸ?†³‚ÍUâ?ŸKYr®l?v¾–ÿéq§cÿ¿Oñæ0ò¿OdÐ:Uõ‹¿RT£ÐÆ,i¿Q›ÑhcPï¿C&:Â}¾¿KÇöð«¿9=¿ôA~¿/Ö±biPý¿#Ù¤F)&¿U?q¾È¿N€Œ†w¹•¿L›M»â ¿EεòfÀ¦¿DÆ£"*‘Ê¿=;;;?ïÿÿÿÉ@?ïÿøƒ?×yŒ\÷ðˆ?ïÿÿÿÍH÷?} Â®›;?Q*B­ds ?hžö¶ã ¥?Aµ¥î­>ú–HlF?ÆË9q²ãK¿Œ ,\»´¿é-A…+t¿ö«Å×Í¿„̵ÔáN¿ ‰í‡sJ¿—=m8Ïn¿—àZˉâ¾øµGò¤Š¾îÎzI}¨¶¾âàΆâ÷¿Â8u:N¿:ç¯*~’¿ò¨f%3G¿"B×…²ù¿´z7¹„Ó?ïÿÿÿ£]¼?ïÿø|™?ÝšõÙZO?ïÿÿÿ¡q'¿¨v•‡ð_¿|ZU% ¬8¿”T‡¢ çX¿mS`ô@†¿%êÆXkCÏ?Dô9–*æa?Ò¶wN‰ž?E} N,?GÕÀsT÷þ?F¶Ã*þˆ?8l8Âôóz?AØÎ?¨€?03d…~8?$n–›Ř?y³÷¼EU?9]Á-?C ˆÛÞJ?B`Wxªá?<Áe\…ï?:­·´ã(?2ÅXÚž÷[?ïÿÿÿ|U_?ïÿø/UP?Ý ŒGUm?ïÿÿþd¥-¿®bôî9å…¿ U(YZ¿™B@ Ü’û¿r50+ϧ‰¿+öfA5/?I’9ÿçìE?I Û¼Óe?Ä[×›µø?MY/>Jñ?L1T¼ò(?>síÈbœî?F9ÝÕˆ%?44[1þT?)|øÛÿ@?Èù!`>?zÂɇ?Hk,˜Æ ?Fæ¢ H¿Ì?Au.¨Èµ|?@¡Í>l=$?7fžÆâÍC?ð?ïÿø 0Ãê?áç僲:?ïÿÿÿûS»¿½k×ý {I¿‘¶jº1¿¨u Ï1¿¡(¬V¿:@â9u“D?X´vnØÀÄ?X4JdþÄ?\b—³ªð?Ѩº4?[K“Á$…Ž?M€š/È¢?U‡*¥…6?C’´Ö¢ÚL?8±Bú(³z?.Ê1K„¡?"ß7íåÎä?W¥Óóñ?V.Ù¬À b?Pé¢éØ?P™ a9?F«"‘¨Ü?ïÿÿÿ³+ð?ïÿø¨.—?àïL4x?Ò?ïÿÿþJ«T¿À1ÑW«m¼¿’ÉÃEß[¿ªì\µÞ}¿ƒh‡~d×B¿<ëyÀ¤²?[IYÕ­´?ZÙ¦ÞFφ?_Lf‡qäß?^ m RG?ÓÊé='…?P9ÿó®ÈÆ?W¯û ,Ø?Eˆ S‘™?;)dÁÈN?0ï&×±G?$Â!‘c‡³?Zú{¢?XgçÍ3È?Ršé=_Ói?Q¹{¬­œ¼?Hð3\==a?ïÿÿÿõ÷Š?ïÿ÷øÞ’„?æ|Œ"M?ïÿÿò>fտл -±ƒ¿£iRf-¿»Ð´„x+ð¿” ø ­qí¿MÞoHÙª?l%9Ô¿f×?k£]§·ûv?p'³K™HD?o ³®<ƒ?`ÅãF º?ÊÊÒ”ªw?hzWRl†?V@ ¸nLÞ?LhŒóÚ·?A€uö&Y?5tT1*h?jä!ômýs?i8­tùi?c:YúcR?bQR”xÏ?YÅÆŠ;ŠÂ?ïÿÿÿµ^ã?ïÿø ¯Ÿ?ãgUŠå!?ïÿÿõíq¿É!ez„‡¿ûg8Ï"¿´âmpe©Ú¿Ž·¦žOC¿F„¼|‡?eˆË$»WÌ?e¬¯’¯?h}n§·Ç?gUh¤M¤?r6·0¯?r3XY2mØ?tw}Ad?syMbeîŸ?dë×dû?n“àØg9ð?[ÁL®>–H?é\Ÿá.Œ~?Q€KF5Ò?EÒ!¹¶¦¸?:¾|”ßdH?pÑòW òS?o|—“Èâ°?h·Dˆ?fÚ˜ ’Ž?`ŠD¿?ð?ïÿøpóD§?ærÐÁÃ?ïÿÿ³Ó2ÿ¿Ù˨yº¿­ 18U ¿ÄÕüÑKm¿ž—ÃŒ¦¿V{z½»©?u”já©“š?uÖËÉΘ?x|àŒqN?wI #W§¿?ig®DÇI?rF|œ…>\?t™©z“³?rÑ[QZÁ,?l±’ÿì1?kPÅmÀu ?c8A’Uó?ðˆ?ïÿûÍAè'?íy¥ÈëX?ïÿÿ"ätG¿Ý¡ÅùÉÛ¿±*WuXñ´¿ÈŸ¡ _ö‰¿¡ÂÖkö÷G¿Z’ŸéòBÿ?y‰Ä­Ô?yáÕ€{ä?|õCõì£?{…DeHÌ?m‹@¾#Ó¾?u˜ NÞù?c˜·—}¦§?X¶^1m ?NÏÑ…?é}ÌYÕ?Bá— 2µ?wÂßâÔ¹?v;ïÈ.î ?póS(ˆ_t?p"þ¡ÈÞ8?fµ\¬™J†?ð?ïÿúGÌ[?ïÿåù}K?ïÿþºÚ(Ï¿àó<ü1­¿³£j~z}Ç¿Ì,GR-yJ¿¤RBEŒ†¿^f’óŠhv?}>[ÙË]Ô?}¬ªµÉ6?€’îË 9b?}e\Ä4?påý1æ…l?x´˜òaA?fj¹a?\DÄé6`?QŸlà‘)?E™ÞàÈX?èâ…Ð;4M?{/K–„ ?you¦ºU?sd¹¹cÍ?ruªp;º¼?iú2”UÄ?ïÿÿÿÉLŸ?ïÿ÷÷óFß?äNË!8?ïÿÿþ¶kà¿Ç_&ÜB¿šÈÇÆnÖ¿³4Â-y^¿‹³õ%%Ht¿D´ÍäÁýF?cÍåùå@‘?cîm|«CÛ?f…ªêƒìË?eu^íBž?W𨦎À?`Û6Üwó?N›S™î3?CLÒï¯h?8eL)?-~~ ï?bŠ…?l¤Z?ëVˆWÇD?a[ÛãjÌ?Zw–›éT?Y3v$C?Q»7?<Ǿ?ïÿÿÿË\c?ïÿ÷ý/!?ãÛÔ§b’ù?ïÿÿöiW¿Ç)—ŒhĶ¿š×þ£§ÿÞ¿³?¹1Ø#§¿‹Ã¹æ¬~¿DÀjl-—)?cÙŽßÿx?cù•µw±7?f’rO b?e™LtÚ•?W¢6n?`äÑâ‡[e?N¬Äý$®V?CWÒÇ Yp?8Éï*?-J\Ù&¸?b•Mê©?aeÃËû\?ë:ìL8)?Z†ª·[©F?YAÕ%n¾?QÅP¦ã 2?ïÿÿÿùC÷?ïÿøe–<ÇNCè?isP³?gx£ B—Ã?aä¶é¬4Þ?a uØö«?éê«"[Ï—?Wùq?ïÿ÷þ/ĉ?éPÛ4ÛSl¿Ô¬wŸ€ ¿§6œ…¿À¥2ÜCLF¿˜ÈûýÌi¿Qôkgç¥ë?q4 £®K?q]6z;x?sŠ»‹ûý&?r™ˆO¶e?cüÐí"C?m5C/â?ZƒLõ,×?P·Ï«œ?DØ.ì•?9Œ*b3}?pð¶úJ ?n¨"&Á?fíélkgù?eÔ²À¸Ã?^¸…t—*?é~æ@MI?ð¿ïÿø eÊ?ïÿÿÿTyç¾æ†ÄÕPS¿3¸˜Š…Ÿv¿—6²Ü&𿺜صÃNø¿ªxNãƒV•¿ŸÄ¢5%v~¿š`ù1Ñ».¿Žjœ™ÑÕ¿Š(nE\°¿jï¥áû1³¿z"H.n,<¿\Z’£HO¿MãvÎÓh¿?„ IëSË¿0ß{üû|¿MÅô,Þé¿}5Ñ™JÄ¿pe Ã4?u¿oZ‚Ö”¼ð¿a3u2æ&Ë¿ð?Ì Ëþ£¿ð¿©·¥6‘Dk?¡Bvôˆç´?‚"úä“Z?™ô€Q¤2…?“©êoz?Œ3Ã&ÿ§¬?‰£ÓЮ—²?~c=ýv?€LFQ8k?fùˆ)ƒV§?s6lòs`?[0¬ÈD“‘?PôW?Äî?BCHõ1f?5«c/¿ª“?u°Ø¼ñ.?tÅîÊF×ýdœzŠ>à¥Ôb4Ô$¿@èßWC$K¿? Öb*H¿)öù*R­¿)å\ÂÆ‚¿»‘ÁÞ#y¿À5Âg…£Ð?ïÿÿÿÿ–r?ð?V?ïÿÿÿ¶áê?ïÿikÑLË?½N_Êe>–¿¸ :3!­¿î<ËîÄÛõ¿ƒM$CâuG¿¢¯¦À5æ¿€8ŒÈj‹°¿c--F ¡-¿P߃óµÙK¿>¿ÁŽ5áÏ¿ú;8Îàk>û‡™+œp?@½¤´H?ˆ¬nìÓ?œç¥jÍ? ãõá©x«>ÿâÿÊ««>óÞÇПÍ?f')(?!&Š­*õù?²òÀûÊ?j9mË?­I2Üâ)¿ïÿÿÿ¿gX?ïÿÿÿy•¯?ïÿü[_‚y¿©Û¯ÿ”èSG÷id4nõ>릸ãQ1j>ááEº°>úžþ°±? ¶ëA0J‰?ç%žðSB? x÷ª<>ÿ•ÕF²i¿ïÿÿÿ Õ#?ïÿÿÿ5jò¸¶“¿±èÿ“ä¿}>©9ÑgD¿›çŒhÇ¿ñ)m‘Æ¿xlGå™ß¿]j²Õh«Ò¿JJ·¢PŽ7¿8¿áÛ(¿j|Œ‰ö>ãÃÁ,#.??Ó…»j?e¼}çòh? V%:©? |›«>÷àr¿j›ª>í*¥ûç\€?À}Ù×*?S6X³f?‰/D© Z?¬ÇdÉÈS? M‚ÓšI¿ð¿°?ïÿÿÿç¬^?ïÿÿóè0¿ššË¡;û¿¤õ÷í;Æ‚¿q‡Á6,:£¿iКË2¿l÷,ÈXƒÃ¿á™{–BŽ°¿Q‚«?®U¿?ì¡;I¿-Î>h¡4¿¸†4ä‹t>Ìáö¿¯? žÔE®þ?ÊÍãyšª?SA«•7>øÌÛRˆQ>ìùîbÆI€>áÄe%´>üM5kJ·? V©»d?º`ÕÕ? âü×g0R?SŒÿÔ¿ð?ðîü?ïÿÿöðÚ迲¿¼~þ0¿™ÜNh¿e÷¤Å œ¿„P)1þn¿aûj;ù–Z¿E«8åuM¿©*gxª½¿2ÍG§,­¹¿"°þðqª¾ýL°}Y¸>¶è–ªÞsC>ÿ™=ìò— >ûjÄQ®è>öI™ X|>ïa+Hx€>âoô†â>Ö§ýÑËXÃ>ñâ¸Å&ªÇ?¢ Y&>ú¼TñÍJõÛiìv¾¿ð?ð`?ïÿÿ÷ñº¿µ@7³¿“¦<¹‹¿`lŒ/¡¿~Â`0äý“¿[W¨ké¿@E D†aÞ¿,c%Œ›û¥¿§sñp"óö¿óp‡n‰u¾õnä)fH>½ a”"½¶>÷ÂŽÈ]>ô­x7–üq>ð¦£S·q>çl‰bT• >ÛZxúS>ÐÃÅ¢$jž>êÞädëÔ¼>úè4¡rr>óöÙ²}ì>ùu“óY>ïL°b¢:¿ïÿÿÿõ$o?ð=Ð?ïÿÿ÷Ýïò¿»Ó©y¿†òë&°’¿S”ÐWé‘¿q{­iª¦¿Ov„Þt/¿3%'pí¿ tëê¾6¿ gµè¿•F+5KÛ¾ëNù~ÕkP¾¢¶Ÿö–ͬ>ë ªEQ^>çÀBÀ?ƒ>ã×…š‹…”>ÜøxgÙô>л½Z?>Ä´ o*¥»>ßT f§ä>í‹TËBÔ–>çÔe˜Ë¾>íZÍ8©>ãØHRÆ=¿ðn\?ð. ?ïÿÿø ÍÑ¿À¦„ u³¿m]Áùtt–¿;0 .Ãx¿W‰\–Áâ¿5†7¬Œ}¿qÞßlú ¿¡›:ÊÍ·¾÷˜Žœ8˾ӛXË98z¿•Àö. Ç¾¢çѪ>ÒІݙˆŠ>Ð:M²Œ>ËuÓ}Gg>Ãm\M¯©J>·‰»Ç5 )>­Ks›ANl>ÅYUlÞ7q>ÓTOVt>ЕåWZ>ÓáVk¸ò>ÊËjp¸¿ð NÔ?ðÌô?ïÿÿö{å¿ÃæÞ ?GV:­®E>ã@ž&)¸N?-lÒ-=¼P>ÿå7[Ø i>Ø's!éP#>ÑÛ’OøgྲÇyå0­¾¤ù—„Ðg¯¾¸9eLE¿”â‡Pâyã¾›Ar÷MÁ¾ ‹N¾tœ¤P§B¾añ ðFP…>p°»k=Zë>oÌiMJÌܾŒYq{ +˾´W“ü”cA¾sÄ’jQ%¾¢.»SÝn>°€/h¨É¿ïÿÿÿ¨P_?ð;É4?ïÿÿõEø?¿Ìá©Á?“®3eÍTt?`r–Ô›‹?~Óní[Û»?[?nÍ[Qú?@µ¢<¶à?-Äp-÷/?åE»‚/©>õüT‚4í¾º(~t¾÷U:¨†³)¿lËÁÁwC¾ô5˜â€’¾ðb˜J ½¾çY¹ûÁ)¾Úø…AL¾ÐŠ€&Ž!¾ê8(j·¨¾úH«Š§˜¾ó’Ê•sü¾øü‹´'™¾îÄO§…›¿ïÿÿÿÉ’ý?ïÿÿÿÒ;›?ïÿÿÿ ¯¿ÇhÕ³(¨G?klÿþúÉ?LÌ]_)~?k4êÈ2é^?Gã2)!\T?,½µ-sáD?_çBc?%O ól>âTE:'¾¯ß!4J¶¾äÍ%½¦tǾâÚøHÞ¿›Âe$k¾Ý œ‡¦Ìµ¾Ôl?š¾ÇÀp{Ìð;¾½§µ¾×wÈóÉÝ3¾çÁfádÔ¾áb1 DmP¾æQ",îô¼¾Û*ê«›¿ïÿÿÿö„G?ðH?ïÿÿö`h!¿ÏÔwÐZn¶?™qEò¡q™?eá„F-§n?„ QŒÚòû?aÝÒ±Ä_¤?EºÇ5Š-?3ð.[jæ?"Û+ðÎ">ý0ý¯K¾¢—à*’¶»¾þù­aØe ¾ú½™+Wõÿ¾õúGµC¿|ç»u®Þö¾îýè—÷Àý¾âKÞG1·–¾Ö‰1 +~|¾ñzçb³H0¿ ¯;ðݾúR¸ZÀÿ1¿†i°€l¾ôß°ûã(ú¿ðŒ¤?ð þÀ?ïÿÿùi¿ÔÌ¢úójy? þ¦è'H?mV:E}g?ŠÎ}O¤ö?gî4mòa?M)3¡K\c?9µ3Ò2Ê?)€UŠ?§?˜+£?¦-¾ž†ìB׿±®"⎿Ø#ö¾ýižy–ö}¾ô¾ÓŠ7¬´¿noš.}žè‡Í)ó¤¾Þ:ËLÅØp¾÷Xvl¸¬¿¯!h³¿œw™Z¿vbx/¾ûø1̦9?¿ïÿÿÿúÆþ?ð4éü?ïÿÿûo~x¿Óìš> Á?¢‘sü¾IÉ?psg ?w!°Ø z?jÓÞž ã?PF“×¾FŒ?<ÙØ ?- I»¦ºàÔ÷ª¿ñ÷Ä$Õ¿®Uù̲¿yW%ôÊÀ¾÷Fý¾ëƀízg¿` !6pL~¾á.º,€í¾ùçøšßŠN¿‹ilS¨/¿¼ÑŒBä¿a÷}“P¾ÿ¡@ó¾Ý¿ïÿÿÿõ@?ðbô¿?ïÿÿôüÚ)¿ÕËso¶z?¥)Žôr!Ã?rôVà¬Ë=?Õ®Ëa¸Y?nxU yçq?R»…Ù&?@kCüÊW?0ãjàT? +L`P÷N>ȉÔ‚u¿ J§Ãê&¿~Îl¥jÔ¿õ_­çþ¾úÍ=Ãð¿ô¾ð õÕÓÚb¾ãå$,0ï¿Q3ž+>W¸¾ý¯§‚±¿ ÓâׯŃ¿·@•bgE¿ å›,3Ÿˆ¿E ª.¾õ¿ðý€?ð. Ä?ïÿÿôË솿ÄFÝ)S?r¸Ž°Û Þ??t{Ó:ÔD?]Wÿ7·'í?9èlÛ¾5I?Cå}™ƒ? uôŒë:>ú[Sªý>Ô—±Äû¾—gò²êc¡¾Ö–¹fŽ¬¾Óœ˜ ÌZ¢¾Ï½-Q|1¾ÆW!U= ¾º$ÝÊàå4¾° PfÓ¸¾É'©ê`¿ þ?Ò¨M¾Ùl†X» ¾Ó–ç‘šQ¾Ø-óWë¢T¾Íâ 3¿ðoœ?ïÿÿÿä“?ïÿÿþЬ¿Å¶Btb¤“?„Ò^‡`æ,?Pk‰ŒMx?pm±³>?KÌí”HÇ?0*ó5)¿?–5sf“? À¨“›É·>ãøùÏ៾‡‰Ïè0õ¶} ¾åCÑsÕs¾à8 ¡,¾×;`ÄF;ɾÊ+D显Àº—kì¾ÛîS²É¾Ž¸o¤ÞàQ¾ð¡ßYܾë®à«N¥•¾æÃ,Ø¿ê}¾à (\J¥n¾Òöˆf\ûQ¾Ç] ÁÖľâe¢EB_¾ñœñé­™¼¾ëGU ÞÒ¿òG¢Ó@B¾ñ€’[+ˆ¾å¤U{&t¿ïÿÿÿÑ‹¯?ð);P?ïÿÿô¹Ñ¿ÉuË4º{u?‘â£ó›g×:e¾½þËtÅå¾õ\W>b&¾ò”…(ã8\¾íßË%+e¾åìÿç¾ØzáÆKf¾Íú¥þ·Á¼¾è?bÿªª¾øL*Ò\]©¾ñàÍò³HžöçVÒ„Ïâ¿1UO°Cv¾ëü“àÝ_:¿ð8Y˜?ïÿÿóÿ ¿Ì5!w.Ì‚?“_ÌלHÖ?a=ôp?~·ó ˆ°?[¡&Ô‡{;?@áÆ÷ŒµÂ?-u¾ bƒ?·ïã_‚>÷wü®ËÆ>¨è[ïÞ¾÷þÀ¾CoC¾ôœÏºÉ×ìde%?Ot5`Áq?~Tô3V9Ó?—ÑìgœÎU?¾ÁxJ?q¿¾—ïF?køÐàËA?ZŒý“rÎÕ?UÉìµ@§Û?/<ëW[c”?AøFSÍ€R?ú~Ð#ž? |23ês–>÷o­ p’>åÃ;~lu?GãììUò?D§~dþ,?3×c ­Ih?2ÕÀNa?!ß^b¿ïÿÿÿT3‰?ð?ð¿'€±éa?ð¿¢÷ÊW~€9?ð 0'?ð,S¥®?ïÿÿû'3}?ïÿý K®?»ÎŒu-Ñb?£ Eµ—¿}?†4ŠÊÐrM?gÜO\Sfß?Š6:¿Û7?Q.‚GÜO¿@²ã%Ø1¿DÚæû!µ5¿BUÑ€E¿<]È?næ¿9ãÈêe0¿ v†M5α¿.;î‹@¿ìŒzæ¿¢`÷Ào¾ó=[xy i¾ã¬:­Òºu¿1£ŒbÞ‚æ¿0I ¸U‘É¿$$zùï¤Z¿#òŒ¡6¢¿XÒo /¿ð_Ø?ïÿÿø…Vƒ?ïÿÿú7d?²¬B×c?ŸäFð?Té 0Ô·l?¬Aì÷!Ð?väL®Š(Â?>ŠP¿-{‹åœ¿2—[{ßY[¿03ð*)ní¿) Œ.aJù¿&#kXüœ¿ ‡]W׿‚‘ðKy˜¾ÿ QÍMŠû¾ðqg ü@¾àýêé½é«¾ÑbÚâ­¿ ÏêšÆ¿³iJÇ¿Å´¢O3¿Ñ{íše¹¿mćØÜ*¿ïÿÿíø†k?ïÿÿúf*?ïÿÿ÷ÔÝÇ?ºµ±x%B?›Ó_Ó™'€?aÁÍÎc[Á?ƒ3çJeþ?•—3þã±?I-?½Šy¿;¿ð1Íc5¿@Òýð µ>¿Q|m{¿5Ûc6­-¶¿3=%¾u4@¿Ïé¿i²èú‚ú¿0Ø1[[/°?m†²<%?˜Eœ±)5K?#(,”\?!‡Ú––dh?1ÁO¢(?#œ‚&‹“>ÿ¤¨~aK? Þ¹¾u†>ñ3uûQÁ>áà/Qâw_>ÒkëÞrè >ÂÐû´´þ?ìܹ³?V‰qi$?SŽÐwÝl?VØëøò>õ[—Íù¿ð?ïÿÿÿ_¿?ïÿÿÿ¸«P?¿&M?1‹ÌS:s?/ì>Ÿ’?]YΓ?"—qnNw4?,';¼Ï¹>÷ Iá'”>çͦ]z½>ØW=2tîc?%Ò —C´?$$ô.Ò—?êáèÆál?™ 2pš? :vŽ[;ì¿ð?ïÿÿÿêøË?ïÿÿÿêl?½ŽZ"à#¿šk HZb¿`Ÿ\@/¿‚0¡¸yú¿GØ÷“‰–?7B¤ &«?=¦|µYC?9Í}ÊÇT1?šHCÌ@¬?3îR;,xa?1žšÓêâà?Ÿò'%Ù?%›B[­? ,iË{×…>ú-M)a…P>ëœTî>Û­ü;ø— ?(Ç#¼EÚ4?&×1ÛO5ä?Jù¶XxÓ?Å2I‹á-?î±D<œ¿ïÿÿÿ]Œ?ð?ïÿÿü›©#?À}¢Øð +¿¤b—K'Q¿i™jåôS¿Œ¤¿Re7˜õT¬?A˜ò·Æp?F¥î4Ð?CÆjÄj2*?>’Tâ¾?²öÝD[OV?; '¥Î«¾?!ºÙ•K»?00|hïf^?O Àâ|?,Xyã§>ô¾ÍlÕí>å75'¨¬C?3…R ß?1ˆhòMËî?%³í©€%?$‹nœ•ÐQ?¸¤Žï5¿ð?ïÿÿÿÅ è?ïÿÿíT%è?¿ž Hê¿¥ô+vû[¡¿kˆ9+5¹¿Ž7/¦‡5R¿SÎqçXÆ?Bµts-è“?H-ŽñZéŽ?E4\E4?@eÛŸ÷?=6óyž?¸6Ñ‹Õ ?#©~m@?1_nH̼?¸Qñ‘Ž?ŠÙM »>ö?VA‘—>æÀYQÛ?4d;îZH6?2Ñá롇m?'Iãµó?& ­{ ÕÙ?rcø.•^¿ïÿÿÿêHß?ïÿÿÿE¡þ?ïÿ÷³.rH?Âu‘;ò(¿³¿w“7r¬¿x½V<‰ç¿›,ÎîŽ4¿aÐ^1&Ÿ?P¨#¨ wÊ?UžÃË5~¤?SVòa2?MhÎlý+?J ;¿©?1‡¬¸~?ñS†õÕÀ??*,±*„X?"•/‡ë·7?Q²’Ðnf?òM·VÚ\>ôeYY‹?BI‰4ôug?@ânnÆ£?4âïÕáÔ?3Ç“õ†«?&Ñ|(N¿ïÿÿÿäÉ?ïÿÿþçŸâ?ïÿþ¥Ðz?Àìœ Sj’¿¯ÝÔ[ÿ4¿s~ø¿•j%!á;¿\XhðÛ?J:+õåq ?QPMª¶?Mó/Bº†ü?G+A @$i?DƒÔte™?*äç¿­öe?8€þXÄ?é+^Ò?G»Ï s[?pÄ¡ª Ò>ÿm¡Ì¿±¾>ðZÖ‚q,?<ЇlŽ‰Í?:šÎjAu ?0sÇú8˜q?/*†Y\‚ ?!úêís¿ïÿÿÿ³¸¬?ïÿÿø-©?ïý 4k ô?ù·~œÆ¿¸8‘“2”®¿~\fPþÛ|¿ ¡zšÅlu¿eê¡™5zJ?T^ÇP³µ,?Z~g‘hò?WM~‰k§?R £ãY?OìŸ(œ·?4ì÷T@—?C¹Œ?&ˇHòïÀ?ô)(²Á¡?©F„%=h?q^<6âä>ù»™a÷t?Fl¤‡Ú®‹?DµDÛ·ˆà?9›n 6¡ ?8@áÁËÏ"?+õÁ౿·¿ïÿÿÿ¬¶E?ïÿÿá*›$?ïÍ i&º?¹Âi÷¿½˜Í§@oo¿‚äB¾’è•¿£Ö$ë3÷¿l÷˜rÈøê?WíöÐ ?`Õ|¬½û?[d–ƒWÙ­?U‘gŠàÂ8?RäCý«õæ?9X¨¤-?Fü¨Æs_?+d–`C%?ò<&œ?ó¨Ùq®íŒ? 4AÃŒ>þ:;ÜÓ©?Jë­ÿ¥–2?I 6Øïç?>Û<3LðA?<÷›x„?1(ñH À¿ïÿÿÿÙíî?ïÿÿñó¢‰?ï^ f×bÅ?¸¬áDz™¿º#µËÄ?ÿté^Ná´¼¿”é^B-†Ê?o^($ï?o^-©á?lÀâz}iª?cšÈÕà ó?_^ û²þ?F7ô›úh?SšÈÅÌâí?4B°÷?"L2Ç£a@?šÈ¼ ½^?óc×{y`{?©¨cÚä?Té^¬ž­á?W†Š‡£?HÕ qöu?HÕ kä¥ýT~/8>?>íýY?¤”?:ä%™k¸ç?áZ]@H°?8ÔT­¼L$?.µOô=—?-kØW? ÆÒ-à¿ïÿÿÿÖ7ó?ïÿÿÿ´õU?ïÿÿ 8Ž×?Â[êvI”¿­‚ |V¿r2ÒjÛDÙ¿“ýöfB®¤¿Z5ÅyìÊ"?HzÅGlìÁ?OÊUÏƃ$?KõS¢(£?E Ð’,?C%ò2y1?)®#;ï?6ëŠeè?UBíò˜? j‹¯âÜ>ýV•è•à>íÿ”ÞŸ‚a?:åýAÉ?8ÕíÔh?ãð‹ú*û?.·lÆ´ Æ?- ðÄ’Ð? Çü…ÊKà¿ð?ïÿÿþÊ>?ïÿüäå˜Ü?Ä7¥Bâ3¿²Äš9ôQ÷¿wƒ äç+¿™Ó4±m“Þ¿`îE™sÉJ?O¦^“¥ªB?T‹èÐEÎ?R(6Ô?KòAó!K?H½˜ xaŒ?08<ŸK…&?=oh+&?!¨¨Z°?[£ÈõÕê?ô`Ò7•>óaš|z?A`Ã…ÈÃj?@ z.NŒ?3Ø3œ“7C?ïå|p}?2ËÊrŠ‰l?%¯+¨.Å¿ïÿÿÿ¤½”?ïÿÿÿþ|ù?ïÿì3.ZU?ÃâJ)˜y¿²«1ymè¿wc øìHý¿™°PÙà›¿`Ö…\\—1?O}$³ ç?ToõÖãe0?QøD ¨½£?KÍ•‚ 2?HœºH€°Ì?0"‡ÓšYš?=uö›¶äC?!‘þAð?Ce-ä?ÛÂWº >óG¿ò€°?AI“Bt‘%??ìýÎ?3½¿‡Ø?2²™“§¨?ð (ŸR‹~?%’Ó\Z—¿ïÿÿÿô.%?ïÿ¾ÿžu?Äí¸'Ÿ g¿·:¾<€š¿}JqZ¿Ÿö*Ò+K¿d÷uÀ‘?SŸ.Âçù?Yqbº6?V`A„Û?j?QOUNw?N¤ߺÒÌ?4 F?BVHk(C#?%ßËYz¸?ºË¶9?w]õÐ9>÷ÿép½Å ?E„؇”Jl?CàdYÏ´¥?8‘åŠù÷?7G˜ð×K©?*Ùå-–?ôOÛeÚl?ïÿÿþÿC˜¿ð Ø—,¾»9ÚŸ†¿2$,œWþ¿b݃Íe_ü¿†ºèO ¿~>ÜíÜÖÆ¿p»¼´ƒœ<¿jÍVXº+d¿[}°S%È¿V¸RjK¿-Ég2މѿ?iÒ~d"¾Í]($R^s¾‹ó©J wѾN÷—Œ(fô¾ÑtP)#¿C‡&ÔÉ0¿B*. Ëí_¿ƒNpAÍ¿X$G°yø¾â+… ¹DN¿ïÿÿÿr“H¿ð?à [® bð¿ð¿®5жÄÏ2?¢J¤iÖ£í?*~È1£?šR3Û»g?=Fdhe?„HÍÌ:\?Š”!uP‰?t½ÞY´:?r!ô_‹e¹?R&Æ3J€?b S¿‡?B—·A‡?1îSAÁý?!aæR:†?ó!hq¡?eÍä½eú?dl’{_Tç?VÝwĄ̈?U_–?QD?Fü7D¿ð¿¤[š ˆT¿ð¿·m=ãC/¿ŒÂŸ\—áø¿¤l"çy8R¿„hÏ­ë¿jª•bÃÇ¿Vÿæ)=é:¿Q\ÊòÀ¿;×@#{¥¦¿5´¼Êv7¯¾öXœ7m$¿5—ËÊ÷ྥG¨ò¨<Ë>̶Ñ:6u>ÌC CïŸ'>ÃJbI–Öî¿ ñXþ势{`PGmW¿-RÖ¹3"¿ÍkXè­´¾ÊSsjS¿¸Æo“‘õä?ïÿÿÿE8p¿ðH׸¿ð?ÄáF_Ÿ?¢ML%¶"‹?ïÿÿÿgÚæ¿ïÿÞ8˜ÝÖ¿ñ.w–Æο’üÒÎÜ¿·ýÐõØ<µ¿‡ãÊ°#( ¿p^Ën€/´>çåŸ&ÔÀ?mŠ\‹7Ι?kNšˆ9òO?l»w½­Ð?Q2µ?^üz@Z0S?@p±1©¹ò?04Ó!D¨?[„2? /n_¥È?`çÔÀ«w?c%݃iÖ+?R×!B?Tlÿ‰e“?B} "!È¿ïÿÿïS²$?ÄÂ@¿± håÉŒ?ïÿÿÿ[Á¿ÈF‘!°“¿rÁàW•¿ï xZ‹~¿’À*çLÊl¿c¤ÞÝ5§O¿LX_ášž?Q–J×HW?Gc’]Ïc?GWù¥8|?G齊Žî?.t"I¶Ö?;K½Ñ€p?]ÞiÛm? [ð³õ«>ú˜. ñóI>èïD_¡ïì?=ö»\y»?@/%A½tò?0ðxŒ­B?1ÂÝq“0¿?!X➈j¿ïÿÿÿÿÜÑ?Ä>²Å¿'äuGúK?ïÿÿÿÿsC¿å ¢,¿Š›å º¥¿¯Ö<¯…¬¿î9–ÈCO/¿{¹í/2½¿e2 ¬H.?¡¥G\—?d?tË® ?bÜ™ G?cÖ¦érÂ2?GéÅò U?U{df“·ø?6÷{¬P?&­ÙW _?íU„?i¹rë½?W~Q²ˆ²?Z€—ž3?JA&Ü&î?LcôØOSï?9á'€_z¿ïÿÿÿûš?ÄÝ‘¢¿°„d:MJ?ïÿÿû­ä,¿Ñg¤’Éõ¿w9^Èål¿šzž;Ïx8¿jz5‰—¿ðxùrâ놿R‹eî?·Î­¼?P×󬽼?OãùæÃ/D?P«|ß¾†?4M"ñå?B<úZKrP?#Ÿ]¥»¦?eò‹Oæ?-n· þ>ïÝ-ê6]?Dµ%{O?FWª?5?6nFßÓ\?8üÎqú‹?&=ûƒ?é¿ð?ĉC?¿ºOF}4âQ?ïÿÿÿú£Ï¿²xëŠUg¿Y»â·"ò¿|6ÊÕ&¿L•fˆ!ƒ¿3¶>V95¿ÃO|U´à9>ï©"i ?1×÷Z\gt?1'*_ÛO?1Ósc±LÛ?é¾bÜwÂ?#°ÙÂ8gY?M1]Il >õ•oÛÁ>âÊ©qY>Ñ|øÌÆìþ?%«Ÿâf¬?'õÓú~B?ZÛ_›cø?õvGè›?GÂE¿ð?Ä‹Ì´+¿¿å·Í‚í?ïÿÿÿî"?8GŠ¾Š= ?0Cgdàú\?$F0]¥tå? ßA–Ñ×>ü>P¾HKH¾ò›ÛUò¾Í¿Àö­‚ ¢#¾Ü&WÆÛU,¾ó§ì5+àï¾îóÁæ^˾Ý1€£Ù¾êKše-¾Ñ$¼ †7¾ÁvrûÜã¾²¨‡îÖ ¾¢½›8E[¾ð)E+Ÿ¾èUàÔTõž¾ã›µ&p¦}¾à jSФ°¾Ö¡a¦ïî¿ïÿÿÿŽ(?ÄŠn‚c¿Áélï,I:?ïÿÿÿº.W?À‡÷£ å?bêÔ3Jó?‡ï^zçv»?XMâtÖ ¿?Aöœ³ÍG¾ÜÄð d\¿<ƒ¢—E^¼¿¯¹ášc9g¿:€,cË9¿;Óà“ÚüM¿ ¶'G—æ¿.v©†_C¿†Ôà>(¾ÿQÏñƒ-¾ëÆ,uî e¾Ù¦oãv:¿0x¶°i¿2Ž³úL¿"_ÈñáI¿¿#ÙÅnÕ…¿x“ªo¿ð?Ä‘ÓQ¿ÅCÑÄYâ?ïÿÿÿÙ>?ËÒ-þʹ?r<½«É?•Q[Ž?eo†fÜQ?NHl0íf5¿NÔ"̬S¿I¹åVÂóî¿H¹ñE¿Á•÷ÐL–¿I…c}Ý¿/(C4˜,Ý¿<^þÔYL¿-î÷Éu‡¿ Ñ vÃ$_¾ú}$L¤¿Ö¾è™¬±ì[¿>Ѹg¿G:¿Ac¨‘=¿1FÑ€Ãs&¿2x Œ!¿!*h3I®¿ïÿÿÿû ]?Ä‘ÀÀ¿ÆÕ7oÆk?ð¿°?Ò³S5ž¡?w0ÀŽ¼à?›L£½Eqó?k­X a®?S>›LÐO¿Ò'>Ñò¿PÈ8 ”}Á¿Oµç¨Ý¿P‘S œw¿Êó-qLäë¿4 kô§î;¿BÓÁvO½¿#oRdÕh¿2à†]þ¿üˆ“â¾ï~›‰s@¹¿CÞ!8Ä–l¿F.3I¨¿6>ÇTñMÍ¿7ß°›Ða¿&  e8¿ïÿÿÿ®?Ä‚“¿ÏÔªåëÂ?ïÿÿÿï;‚?àí%(º?†åQ,'|o?©½—ü5?zU­a‰/T?bs‡^Ó(„¿ü¯QYVt¿_Áõ“S.¿^tÐw{)¿_¨  } ¦¿Ci=¸Ž^q¿Ãg°ÚÄ׿Qt—@.ú¿2Ù’r¨è¿"¤ ‰ÈÒ¿›+ð[”¾þâ-³‘z¨¿S6³@`®¿UA{,f`¿E’¾¼ø®‚¿G®A…<]¿5|]Êøó¿ïÿÿÿèÅ×?Ī> οË*Ýuõt?ðoœ?Ø…VK”]Ó?€™Ž®µs?¢¥HªËx$?s8„ï…??Z·WS¦¥^¿F3®Y s¿WNCI²¿Vò’¾+¿VóÌ÷/O¯¿<&þ»Ï¿IPåª'ö6¿Ôý‘ºáVý¿+W ýŒL¾¿x<$†¿‰± û¾öf™F¡¿KÝk΀à:¿NÒÖ'îrX¿?IÝ»^—¿@­ÔÓÕ.¿/)—”Jõ ¿ïÿÿþ`ï2?ć~‹q¿ÑðA$d8?ïÿÿÿÉ?ãv ;s8÷?‹B÷Ê`?­Õî!•A?ÂNöX?f"`õt¿+°Ë%4_p¿ayt¢­HA¿aƒ3àá¿b'¹G궿EÏoðç S¿S[¨¿5räÈ–´¿©È Jí¿%Ù¸ C_d¿™åVä3¿i~ž‘ÿ¿U ¨zçw¿Xa…»Ä„—¿HÈXþ½ãï¿J:…4¤Ûé¿8³È9Lv¿ïÿÿÿËé?ÄÉÚ¡¿ÕFBü-ç?ïÿÿÿ“Ë?íe@ê£â?œ)²Ôxy€?¼)³O²?”°ìˆ²ÚB?Õ{”·:?€ÔfV\M?˜ß͘ u?pÐdá?iœ€•ƒ¶°¿Q›˜'nô?pЂ™rÍ?9œ€–ú`¿A›—ørfÙ¿” šï‹¿-œóö¥¡-?ÏœÓóÉ;?tÏ(¶e¾¿Yœ€MÏR±?Vhð“|½#¿C5`**tâ¿ïÿÿÿÿ¹¢?ð?ð`?ð?ïÿÿþa±?ð^9?ðþ­C?ð¡†Â6?ðt/ñð?ðFëcž?ßÔ;BHýï?év–†ÙgT?ÀµÒL⫯?ßÔ<­?« þÿ»#)?ƒä¤Ô]¡¿ˆYB;5õ3?€OøO°V6?ä°[¤¼?Çß+÷˜wŸ?ÆGÃC0“ ?Å|tÐ6}?²M;¯\:ÿ¿ð?ÄŽe舿Ø/„'! ?ð?ê”í™6µ?“”P•fAÁ?´hÃ{“?…F N¼î[?nT³Hþ¿2PJ ¨ÿ¿i9ܺ÷ Ó¿hÙpáuœÅ¿i’Ux—y¿Oá´Ã$‚Ç¿\¬ey)s¿?CWì‹ÖO¿.öpù‡ªš¿æˆñŠv¿ [Ý(~†¿t—g0ni¿_·ËNnp)¿aB›ªGO¿Qã1>¿RÚÎ~颪¿AùUÒš3L¿ïÿÿÿÔ‘½?ÄyHµ‹¿Éu½‹ L&?ïÿÿÿó«?Ôãµ½aoT?|º¤©ÿ0c?ŸÓA*ö÷…?pR) zm?Vìv ýL¿Bµô4 “¿S«×#á¿Rôˆ^z`-¿Sª]oÇ®„¿80À”$5¿EÀ礣ÃÒ¿'ˆ{v.›¿F­R¨K˜¿ÇŒ“Œ\’¾óX…ÚU¯d¿G÷§Þó¿Ú±Nl€L ¿Jnõ+Cÿ:îENs¿<§–/f¿*ÝTMéÂ_¿ð?Ä{Š€¥¿Ê.Ã#«¬?ïÿÿÿ袨?ÙÇ ¸ œ?€ãÅW~ÿ=ñä%`m¿Zûô¡X'¿Y¨À¹a%t¿Z•)E¿@dõD ^¿MxÂæç ¿/ïʘ¿š BªôÚ¿ Cgë ‹¾úV¸™0â¿P?Ér!¬?¿Qà-‹“¿BF›¶¤Û¿ÄÞ(f7ø¿CiÔ4¼G­¿2Biayù¿ðoœ?ĈZ°N¿Î@8½o6?ðÏt?àñã¸Æ¸?…£vÔÁh?¨pÂç ÐG?xújnø¯s?a~åÚe¡ ¿;Š?Ta¿^#|dÛÚ›¿\Û×6ùE|¿^AÊîÎ#¿Bd$3}iô¿Pˆ$­«¿1Ø<`*Å¿!¥¥ ¥©¿kBqP4Þ¾ý4×òivE¿R1¹c¬?÷¿T%QQ{ ¿DkšdÉÚ¿E˼K¢Ò¿ÄD~¤hõ¿4UþZÁE?Ä÷÷gØS¿Ñ®Èn&C?à½9øÖâA?ˆM®ƒQX?©©è$+ ¾?z¼he'm:?crž[ºt¿'”ò²Q’¿^ ÊÜSZ¿^j‘œ›Qÿ_qEøÿ¿C‘Ç:ŒÑ—¿Ql¹Ö¹L¥¿3 o\¿#îáEZ¿¨§9J·¾ÿ«ZÈ ]¿S‹¤‹Bf¿USXпFñM¿G>BØcªÎ¿6D܈Ì¿°ºÝ¶1BÈ¿ïÿÿÿ“/¿Ä¡ÀÛƒ?ïÿÿÿùŠV>ðúA71Û?”I¦ŸÊ?œM‰+‡›â?·1 çô?«:–4?˜^ú,àH?‘èsušþD?}H ´?uÝÆâ ñ>âSÆÞ‹×?,¢ß´Ï>K¾ÚÛ\þ/=ÎZ‰º=U€MÜ5ï<âJ62yk-?FåŸ2ØÖ@?<ÉbAº£>ãÝÏÜ¡í>ÝÌ» ü,½>s ~;Ó¦N?“·!bIé?ð¾ïHTþ?ð¿”Q2za'?ïÿÿþ¨­p?ïÿÿýà×]?ïÿÿÿüùò?çÏ¢ÇW?lkHÐäÇÙ? >¨ÕNê?„®®¡yÓŽ?dylz‘x ?‰Å6 1°?H6IGüé¿CGçš¹§°¿E:mbü+Ž¿B83v¿:dþš–‡˜¿6þq ¹.¿Ï^%D¿)ßÅ`.¿ ÃÝukr¾ûr‹¢o m¾êûU>±›ù¾ÚNnðÒ§¿.Ù˜Ë|P¿,a­ç:P¿ ­ÀÀøÝ¿Œ ú§¿NËW·²¿ð?ïÿÿð,ã?çÏ¡ë7•=?`i`­»?‰ÇJpƒ½?PQÎ9ùþ%?­GÛíFÛ?tu’ ô,j?3]P¿ Ã…ŒôëÏ¿ IL·uŽ½¾ûÊf¬4Ü¿ðˆ?ïÿÿÿûvê?çÏ¡ì=gw?ix漨9Û?—’š!@Ö?]¨ÝÜ¡œ ?‚Q+Yÿ«?”ç9aMã?AC¿Çe¿?¥ýÿ?}Ô¿@mök¿;eþr%Íq¿3ÇÄ"ýóä¿1q‰õ9¿ÿë,™Y¿#S»ƒä¿Ê.Á¯pu¾ô“tz-4u¾äSôøRo¾ÓߦýuS-¿'Km6µ¯¿%óø‡õZ¿ýß6t¿„z÷Û¿ "ò»Þ£¿ïÿÿüýÛ?ïÿÿÿÉLŸ?çÏ¡ìmëŒ?d0´k1Sh?t-"í<Óí?9‘qég'?`¸F{‡^?×v#?³÷øjLÝé¿Ú4¶•$`¿• Yù¿õ”ef¿ôÅëÝ¿ ççõ»< ¾ðÜÍ­¿F¦-û1?¾áy†EÓ˜¾ÑHÂS–—¾ÁftzBL¾°˜SÙݵ¿kS`tz¿Õ"®Ì®Í¾ôÿ˜rX»¹¾óÕ¼Á¢m_¾åΖ_Æ ‚¿ðý€?ð?çÏ¡ìŠX?c¾½\ÊPN¿…ò¼pöú¿JÎG—í?2¿q iè8ä¿/õÀõ,®Ø?'oá×Ü?–%Û¹ƒ?*¤£»Ô?']ož»v? ôÒûG L?¥òÑÛaó?D¿>à A?¦ö·ÙQ>ñ×€.4$u>á¡V>ÑGëÜe >ÀÒ`v±ñ?Ó¬%©–?PdioÑ”?o¼3Fn?SŠÁ1i>ö4t[Ô®“¿ïÿÿÿ(~è?ð?çÏ¡é gË?g=â¦.¯Ó¿—™ùj˜¨ ¿]Í[õ3º¿‚¹ž´¯E¿A˜ü3„²?<\qR}ì??w¨€Ô?¦iÖuO ?:™N•‚+?3C g·?0Å\!¬v,?ŽÜÜ<ÉJ?"àimêú#?B%¥ 2>ôÒž!æÄ>ã²é½":õ>Ó5ËŒD?&ƒ w9Æ?$²²RШ?WŠK ¬? Nß‹¹? DCݘ^/¿ïÿÿÿÆF?ïÿÿÿ““?çÏ¡èRì¨?eVVTKV¼¿š+nDüR¿`›õ•Ç¿„ÆžWv.2¿CŠ'† f?@S !i(A?A§þ# “?=íÇÈ0äÃ?žjM_¯ô?5§¤î>ñ?2Ó |»ï?öUž€áÃ?%4Q@GâE?Å]n˜ÆÇ>ö…`ÏT‘>æ-æ{åG>Õ¤úµ9n?)N+pê+K?'9ý·²±?] +¢?Ö#½/ª:? l£wí%¿ïÿÿÿä¦O?ð?çÏ¡ßí„C?f¢L Vü‡¿£ª¢n Ÿ¿hØ€®Ð`9¿5KD-пMT¾g|Þ?G¸=cUÝ?I÷0ì ~]?F2¨ö(y?@cÏ/÷é?¿-W—ï?;û \;? Q3:Ëý?/•£Úœ?ç*å:l›?¶¢–âû^>ðpMõ¾‡>à,o4A?2ÈåÈeU?1DQcEµî?$OzÅ!%¨?#2Èó4Û~?e„Í+K¿ïÿÿÿç‰/?ïÿÿÿµ;´?çÏ¡è¯ÕJ?dÜÍá¿¥ ,Û¿j¤Z“¾är¿Àû=ž¦Ÿ¿O|%¢‚K?I4‘ÈRºj?K²_‡˜ÚÇ?G½"%Äó?A1mÂçze?=òÁ w‰§?ÆN¸v°ý"?!v?ÿx?0ÚCÓå•?G i `?጗¬>ñ”.â\Ï©>á#÷K–¼?48¡ÿƪ?2{XÕ\"?%º\{Çè;?$‹œLÕk?ŒßlÁ»ÿ¿ïÿÿÿòA?ïÿÿÿDò?çÏá †Àž?eëÛÞEb¿²“æ6Ý÷¿wg-íDŽ¿x°îÞ=‚¿[šLeDw?VTÀJô;?XPbζŠ?TßKeIH?N:,íÓ¨—?JT ç;À?.±ÖpÀ# ?óZKJ´_À?=Ÿ¬^^j?È1`ÕU?kvñ ÒÀ>þáÕ‰0|û>îÎÿº3¾?A¨ÊdÛ?@?Œšân?35µÙÝe?2 ˜øf?#Ð-6îD¿ïÿÿÿñ(?ïÿÿþV6Ñ?çÏ¡cï‰?d 5‘§¿­€Éz1Sl¿r—Tn{q[¿—fÝ{Ÿb¿¿UùàSÇzm?Q€·ÍÕË*?SEô3‰³Ç?P‹‡çõ-Ý?G÷ïøZ|?DáIC&å?(X®˜^f?7~»¡’Þø?ò‘cΈ?5qGØEG?ì\6æ6N>øÙ°~ÿN>çâªß`Ù?<U#B 8?9ÅîŠÃ?.J/‡ðCA?,¥‘ W ?n†Â4˜¿ïÿÿÿý@P?ïÿÿô-QÂ?è*¿[³j?e>‘lˆ5û¿µ¯Á@á’¿|k%§äø¿¡—¨üÕo^¿[µPÎã?`=;÷_\?`êrÄ`›¥?]]ìeù?TLˆßÄóÆ?QA Ó‘Ã?4ùÀŽŸW³?CŸQ µÞ‘?$LˆÒ»ì÷?õ”èO¾f?LˆÙØôÇ?Lˆõ@Sm>ó´ø5Û¯Ó?GXÇŒ´Í?E¦ø;T“C?8[×dáè@?7X© ÿn?*ŽÌ½cbÚ¿ïÿÿþHxa?ïÿÿó<†½?ð?•€«ðªM?…€«é¸ñ?…€«{ Ñ?€ €gœye?p €Vä ?e€«–¼H?P €SX;?U€«ÔÞ?*àÕÜûf?õêt ]“?€«SŸ¬?U€« gƒy?U€« ÖDþ?U€«O ’?BЕ¸èÜx¿ïÿÿÿ6(?ïÿÿæ^ðr?ïÿÿóçÆw?ôÛäŠÖuª¿ð?ð?çÏ¡ßhyÊ?dmÿÊ@¿Áfú/F?±¿…ï®pâ_¿«›v¨¾¿iðböý]P?d¥ˆN†?f¼FÎ’¸ç?c„ù€W‰?\EëÙ<4V?X¡a:(BÂ?<¸1a ƒÄ?K·0 ³˜Å?-¼á7K?f×R0€? æ̓„D=>ü-‚ß²|¹?ô³föWQ?P…Ïzmþã?NfìMŽ?AÝ›uS¼“?@å€Kº¾D?2Š"óþ$Á¿ð?ïÿÿþ”¿´?çϤÜ>Áô?h|>üÒ´¿«›ÂžÄ"½¿qeÌ©6Ü¿•æ'Ÿ#1¿T’ßÌqÃ?P]aT{®?R¾ƒƒ?NôlEý¾?FkøQÅI?CˆwGe?&Æ ñ£äœ?5ú¼0£:.?•3÷ ¼ï?PÍ:ß>öë6éÙtØ>æX,¢''q?:4¹K÷ÖÊ?ó6uG`Ùã?8Sñ[©?,UãAQL)?*̶R°?g±#1]¿ïÿÿÿÏåx?ð?çϦ…jLÅ?gôŸÞÓµe¿«™ø©o%¿qd„8L’ï¿•ä£Ïµúw¿TiÁ{‰?P^@w?RÙ[òÐû?Nó‚AŒb°?Fkƒi¶ƒ?C‡ü]gå|?&ÅøH^K‰?5ú0³ªéÂ?”œR`î;?P,ÚlM>öê®U‘b²>æW°º0^Ÿ?:4.h-é?8¨¼Ïm*?ò ËŠ[¦Ø?,U:r—?*Ëæ!õ‚Î?fÏ’y7¿ïÿÿÿ¸dñ?ïÿÿüDc?çÏx7+L8?hþU•Gl¿±­?ëþGl¿vH.°ÎQó¿œ äG{>¿ZLì:Lã?UÑÄ°Ñ?WËR@¾ ?SÙ¥T½·?LÀÎো?I Ñ3\±?-2ÃÉ_[â?<,³Èù—„?:™¿»z³? ä“ž6–2>ýa¡8«>ì¤låÐxY?@Ëkkχv?>éO6:3t?2(dˆØD³?ð q˜lr˜?1.MŒ›¨¿?"Ù¢}Ü¿ïÿÿþÒ»Û?ïÿÿüÁÙ?çÏö ÁÄX?h74\Œ#¿±”ÿ Sëпv&P¬ÍâÓ¿›ãQ] C¿Zó÷O-.?Tëü|®ã?W®5ð*?SÁ¬œ Y?L›ÊS*?Héýi±3?-a?¹ ?<7Ÿã{?ÝÄPt? ¼ÈzË¡>ý:ŠyOý>ì~*Ʊd?@¶sÆ6?>ÁÓ¤:;?2”•ƒ?1'ãóDò?ð¢–˃?"ÁatA+{¿ð¯ì?çÇVµË?gF”‡8 W¿µƒ¦à Ñ¿{ìåÓ( ¿¡ƒJ+[=3¿^Tߧo_?[òéuím?]Z¨Ï‚?YtôÈ- ½?R ôHÐ8˜?Oj2õò ?2^Öè¦Ê?Ašg­ 16?"é8ZRR?ÆÕKªV?jdÚ—Ý>ñÈ 4ƒ‰o?E“›³pÉ?Ch™ŒŽ Ú?6‘qS&ÇÀ?5ÍP¼Ç±?'¦Â¬ojb?õèx[‰{-?ïÿÿÿ O¿çÏ¡á¨ð¾½MçÇðeã¿8ËüÓ¿dÛê€vnl¿‰2Î…Ò¤¿}\…ô¿oT;Ñ ú¿hyŸxù—¿XFZÕ¿Sþ¶)[4¾öyã9󸈿"^iChÑ$¾z3fšåP¾%¶ ÿ“½Æÿözµká½sdA=çq¬¿5üëÇxM8¿/HÈOYx4¾ìÖÅ·ÁS¾è;÷yY¼¸¾—^âðf¨~¿ïÿÿÿ'B?¿ð?, .SÕ¿ð¿§ç ~a?¢i¿€ËÏ ?’Ó]šËA?šH…ü¯Ê?ŽŽ½yŠ}?‚`ËÐÕRÚ?P©ˆÉ1Ñ?qÎÚr…ÿ…?n¼ã/vˆž?Kç³=¶¬ñ?]#å“Å?:•ˆ¨láQ?)™Fd-²?;½{™?ú?ÍÚÌ[:ˆ?a¦~žë?`¨†*¹zà?QDÿîQ?P©ràáAz?@zß½È/¿ð¿Tå’¿¿ð¿³@ é4¿‰Ç…u.¤À¿£•Š/ô¿Új¯Ð;x¿fs:8É¿RŠ•2áGÅ¿KŒìpÿÂ'¿4õ‹·¿0+dét¾éY+W‹Ÿ¿W®ì#…Z>±h5d¬ >Èd€¡žFp>Ä6zˆl÷4>¹am*#žý¿€“¨Æì¿Ë›c†N¾ô¸~@SL¾ôb½JÆó¾”O3Î銿mÔ™‹1É(?ïÿÿþÏü+¿ð4:¿ïÿÿû"Í—?éòöO¯@!?²9ñÿmà?ïÿÿý«Ê2¿ïÿÛqÞ8¿ñ>Üi–ÕA¿¤ùØþ ¯¿×òþ6 ¿¦1’ôпt7rö%ƒÜ¿:|Øè?b™âÛ0È?aÎüXU?bE@Á%u1?Ggaw*¢?TgÞ+®]Ÿ?6ôÕzQ\?'$œ“U"*?°ÜÕ¬y¸?FÓ”gj?VÍ&m½?Y40«¨?I^þx;\?K¡»nf´~?9‰7M‹Ôª¿ïÿÿøõÏ?éòß;‘\þ¿¿£qU[¤m?ïÿÿÿÎ… ¿ÊDG΄C¿…™“5•É»¿ï;?S¿´2Œ®5¼ï¿ƒ“Â2«šå¿RW¢¾pò÷¾ó/¨<î¥\??¦ ¤Í??CÑ£dP…?@XÝ$øáö?%ìipu?3ÓÀç¸?Ï0ãP?flÌ ù>ô°øÚž‹+>ãË•wèHð?4òJçÝ¥®?6ßLƒgÖ?(ioe‡¸D?)½Ÿ9Öá¦?98 uÓº¿ïÿÿùím‘?éòß-rþ`?q€³ü«jË?ïÿÿÿqyοå"tc]'7¿_±Ãˆ½¿Ïé|­÷³Ï¿îdÞc#uä¿i7↢p¿iÖ=@V+æ¿.ÇBÇ2áâ?Yºí¢}&?W¯xÖãY?Ye6¦®“?@^8´Â¥p?L†± S`Í?0¦vdá? GA#§kƒ? =Lj§Ð>ûšY§¤¨ï?NØMKSÖy?Q‹ŠuM ö?AȨ‡5M?CMÉa_öê?1ü&£Ãè‹¿ïÿÿÿÿ¹¢?éòß-ž¿¼~F]SG(?ïÿÿü§Á]¿Ò Bûæ¿ŠVê´AX‰¿»d }9»¿‰€hÚ e¿ðÎÄ}®¼¿V’P+P;¿¯p2kÙ?Fi+ýxÓ?D«¿D]Šñ?Fg ã?,°ÏFkþ?9ªì൯?f¿÷Á_? ¾†ïù>úŠeÁ§>襇þ1 ±?;ÌÙÒQ?>‰Яu—?/^ˆL¹Xj?0åòÖL9‘?èÆ×'ê!¿ïÿÿÿYý?éòß+¾æ]¿Ç«øèc¹w?ð¿µÏ‚K½¿p‡eΗz!¿ Ÿ?>÷-¿o=˜‰H']¿;êXL‡¿».^ =€¾õlH–è€A?*¯©8A€?)_ôQ —?*æGz· ?ªÜO> _?Ë耺šN?“JhMÏy>ñÍËíXØ->à5B ¿á>ÎÍòC¯nN? ¿¿“¥?"²þÈ~?j„|ßÔo?Ê°»Ÿ¢?×pí—+¿ïÿÿÿª<ô?éòß-ÔG¿Ì´)Y§Õ?ð¿‹€­7X]¶¿ È°u(¾ö¿rçK¨Y¦g¿<Ü)µ˜iû¿z«ÿ÷0¾ò#AØ}¿·NÌÈü>þ3¤Ô½ª>ó—îmÆ>øÊ-ïÒ>ØY Æ[±>å/LùðÑw>Ãþ†9ÅÎ>³ƒ±õqü>šTC#R[->„×ÀíAV>äï<\†ŠÌ>îþ5­t´>ÖüÄ4>Ý1Šsƒ>Â. tàËV¿ïÿÿÿÎï.?éòß+òp¿Ð.ìñ±˜§?ïÿÿÿ­Ó?»´Œ ,Ò?qíô¸;“g?¤©§6Ý?scy¬S¾@?B\ìÝ–Ú?Ÿýlÿ/OCõD‘¿¥¥ÂÚ0ƒ¿,¨ð¾3•’¿.¹Wo'¿²ÔFëØ¿!2?N:n±¿TÚµ ÷¾óƒEr–Êc¾á~GZdƒ£¾Ð~ ?Dj&¿"™¯6ŠÅA¿%.Í”e¿f”(%3:¿>ÕhEC¿™<ËÛy¿ð?éòß-jœ!¿Ó:óöbÌI?ð?ɹ‘L¬kÓ?‚[ IÛ0r?³k[.=F!?‚u€Û6Ùv?QlTer®? L#AC2¿=Û±»Ð»¿<(àØ%´#¿²QÓf¢°;¿=ä Fdļ¿#‚ïÕ‹ë¿1ü ÂEÿYŠÆ rl¿’¤×`µ¾ñÃìržàÚ%U`o¿2ƒ „Ú ¿4º‚7®| ¿%i)¸É¹s¿&úXéWª¿Ѹ%‘¸º¿ïÿÿÿó«?éòß+›·*¿Ô¯Ê†þÓ?ð NÔ?Ðïé¦u•Æ?‡¬pDžk?¹„½£Æ‹?ˆ”2ŒëŠ?Vh(T7›“?àÂgï–¨¿CÂDdž$…¿Btûø¿C©i"Ó¯O¿¸”iÈG)¿)ˆ)Ðî¿6FŒÇ{5¿<ð»Ý¾H¿ „½ªã&`¾÷ЉO¾åש=Š›Î¿8,jÝÈú¿;9ƒgg±¿+ë ¼Bݬ¿. mÇ¿]ˆÉÜ ¿ð?éò߉܇¿Ü敦5ÈÎ?ïÿÿÿÿ,å?à>™¸17?—ö0Ó>?È£Ÿ?_Ð?—iùœìô?ĕ:O~?e6Z&­¿S0¸%~A¿R=ÖáÉ(¿SR"Ì ¿9Y){áÐ[¿¿ÇšzhÄ¿FÚ(kK<¿)4õ¹ÒЗ¿„_ųW$¿;Hýß'¾ö9ê­A¿H —×M„¿J×htö#ã¿;à»6·*l¿=Õ¾0W繿,zõߊ˜W¿ïÿÿÿ§}D?éòß7»I¿Ø¤Ëõ±õ‹?ð D?×JÄa r¯?‘3š½%½Á?Á«³Ú?É ’r²H?_7èúëm?µ‘hy¿KŒ¶„ö’n¿J1&ƒS¿K½|§•s¿23"“‘2ã¿?À‰ŠÊ¶¿Í±$¸ k¹¿"|VgïÔ¿R¬\Ř6¿®«:˜¦š¾ï³)´(¸¿AG\#’3è¿CE)¬‚ä0¿4Mø çÍ¿5k¹’)¿$sm½’ú‹¿ïÿÿÿ÷z’?éòûTY€¿àIµ¸ïF?ð$kÜ?âµDŒpÂ?œ[ϧ/k?ÌuéN=Àð?›-Åz¾??id×¢×'?ÎŒö4c¿V_< ±¡ ¿UTRCTë¿VˆpŸ°ýÒ¿=§Ämzº¿IãÒV>v¿-Ü÷Dùœ¿¢ÿdF¹÷¿úò¾I¿ j’c9_¾úý k¿L&X~Á¬ ¿OZ Cw)K¿@[Ì1‘È¿AmËzÖU|¿0¿o Fs¿ïÿÿÿr“H?éô?’ôŸ¿âàkA;?ðä?æo¿êôEÔ?¡±TË$<5?Ѭ Ò8Ê? ²åÝJ™Ù?q\‘X4”e?8b¯¹¿WS@eEñ&¿Uÿùs¸¿YP)…Ô+Õ¿@U‘Çd“[¿MIü´„ Ç¿0²ÞŽ+Ý“¿!—áŽå¿ÙýVnx鿽¤gš¾ý|éÓœ¿MѲÓC+¿QÂJˆ¦­ñ¿A§@/ë ¿CHu;óG¿2thÛ]›¿ïÿÿþ|Õ ?é÷·–«¿ã™$Àž Ç?ïÿÿþîŒ?çVÝvâø?¨+%ú+ˆù?Ò ]7¾?¨+'t²Z?pë¢ër®¿cU·¬.Jé¿t‹ùk÷Ë¿M”Ü3Ÿ¿H+&п-”ŠÞ¿KË8`åû[¿•Ýz¬ç¿kJÉ1cÉ¿¨s9ÿ{Ô”²m¿U·±íK€¿8+&h7¿OkJèq0ª¿B \jñƒÊ¿0PS,²¬ž¿ïÿÿÿÿ,å?ð¿ïÿÿÿÑh?ð?èR¶d)ó?½˜ÊFì„,?³»1Å$ ;?±CÎ@‚n²¿£»0·`¿¿´öã?«ÿA?˜ÊÓ‰?ƒ»1ÆlÝ#?qCˇŒ?X©þE„U¿F2—‡«5R?2~­š4&? qÚÕ¿g‡?ûΡž?œ]­öM¥¿x©ý½q~?s»1å{yô?s»1ßšw?aCË¢2ª ¿ïÿÿÿì{Ò?éòß' ä¿× {Hôî?ð$kÜ?Óºúí å+?”DµØl?½ü˜Ôi·+?Œ“IIæ“??ZŸ†wÕ?Ôf³™Í2¿Gb+¿„d ¿FYµèå⽿G æ)LOÙ¿/lU¼¾J¿;!->Óv¿ûãöqPJ¿`BZ<ûÞ¾ü ŽE)ú¾ë9ۛęž¿=Á A¼¿ÒÞ "m ¯¿@n ²[¿1"X¬þ¿2K¦Tä¿!ˆ|ø¼v¿ïÿÿÿǃ9?éòß2)‘û¿×¹²“äÄ}?ð?؆²Ü Q?‘7×0¹?‰BÖh—1?‘{ÓüÅÙ]?`(@Õ'†B?–]ô¹‡¿LðDjÁIè¿K17•9¬1¿Lꆸ–?.¿2Ø+¹ÿ%¿@oõ¼Ù]7¿"ª±lø6{¿âc0m…3¿Ú…ÄŒ,¾ð8Ô³K¿AÚ2¹ } ¿D R¦ß^ʿѤ~¡9z¿4¤p¾||¿62NK²nô¿%Œ™¬î<¿ïÿÿÿüJ?éò߀W´¿Úø(6£ñ?ïÿÿÿ¼î?Úêïåìtö?”hz#¦Þ?Ä{UCnãº?“•e3„šŒ?bRhYCB ? Ÿ÷Á £¿Oä›±<3Ù¿NžÚ°•µ¿P(Ðä©Ñ=¿5Sñ臿BšÃq 9¿%GFvlï~¿~ź+Ú¿³f#î*¨¾òÀµœ4{'¿DH¯ˆhǨ¿F}̼`$¿7ˆŒËp'¿Ã¡Å‚mà©¿9$ž$׿(ä$O»¿ïÿÿÿ²Âb?éòÞƒP-O¿Ûn…ÊÐ?ïÿÿÿíþÙ?ÞØœwঈ?–¢ öW¢¤?Ça÷¹› ?–0 ð?d£œ‰EÉ ?°~&™pê¿R7f—ò5Ÿ¿QGjåÀ^Ž¿RPmì{¹³¿8/a¯ÚÜ¿Dïÿ?÷ÎU¿'ÙáVr†X¿$@4ˆs0¿öþ"ZW¾ôÛzqD¿FÇ& Þ«Ã¿Io†0¸Å9¿:`ÌwØØG¿<@2‹ŒÛ±¿Ã›é&¹7¿*îš;}L8?éòæ‡Ø ¿ÞÙÆ¡Ø^ÿ?à¦r0¿—?˜þ19/ëå?ȇ}ÊƧ¦?—šHÇ?f:˜a>g˜?΋²ïéé¿SFáv:¿Rtƒ¨É6¿SoæóZw¿9Åñ‰a¡j¿F}#,rš¿)Í¡ß±Çq¿%²ÇÁö~¿üœ«=qÿ¾öÞRôf!¿Hˆ&õ½B†¿KÕ9—nw¿<‚ÏMt~‰¿>Mä·e¿-Q(nRç ¿©3]?Àûá¿ïÿÿþë♿éòß645ï?ïÿÿÿöº>ð9™€o†cï,ÿ>&!K馒=Ì1ºú™.a=sêï­…J?MAƒËõ¯ð?CôTLn>ÿë,»€>úwßq¤v´>¥{ ÿÖñF?®ßþ¬ˆ#è?ð¿ qç#`P?ð¿¢ãF‡¶äì?ïÿÿýïÒu?ïÿÿýãÝk¿ïÿÿÿ„N?ïþ“ Od*?ÏÇ_{˜o™?ïÿÿþû?×z´1&´?ÛÙÈ««/?±T/ÙN/?ÅLK©8ç?£ÿT»^÷G?}ê0Gr‰E¿`&Q-ÁEt¿fÞ¤h2{å¿tnU,;·¿tgcŒ¸•ê¿m+lµ½d#¿skc…4È¿e0‹è˜¿]Egí¿S…ï[$r¿IÁdBrˈ¿tD³gñ›¿s(J ÷\¿pCË ¿oîÜlŒo¿gôýe^¿ïÿÿÿ•|?ïÿÿþ7úA?ÍQË:Äè?ðä?ÍÔцڿQý¦­ iZ¿H37;À¡Ò¿?ë¢Øy¤¿iC¿Ë»¿g¦4ˆ•Ù¿d@Nâíô¿c<]< ©®¿]¶óŒŒÌ!¿ïÿÿÿ³+ð?ïÿûäÑjR?ÐÁ}âÐ{é?ïÿÿþùL?Ò̺žî®œ?«¾íM·‘H?Á÷û”£?ç>ÿy‹qå? K(wØ?x'{l†ßM¿Z-Ó¾Ý ¿b˾W‹Cd¿pø ]²¿p–+*µ¿gKêŠÚ¿n£»éø¿`ÖúV¬9¿WÌÿŠ¿O =¿ÛQ ¿D€vÒu¿pK5Vaa¿nWT“uÌP¿j çøÉ׿hµðÿ^¿c'66¿ïÿÿÿ¸ñ®?ïÿûÒ†u6?Ói|F Ü?ïÿÿÿÁàª?ÅŒ8óÀ½|?ŸÌøR?³Ž- Ð/%?’]Éœ 3½?é$+_±kÊ?k±wݺÈ¿N žE7Á¿U˜I݆Ò¿cÄXÓŸu¿cÐp¯n£¿Z²ûMǘ¿aˆßõ;V¿SKÌ8+X¿Jy¯ŠŽÈž¿AÉÅ']Ç¿7~-=Ô"å¿b®êÊJ¿aa_#³¬2¿]ôYY»-§¿\P>LÞÇ¿UáÆ¿ÙT¿ïÿÿÿ7s?ïÿûÍ8á?Ø…ËÙ×?ïÿÿÿ;¼·?¯¡¾Õ¸œ„?‡ZטuN²?œ¶×ïeåŠ?z÷²ýÆp€?TNŠou?Òã4Àà~¿5ïWVÉÿ^¿?k•ŽAøñ¿L[U¾‡˜´¿KÑZ™¥½S¿C›cZpœ ¿IÁŠ÷ès¿<^¶ð×­f¿3tÎ~g…¿*'òÉ2B£¿!CËО¿Kc` Cùl¿I E{ð¿Eõâ•oæ¿DÏP¨° ¿@džÃx¿ïÿÿÿ¸«P?ïÿûÑÔ3?Þy”dƒ?ïÿÿÿæ’俛NJ2—Éý¿t‘Ÿ„ú†ý¿‰>EÛ§³×¿g´€ekg‡¿Aüõè?"ÐÉ@›‘ ?Ü\`Â&)?*”*É;ãõ?7ï•€8]?7úÛ3w ?1AZ˜Ä¾‰?6„ Ö)­?)a£áHÇ?!,(ÀEÃ? Œ5m#?t&Rc‰À?7éÊLˆÛ½?6›ÔË碾?31B¾vÊ‘?2`d8ÓÎå?,Ocß&¿ïÿÿÿRÓ±?ïÿûιT?Ý‚¸îºÂ?ïÿÿÿ–•–¿§Špmú}¡¿q™­Þœú¿•eÕö9¿t€ñ¹¥ö¿N«6è?/žßš†-?6:Õýp>_?Î×ô…eþ?Dp>ýe?D0NŸ+K?=BËóÑÓT?C 6y¼ ,?5N/©·IA?-%½uÈ3?#£·\Ošž?×ba~÷?D8ˆ3 ¿‡dó¡;¿²~dá/ã¿‘•hAÜ¿ilEôÇ¥?J±L›þ£”?R¼“—¶¦Û?`Úç⻳?a åéšö?ÞƒÎ+HPë?XúSzÉ?`&od?R IÞW=6?H¬÷ù›í·?@¡&†k£Ç?5ßïøíG?a›S×)?`B¶z•X?[u¶:Ý9?ZiÓ˦ß>?TR?wèï¿ïÿÿô“1?ïÿûÉýŠ?æ%·¤®¦X?ïÿÿô™Â:¿Ø}}©ã¿±Û¿©G:h¿Åå,Ž¯(¿¤ŽØ†8­D¿~¶ExyúX?`wÝ΂|?f}Ï[\j?t9mÝaøÁ?tŠ·Šrf?mó6d Ò7?ÔÅcÉíÄ?su¨@C?eÖ'*ò0û?]ۨ΀Ðò?T ë„þ8?JwYЙ"™?t¦œã ?s®úX"W¼?p•sÃÇH?oö¼#!ž?h”gœÝ†ð¿ïÿÿø™ô+?ïÿû¾ði?ã”3‘'´?ïÿÿø•÷Ò¿Ñ<›þ$Ê¿©†ÿŒÍê¿¿SźO³¿jÉŒÀ‚¿vè¤ßc?WOˆZE'g?`s®_EÔ™?m MN?3Å?m¸¯P";?ej=Ê¥?kîvTQ¦?ð‡V,`öÛ?_$¯¼òå‘?UP…Á[ru?Lµ•ôÔx?Bæ6˜ÆǪ?m©„gDŸ?lE[Ùæ?gÎÈŽir?fÏ…Y~@?a‘@‡…ïß¿ïÿÿÿ·n§?ïÿûÕé²™?èžÈnâÔ ?ïÿÿÿ·‘Ö¿ÞåBº`¿¶ßíÆ#bÊ¿Ì8¤¨À¥¿ª]îtG¿ƒÁ$ÈŽj?dí@cý4Z?m‘;Èè u?z aö2 N?z¬¶£ù˜?s0£ ^3k?y «~§Šf?kæ88R`‰?ð¢ÕæÇŠ?cʦ씎?Y¸j¬Ê6?PîþPa8-?z˜yn1™¹?y$¨‰ I?uXT+ÜÑ?toÂBâØ?o{ל¬êE¿ïÿÿÅÔ x?ïÿûœKx?æ²òéWÓ?ïÿÿÅÔ}I¿âÆiÔ`mô¿»Ì Y"×ê¿ÑGéOe¿°¾U¿ˆDòÌ??iu¦`@Ã?qÿE=Ëà$?€5kRpáG?€8§Bâb?wR<8oy?~p½áÿ?pòØ O…¸?g4MCîÍ?ðHG݆N?_?ŸH¬G?T“††Æÿ!?€*`’¡¸?~ŒRýËA?yò{ ¤Ç&?xÔâ-J7?s!(2»¿ïÿÿºe–å?ïÿüÀD!?í‚a qx?ïÿÿºf0¿æw^¥Ù n¿À¡6±aö6¿ÔiÀ^¯¶¿³+="ÂÄI¿Œ¼ä”„·´?n~1û;®?u§ï‘|e?ƒlfûLéŽ?ƒltUö¾.?{çW•%I?‚7>u χ?tF°¤Àå®?kÃ@ç‘{?b±sÄ ;?ð~HðŽ?XžE¼°íg?ƒY˜)Ç ?‚EÈIÇwè? ñW|ßK?}µMÝ^Â?vãtš¶7¿ïÿþi=?ïÿ÷×éáÖ?ïÿý÷RÁP?ïÿþi=ƒ¬¿éìÜŒÀ¬¿Ã0Y=Ÿ^˜¿×Ž1] `¿¶±„˜är¿•xå«0Ó?qš¹Ñ.–?xèå]O¥?†p*ºÃƒÍ?†lÚîŠÀô?€MÌΣû?…ÏÏn ?wdÁØZ Ë?p›=o6?eØ]¶d?\g´€1Ó?ðkÎjXÑ?†TB$¤ ?…ÝÍòMf?ëˆý|?#q¸[5š?ziC ×+¿ïÿÿþë¿i?ïÿûÇcl™?äC_Ï[bö?ïÿÿþï Ö¿Ï/þ+‘꿧õî n¿¼WRšär¿šœõic4¿sï=ko,?Uò­±Ç!?]ÄÖ`Ì¢?jÍ»7<Ê€?jãœËëë5?c_‡)Úõ?iDñ×!oÝ?\,µ>i?SHfؼ~Y?IùÉ?A Káað?jÕÉÆ„:=?ðmT3ÁH?idXÌÒËó?e‰ãe€ž„?d¢êíc¸`?_É)ÉGÝÝ¿ïÿÿó: k?ïÿûÈõK³?ä ®°·?ïÿÿó9ê<¿ÏPßèˆåB¿§0@‹I¿è¿¼u"'0É¿š¸çL뮿t>D¡Åu?U-|‡ã“B?]å?´Ez ?jêâû/2?kW„[­D?csÕ¨ßb|?i_—˜(º×?\J«kRþ?S\–'šÃ?Jy¼£ö?A*çôe?jòŽB$?i~Ý*¸§¤?ðtÃÿ?Ûù?e ˜kõØy?d¸}0¶JZ?_êp:æ>¿ïÿÿðoël?ïÿûý¿Au?ç ¡qëÜÞ?ïÿÿðu÷‰¿ÖUÖÿ”+¿°‰èÕu;’¿ÄKò©<é,¿£'uºf¹¿|Üö†˜?^7 —0¶ ?eT—ïó?s4H‘:0u?sBÎ<ìsñ?k¿‰ó$r?r°EEÇ?d-T“GŸ?[ž2Øéœ3?R™t7mÌ?H}[‹q/?s88M¯Wª?r.ö”kâ?nÚ%K—N?ð¦»ïd?mŽqR!—Ë?fÃdÕI¿ïÿÿù¨Ø‘?ïÿûì©ò¼?浟Vù?ïÿÿù¤Ü8¿Öa;õ?mlk#qÎ~?𧎣3…Å?f©L8×I?ïÿûp1Ó‹?é|ŒøØrE¿Ý]9B鿵½ºu~ڿʮզ@Ã(¿©lÞî•¿‚Ưý„z?cá°ó’»?l˜^6¯?yJNñyÁÏ?yW”ý‹9-?r= þ›ñ?wÌHD©Bï?j„°&ÝÒ1?b&«ŠC :?Xr,ÈyùÀ?PDO¥ÌÛ?yF6-P?wæ 3Z?tHîE0Lí?sl±q÷­Ÿ?mìm?ß„?ð®]Œ±¿ïÿÿýï¯F¿ïÿûþè‰A?ïÿÿþbO ¾žbæGk„о” œ0> Ì¿fü“˜dý‡¿­ËË9N&;¿¹ûb÷¯ß{¿­Åª]Ü—&¿¨ýý#X*”¿Ç,”ã¿™èWŸ Ò1¿}Ëlúþ¿…§†¨ïíé¿l;Ë {c¿_ÿí¶þ§¿Rû*›º†¿D¯Fû‹êq¿ˆßTl(sü¿‡¡ ]m0¿}Xc–?¿|7·HR¿p³÷ëŠq¿ð?ÁË[«d¶‚¿ð¿ªº 6?®C?…©Õ?c1|ú“X?–“%~da-?“›¾ŒH²?Œð×> Q ?‹®§‹?ƒŠñ—ˆà?‚8©RÛÊæ?nÂïBÓF?wK»£B,t?c¥™|?X×i˜K?M—þiø­À?BhÛd?y÷o’Ï=?yù»æm?põHM~ƒ«?pŒë=t t?e‘ßLNqu¿ð¿†æÆ¿ð¿·_kg.Û¿—ôëi=$ῨbÝКÑL¿‘<<´ÑÖÔ¿~v™ÉÙ·¿p.gºôl¿jcôâI›¿ZäÎÒV¿V«û‹/K¿+õy*·|*¿B7rœâ¿’dçð$ ¾×¦+ñ8qX>ðŒ3ÔÙ9ã>ô \³¿Fû5­[÷¿EÙœ¢Ï\¿2Fæ_½ ¿1»ð„d ¥¿YmcŽ²¿ºLøˆµÄ¿ïÿÿøÒ·P?ðÿ;¦?ïÿÿÿ´h˜?ïû¼=ó˜é?Àieü¬Ü¿¸õÌ¡ÐѤ¿ó-q#I¬U¿‡ âíÄd¿¤41𸼿ƒÉka¥¿h¶Ðhl=¾¿WJã0œÛ?¿H~Ôá‚Ul¿(~ÑWeAÜ¿?ºÄÑ? K6n´U:?vq?šÏ©­&&?ï":ȉ?@ìÉgOÙ>ûª©ØGW ??²¼5h?¡ù½Z?fÞ[kc?!c(ætÞò?6ù|ƒ‚w¿ïÿÿÿ¶1þ?ïÿÿýÊÁ?ïÿÿÞ6-¿¢!­‚_9忤٭[ e¿t`€tæ0¿å(MÑäZ¿üŠ¬Ç«ð¿p â¹,cŸ¿T›H~²‹¿Bd@˜ù¿2ìŸîY5¿Ç›Ëc8ľãâ:s{p?{ãé_ ? þ«7—?¼éå¹W¨?f Ëž)>õy¶vÿe>ë[µä¡>þdNÐ5[?–bGÊ“? ÐöÛŒLg?³¡ó?SÒЧ"*¿ïÿÿþ]¢Å?ïÿÿÿ³ÛÜ?ïÿH‰r–?³:²C;ÿ²˜æ–*r_¿&h_ïØ+¿žW&ÐÞk¿ó•b‹ÿgÖ¿|*LVB¿aÓ$©D&T¿P4êÉA°Æ¿@37šv Ì¿— ¼¬†¾ä̦ã±*?1[æ•9y?²jšHëå?ö¥¾¼]? <Ýãߎn?¶#sÈ>ö{¼¢t,? ØÖlU>Y?d:lœúœ?Lw‚?×ù¶}?xcFÅÒ>¿ïÿÿÿáÃp?ð?ïÿGÞlNÙ¿‚ïÓW䯫¿¦X¹K’%+¿u´tÜÍ¿’Ë 9U¿qf/Ÿæó¿ßúˆÿÔVÙ¿UÊÎH“‰³¿CÅžùJJ¿4²+å·«¿É'xÿ5¾á•N†æÀ9?|9r.}? ,™Fèÿs?h5"Ó?æKÿy>õÙü 1E>ëÔlíd^>ÿUÎуž˜?Üf¶_é? F(½Žè?o„{…»?ÂÇÙëy¿ð`?ð?ïÿH÷1?¿©ù|(é¿œC\X¶G¿j觉}üŸ¿†ûj7«œß¿eÁðŠ'u¿Kµù å‡:¿¬ã‰ô‹Ûö¿8ê>¶M¿)“±m)H’¿rW…ÚKä‹^T˜?&*Ú¨A?Ãþ6XÞ>ÿt[)×Ò>÷36P)>ìKŸéµÏ>â ¯ÑÃð>ô#"׿(?d{ͽ%?™ÎvoR?TC™`ºÏ>ý|’Htéпð/L?ðoœ?ïÿHgÄœ¿®«¦ÖÈ¿•IÀ²ù“¿dAòÖ×.¿Bq6Ú$п`A­HuiO¿DœR:†Øf¿2‚寞@뿪ÂzoÅ´I¿"Ç2n탿œñH;Т•fTDÌ>ÿÂ4&Ö§…>ùE%غ|>÷|¾Y7Xš>ñ5°ój¹>å} Ùw>Ú¾r3¯>îCƒ‰ov?Iìc¢>úJVˆ¢ž?ÌTK±C>õê±:ñ¿ð þÀ?ïÿÿÿìŸ?ïÿH—J–F¿µïoZÝÏ7¿‰H»Ù;=¿Xñðj uÝ¿t»Z7ŸQ¿SÝJsZ¿9m_ùE¿&”*\Îf¿ׄ˜)ÇÍ¿˜¡Nv„¢¾ö"§œiÓ·¾ÑL|9sÉ>ólV“ÙRg>î‘ïnë-i>íM‚Eo÷w>å‡,ä›ç>ÚÀ.ƒ}Od>Ñ'F˜·ß“>â‡óò.‚Œ>òðj«P>‰>ðmí>ªM>ôfq¿Ö>ëÛO¤ÜàK¿ðH?ïÿÿÿîÑô?ïÿH“³Î¿¿º–ýÄ`j»¿s‡ !T¿CMrPYšú¿_„1Of.ì¿>x{?¹z¿#‰¦í’¿Y¡|¢Ž ¿²³ü ¾áoJo·—¿™ÙÁR»ãO¾¿ð ¥ª?>ݽ «ö>×CŸ',(>Ö§‚ÀþÔ >ЪÀ¾û>Äã@µ” j>ºáJA“>Ì`•ÑsG>Ü<óÙ…Å>ÙjãÔ]Ø>ßõËóÄ©>Õ¹òû( i¿ïÿÿÿßÀ?ð'+Œ?ïÿHš‡äÆ¿¿}€˜Ü°¿8*…üÂÓ–¿EëOÕû¿*fÌ|üŽ†¿e"õ)¾¾ùµ©oŽå¾ãwð6 ¶{¾àÓ,ü‡¾Â]û­a,O¾¼&™ŽØ‘¹¿™C W"¯>±W0œa>¦5$Öy6>°Ò²V†xO>©~{iü1>£@‰—än>š+õðÛ> ’K™óq“>‰Ðôôxç >³< Â!X>¯à ïõÆÖ>³qH ô4¿ð=) ?ðÌô?ïÿIYlÉ–¿ÇÝ µŸð?“‚¿‰ðE>?bVÄ!2ž|?¥pŽþ*?]áÎõE?CéBy·=?1\rûµ)…?!±q¯*>þýÞ’ ò>ÎÖÒ+†é´¾ü¯V¾Q8ß¿rŒY6¨ð²¾öÁ±ÒÕ¾õ>%QúS¯¾ï*\–†¾ãÅIÜQù¾Ø<'ðsõA¾ë=ëò¢À¾ýN»à-T`¾÷¹“=ÏhF¾þU gF¾óÎÏ™;u¸¿ðJç|?ðÏt?ïÿHwŒ;ç¿Ã›)㊱?€p¾ë½‘€?N•¥ªöÂ?j—U@®>Ü?HõË!ð@6?/ŸçiqÂ?’5·Ý? »<É…¡->éÀÿˆ¤(ü>µd£Ñ¾èF½n+@¾ãZ`¸nÓâ¿œqÎ:½D¾áßû¹¼Ì³¾Ú/^ ¹Æ¾ÏÒ˱`A¾Ä9PÓåà™¾×ØíM.ú¾é*ᾊ¾ãý;0–/g¾é¸Ömi¾à™‹¨ô˜¿ïÿÿÿ·ûd?ïÿÿÿÅ è?ïÿH‰$˳¿Ë%KjÛ¦?™ô×—K¥?i¡Àƒ‹?…*íé$$?d"÷óÕŸƒ?I¾„Ô‰àt?7$ ¯to?(X ü ?ªÇ‚ÂZµ>Ûî™/T(I¿‚ù¶‚žþÔÒµ)Yæ¾ý+ÔJÌw¿€}‚öjÀ¾õjW ÎˆÞ¾êbŸyÛÕÖ¾àÝ6ì2¾ò’—Ñý¹U¿y™|U[à¿R¾(B¢š¿Ë1Ý>¾ûxÄq6'’¿ðí¼?ð¿°?ïÿHŠ~ ׿ÒuJœ8‚ ?¡y)¹¥Jà?pá×ò§«‰?Œ…C ¡?k+*²åkÔ?QdiÉù‚å??K6A[À?0KÊÝê¸? LDt3>ãobˆ4|à¿ E½¢ßø¥¿¼>[¢ã㿪¡ùúNý¾üâXZdw¿qéÀyBwï¾ñÐTЦ2¯¾æÈ/ïžl£¾øÿ¹Ejjt¿ !Hך¿„KlùË¿ ¬;~¿¿l¿Š\O9B¿ïÿÿÿëú?ð`?ïÿHŠFíè¿Ñ"QDï ¸?£^Ëuþ{w?s‚ŽPX*?Çå®7Ôp?nƒéÇ´†?S þ6ôè?A•¹–è°ù?2¨r—f?ßk$‚ )>ê Õñû¤¦¿ |tÁGpõ¿'ð%ß¿D£„¼·‰¿_x±„Tõ¾ôZ«úWпcuCÑ8L_¾ê"æï žü–½W¢ë¿ ¨[]áæ'¿î¦Å¼.i¿õ+%'ˆ\¿)ùÝ6”¿ðK—h?ïÿÿÿÔ´ì?ïÿHˆR¦Ë¿ÒÇ`Š~Áé?¦<Šuîˆ?v$wˆw´?’HL—€ÿ?qœö¶¿è?V¶aˆ`O—?DSš?€+±?5¼úÐ\l?©zëo (>ð}Øo:ÿ¿ÿq0±(Ò¿ ¡ý¸ÀÔ¿ Ä[« ‹¿ôérB¦¾÷£ðPUþî^vïlé!¿Uv~+~º¿-NÖæý¿\L*3¸¿ Ú˜$XÞ ¿Òy† ö%¿‘‰v'¿ïÿÿÿØÔt?ïÿÿÿù­…?ïÿHq=v·¿ÀpÖ“r¼?pv;ÿ×U??eZLð?Z¶… »?93þý2? œQðÞÖ? Ï6yîí>ýSKÖ½5I>Ú}Àñ°Ë>ªë7°¿™ƒ¾ØˆæðR¤¾Ó~•Ïñk¾Ò+w¨ \Ӿʣ‡L˜£¾ÀFžJÿQ¾´»ÙÁT¨á¾Ç],xæ!¿ ÓÇDk£¾Ùh0ýw¾ÔTóÍ•Íq¾Ùïýˆƒ‘¾Ðøž§ù?Ä¿ð-ZØ?ð/L?ïÿHt ë¿Áî5ûuš©?ƒ‘cjz­ÿ?QkÞCÿ¬?oUè¾%s?Lô“õ?2,â[ºrä? —ç=š‹˜? KÒ°í>ì) Rh‡>–ƒ£znWX¾ì%òå§ä¾æª‡ 1 ï¾äVœ¹Qý¾Ý¶|¶ Œ¾Ñ»æún€¾Æ^Úz­Ëw¾ÚÃör<¾î “â¿Ÿ…ôæVü°¾æ³þôe«è¾îà߯¾â‰a›¢Ïn¿ïÿÿÿ±?ð­l?ïÿH{¿$á¿ÃÖvu ë›?Š:Ëd9?Y2§ˆ ×2?uI®i7îZ?TB_ÿÉC5?9á÷ex1?'3õèƒ ˺>ÌÐ;ç–·¾ó°]ß¾ïQ€½Ý¾íuk‘°ßN¾å TL˜¾Úªk#¶Y§¾Ñ 4Àâ¾âÁæ-€¾ó~ê3‰÷¾ð}íÓò¿’Q‘…ºŠ¾ô¾„ ¾ëÅwT å¿ð ®¬?ïÿÿÿ‘éQ?ïÿH|æÆ¿Å<îv±àR?‘ÁZF]2‘?`•E'Nvß?|¿2bi?[P×Y,?A'‚r¶=?/Ñn4#q?R:uì">ü]f=*~>Èì†TUid¾ú=Eåxjh¾ôã´Î?¬à¾ó[ž“ªaù¾ì^;¾|ؽ¾áD’ÚuhM¾Õö¾ÂÆ4ž¾èøˆ‰@³¾û•Jݾõ¥<‡ÿ‘+¾ûÈ]‰Õο‘€cÓA¾ò¹y÷Ç¿ïÿÿÿè9?ïÿH‡øÄ7¿Çj~Eù?“à]Úª|?c•2 þø?€K©y{sT?_@SÏC3?D:!$‚½?1ë¼Ã³¦?"ô‰UVÛ"?K.>a ¢>Úà}]Öv¼¾þSZ[æ-¾÷×·þ¾öàŸç¸s¾ðб܊ñ¾äã;N]¬¾ÚÉÆÎä6¾ìãTëà=º¾ýH_‡/Ǿù —j|¾ÿÙçÿÉý ¾õ»W3æ©X¿ƒÖ¹/+…%?ïÿÿÿS¿ïÿC‘óPÉ>°@¬1€£¡?6bGî ?jIôm? ×oÑ?…GúŸ4º?t·\‡8S?p.E6ð'ù?_ Œ‹™Yß?YÅ7; J?3£^èSEN?B · ìÎ?(IƒT? O“ü˜ï>û¸Ž¶ÿL>ê‚KfR·??Fk\a\F¶?DXfÈ)ì?4ðOf=Ï´?3ï5a^Q2?#©%h‹¢¿ïÿÿÿ!æ?ð?ð¿<úr>4ß?ð¿¢Ï°ê ?ð"ò–³?ðhÜŒ¿ïÿÿþã]*?ïÿ£K+À ?Ï«R·&hÍ?ïÿÿÿ~«‚?×lIhSE?ݶH´ÿ9?°P–Ö›d?Äã×–µ?¢«ÈgÙ(?xwZi%wL¿etÌ"Ù¡s¿jÈ!òD-R¿tè ;`¹¿t›u%ª}€¿k¢¬ý͇¿rÀû ¿c«A š²¿Zt6•nz¿Q„Íjì¿Fµ; .¿sÓeí’pý¿r¨Œ[š¿n÷ûÿ{’ç¿m•‘ <¥;¿fVÄHÀT[¿ïÿÿþ ¯-?ïÿ÷…ÁS?Í!ѬÊ?ïÿÿÿª<ô?Ì®§ß'ÑT?¤-X3Þn?ç>0JÒÉ ?¹’¨aï;i?–ÚÎð.eW?míSvHé¿Zß¿p§ô¿`ðø´Q±Œ¿j€So¿i¼eð½’¿`ñ£Ÿ_9£¿fÓЃŸ¿X™$l¤¿P08ÙCsž¿EqÒ/PY¿¿;ÍWë{^G¿h¾Š&1¿fõGY4c!Rh ¿b#¶-ù_Ä¿[oÿ›XE¿ïÿÿÿO·?ïÿÿ„é¥a?д",æs?ïÿÿÿÙ>?Ò¬¬3È?ª'ONBrô?À–§DÊE1?è0bèr ¿?¦ñ£´\ï?sxKQ(´¿a•ü»ˆº¿f¨mÝàË¿qÌ–Gy¿qÜšJ‹b¿fÄb)º¿mÒµ8y ¿_MLr ÔÝ¿Túâ¥A-¶¿KÎÛ k¿BFz„ù¿pü¼/ ¿mèË@&Ö¿hØ?¼Z¿g[[”Xm¿aØI¯—GË¿ð?ïÿÿ}]í?ÓS—¼$šk?ïÿÿÿûàx?ÄÜì­u ?T›’6ç±?²˜®tü-ˆ?žÅ³"?éjØð.?eÊG ­=>¿S»XÛEñ¿YvAi׿c”}æ¿bæ¥;«l‚¿X¨xR&Šß¿`¨ËŸàÍâ¿QŠd纘¿Gˆ]Ö––¿?.‹ùn¼¿46H_ƒ«Ã¿a÷µµW6¿`ºã u]ë¿[ɘéAt­¿ZeÛ ôBÈ¿Sú¢µšX¿ïÿÿÿ®Æ ?ïÿÿ‡2«?×ÿš3ú§?ïÿÿÿŒö®?«Ý¿L½?ƒX`ïW›?˜‘ïÔµ?u1ÅÿL(?L<X›˜ú?Òª5&Œ¿9pp ¢Þ»¿@X1Þà¿I%èÖ¿H\q¦U¿?ù½á%Ùˆ¿E«wþ9S¿6¿àŠÿ$Ô¿.‰Âà4g¿$:\Wk:¿9•û)Ò¿G7e¹Ýx±¿E¬W¡œ_¿Aþ²7B¥5¿Ašø€b¿9äõÐl®¸¿ïÿÿÿŽ(?ïÿÿ}øˆ?Þ“κ#¹?ïÿÿÿšK‘¿¤¶d6¬¿|1ç[^²C¿‘Ú/q Ȩ¿oèF~;›¿DÊ`®´N?2P÷O–ô?Ý0\¹ýÿû?6¶¥%ùÅå?A¦3øÃã?A‚®º =?7 tב'??–á=>B™?0ÒDá3õ?&¢Ü3J¿?õÎã¶Ûr?mæCö?@áýàH??ãZââÔ?:s ë#-¢?9JÞ!SJ0?3¼M“š¿ïÿÿþõë?ïÿÿ„„!?ÝuIÄì½&?ïÿÿÿƒÏ¿­ü ÕÞµ¿…$F³÷¿šÃ‰8’iÖ¿wê$Âáý¿O”VP?;&‡ÑÇ?@´ß›?Ч0Á™)?Iâ âÂØÏ?Iﻚ–`?A²º”»å?G”­LÁ˜±?95 WEÇ?0ú.Å>ƒ!?&v<Å׺ý?!n´Ûi?I!EÒäð?GØJ|µ1?CÅ ÙÄ@?Bò)X¸‡?<’ @9¼¿ïÿÿÿc r?ïÿÿÚæ?áI¬W{”k?ïÿÿÿ^Ï¿Ãxsaü"¿›v )o×࿱aUç¿mÈ[¿d1‰ÄS57?QšÐ*%"»?U¤ Ÿè ?`Á¼¼Æ¤?Ü¥xóT ”?`гȮ.F?Vü‡ êÌ?^œzê¡?P^ˆíøê×?F m`€I¶?=,ÜáÒ¬?2ë8J$XØ?`M¶1A\?^õ®è÷?YªÕ¢é  ?XšÌÏ ŒL?RŒÐhØÄ»¿ïÿÿùð-A?ïÿÿyÙy?áÃܪ?ïÿÿùú|¿Åô5Zãó¿žõ˜;¢­¿³˜ˆ)—º¿‘‚Ž žëZ¿fƃ~ÄYT?SãÀ"ñZ?XzŸ"Œ³?böêIäq?bÿYÄÞ˦?à—,}‡?YêÙ5ÂÈ?aD’&pe?Rtýr¶€?HÜ_u‘5?@rD«„\”?5T@}í¨Ë?bgr+MxÙ?auÒô~?\óö-N†š?[¾”ôÉ?Të“jž¿¿ïÿÿÖ†'V?ïÿÿbz c?æ!ºIx?ïÿÿÖŠ#®¿Ùƒ%J´”ð¿±þ>MÏ¿ÆÆ@øV(O¿¤Y c>~õ¿ztNEK«ü?g Iâ¸&e?lIò·d?uådñoÐ?v@jÖÃl?n¼Ñ(ÆŽ?Ö2d‘ç?t qsÍ8ü?erîN®s?\æ7¯L?S¬m[í?HÊ»O¯ž¢?uX:Öÿ??tG;/¡ ö?pÏœáãÁ~?pŽZV›~?hMë:Q¿ïÿÿþÐòv?ïÿÿaOËL?㎀ eê"?ïÿÿþÊŸú¿ÒyÍÖˆW ¿ªàz,Xd¿À|P|³ô~¿v›DÄÐQ¿s3N‘¬£?`ìŸüî°ü?dÿ‰Çk?pQš|u7?p-Í8¿ß?eÑt¹‹‹@?m-bÎ)ý?ðˆXÿŠ4-?_ †üÙ?TæÖ2‚½?Kª<1&?AðupÎ?o1VÞªbx?msRÏ_d?hm•ÝYp9?g[>-Ú%?a ß%úÒn¿ïÿÿò]¼ß?ïÿÿg%Ál?è›ôÜÔãb?ïÿÿò`¿àGóË”¿¶ðY½J’“¿Í Í5h¿©öL‚‚q½¿€ìåÓ®÷J?mãú"q“u?r‘õu5?|ápCÅ?|“úK<Þ?s:C£«,?yºõ(®#Î?k`j7ópí?ð©Ÿ …]?bj[A[Jy?X`@ñáˆ?Oœó„48?{† QôÅí?yöji)0f?u‰eÒv82?t•QGkîý?o‹Ðy|¿ïÿÿÇ´³{?ïÿÿî:]?æ¤E8N2Y?ïÿÿÇ´Ií¿ã¶±˜V“á¿»ÅÞnz=l¿Ñ–¢>ZŸ–¿¯oT€†¿„bÔ‰j2?r8su‘?v‡°œrÄÐ?†rí~I«?R¹r?wH?xJ—Í?*û?#à?p“­“U?fK·êµ$p?ð˜ëjKí!?]ƒrÁíX?S"°l V?€¬èIŠß»?qƒµ„Ó´?z˜îm¨?xì}kÖ3S?rÑ3Xâ¿ïÿÿ,Ï$?ð=Ð?íO%ß~j?ïÿÿ-Åo¿ç†"^G ƒ¿À‘Ή@a¿ÔüÁÜÒZ࿲ÁFFW$¿ˆvcÝÿÒ?u£ìãv§?zí†u`ä8?„ó`6`š2?„±"€4?{È÷¢´?‚š0)”f‚?sÇ=ÚÜ>€?jšyZœ!zÏ=ì?e7Hè„?`%¿ÕÐo¿ïÿÿü‘ñ?ïÿÿa6¤?ãý"ë™°?ïÿÿü„’*¿Ð׿gA¤¿§»¨X~¢¿¾†oe»¿šÛÚmøH;¿q€Ù|9À?^ÛÌúnA•?c%Ò€¥?mÁÄÅp`?mù"F×Þ?cã·q:#Xú¿Ë¤À•Ò6k¿¨³ìÁ)|i¿€j)´¤4?lmã·®Àl?q¨*ˆ[Ø#?{uw f8?{.†ÉïX?rKp$X?xz…`MªÚ?j n€5’?a…ÓöïÙd?W1®‡Hg ?N®aÉyÌ?z.~5ç¸?x³~^¡Å?t}rk+Ï(?s•£ŸÀR²?m‘EÊ?ð´ÄU8¥f¿ïÿÿÿÓ1å¿ïÿÿ!oÈ?ïÿÿÿâÜ꾸€+p—Ïÿ¾ÆÞ*gq]˜¿yß%ç5ž¿³_u6 (û¿¹ü‰»}üí¿­»¹#ܱ¿¨Ù„ÒWŸL¿EË2ñN*¿™_I»ž-ü¿|EJ&Sø¿ƒ±Eá3¿h×óµó¼¿[½ âyõ1¿NáÌp`9¿An¯Ø Y.¿†¾8’"ù¿…?1hB¿zZÙrÒ¿yRÑ ›G¿mˆ·Ç`üY¿ð?ÁRǪGO#¿ð¿ªŠ»g¶?ž°&ˆéã?n¢¯ëdú?—^:Ç}3?“5®XÑÉi?ŒØ,"m?ŠÆ(jsßt?ƒ0­ûGm?¿Œ4ßó?lp3`8‡ñ?vWQkó?a³Ñ™?VF“iÃ?JÅr+FA‡?@l=iÒ²Í?y@ ÷p9?x]í¿ùÅ?p2@BLô?o`Ô6ä«(?d-j&¾LÍ¿ð¿…>þ[ê`/¿ð¿·¶-^ºó¿—¸¹G¿¨s‹†LÒ¿ër³ˆæ¿}sR_Ò…ó¿n÷ß SéS¿i%DÖÐWK¿YY³&ø¿UKz+ä¶<¿)¡G·/ Ä¿@äþ$RÞ¼¿?'¾×}Þ3Tÿœ>ì´ø  >ð÷ –lr¿Ed¤ ›Œ¿DžˆÔ¡N¿0Ñ·—€2ù¿0O ö1¿V¹°ï7Ì¿»™5´4€¿ïÿÿïð¦±?ð;aì?ïÿÿÿرE?ïòH±l¢\?À«b 翸ìÜ“4T¿ôÒ¦…n¿ˆìÜreîn¿¤ãW~ǃO¿„‰x~Ú–+¿l´fñ[¿YúzŸ~‘¿Nä­Å ŸÆ¿;aõÛz;,¿*®7:CO?aõCú[g>ü³E>OE?ß>ÞÒ¨?ço,F"Â? ®7? ‡¢>ýלY¿ÙÑöMN?ß>Îõbå¡÷âÑ?){ÍŸ?gÔ¾–_>õªO­³Pg>î~`°íZ¾áÏ;0¥ ?ölÉfñ?Á µ¤bÄ?õCélD)>üà`ÔÿÑ.¿ïÿÿÿµ‚?ïÿÿÿÉ’ý?ð7ƈk?µag§!‹G¿³Õ±™¡}¿‚çdíª$¿Ÿxæ-ÿ¿ôL!iAm¿~±VΧ^¿dwi`)¿R€·ðÝ ¿C7)¹¹Š¿"¯Ö’÷~¾þÁ¥yÚžA?Rqd@ðÃ?Ye†qÅ ?ÌŒèRQ?á.¥gP??ìÛ—Yù>üåÇG1Óø? ¢M.6¢?|-KW2S?]MÞmÇ? y—ÁY™?å:·¦|#¿ïÿÿÿ\ ?ïÿÿÿòa?ð8]kJ?U^-½¿qý¿§GRKn)¹¿wpܱD8A¿“Eö)l¦U¿ríTÅ­'¿ßö+KpϹ¿XåîjÇó¿Fölæý,Å¿85ÿc…\®¿k’GN ¾õy3ÁÿJ?5Ÿæ¸’? {ßóJÖ¥? kïô‰Îß?"Ú‘íV!>û¼;–OÁ6>ò3î‚œÅ>ÿj–SK 1?POiˆØ?\³Ò#%M?&j•â‡Á? C%Œò{Ø¿ïÿÿÿ×.>?ïÿÿÿÍ%È?ðSóT¿£¢;οñ)¡*\¿nyÁk¿ˆÚ髹ù¿h|ú.?f¿P>x\`¼¿°}R€õƒ‹¿=˜¢á u6¿/wРҨƿ¹û× '{¾íÙÙËŽwp?ïO†…„?r6Œ_v?-oÝP!>üÞ/âŽè>ò(Z¤2@ >ç°:üxA}>ôfò« B??€£¢a?u¹ò,¤? ÏÐß‹?Ù/±¬7¿ïÿÿÿÆ2?ïÿÿÿ÷ä?ïÿÿ o¿§Me)FÑw¿–CÀ\£b¿f°¹šyô{¿‚¡˜ºöÚ}¿bE8ÍiZh¿GîŒ1õf¿5âU‚Sªe¿­)eÇÏ]¿' ÅP¿ÃÖae¾¸¾äÙ¬ø÷â§?À…ü ù>ûÜT߸¯ >ü³d/Ñ!û>õ“z&«>ë=†É!>ášîþŒ>î¼È½Vî?êÑÁîà8>þ£Yä?‰Ü?¬¡6û¿£>ú›Jë¯Ø{¿ðß8?ïÿÿÿð?ïÿþã&à„¿²K«NM¿‹¨ì¿ïß¿] -%‹ó4¿w {O‚ú¿WN{Rm·¿>eP†á¿+‡^¥k'Ó¿øl&Áç¿¿šÓÒUz ¾þ ¬(Uæ¾àéïRÖ§>÷¤«ðPv>ñ_è=!¾>òiº}ïþ9>ë¿RŠmÑi>á§^Å€I²>×"1,sA{>ã_ö@dŸ>õˆíðwü>ó°ëCÿ1g>ø¤=ekp>ñZwA絿ð~ ?ð ¾p?ïÿþH±°«¿¶s+®€—ô¿v„"¼^¸¿H /ãÇ›`¿bèÿ/$G¿B蝹e¿)´åGy¿§g&ÚÄ:¿ žWà K¾é-NR!žU¿œMø~I)¾Îi†ŒÄs>ãqŒzTy>Üqn­p¼/>Þ[Ÿ{9³>×â²{…å>ÍuvÃ)ó>ÃYez7ú>ÏÛõc>áWåÈØ?@>àRM(3É>ä5ˆ3~™ä>Üðžv÷I¿ð|à?ïÿÿÿ“ù?ïÿþFw)¿»X²œ±/’¿S‚Ðm^gá¿,!CJ»2¿AÓIšÇÄØ¿#øŽÔ_®\¿ a/´0¾÷Åûr@ËK¾ð\k™“›¾ÑgIƒÃ±y¾Ã‚J˜¿›‰mŽ’ÿ>ć›h¹ ¸>»´N„3J > Ô?æk¹>»šzð[ó>³IÓp߶>ª+Ädô>°ÉmüÆ_>·¸Žh-¬>ÄY6E>ÄWÁéc^>ÂÏ3;_=o¿ðoœ?ïÿÿÿl@Í?ïÿù¼-T}¿ÅN€­¸`?“AàÎê¡j?ce §ŽÛ?ãêBÖ¸?_RuµàZè?DšöôClò?3–õF\‘?$ • Z¤?a½÷÷%Ó>áÍr?XµÔ¾ÿÇäë‹S¼¿uÿÿ¨Ä{¾÷8_/¾øW~b9¾òP›zc¾æó?å·s ¾Ýå7ÈmÀH¾éü·Üºj2¾þIêh’¾ùòd‹ ·æ¿ªå„,z¾öŽÙ‰\æn¿ïÿÿÿü&Ö?ð# ?ïÿþ¡txç¿ÁH ®ãé? ¾vï_³?Ní½J{#Q?i¡;4ć{?Iôxg|r?0]PHU? £6÷·m?V°8„M<>î¹:¨ô.À>Ê%_Ên¾é¤ûBMò;ãôe±¿(2äwS¾ã†Œñ~ƒ9¾ÝW9ÉQô¾ÒKUùB ¾ÇÇ‚¿] Ò¾Õ}qæ…¾èÔe/}£l¾äÔ$éؾêôô”­¾â¥?µôë¿ð ^˜?ïÿÿÿØjç?ïÿþ;Ò¿ÈM•;àkK?šʧֻ?jèËÇ®À?…½ÕXN;ü?e⻩º³?LZÆ‚ü?9åušµe?+ËB’°+? gG&@>ìJh寱ò¿øú®]º¿5©Ûf:d¿ú³È”ô»¿¯ØA&-¾ù’ ël$£¾ð'÷iz­¾åF,÷ÝE¾ñüC:Õ6z¿ojnF½¿!ˆU#οöëN…kê¾ÿÂÊ’å/n¿ïÿÿÿÛ·S?ð NÔ?ïÿþ4§^m¿ÑŸò¯Ue?¡±êa'd?rE݇ž¾?xÓŠE¼&?m0˜#Àm?SC™+ç³?Aš¬“¼¢"?2ðÙê!?¢„”ªYß>ó~¶vu玿 Äú(È6¿ñoå6KÏ¿ €£„&Ú¿Yöä¿sƒYΗI…¾õòç2Wšñ¾ì²Š´óܾø\ów¨¿ —ô‚𤿘æÜ4_u¿“ç@ú@¿‘t#µÛ¿ð??ïÿÿÿiêª?ïÿþ-›å¿Îå-½o?è?£ÇÃÇO"?tÒiv†µ¦?Qý&»?p‚ï™K+?UãmBr1?Cí;ÇB„?5ÇýZ¡„É?†±Ÿs¢9>ø.ÜÅUæ¿ÓâÉ÷òñ¿­=y‰¼Y¿ BfŠKhl¿Í |FÒW¾ù: ²t¬¿e˜È]åà¾ð‰ò¾vV¾û‰ ŒÞ¤¿{é÷ èÀ¿ ’”Ï')¿†ì5‡wš¿Åa¨QB¿ïÿÿÿÍH÷?ðí¼?ïÿþ+")ô¿ÐõJÁ%(?¦Íé õ·Â?x1ŸZ&Ð&?“`²´ ?s"ŸŸ¸;?Yi´â?ß“?Gxùô Û?9n!5ñ'%?#ó¦çSN>ýœnâ@E=¿z×;Qpa¿ €V ¡SW¿øJk·Ð¿™èçöž¾ýeúˆ‡¦¾óK´ÙJuô¿XC„Aï\¾ÿÝë!3I¿yÑ`¿ˆ¿Kì› Þ¬¿CvûÅK'¿ Û-$äžP¿ð3Š$?ïÿÿÿ©Óf?ïÿþÓÞ󼿼*xî…ab?lÒ‰dÙ?=[±2¢?WÝžI¹¹¡?7jUèÆôE?°ø6Up? É! C >ýšèªGË7>Ý/:w"R\>ºá‹Ív½â¾Ø2GÈq„¾ÑÓ?2¿ã¡¾Ò`ü¾þO3¾Ë£,¦F¹ë¾ÁQáûæ)¾¶/F0Ú1¾Ã«£ ,ø¿¡#Ðà»,ç¾Öç¾DE;Ӟ<&¥Ž%¾Ù.=}›s¾Ñ d ±¿ïÿÿÿÇɘ?ð·µ`¡>ðïÆ>–±<>Ä<ÝKM|z¾íÉ›8ºX¾ær½×÷0¾æ@U.ƾଋ¶ó!!¾Ôlè±ö¾ÊZºÕAÒ8¾Øiø¼bô!¾îC–¿V¤>¿ qݘ¾ç°ršÞ ¾ïˆ%/驾ä#úV˜*—¿ð;É4?ïÿÿÿèÅ×?ïÿþj’\ê¿Á/)¶é—û·*ÇN3>ÜH#ŠË:¾õ®2Z€¾ïütÇ>U¾ðÅ"•Ñðd¾éA$l:“5¾ßðò„›¾Ôà¸FnT~¾áÁ¯ûfå`¾ôæ†äU°¾ñê$Ò•v¿“ªð¡$œ¾ö§¬)²áð¾ïfÛ×^‹\¿ð*›(?𠮬?ïÿþj­Ùʿ¨!3=&?‘ˆñq‘Õ?aŒOÿ—×N?|úïhaƧ?\\«6@?B’ ˆ+!?1 .r¦|?!ܨþôv?}Gõ0D>Þº½Þ>€¾ý¬ræ_)¾õ”¿äþ¾ö#~DÎë¾ð£åÔÇ®¾äÊ°Ñ/÷¸¾Û \o¬Ö¾çÃ>ÎAK¾ûëùìªz­¾÷Ç£pþоþx2ü\L¿’GÍÆH %¾ôv5˜p;¿ïÿÿÿË\c?ïÿþD]¨B¿Ä{w½Qw5?” 0Vº?e Ó˜ {™?€¿ ­œÅÉ?`°BÏ l?FwŽ=?4‹È)°?%äºgÕ?Ä9H‹GL>è°EL]¿”¼)7S¾ù }Ù·¾ú›‰}&¾ô“ḾéŠÇjv€¾à½8“qѾëñpe^ ¾þüüm¹¯¾üpœTÙ(¿Ç|íR#¾ùÔmÆ;—¿…#yû|?ïÿÿÿËÅð¿ð :¶E>•NVíúÀ>Þ&Õ8vm ?XQQ¨å4?‡ú7“ ?‡E7ÜÛ×?výúž©Ÿ²?qîѱڽ{?ag¡[L|Õ?\ò–¢¸}?6ÅŸT< ¤?BìÃQï{? æË(Ä?-ë(õéã>ÿ²UBdD>î?¸êö?G\ ÝŒml?E;ƒxGï±?64¦ÿÆÊ?5(è±BP_?%2ª¼wnm¿ð¨?ð?ð¿E»”á‰$?ð¿¢¹qsƒ‘?ð ì„ç?ð û˜ù?ïÿÿÿÿ–r?îÕæô¤UØ?ÁVe¸ßîd?”,ôpÚ?zýM¹A§?GñrS[¯?`Ú{©fË?ÜhO¿9sD TÁ6¿>S“¤ÙŒé¿@häÈ¿9ZVfKøk¿5ðº$ä…î¿_ß’\_ž¿(¶E„›¿¶âÂü S¾÷ì äÿz¾çûsÜw ¾Ö®,”=¿,äUT´ù¿*ŠTWê¿ŠI7G¸T¿Ý`}Ë:Q¿ YM#¿ïÿÿÿ¤½”?ïÿÿÿøN?îÕå1_?²h"&gÎò?~µßIÒ¦?2PÂôD‚J?£‰Â‘Ý&?H_×5*ý•?êS~·¿#ëò( Æ¿'…€ŸVM¿)F¨ì® ¿#„dFžƒ„¿ Þh~ú­Ö¿¿½`—í²¿…šâ§Ìù¾óµx_®¾âk¬¸v»N¾ÑÁ}€®=ã¾Àùãœë¿=ß%júb¿f‡–¢†ä¿ƒ*  ¿3<õ—j¾÷äÓ5ïÿÿØóío?ïÿÿý„P?îÕå°±õ?¾]ypeNm?Œc&应ƒ?A@˜]ÜOµF…¿} d}â¿!âÊ[À¿ijß ¾ñ×¥öì¾áD03çҾЋ“ÅG†]¿%…fw9©¿#ŸxF6kÿ¿Á“qèE•:‹?e•¶j·G?ÀEEøø?1!¸¼²N¿>ïþû‘ÇM?ª¹Æ|¬—¼¿ qS»Y¿ÅpëTº¿Ç BÉ¿ tÚbVÙ翺Š|jŠ‡¾ê_¿Á[fº¾ú?t³¾ÚÃô>Òm¾ÉéôR#>Ô¾¸úþ’BÆɾ§âkD½Dœ¾ÿIüq0ùž¾ü²)Cÿ¾ð‰Î(óÏž¾ï:~®;¾àέ$ d¿ðÏt?ïÿÿÿUp2?îÕåêH5?´-Jnº^ñ¿}ŽZmîÎù¿1MŽ,?:=¿GiæéH·¿/²É«&µ?!R¨±œl?•EãÝ)I¼?$ü³Y ®?'6â$þ?!ôÝ{?2—éÁ»P?N¶ñ²ëƒ?€hÔ>ñpÇ2¦>àîåæ>§ñ>Ð@äp[ú¥>¿×-- ?wñM¿R?âÃÆí? óÍI6>õìkV]ˆ3¿ïÿÿÿ´h˜?ïÿÿÿ|â?îÕåÃLU?·4FÕ¥Z¢¿(/8¿BˆÄÑø®¾¿X¸¡Hëz ¿jJ 6?3íØÈŸ?‚?7£T“-ø®?§1È€Ì"§?9}ª t{?3¯õ;Š.Î?1Ñlëê?ëŒÈ`ú?"°F˳N?1"†ûY>ò”6ÚÁÇR>áæ)—ÍN>ѯ•&êI?&oŠÌW\?$˜O>B$?·stÜe?g}(kÿÇ?ú´‘L”¿ïÿÿÿ¥ò?ð „?îÕåo•?´¶Bˆ(vì¿‘8ñqg¿D›Ëò×m¿[X:ÆQŸv¿Ïf —3?6̬Ã'–Š?:½y>ánÀ?<— št? €ð:üÀ?6y^ù?3qÓ€8]?/Å&ž_Ë?$ïÛÝ5¦?ƒ,S¸.^>ôÔ¹²_F]>äeÄ>Ó8;ûZÀC?)%èœ?' žQ6™•?•úìϬ\?ŒÊg“n? ƒY™"¿ïÿÿÿîÑô?ïÿÿÿæÙC?îÕå r)?´öäWXåP¿™¢¥éµ”Æ¿NyÞËV°¿dV°Á~ö¿"p‰û³ÎÊ?@RŒt6ù?Cc·’ˆÛî?DîòÒP ?@+-Ôª©¿?Ãç¦g¿?;ùàr7?ÑÝÒ•!?.³%Þ@?†Oƒù>þ„ƒU»X>ídÝ˪§º>ܯƒJ´"?2mk^ ?0êä!Ú×]?#zG­§¦é?"g"m[JL?É­Ï¥ã¿ïÿÿÿ±,?ïÿÿÿ¾Úœ?îÕå|/D?²»¤"Cß¿›}U-RÆ¿PQg\R‚¿eÎy ¤Ü4¿#Äj¢dÏ¿?A[ôFÎÎ?D­‚bú%´?F^ÒÊ_ ?AGí†xõ?=èw³Ù%Ä?Ìô%lftè? "À³ùc?0h–¬_z?Ø¡%+çÊ?Nx'ÒÉ>ïg–À&Î>ÞUkSÖ ?3±’yš?2åÁ×é?$Ñ>5¢?#¬£Ú–i”?$iÂ0ˆç¿ïÿÿÿÜŠo?ïÿÿýÓÈÙ?îØgr;e6?¯A­©vÂ׿§þY²Ñ¿\šò€‚vø¿s Θˆû\Ÿh祉>ê(ä™*³?A(ŸÞláJ??ˆÿ¸Oèn?2$„–7mw?1-–ˆnF¸?"k?Àüò¿ïÿÿþøÍí?ïÿÿÿ›e ?îÕømaü€?°‰¿ÑÓô¿£¦w\¶¿V« ÏÅr¿nJ £9ˆæ¿+{à¬þiö?H©»¡ä?L®%Nʶr?O Ä—{Ñj?Gû.ÌõV?DÀß3›?'2[3ú?6ÅÜG²â?ðšµú¼¶â?ašÎŸl?¡ºx‰©Î>õÊMòeÇr>äÒètåø?;Täb5Ìœ?9šKÆ·?,ä"¸ÏÐõ”Rš‚mñ?LS†Ã+SŒ?Jn§Î?=ñG²r†f?øbC‡DŠ.?ð?P÷*x Ø?Mg%7ôhö_å…{>〡’Ó?9™…»"E?ð± vÉT?7„RÂ'Þ?+ê‘v?)“®àÍý?{p^B”3¿ïÿÿÿùC÷?ïÿÿþmMÊ?îÕì%åIÜ?µK5BÔ¿¡ß”ƒV⎿U7#œ×§¿l[C{aO}¿)¶S±™ËÌ?Fˆ"á!,T?JÛ;ˆÉð™?M.¯¨ìv?Ft•$ó&N?Cnø33wÏ?%–þŒ„s?5Rš8ûû?ä£×“?0£ ô'¹>ôg döçÌ>ã4¯Á?9—0Ž†çB?7‚[j;•À?ð¡,•É!:?+ 9iç˜?)‘NI¤ß¿?y’¸ß,¿ïÿÿÿy•¯?ïÿÿüCI–?îÖƒ¢Üø?´§PÞ@ k¿¦ÛŒPJM¿[IÚ±}¿r ›<ã©¿0»duúq¶?L¡ŽÉì¬?Q–L¶Û?RßÄŠ?L—6gå?ñ¨aAr.? ÂÈb}>úÙ.^²>èåࡾO?@O¹q+Ý?=ø ¦•]?1E­õó ²?òvà#¼&È?0T#ˆ"?!„‹ÜW~Ô¿ïÿÿþÂÊx?ïÿÿÿ£]?îÕ"ÉÖš€?´W/eX\0¿¦®¹½¹6o¿[r©¦\b¿qÿñ\hþº¿0|?2¾Ü?LàÖlìç?Q¿1y¬g?Reù°MB?LvJ–Ûu?H›ZAá?+pÎóQÚ?; ú76oæ?Èò¹Ø~8? ïˆÌý&>ùáè¿×“Ö?@:\~6™¥?=Óêé-š3?1,¿zL!?0>Ä×ÿi±?òj5áâÖ?!qÊ” û¿ïÿÿÿRÓ±?𿱕ÜÅDÔ^¿°Â¢ˆË#–¿cBûT1ue¿vxÏÑ0ŠD¿=YàiIÙ?\äyÁ©è?]YàåÈúî?^ZZ‡B¼?VýK°­/?To›Ì°!Ã?7¡ (±§*?E¬ æà?&ZlðÿÎ?¡ /yØÑ?d×&g 9>óÌúœ¦—?JÒ|„¡C?HD‰×¢Ï?:Ò|ŒSz?>ìÜÓª?-`p<ƒü?õÍ|onÐ&?ïÿÿÿX ³¿îÕå¢Æ¾³ñË‚[U¿2¦²3«E÷¿\Ì@<þø¿é}ºT(V¿|Yo¥±Wr¿n9r5}>ˆ¿g­„šÁy¿W-¶é^|è>Æ5—ýä&€>Ád%5å9>µ'¢`+X¿3Ž@ºº¬¿¸ 4ý[¾ð·ª(;³¾ð~ìaöKJ>—ã‚…Àlà¿Ãž)¡Ý€´?ïÿÿÿ$‚¿ð±K׿ð?ïÿêZ¶Ùã?³Îƒä?ð¿ßRjòçv'¿ïî•4É›@¿¿êƒŸÄ¢*¿Üã|c3D;¿Ãƒ•oÒ Ø¿„%Uõ´ƒ?e4~ãʽÊ?‡”aÍ:?‡÷zš?î´Wß?bË]Û'̬?qõC<…EH?Q?1Ÿ?@ JeúVA?*Î]ç´.}?›Ü6Æe?ti O?vk¿‹`mž?dýÛÄúÖr?fªnN9Æ?S†Ü}¹‰4¿ïÿÿÙǸ?ïÿû…Ã’à¿Çõrv†ß¼?ïÿÿÔþ-¿³ï¬w½æÒ¿@Å0þ‹Ï¿ë=gcs¿³ UF½Ç¿›‡ô¥”Úd¿_s³cƒ?Gº%Áh>?_šU i³?Y’dT¾ñæ?YKyÖB†?<P— ‘?JÑÔs€G?*xˆ •¼Í?ŠËùl ?ÁHAsq>ó_Ä3V?NiFüpi*?P;zqlR?@7fŒÌË?@Ò£Àè·?/1* wμ¿ïÿÿû:ÚÛ?ïÿûªÌÝ¿‹€RËw¾Ï?ïÿÿÿÿsC¿Õ]4èñI¤¿¶¤b¼D•¿ÓÍwvû-¿ë)íÍõn€¿º¬ŠÑ¢¿{Ú5¡Àr?]¾àg·‘?ØÀ 5?wõ/û'®Û?xu“=p?YÓØ 6L´?h¢',.`½?G‘_ ¡ ?6&[hv]4?"ŠpÀ÷¬?\%°î-Ë?k|M++ó?n­·ï¦Û?\à)e×Q?_)P“?Jøäݼ38¿ïÿÿÿÿÜÑ?ïÿû²Zút¿Æ'Ü ÒÓ1?ð¿ÀKÑrÒô¿¢~:Ýöv>¿¾\åÉ5z¿¤Ì¿÷W9¿ï©ÿ6 s‘¿eÎu“è¢ò?IÜËÍ*™?h­3’BT?bÔN:½l?c‡ÏÒ»a?DZÆ€œÄr?SmáìLø?2´AŸKú×?!˜ôMõ? ¸ Mµ^k>úV Û&)Ž?UÂ4.Ù­—?X_þ†QÉ?FíBÓ¢_Î?H{¸Ó¯?5ûÛ¯ÿ­¿ð?ïÿû¨h¥—¿ÑÃkLñG›?ïÿÿÿ„¿—šGÊæÏ¿}D /b¿–&šÜBs¿beoƒÁ¿@ìu˜XΔ¿Óï @0à?&ßÂE?B;ÚC7@7?<_@UÒÝ?<{þÿÛÔA?Ë>ñõK¿?-i&uîæ†? Ž†¯œK’>úçXZYÓ>æù RÑ¢á>Ôw·—ªï!?0Sh4?1úëP$£?!‚bžÜ†?"}ˆÿ æò?™S¹2€º¿ïÿÿÿǃ9?ïÿû¯*,¿Õ‚SùÒ‰?ïÿÿÿ¢Š¡?‰²9—0?wbp†?‰5Là¿Ž®?s2bLëÿA?7-}Óh§¿$á³ '¿×’%ðd¨(íHÔ¿&ÀÒH)xè¿ô¾ MO5¿A ßaô¿vh¶é…¿ïÿÿÿþæ†?ïÿû¸ÚÐv¿×ù†1ð?ð?²ÇsË4?”7£—Â6ß?±boLVä?—Öíó *?Yƒ`&q1¿<,Gè?r°¿\”$Þ±B ¿É-¨kp"œ¿UŒ¶'Ò~¿Uàí¯#…7¿7"6/Ä¿FÝó)T%¿%,tÁ-¿äØ®×Çœ¿¹öûŸb)¾í’-ß¹pD¿H¾¸+÷ø¬¿Kjm¹6o¿9þjÄ Ý¿;؆úŠO¿(V³æâeo¿ð¯ì?ïÿû©W§7¿ÜjIe×!É?ïÿÿÿÿ–r?¾ÎQü)P´?¢ mÿ??¼ÀбDÔ?£ë+Ï$Å¡?el´ÛeÅ-¿J0´Î±U]¿g–€ž¬V¿bÌ(©Zè¿æQ†{å¿bH`!%ñË¿C–WMgÀ‰¿Rµ[–C¨ô¿2<ñ‰"¿!Ú¹¦’¿ Ø_’£Ó¾ùœä¾ÇV¨¿UjP½4Þ¿W¾³V9B¿F'ªã´“ì¿G‹Œ}ˆa¿4å4ä´Á{¿ïÿÿÿqÀ-?ïÿû¦GJ¿Þi„´¶…?ð?ÃÌ")‡‰Å?¦s»)O?Ân9úr• ?©W„¹|ý?jã…mÆë«¿Oà î3šÀ¿n‘ÕŠ¿f÷®f‡wc¿gA^þ„ ô¿í(S¨‘‹¿H˨x0Û¿W­oÆ!ó¿6ÊÝuÝ–ß¿%pÆ—µ!ü¿½ÆÖg%¿WQ!¿Zˆ¬ç{•Æ¿]<W¶…¿Kóô¡`οMÒ[|O\¿:H°ª +Š¿ïÿÿÿÿ ¶?ïÿÿÿÿ¹¢¿åű¢ô?ð]X?ѳ±˜œSó?µ'Ã6&Éw?ÐŒ¡äÃÆ?·!¡“?x#¡êNt¿^ÿ|lF<Û¿zñô ‡cÙ¿u[¯ƒ_z¿uHun¿VÆ|Psm ¿Ïß×æ³Ó¿eÏìÝ+¡Ø¿Dôr |DÕ¿3ÔŽQ΀࿠ө6Zã{¿ªäñúÚ¿hVöÊë¿j¶¶ŸT¿YÀ÷Ó»°¿[M+ì5݈¿Hh6?ϳ¿ïÿÿÿíÛª?ïÿûP[%Š¿â «_å4?ïÿÿÿÖÄ?Ê”¿¤µ?¯QX+`û?ÈmÝÈlëß?°ÿÔâþG?riíÖ±¿VÞÇK#­¿t(y½^ ¿nòé³&§Ù¿o*¿Í_V¿PÂûO›[(¿`—‡$—Z¿æa9]=£¿>û³y ¿-,µÙÅ¿ЖÑGáí¿jœ°Ã©¿aü–aHÕ¿c£ë!x2“¿RþºÑÄsÅ¿T$ðˆÛg¿AôÞÞm<пïÿÿöŽO¶?æ’½ë4nx¿Ñ²Mx‡Kƒ?ð¿ð‰ø•¿ðìØæ?Ðî_ºd?Ðî\œó ?ÉeÕS+¿¹eŒË6ý?³Ài:DM”?…)•"HC¯?œ7q˜ãÞK?ŠÎEç÷k¿º—æèè›d?u)•l_λ?`“ÆU÷i?JÎE«£0[?²W=SSÄô? î÷³C’? ɹoï?v’Á0N`:¿ð?ïÿûª¨§K¿ë;ª²Á5?ð?×Òµxâ}þ?½ÁÏ\í‰?Ö_Õ4êƒ?¿`H©~©/?"«vÜü¿fu.Ê[z¿‚kÁôM£¿|¶©|¨¿|Χiο_-éo¿mÇf±‡Õ¿LïéùÏ¿;CG|Uþ¿©@SÃ(Í¿'LæoÒoŽ¿Ãþ_c9Q¿pÉ‘³Ô ¿r0ë@Zx¿a½^´»K9¿b¸2ü‡†U¿PÓùÈ?†"¿ð?ïÿûª¨§K¿íPÍH&] Ê¿€Á=¹7¿€¶î("—÷¿bDÖš乿qrzzq~¿Q ï&/¿@6Om©Õ¿+°®ÂÜ!š¿ÂÕœßøh¿€L74Å¿s³wš¯Ë¨¿u- f"1Ž¿dè´Ù-J+¿eéþQ<ÂyE?ïÿÿÿûàx?ÆsíÛƒ}‡?«_–÷’Þ¤?Å Û¼Ðog?­]#ùQ…?oà1áDÖ¿TR+Dü¦ú¿qItÄcÉð¿jÌö ha¿jòˆìšh¿MÓ§ûG#¿[ÀhØá—¿:æ—;$óË¿)V8³™wA¿—ø8™àë¿7× ã©O¿_5”“ö›¿ì¯fÆ00¿`ÿ_ÇÙª¿P~›,¦ýo¿QsÐ$7¡…¿?9¢ìøç-¿ïÿÿÿs‰’?ïÿù¨ùÓk¿álø8¨,é?ïÿÿÿ€tç?ËlÖohS?¯£<®]?Éß~Œ?A?±§É„#Àê?rå³Qú= ¿V´ÐšÙöì¿tïì5Ýõ¿¿p=X™Ê|¿p3¦yZHr¿QR®PU¿`Šœ$@ ¿?åv˜”÷¿.áàUÜW¿kÆKGæ¿Œù«HUx¿bŽŠó¡R¿da ý„ P¿êãW=Z6e¿SÂó”™¿TÒük–Q6¿Bm!¬ïï¿ïÿÿÿÿ¹¢?ïÿ†ˆ¥Ô¿ãϨ·ê ?ð ^˜?Í`Á Þ1?²q§oZ#?ËÌŪ[H?³‡)ÄtYÖ?uüqŒ¥AÄ¿Ws® ñzp¿v3,¤A¿q¢}^WZ¿q¦f$ø‡¿S1,\¿bPlè?¿A¶º¶,Ä¿0Æ¡%dc¿É‘?¿ ‘Ò§§Ë¿d Í*=¦¿fN‰©[Á¦¿U˘öò¦<¿×Š ªÖpØ¿W>“ ’¿DǬG­°¿ð?ïÿ¬s}èK¿äØd§?ðoœ?ÐØm'ÁR*?´¦‚i¿?Ï|-c'•}?µîÓ{ÇY?wíË›hf¿\¥¥FÆV¿y“æ‡î ¿t)íÊﶿtb@S¿U¸B¹Ã“’¿dµŠ b4¿CÜ,e ßx¿2Ò*@…m¿ 8S9¹¿ d+êþ½Ó¿g;­i÷¯†¿i` D€¿X‹AöÔØü¿Z}ª [¿Ö“ t¹G_¿GF—C'§æ?ï–þ6Ny„¿äÓC8L?ÊvLzÁF«?Á;O‰„?ÍOÖ¡:Ñ?¶ùvü1õ?¡; vÏ?±;qQI?™Ø¥k¨ëæ?U‰Þî?[H<Ðh0u?,·ÓÝAÚØ?ùvG Ùƒ?ª°$&0?rª°0N“:?\·Óí0‘i¿Fùv ºŸï¿ÁMn¿ïÿÿÿÿÜÑ¿ïÿû†^¾?ïÿÿþlW€>óÕq£SÙ?˜`ñF–Žh™•žq? þ"·ü°µ=Íæ!ü£=f$ŒÓ;Q§t~9~>žú@d¾>½$º ?¾ÀM(ñ?ð¾æô‚´Wë?ð¿©U¾Ú‰Å?ïÿÿÿÔØ?ïÿÿÿóÄ—?ïÿÿÿ ž ?ïö]kZ1ö?Ë£ÃÚ$Õ°?T n°ƒÂ@?z!ÉW_t?M¹n½`?Hë­q.?ÍäÓà´H¿0$yxM¤W¿5Þvª°¹¿A¢GCÆOŸ¿8BÎí'g$¿4Ùï—º­¿8]W¿˜¿&J0ñûÇ´¿Ûdé’p”¾ô±Ã`Y6̾〻Ík#}¾Ò?Èú»ï¿*ïƒuP£D¿(³ÿk+ë¿Ïn­iqi¿D,¼Šö ¿’ÑW}Y¿k4ª3 ¾ôp  U¿ð:i\?ïÿÿûj0?ïö]êÖ,–?ÇkAÂùR|?Lå!&ÑR?E­ˆ1õ©?Bpx~Ô?Šãwáñáƒ?9(¥E•¿)‹(Žì\³¿1:áf½\¿; üö8Ô¿2™lmúI¿/رÙZG§¿ÚÕ+· ¿!Qg¤ԿĶ¼7²\¾ïÇÙ<~Ù¾ÞZÈŽg ¾Ì. Y²3¥¿$§ƒýF\¿"Ú$¸Œ¿U›Ì^h¿½x}l¿;‘½Þ¿ïÿÿ´¬}}?ïÿÿÿõGž?ïö]êŠþ¼?¾û8@gg?!Édȵ]¥?÷¾Z‹ ¦?! ÂèU>ä1?4ÌW¼?¬HºùS¾ý(«¸cxÁ¿²&çóù¿ªæv\`¿Çt¯êA¿´aË/¾ãÅXºêñå¾ô<ò3#ø¾ÓŸìhrľ•†aa¨v¾±†¡-#HC¾ gÖúfÏÛ¾ø.–ƒØdK¾ö(;¶àÕª¾èø3a í¾ç‘vïÓ±S¾ØÎ~K1Rg¿ð?ïÿÿÿ°øü?ïö]ê]êC?¸úI/#¿?®Äá.z¿6\F¶ ·¿3¤AÌ6|Û¿5™D}—?Ž†2ž"ª?”ýìˆ;n? *áô퉶?*wM{ø?"7 0ˆ°×?k=T‚ÎE?’Тyyý?Áäfˆ7U>ðf°_í’Í>ßµ˜FD…>Í'ÿ3õEk>»;åÆ”|?8yš-Û ?Ÿrê%?ÞŠÓ”Ü)?ÄݹÒi>ô¯+ ÿw[¿ïÿÿÿÿ¹¢?ðÄ?ïö]éPÏC?»£C-[9¿P|˜ÈŠ9¾¿Gåÿ8õC¿Dçäε¿ÄELº¼?*{DeÜíŒ?1ñí$ÅdðýÄ äös>àß抶ë>ÍöW˜'%Þ?&»oc?$I2m\÷ÿ?ÕŠq4ê?‘nUbø©?¬Žð,Ux¿ð`?ð¿°?ïö]ëØ5?·XÊíCH¿RG½§ÂŒà¿J¡o׮ƿF¼Üoçr¿Ä2«ztl?-ÌEÑ”?4%XÁ|A?@5¹hWíN?¡ ºF¦m>?6L°+?2?3'÷Ä"µÕ?>è¦ú?$|º-—‰?«SD>ó¨t¬ê>áðN^ØA>ÐÊ:J5zP?(Â]wNˆ?&±bÆž?—XŸ?"ŒxÎÓ? dü¥vàf¿ð?ïÿÿÿ÷î?ïö]ö0»°?µQWJ§G¿ZÉ~GhÓÚ¿Soý|䜿P§-â2·¿yàòïÂ?5˜tg ûÞ?=@ ¶ƒ½?G•M:ä ?@9 jƒr«?Ç“\\¦¨F?;âtÕ#?víá¦ô÷?-ÏB[–ro? ;SÌq>û­h)óË”>ê´a†H¼>Øh4Bíñ?2ûÛ/q{?0„•º–¥?"˜Äï  :?!3¶åež?wÒVÃg™¿ïÿÿÿÂÖô?ïÿÿÿf?ïö]’싨?± % !u¿\§••ôZ¿TÆ’´Á8$¿QжÑ}¿ N%|Õu±?7 WËЂQ??:¬Èa?I0yš‹Ð?AS÷D"o?=Éxçòó5?ÕÍb½Ü¼P?y+Y”?/×d–þ;ã?8ðAt¶]>ýà ͭ>ëÛ«C=>ÚÛ 9‰?3=X~‘&?1¥ ]x-s?#Üü²üªõ?"ÂÈaiƒR?¹‚ìÀ—Õ¿ð?ïÿÿþV}/?ð? ‰R¾M­¿hœ í»N’¿bg¢@‡rA¿^ë‹Ë†§²¿09îdƒ ?B°Á3ð?J8ÿía»?UN1j?è?MAV÷y ©?I ¶M¬Ô?*cÒ ÷?ñ`l1¯?:Êq¾äX?y л™q? ã<É$g>÷ˆ°ü5Ç>æˆ!°?@-†5•?=»rÞg;?0ä¯Æ¥®•?/ˆHõ“¢? tÚ‘¼+¿ïÿÿÿÊf?ïÿÿÿó¡h?ïö[莃±?¥ÏÔœi¿cËÄð#^¿\¹Œó0˜¿Xžã$½¿&–>Zú–??Ùª¹€ÿñ?E”ùJ2Ä¡?QiBª‚*?GóEƠȆ?D•`¥rò?%À~ɼC?6ìø¡vÙ?ñ!ÊÀö…N?”~•å~Ï?n±¾ú>óA(Ê>âË,?:—0A­²?8d*Ì ?+t $  ô?)íøk2=?DFG g¿ïÿÿÿèë?ïÿÿÿú]q?ò· rã«ð¿ð?ïÿÿÿÿsC?ïö]ÝÎñn¿¾§æ¦ƒ®¿q‘Y¼/fοi{ÂD„Á¿eו¿Ö¿3ý»Ö]Â&?LI7¾œ\'?S)Jd?^ç‘@~êW?UBmÐniã?REžž à'?3N‰—Áù²?Cˆ\$â+Ó?#'Dõ£VA?"{!Îg?ð?¯Ãí2>ïû´t½ªÙ?Gšƒdu-¦?E¥ÄŠ‹‚N?8^Ÿ"P?7Yæ¾?(3aR—G¹¿ð?ð?ïö]ÝÎñn¿¤qºƒ¢[¿t_‘é Xþ¿m±¿@Õ¿iT”~ïw¿7/"=‚?PfÔñb•?V8w`ÈI?aë‰x ß?X§›¬Ó¶u?U0§sÖP­?6câávx?F¦ñZ(þ’?&6Y†Ð¥?é`õR?ÑØRÕïF?ð>ò‹ª¸ì‹\?K_ˆ“U%?IÐs ?ôð׺û?ð?Nè’ÖÙð?LXÙ.tù??éŽÞ°ð9?>#îó!è?/°Â&_ÍË¿ð?ïÿÿÿ²XÔ?ïöQŠDj?³”ÂÙ¤¿bŽ!§¹ÈοZë´«E>¿Wj_Î;¿%!Ô¾ÉÞ?=Þšž²?D;´”E÷?PQ˜^#Ë?Fs¢ó<ÁQ?CLÎã?$c çKµ¼?4 ÅþèZZ?:^L’ ·?'302>ò …®y¶ƒ>àãª9Z…?8í@~›’­?ñ3š¨†Ë"?6ܳ:%?)¼åkÙù*?(N刪Ϭ?9D·²¿ïÿÿÿÉoÎ?ïÿÿÿ¦ð‡?ïö\¶íé#?²¹š)‚·Z¿bŒP.¹D¿ZëÉ€Kt¿WÊ[m–j¿%&È/w…?=× h[sè?D7Äçä?PNœ‡Ã'Q?FoTÖÏrW?CHȪ*™S?$`ãÝŠ=6?4ŠâÉ· ?7 oº{p?$-IrˆÕ>ò ‹oÌ!>àá;—?8éL[¤+?6ØîsžO¼?ñ ¼“O?)¹Ø L?(JêfW?Šýë§b¿ïÿÿÿ¬L¸?ïÿÿý¼HR?ïø‹Š‡Ém?­ûyƒ¦Æ:¿gjè-÷Dc¿aÏæP=¿]8^ÛZ׿+<•¹fT´?BøRn&Øg?I¡º(gÂ?TâïvÀ‹B?L‚‘åø·?H¥bF ‡d?)Ëw†*ö?:6gl<o?Ëw^ Ø?bŒ iZ>öìBó›<È>åŠê¶.??—=eË×C?=0W¥†*Ì?0ye2k]0?ð„~ˆÙD?.öÔóAw¤? JœMk¿ïÿÿÿß³¬?ïÿÿþÆå?ïöúÑÝ:?¯>hk'Ë¿g|!¼Å¿a„Í—:yí¿]2¬¾¿­¿,]Jkà®?BjÊÚÚŒÌ?I {#|œ·?T™gÏô9æ?LnŒ³¨æ?HG˽ÛI?)šúˆÞK?: ^ßAŠ?š÷22ž?G/Ø>ö¨¾úç\Ì>åU½ÈöÐ??W(•?<Ãï)9œó?0K£ók)˜?.uVà·¢?ð}È78fÔ? Žr¹Y‚¿ïÿÿÿ÷ä?庭=+›?Çéß`Í¿‘üDzTKÅ¿nÕš[˜¿pš«Œ‹‘¿f·ê’¡þ¿eÀŽ÷ñÖ¿EÀŽ÷0$[¿EÀŽüÅ0ÿ5ÀŽö¯‚ ¿ 0²¸&ÁN¿UÀŽøïÓö¿PPkH?j“;_;?F*9‹È£?X&óˆùX?4K$IaI?"eÜÁ¢L·?W¿ßÀ(>ýyI·w:?]›äm‹:?[Û¾³ón?KÎ0¿º?JÊ·M¹¡K?9{¥ [ð¿ð¿´üì¿r k¿ð¿gì½ú­Ý¿sƒk.eX¿bÞEˆÌ0%¿WÊ㊿M¿…ã1j¿@3µØóø¿F»Òêê¿0‰³w^4Ï¿(ö¹û‰œ¾Þ¥È¿ÆH`¿v8fáü>¹å³õp¨>ÃÙ‘×–„>½‡)$ >±hØþ¥ü¿G³5Ìw¦¿þÁÍP¥X¾ê¼k•üÆ÷¾êwß©qá¸>ªî±nT¿Ñ7%Þ•Q ?ïÿÿþŠý¿ð0ˆ¿ð?ï¥Ù}Ê? èƒR^xË?ïÿÿ÷ìë ¿¯  ZŸ‘ç¿ïÿ|y¨À¿•šù  #„¿¢Nâ’/¤Ð¿…a†¥&Ç¿]Þɵýà1?2U©’›®.?pJýA¶?j—œØR`?jü„Ѿ Â?NF›ò?\ Ç ?<@¢F˜iO?+/½ôàˆB?<Ù¾4Ç‹?ö)ú­ 1?^ñT瓵?am’F Q?P¾ûwY'?R›+??ûä©Ú’¿ïÿÿÿÿsC?ï¦&Àd{ü¿²*ž/m–?ïÿÿÿî"¿…Ђý¨A¿t—vûªð2¿ëoZÒ ý¿z‡ÿÏ3—¿`xþŠ=Ÿ¿8V•w•å»?cc‡ÒÜ?H0‰ÚgÔ?D¬ç; G?D̼QL?(ŽÌ ¼ÍB?6À&ØH‘6?¨\/¢’?çz1:>>ôT`jH°>âªUM®…8?9‚-=3òÎ?;Kp– ?,_¿bã?-6€äX‚t?•]èÐbØ¿ïÿÿý ô?ï¦&ŸÙ|¿fĪ¤Ãž?ïÿÿÿÿ¹¢¿¥?BsC}Ý¿ŽºÁOï¿™/µÿnT¿ëaþ3¦¢¿}sËïí Ì¿Sôm‘ÙŽ_?*pwÄN?f|@ÏGJ?aìÄà©™y?b‘èjcº+?Dñ¾SÔÃ?Sa‰è,‘J?3šes=ú^?"ã® ¨2²?3%ù¯4é>ýCñ¢º?UhT[Ý?Xä6)±?G1» ƒí×?I °òR1?6AžP˜^©¿ïÿÿÿþÃW?ï¦&œä›À¿°«{~úL?ïÿÿý]“¿ÓE’ í»¿yÎþ~Žd¿„ E÷Wy+¿gÄŒfg‘¿ïŸhßuÏJ¿@–ƒ7™G?]LÏIž?Rõ¼‘Ü2?M&‹×ûø?MüÕÎ8.Q?10åãàÈ??ŸÒíÃI¦? 8ä³"? còÛ>ú׺ˆ½É>èW+Hˆ‰?A‡ôÆ&¦ï?Cty‘|A*?3 ø4VNN?4d@xŽ®4?"c§ZC Æ¿ïÿÿÿ?•á?ï¦&št\U¿»î˜6½h?ïÿÿþà|¿mßœû$ÁÂ2Œ¹?07ÛÉ=?*§¸%ÒzÂ?+584“cä?OèÎqk?«,mïM>ý¸§³s–>ì±8Ò4\o>ÙHéWx>ÆËWá#? &Ƶ ªr?!³ÃÒo?™eD@v`?¬¯Îäõ?*Ìÿ¬¿ïÿÿÿ¾·l?ï¦&™žë¿À`ðC¨âÇ?ïÿÿÿ~Å?JÖ´‘—IL?D¸¹Å¬?A†înŨ?(™Ê¿É?pf¾ó²Q„+Æ¿ÁÇ ‚c}¡¿LŸD¾¿P¢ˆ±r\¿qZ+T ¾ô ïU]ò,¿“ýà­R.¾äB38Ñç×¾ÓÅ9^ÈL¾Â{æµ–O(¾±_³<ÏK©¿Yl“¸\¿F±|*Û¾÷øÑà%Ž¾÷¡A×t%¾è™¯Ÿ=ÆZ¿ïÿÿÿú]q?ï¦&œ<…C¿ÂQn7¾“)?ïÿÿÿ¥JP?€Û]hêjß?hqžÄHÀ?sîm{ ?WŽÍ8¤ß,?0û=šf'Ý¿–N€s»ˆ¿BÈx?'¿²'á²ëU¿<Û:9ÓL¿=ÀŸ±àr¿ ů/t¡¿/}Ï«¿wF¶TüÛ¾þM”è)æ¼¾êÝ X¾×“Ð1+`¿1:ŽMeN¿38ƒdÙý¿"§"Æ !¿$ ™ ¿¿í3‚šjm¿ïÿÿÿ¾·l?ï¦&–&É—¿Å½[d¤R ?ïÿÿÿ¾·l?ŒÁ³öã¸?v¤l4çC?'Z‘.Šª?d‡-n3Â?=|£2Ïí¿߬q&ç¿O!mQ˜ ¿IMXŽ0Ï3¿É”£)7¿Iê^=ÙÖ¿-£öGåd¿;x¼£ÙÎß¿aJ3œ¿ ›‘Úɾ÷}B û4;åW° %bÌ¿>†ÿ×/-7¿@Óĺ±å¿0™Ê@B|¿1°y%ŸÕŽ¿ ´$A¿ðoœ?ï¦&”êи¿ÇN/‡Òå?ð,Ì?’¥ISðo¬?|ˆ%ª"p?†0•\Óª‰?j^Fºh?B©,jX»¿[».ä¥Ñ¿T¡ ŠA¿P0D)Ø<οP£¬>êô¼¿ÐœÒ6ŒtK¿2ðc‡qþ¿AŒ5étÔ«¿!Ù¯¾'¿6– ±¾ýÈâSÝ}Ò¾ë½ÊHqb¿Cv¢˜÷¿E”Q#ÉÂH¿5#ߎ1³Ù¿6ž;:‹GŠ¿$iyÒuâÄ¿ïÿÿÿz¯)?ï¥ûj”Ó¿Ð5yµ‡u?ïÿÿÿ\¸÷?¡Uöbw´?‹fpË6?”\°V;Ô?x{= o"ý?Q©tÊ›ž&¿-˜îü+Iv¿bwÍÐwz¿^+ä×\H¿^ì8v¤h¿A¹Ão”ï·¿¼íjwî—¿Pn8Ì©`,¿0Ìä¬0 M¿ 6³»ù¿ @|ÀÕj¾ù­^Ÿ”¿RE„“¿TŽ/üa¿Cå‘!¿E&‹®åB!¿3Q­!I0"¿ïÿÿÿÿ,å?ï¦'Ò«¿Ë±ËL“b?ïÿÿÿ{¶?˜èQµ¦?„ @$È/É?ÇhaT–Ö?qå!<ê.?IÑò8¿%ܼ[ Êq¿ZýûÙÁ}¾¿V'5Ö±h¿V—ž\ÙB¿9ï+ËtÕ¬¿H ËNň¿Ó¸8žûï¿(”p%Ë#¿¹ww©ÿ¿©Ïd*÷žò̸ݪ¿J½ß´€6¿M_PŒ1lg¿=´ÿHG¿>ñRå°¿,A{1è¿ïÿÿÿüÖÂ?ð¿ÒÀÀ£Í?ïÿÿõïâ?§±Öµ3¯à?œ¥pn-1?œGß/½DZ?ŒcÓˆ<9?n’äÍ”\?n’äyK4k?^ÐlËtØ?NÐlÀØÒ¿a·×èDòM¿+»”áƒ&¿.Ðl”è6«¿'QWzU>¿§õí"Çí®¾þÐl~¦µ­¿8¦½?®í„¿5‘å™3C?2} Ï  ¿2} éÙ´t¿.Ðlp®-¿ïÿÿÿþ (¿ïÿÿÿ·‘Ö?ïÿÿÿæL†?ïÿÿ¼2²w?ïÿÿu-h?ïÿÿ€0ÞÔ?ïÿþ«¹ôP?ðÓz` ?ðsjq¿à 3(\ó?Ð 4A ù¿ÉÍlç ?° 4I”• ?ÍÅ8Ûs?²$;’z…ö?Õ.€`nã¿–ãE¬lf¿p 3}™?YÍ ÔN?¶“|¥Ùû?Ðî¸ßÐ(?ÃYØë › ?±½E{&r¿ð?ï¦&˜ñáá¿Öˆ¾º]-?ð?¨G"¬ë³¡?• Í‹ý£?Aã£xì7?ÛU_Te?Z3JUÞ)C¿9š/¬çMI¿j´©Šì ¿f; jÿ´p¿fŒ«À‰Q¿J8ýïM–¿XMÑz:ò"¿9 €mR=¿(5Æí¦i¤¿Hb±Ý¿‚™fc±–è¿sñÔ˜¿[$¨´Øý¿]o­öžoý¿Mª™LÙœ?¿O>'TËŸ¿<ÿgovÍ%¿ð?ï¦&˜ñáá¿Ø™Ù2ÅO?ð?ªiR?wA?—QÞC(¿?ŸäºÒ‹.÷?ƒŠ;ð†?\ÉòXúän¿= 9J¼nó¿m 9 ƒ±°¿h_亰íC¿h¬»†‘<>¿LÊŒ‹-Ü¿Z®Ì?hå¿;‹=w65¿*£§@J¸m¿x^îsø¿xŸ‹ÓáA¿nÓj¡sç¿]Ô!‚$ ¿`¤W£¨¿PPÆ_ò¿Q$õ€ïº¿?óTŒ`Â'¿ð_Ø?ï¦&Í` ¿Êu¯!"’?ðÏt?•UùhÛ·?pÍè>?‰A•t«¥?nÎq@°Õ?FK¿J P4¿#{v¿þí®¿W-:Æ;3{¿Sa¹xÎk¿Sr)dK¿6b€€1çø¿D¿Vx)ý¿%@HE^á¿„8W»ÊJ¿ç™¸nu¾ðN»ü'y¿G+©¥uÞ¿Ùo·p.Ä÷¿INú¥:¿9+`I,Óz¿:³%ÊN¿(vÇîDNÇ¿ïÿÿÿû0Œ?ï¦&êſʶƇf?ïÿÿÿÏØ?š+iÔÞP?„Q÷Ú¯¾M?-«®•Oÿ?rš;AÉ¡H?JŸ/…”òk¿$çÕ8w^j¿\7ÚCãŠÇ¿VåQoϲi¿W|%”Ðá¿:˹ôˆ"¿HÕ£½ÍtÓ¿)Lêd Õ%¿g*Q›~Ï¿)§7ô3¾ó5†wlUæ¿K“ÆØëð¿Ny{„ŽX¿×kL*EÖ¿=øZRY%E¿?ýÆïAª¿,üF5V9(¿ïÿÿÿÔ?ï¦?94ó¿ÎaBôêkó?ïÿÿþÒ»Û?œm¾¥:Lì?‡™:r!?‘ ûÑzîÕ?t¥ x‡rd?N*©mN¿*Iû«ûÙ¿^è”ç|ÚÄ¿Y!DοZÑ÷€6í¿=þ|{Dî$¿KÍ° o¹ì¿,Š^IÑ>"¿‹UÕ³zµ¿_ÊT5¾õöÓ˜·¿N÷ˆÁ ¶M¿Pì©‚ìjŒ¿@ä³â¢S4¿ÁÉéyÞÞ¿Aã¿x<‹¿0u—-ò•¿ïÿÿÿüÖÂ?ï¦Ñ/A¿Î×JÃr5Ò?ïÿÿÿ‘Ä? 06ñ´‰Y?‰á´é]Ô?“V…D´Ã?w:! êÔ?PÌñ †Â&¿+½)ƒÝ»Ã¿aÖYèöo¿\¨}Ú¿bP¿]Qö:1¹Ó¿@ËÇX‰êh¿O*Ý]ÛQÀ¿/Ï»ŽO3Ì¿­mÍ-Æ¿ ¹ñoäíç¾øIRpª¿QOum£6¿S=òFÄŽ¿BÕš…µó¾¿D Ÿhûø’¿Àüoì°ª¿2Jr.vø?ï›$–ƒee¿ÑY¼a'¾? ñ9)èÌd?| më9?”F» Â!?zp[»,C?VœSÐ7_?=Ë€hH!i¿eñÀÎg•¿^¸Þ€7Ž¿`uR•`y¿AŽ5ò=ñ7¿OÑÁÔ5'u¿.ÛúÞ˜¯Í¿!|§³íп"3žÇaѾùÈß<ŽŠS¿RƒüîP7C¿PÞ§ã# ¿Cã"fVY¿D’§9ᙿ4)QöQ+µ¿°wyŽþ3¿ïÿÿÿ@ÒŠ¿ï¦&– Ä?ïÿÿþ„e>òîëXÄ™®?–K~d—Ì?ápw¾½,?¹Î]a}ýÈ?¨¨Šüïxé?“¦”R„y¥?ŒPì[Ô?vÁ7¬E ?p^šZg>²{à ðµB? €Ã7i>†›`TÕ8=fL\Œ÷òé<ÑÝ(¥P„u<@°+îMð?2nÜô ?%-MVÊÍŸ>¼/඄u>³ÿð-þ¾È>1Š:#ùwp?“6 E…Üš?ð¾ízzá?ð¿“߆`Ó=3?ïÿÿÿTãu?ïÿÿÿÖ¿ïÿÿÿkm²?ïüíÐæ@æ?Ïå€$Ü.;?ð/L?ßv+Ü0?íÆ—#ߤ?Ê”Tœþ‹Ö?ß^°éoýƒ?¿7#=¨7?›ÐÏ‹Y¿h¹œüÙ¿w} 5–^¿Œo ©pö¿ =p¦~¿‡Uˆ$rt¿\^˜É¡Î¿vB_}Á¿x¹“…„i¿qDÏÉŠ˜¿g7Ýã”l™¿ŽqDåi¿\_GÎJ„¿‰¦ô;(‰¿ˆ’]ª¾z¿ƒxˆÞ5f”¿ïÿÿúÛU·?ïûÐml?Ìc ¬`Œ?ïÿÿþ¹•?Ô@BqÇ?À8ÀnU?ì§Å«ï%?Óž_{ˆã?²ÇõÏÄK?™÷CVW¿k¶=´b‰.¿v©6 †…¿‚mÂV›Í¿€óÿYŠ¾Ÿ¿{q¸Ï÷ší¿#8´ö¿t(Vn¨|Ï¿mFÔ”®™{¿dG%±´ð ¿[s¸—.¿€èl¦œ¿È½-u¿€d s“Væ¿ïÿÿþî¢I?ðCO·?Ýu¿µ¤•®?ïÿÿþî¢I¿¡¤Û7Zâa¿ŽIÏqÑ>s¿¡œ˜Ô(/B¿ñg*g³¿`3½_B•Ê?!,3ê0+?7v p² ?åúøŒ ¿?NÉ¥G“)"?OŽÀ$Xf?IÃå›?P pÁÍ•T?Ck.žö9C?;{Ux¢$ï?3¾§Òî?)ÞØÓ¨ù?PÍô˜ú¼Ð?OÈ°”úÅÃ?LN(«d?K ‡Uv%É?E´_Î梿ïÿÿþƒ(?ð ž>ýë?áKÖ«ª›5?ïÿÿþƒKJ¿Ã Ššã^ ¿°P9’2†¿ÂþÑ:7»Û¿£9 ÃÏJ¿7„:E?B}ÈÑË&?Xó>ׇD?pí±Y•'{?逸tyÇ?qææür?m3ù!ýn?r !Âì?e🰰Ý?^×°´ôsA?Uy î0yd?MŒ“3y?sNÈŸ,÷¥?qϯ¯³ê?oeok ?nºpHk÷?h›ÃA‰xª¿ïÿÿþÒRN?ð Ÿvæ¿ÐŒ¾¢&¿â¿a(W/&¿Ã âåп¡Bœïƒç|?bDm¥¬®‘?x™Q¦`c?“ ®¨ëÆ?‘NtdŽÕ?Œ0hx@ñ£?‘ÇÆ“?…>Á?]Ø­?î5~œ?}ò;—œÞ?tÓ›†Æâç?l6³Àøsó?’‘ð¢] l?‘MO”(^Y?Žs)uá›?Ÿ‘x›"?‡Ëª#hC¿ïÿþßoïÙ?ð‡ùÙ×?æÏ¿Ðñ?ïÿþßpYf¿ç]-Æ,¿Ó¸Üï õ¿æòŽyäß¿ÇNÿœcu¿¥¬t ?f]3éW{E?~[KÎ)ß?”<’F·\ò?• \’Ì?‘%û¤"J?•OÓœ-Ç?‰ÙaZ`è.?‚;ýóè€?íÙ@E¯3?yZ[I§=Q?q-,ŸÖ*?–‹ «»²#?•Ü ›Ó ?’—Èõûå×?’Wçà¿?ŒðsȆ¿ïÿÿ6ÄM?ðÆû¯À?íï4;‡Ò?ïÿÿ7 ¬¿ëªÖhŸ ¿×ºÎ£ÕÇ¿ë›1 T˜Õ¿Ì¿PS„ˆ¿©hɦqë?jèœzcÏQ?‚VUu®?˜K'±Ä?™,ÆŸuÅc?”†N Ô<?™…Þ†Ã?Žð|êǶ?…×UËýÕ?~[ܲ«âüÄË:?–S;`Õ?•–f}õ?‘O÷ÜP>¿ïÿþë§`?ïÿýÍ ƒ?ð½Ör?ïÿþìí¿ð ù©¿Û|Y=W Z¿ïøÛöþæ•¿ÐBQ>¼Ô¿­lÃó‡ú¯?o+À?eÌb?„ôöf} ?œÒIJøl?´÷÷?—­_þ?tœÀ„°Ï?‘ØoÿLó?‰5½‚¯N»?„>Ÿ¾H?w½’xäú?í7øwIuÌ?ŸÌ49H?$ÃB"Lü?™ÐâŸÎ,?˜èmýU¿?“÷¬0s-¿ïÿÿìŸ÷2?ðµã y?ä:Q˜8Œ?ïÿÿì í|¿Ò6ÿ= Þ¿¿;6Ͻ¸æ¿Ò+½àúÖƒ¿²s/¦`y¿ºLUa)3?Q´ó*ݺö?gÖ`UJ_}?€ …óà©?€µu±P(ä?{9ù´¡ó,?€é×8ÓY?t…!A%ã?lðä§^?d, ¼ ?[Cƒzx?éíé®®?ï 9)ó#?€¸Â\¹ü?}yDþ_PÝ?|žrHÿ±?vú7`ðÍþ¿ïÿÿîÇ^æ?ð·b}ß?ãöîÆ´­©?ïÿÿîÇ뢿ÒOÄ)ãx¿¿dUħT¿ÒC¿˜v]¿²‹t‘=SU¿Ð[‡Œ°?QÌy­¼@?göƒH?€Ü6©ˆ?€Ëþ€Ëš½?{^–;8'?ˆám,?t µN2Wu?mVPÂ9?d:'õ°?[gˆG¿f?‚.# ò?€Ï.ìÂ^?ï½ä/@?} g£˜é¢?|Äá“W.i?w"¾*¬Ø¿ïÿÿÙú’Å?ðcI]ç?ç\uJz?ïÿÿÙúÙ#¿ÚÀxN¼ï¿¿Æì¨eM2¿Ú®€{f<¿»J9Jœ¿˜‘[-`¡$?YýÐ;½ ?q‚8¡q»?‡¢(O•?ˆÀ€m—?„&£Úë¾?‰JŽõZ€?~_•ÆG¼k?ud°ÈŸsº?mÃsÛ©0?d(Nòm¸â?Š—“ª´ºZ?ˆ·cº¸À??…´´€a™ü?îx$:S*?…+V TÀo?üœ8j¿ïÿÿö¤¶Ã?ð(œ©á?æ†4m“«í?ïÿÿö¥‰ß¿Ú¢*>¥¿ÆÓ­ØA@Ê¿ÚØ]I¿ºô…×…|㿘utÊßP?Yáº`A@Õ?qn%T?‡‹c„bÿ?ˆÝé¢\?ƒÿ3hñÀx?ˆÔÂkå«?~$DxýPw?u={›g~?m‹pÑƶ?dâ Ÿã¸?Š[©-j¤?ˆŠÆY½Á‘?…•†X\!?….ÞV?î­ååŒ?€á¯Kñl?ð2}&W?é|÷ê¦G¿áÒ;Oª¨h¿ÎŒê¯EÔt¿áÆȬõˆ¿Â (´žg“¿ ]É×äêâ?aR$y?wSÆŠv†?od`º?i䊊úh?Š¼ŸqX?šòm0?„&Ž¸—U?|g:v‡î¢?sÀÍ­€»?jÂ_+"˜ ?{Æ8gɽd?zë¥ÉC§?r¥€ÅíÍA?r<·ZýV?h\Òæªl`¿ð¿oÜ0MDðÓ¿ð¿¥XZˆ 7ø¿˜²Vßìb†¿¨=¾¿pÞ¿‘Ö0/…õ§¿€={7 ZK¿qhº oοlú+ [1¿^4†ÿ.¿Y¨´)#5÷¿0ÜÊ&o0¿E?äãv?e¿ß·²Ìe¾âflìñ¸›>ô ¦I-wÝ>ù’t•öñw¿J“öæÞV¿I&çñп5Ïß"?Ë¿5.³•d½ó¿þ³ÄÄ·D¿·Ì•k¤(¿ïÿÿÿTV¸?ïÿÿþF‹Ì?ïÿÿÿÛÚƒ?ïäõz™©?ÄAnÖ-èÖ¿»‚ª÷¿ôæl ¿ŽÓý8Cy£¿§§pµ«¿‰ƒM=5f¿vRãÍ 9N¿eBÀéWV¿YƒMõüóQ¿NÓýSÂZæ¿?ä L à? ƒLÕ§|Ä¿2V_ä0…¾ùƒLÌ*x>ñ38b“û>á37㪧>åBÀ±.Ì¿42œÆ\I}¿3"y…Ùý¬¿'ca 汿 ÃÙ–ODè?38˜+¿¿ïÿÿÿ ûù?ïÿÿÿ4Ý€?ïý@€“Nw¿™B'ýDÖ¿¥ó¶>¿uðt†=Å6¿æIJ½îü°¿’“^¤†í¿sl¸7„q¿^qÅÁÊDÙ¿B›d€a|¿@öÞñ*¬¿<¼®‹d.¿0×Ƽƒ÷¾?7cÃÈË\? µe·>êòõ¯X.¾>øoÇn,3¿%àRXË¥›¿$-²*c“?”x1Qˆq¿ïÿÿÿéµ?ïÿÿÿ¼„y?ïÿÿûÊ?·\'ÜÇ꿳—\æïèx¿„|édÊë ¿ j˜°O#g¿ôO^|Ha)¿€ƒ’&I,e¿f"N ¿®â¿T©Umד¿F˜ÐÁ ¿'èHUÜ¿ {ÒóXŸ ?!^Yþå—?=ïÄWÔ?&†Ñnrã?Ñ·3!‡Û? q¨ÒŽx?yƒ".3z?ÉeZêÁ?·§Z‹7?À,ã+é|?"%Py§¿e?Ô5§h¿ïÿÿÿË’?ïÿÿÿê%¯?ð¯Àý?„(ðê÷&ß¿¨/]K„Ò6¿y¬œÄ_uX¿”XKçƒQ¿t™Î)1¿áqÕ{d ¿[Â.úX ò¿IúyïæeÅ¿<%´}(j¿)¨š—¿ÉšÏƒö KQ.ø>ý‡üë-H?O—¿²=m_¬×¿@îÉÆL ¿2|âοH0ê÷z6¾øX–®úZ? +V뮤?}†¡Û*?IfÑzµ—?´Ã¦þý>õ÷½öæ>í$jñöÇs>ó}êŒ,9?æÔwö?Ç”NXÅ? P ÈG±?—ÃñÔ^¿ïÿÿÿfäœ?ïÿÿÿô ö?ïÿÿŸ1ŽÃ¿¡aµ}а¶¿—¢5_Ò-¿i››‚É¿ƒág<Ÿœâ¿d¬MÖÇ¿KTŸ nÑ¿9 :MÍÙP¿¯aOõsT¡¿+$×. HÅ¿ º{-!²¾ñ‹åû“w?;b/]Ë=>ýƒÙÝú V?µ‚_.~ª>ù¥þ˜ÜÏ•>ðd1E„}>師 Ñ:Ç>ít‡<Ý?ZOÁ––?›Nÿ†´?k­(+<>þÈ Âx¿ðoœ?ïÿÿÿà©÷?ïÿÿÒÿÙ¿®ÈÒŽÂÆ¿Ó,ûȃ¿`mì›RïÞ¿yP2€¤ø.¿Yñm6N¿AŒ=ÞHÜ»¿0!ÇmŸÀ¿!ýüý9±Y¿œÀ)2z¿Bµ|û¾êŸ¾ëÝö>ûiM¶>ò×ñHl¢Ä>õë%8“â>ðÛ{#OvA>åÙ ³bS=>ÝüÈU×A>âû ‹Î>÷k;s3>ö{ÿØB‰>üa”»ÎE >ôË`¶¿ðˆ?ïÿÿÿÉoÎ?ïÿþn½Ó¿³$O·þŠÚ¿yÆnŸéX±¿LÃÁÄbD-¿eòÍ×ã•Ù¿Fš%Gõ}¿.©KÝfÖª¿GÁYªÅ¿¬÷kãD‹¾ðÿÓ”B­¿žJl×õËú¾Øl©]ÔÊ>çß'Róe¢>àX±>Áò>ã2Í­é>Ýc¼œ†>Ó>F,5>É°ÌÓ¿ò>Є˜'9”>ä ë›@hØ>ã´C˜+ È>è©hlë´e>â ½˜š$“¿ïÿÿÿþÃW?ïÿÿÿùC÷?ïÿþ? o¿¸ ˜Ò‰ã}¿`Æ1ÕÚM¿5\õ[ØL»¿L»9¡Â÷å¿/“ýôÞü¿(Š Lz¿›j¼že¾øüM¾ÎÈã¾ÛÙ©íCÔS¾ÌhúH0¿†žÏéS>Ъ)„…>Åœ\2Œ¢>ÌÍ9•Á”>Æ]9Óî•V>¾ÏÊØ«îA>µ½Ó]Ð7>¶Ûe&ünÑ>ņèEj8Æ>Íƶô8_º>дÀƒÊ% >ÌÈ{q»:¢¿ð]X?ðÄ?ïÿú] ¼±¿ÃB4÷ÑC?“T ´×$?d>¦1f3?€ J ­^?`=ë.‚n?Eâj ŽÙ?4z”?Áíè?&0aŠÈ+?þ2¨¯t>ì Ù€¿õ B‰È¿w&/•œ³¾÷†8–Hù¾úº'#7p|¾ôƒùÎÿ;¾ê;ª§²Jg¾á`?çác¾çw½Hû¾þUǃÕ!ë¾ûJÜADTÒ¿¬äªð½s¾ø—þtŽ5¿ðß8?ïÿÿÿç¬^?ïÿþÅÒO翾àòî|‹?}0¬¿ÝÁz?NžÅª¬ÙÊ?hyíßÛx?H¤2­R!?0ƒ; û†?¿Vw\?|ÚÀ('>ñT}>üE>ÔÚß¾éùöñ~ >¾âx5íu›¿ ¾È?Ó&G¾äS€ÓŒyü¾ß-L0j*ú¾ÓÒ8!ú’û¾Ê5™³n¯x¾Ò`NÈg¾ç¦Q}CU¾äÊ8 F/¾ë!Zw7%¾â+¸Tõø¿ðä?ðÝø?ïÿþd¸´¿Æ %xSÌë?š;¥çûf?lr!f„æ`?†.”X<7?fnà Ü[?N‹ö†eëw?õ›3Ž¢#¿Ã[¦Jò¿eäõ6²þ¿âŸ‡D¿„Ï«:sâ¾ýb¹Ë“£¾ò³Æ íG¾èÜ óbñȾðs낆¿µÿ•\SÁ¿U<ÙŒ.J¿­=¬y¿‰ùa˜s„¿ïÿÿÿî"?ïÿÿÿïà?ïÿþ]0%´¿Ïñ’å^r?¡â Dƒ?sp§écÞ?ŽCcã^•€?nä!²ä“?TâWfˆÇ?C]ÊÛ‡Aç?5a nM§¡?93UXd>ýË씜Æv¿4 ê-¿V–7lˆ¿ ÉëÒ"Ì¿ÒiÃ-Ë¿waObzdÿ¾ù‘Ñ 6…žðÿé,gHœ¾ökÌá@¡Ü¿ %*Ü–&™¿ d¥ð¹"j¿Ñ­oš ¿øØZrοïÿÿÿßÀ?ðm?ïÿþZ£Ü¬¿Ì8ÜŒ,?¤ ×.qmÿ?vES‹`Ö?‘C5=«~?q”%œ¨ñ?WÜ‚8a ?FHçQk?8²"¶Ÿ ç?7: ó ?@»Bq$_¿lßféÁ2¿ B³£±¿ Z/מó¿¾ xò ¾ý‰©Êëì¿j=-š~J¾ó°“n]¾ùwß4ÃÉ ¿A&ìv!ï¿E–K.I®¿0)ØM¿ ¬ýr}žÁ¿ðì|?ïÿÿÿ™è?ïÿþY˜ôŸ¿ÏÇܺÉ?§M Α½?yöfS·?“ÖÖ•ÙY-?tq†£]c?[ÌA9ÃØ?I­¬»…?<éæü§_„?KHë?Ï¢üB%Q_ì>ÝÔw¹qÂ>Â×îù ¾Ö4Ó&¾Îµœø±Kƒ¾Ñ^Ö7¬°¾Ê¨°D@¿¾Áúª¼ÄV¾¶Ž¨Ô’Τ¾¾£ëBù9h¿£›1¶Î*¾ÓÐF”£?¾ÑÇ#8bàÔ¾×€­›–¾Ïù²a ò¿ðn\?ïÿÿÿ‡àÜ?ïÿþҖ⣿»ˆl‹3Ê?} ú ¶‘?Q“P¯1òÌ?m27Ì®é?LÄ—šà¾?3åC‘¿I?!öíu—?”íÛ ‰>óDŲE)Á>Ò%ºO1ÿŽ¾îS¾šÝ¾åp;Ãa+G¾çBí€ÀCg¾áÊÝ•ø®¾Ö7YuÚL#¾Í(¹”h3/¾Õ…²“e“¾íP.‰!¸¿¢nÍUû€ö¾ç½)ä8Ùm¾ïèù–¼&¾äã×ù#?¿ðß8?ïÿÿÿªìà?ïÿþ3P¿¾!©#Ø?‰3¿àÚÌu?[eÚcõô?uR æíP?UÀƒ\+ô?=`Aþ|’•?+'Ó@7?ú)êÏ>ÿÆÆ•8i¯>å .£p¾öèÓ#þ¾ï›Ãbdø–¾ò8yë™Ô¾ì£M_{)¾âˆ¦ÈÓ¾ØYÔË/>¾ßº”’ —¾óé˜zϾòª<#£ ¿–@Ic/Ô¾÷Ç&rã•Ÿ¾ðñ¤¬Ÿ³¿ïÿÿÿç¡?ð?ïÿþŽTw¿À™ü=(þÀ?‘L¸‡±3?b?ל³­W?} ¡¢}”~?]Pù‹p?C­UÒˆ9?2Réù>?#½‹W÷B”?¹D+ >è™ÒX³ª¾þÛ/Ž¦ð¥¾õ{„UO¾ø6‡ú`/¾ò“5Ú¾ç­ORµÂ´¾ßV$ó‰ »¾åerT³à³¾ûá^my¨¾øÃn”¡æ)¿÷'úQâ¿•9"C`¾ö:èZ-¿ð(‹d?ïÿþfl<¿Â$e ¯A?”¸^Ýø?f0Ü'ñg ? âsœš?a‚à‰˜|õ?G½gãÉ~ø?5ã«Ð3¨D?(|¾yÜO]? ºÁRO >ò*éÛ¼­Õ¿jÏ´ˆ( ¾ùEi`Gúɾý…Fàjà¾öµ¿ z<¾ízà#~pñ¾ã¦]ûç¬Ò¾éyýè¨z¾ÿKöÎÚ™¾þA,¡oÏ¿UÙaæ:¾û¢¿~N^¿ˆÅ7™ =%?ïÿÿÿÖ~R¿ð [ì…>}kŒùÅ¢à>®«% =?GÃܬw< ?„ƒ³&óè‚?‰<Æz±»J?y(Í"Å?sªÃR1=?c3©²…aû?`<üCÑ?9Á• MCL?FqEþ1¯?$™EèA?ü›ÁV^?q÷‹¿ä,>ó)Ù«‰m?K“¢Sä ?ITo×9Ü?:•˜šYo?9Y“w3_?)µcü¥…¿ð ®¬?ð?ð¿K"Ë•‰'?ð¿¢ÈãmÍ*?ð ‹BÛ?ð—:*¿ïÿÿÿšû}?ïü<ØÐí¸?ÏŽà^²?C?ïÿÿþ¥§b?Ö©jÏnð?ÝXd•4Ì?±‚.òßÜ/?ÄëV"jÈÕ?¤ŠQ×ä6ä?€ú\f¾ŸR¿U8ô\U¶Œ¿b~nž&¨¿sSÚ$æµj¿sŽ ÿ»Ú¿m¿Ò“4¿rüŠ"šx¿faGì.Š¿^²]g83{¿Tá èÝ™ ¿LŒ+1–¿tâþμE¿ròÔí iç¿p|=–.8¿ote‚MÞ¿h¿4óê?ž¿ïÿÿÿçN?ïÿJ?”tY?ÍNnZ$?ïÿÿýƒ¨[?ÌŽkú»ü¨?¥ù2³8?ëañ4‚D£?º?ܺ ”D?™ºÆ¹…÷?uáÊÛq¿JtϬ¹"j¿WG|û4è=¿fá'ì>|¿fb’$õ”½¿b©yt¸´¿f¸\ …»¿ZÞý@ãñ¿Rº¯Ö~™x¿I¦WšÂ[¿A@ÇÊáG¿g×jeó¿f rs~t.¿d±“˜}÷¿c«‰lr¥¿^í|Vñ0Z¿ïÿÿÿ]Òq?ð°ÀVç?л[‹?ïÿÿÿàc˜?ÒH¿c¸Ø.ÍG¿ïÿÿÿøÚj?ðS¤Q?Ón(ßh“?ïÿÿÿþæ†?Åw_ŠL.? õçEP?³Ë Xç{þ?“o¯En¼?íl뿃Æ?pAvh[¿C•@ÞÔf¿Q,èãÚë[¿`Ó¡¤÷ÎL¿`OüÔëû¿Zå@¤H¦Ô¿`ØL%öÝ®¿T_È9½°¿Kôõ4õ¿C »`Ñ:Ç¿9É7÷dȆ¿až˜Kªl¿`3'ò¢ß¿_ 0&ç1¿\X,<1¿0!Sùr^¿%‰®Ôª¯¦¿N½ÈÈ«A¿M¥)Åq7¿I;.n‰üŽ¿H0ï°Hâ¿B÷í•t¿ïÿÿÿšû}?ð\i8?Þ¿!Y¿)?ïÿÿÿ¡q'¿²åþèë¿iÝ(c:Ý¿~ÚÉâ1Dο^D½Kt‰M¿94­#óm? ᨠ|“?Ü,÷Ö ?( W‰=¯?,.‹ˆWC?,ƒ´ÓÈ.6?%Ϧ‰¸x¢?+Ò9m;°U? %¶5ÖÀ?~Z^ØÞ6?Åh•Ûf?‘ŽÜ¾àÉ?-T˜´—3?+»À"øü?(@ó[*5?'ã`Ÿ¾?"o_}g%¿ïÿÿÿ*Õ ?ðM6Üa?Ý‚÷0œ¬©?ïÿÿÿ;/û¿¡bí:ýl¿zð˼ç—¿öb#Ó¿oƒ¤0Ìò¿J8{ùë<Œ?þ°?]žw?+#Šà¤ÝÛ?Íýz¶ Ù?=¬ÁOzÃ?>5x ãK|?6ÚXdSÖ”?=;BþÃr?0çèm‹ÊK?'‰àgä¸? hÑÁsî?~›diþP?>ÙÎx²R?=K0!7|]?9ƒÚ¾?85ÃýÔ”8?2áÄŽúÔì¿ïÿÿÿ»Ž/?ð| µ?áPK¶œƒ?ïÿÿÿÆ#a¿¾žÜ—îy¿—ÁŹDáÁ¿¬P'˜PB‡¿‹Â…·f(m¿g„P‰»?;ÕJù p?G»Ü>ì0?ZµõÅ×TD?تß_¾?[ƒ;Ë[4`?Taì3r.†?Z5ˆ†S)?NUè‹æó?DñÛ Œ…=?<¥äˆ6ù?3Mêît?[¹$ °5?Z‡á4ÈV?VR†xïW?UŸ%?b.?P¨¢ø/Ÿ¿ïÿÿükÔú?ðÙs–&?á'|»üë°?ïÿÿüsðÛ¿Á•Ž`ûª"¿›H™/œ\O¿°B8˜íÕÈ¿áØ»m5¿j}³³ð/??)±,ƒ­?KD4Ë–z?^¦º7 ?˜?_Ž¨ûNú®?ÛZ×bßN8?We؇D¯?^‡u ì¯?QI';Pˆ'?H ¡ÔñZé?@qÐú¸½;?5ç_ÒT4?mæ3ö= ^?Ѷjùòa?sSþ¦P?f\y 9?^¦vô¿?Tõ¬,s×–?K×ZAX?t}Æpõ?sž:a_?oô[ô§X ?o‡Séð?h*I=p·¿ïÿÿ÷$e ?ð*?Â)?ã•#k´•ß?ïÿÿ÷'±x¿ÏTçŠÆ¨Z¿¨G¬.Bè.¿¼ô‡…Îõô¿œeÚÛ2Ђ¿wŸâdW?Kê’œ±;?XovŠ3µÒ?jÌÓ–ÜÕ?kQÀ¸y?džæVù¶&?jcë™öc?ï7ç%ñ¡?^:³5]z?U;÷Gg{©?M ÜF"øF?Cb–ì/é6?kÛ㊦܌?jyÍpøê?f›–=”?eÙ*ìE;?aŸ‡Zì>¿ïÿÿñäÈ?ð‚’L?èžÄ{ŠYõ?ïÿÿñËN¿ÜŽòyµ¦¿¶ è\ ‰©¿Êdúj ¿©âEe¿…‰,qЦ?YuOó4ú‹?fI.|ïs?xap‰@B¨?xÓµtN¬„?rÆM3lé[?x2å$Q?kÆþQQc?î®1[ч÷?cVYfê¡+?Zs§ ÷¬?Q¨Pçi¯,?yYe8ÛP?xŽ=ŒÈ?t›Ÿ,fzØ?sãÕôüâÃ?oÑ·ÒmÚ¿ïÿÿ¾o®?ïÿÿÝø?æÁ!°¹¤²?ïÿÿ¾og¾¿áj6]Æ̹¿ºû½¦Ò 8¿Ð‹D^‚+¿¯‘!N“ÙÜ¿ŠDãÞà€o?_þÒóS?k4*ZIe?}¦ /ýús?~%àÄ×™?vÜw#û?}8³Ôý¶?péçù †»?gQ•™Zª?îgR’µ½Œ?`Øì–ós?UƒpCr ?~ÕDV?}@'ÎS ?y"‰¥>?x6 !§âT?ré-Ü ™´¿ïÿÿt™&®?ïÿþ”Do?í‚{=£·*?ïÿÿt™&®¿ääOÇR2¿À.Õ[‚‚à¿ÓM±S(¿²ï'3cX;¿„³]Ïv4?b§R 0æ?pTÀ˜®ß?¼­óÀÉ?‚òK}›?{aÈÐl`”?}hᥕ?tCaÚy.?l8*³û—?cM'RÕˆÔ?î-|g°dÄ?YÈ÷B[û¢?‚rõ*æz8?|P¸è ?~'é´i{?|ÿµ€äÓa?v®…“4ï¿ïÿþÀ -Œ?ïÿüäyØP?ïÿùãù­þ?ïÿþÀ¡§¿è&ËÄ'¿Â´ ÛKY¿ÖO¶ì¯š¿µâŸ,]è ¿’7»žE?e“›Àf9?rãËÊ^÷Ü?„tô*£•8?„¾r Žû?œKíÄg®?„.ë “?weJ/*ç?pJåJ/š?fIžU¿qð?]È/j¾çÀ?íþflàvª?…H$èãd?„'}Óh6"?mô£Öz—?€¼}„7?z6ƒ /lÛ¿ïÿÿ÷.³ß?ð.@]¨?äAj7D´?ïÿÿ÷,êz¿Ì:%Î1¿¥ßÛjü‹¿ºLx1jØ¿™•×çǦҿuI0ÍrD©?I'ïòþƒ?VfÅzª?h J—‡?h•(O.!v?b‘Þ]x/?gÂÄêæ¤?[xç³¥?S¾ÿ£Šâ?J(ëîÙÿ¦?AuÛ1ó7o?i¼œ[m(?ï=µìAǘ?gÔ#žj…ãUo?h´£ln€Ó?b¨¼ÔÑ`?gàQçÆin?[š£ZKj?S7/—¼#m?JH÷~á×é?A‹#¤d8ô?i4 $ç;†?gòW0fk?ï0mR×{ò?dw³``?cÄêÏ7a´?^ÎÒ£çÓ¿ïÿÿú’ZÐ?ð(á$?ç §í»¡?ïÿÿú”j”¿ÔzѸ¶"¿¯¾$¶Öâ¿ÂíGs›t.¿¢ù¯éì¿~â2“k‰?R>ÈÉ:Á?_ïºPð|þ?qˆ†+y\?qàÚJ$ï?jø(‡œ‹?qBÇÀ¦?U?còƒ*~P…?[ÅžW´?Rþ2góO”?IYZlö/þ?r9 òúÕ?qR¨ä®P?mù§#ÁÕ?ï õÝ?l“…Ó˜mQ?f?É"£Ò¿ïÿÿêoæá?ð*™Çí?æ~{Ù?ïÿÿêpÝ,¿ÔcÝnW¿¯š(èØ¿Â×öZª¢ ¿¢{Œ_è¿~¿¡¼¡¤b?R*Q¥?_Ízl±êü?qqµæe5?qÈsíBð?j×i¥óëÈ?q-)¯+-C?cÚ|f¸é¬?[£½µ Äí?RçtÆgò?I;s£»éQ?r!ï¡D—!?q;¶_t¯?mlà2]¦?lpKQì@?ïT 1-Ð?f&{Öu)ñ?ðŸ?é~\âWé¿Û—¨ZB€¿µ>üãZy¿É{h0¿¨’±Æ/&L¿„q°œXO?X)´9ž;j?e&¹rÔd?w*]$¥Ð?w™µd@w?qÕJ+aË?vÐÜÒv6’?jaÄu¯%æ?b]}ÊZÆ»?Y7Y :?PÄ£ûÔÇ?x:øi?vàÐDA}{?sJ°p5v?räœÛàP?ms#Ë i?îÙ>áû i¿ïÿÿý¹BC¿ïÿïsµ6€?ïÿÿý¾«¤á·Ê¾`ö èÐÄ¿Sú¿¥ RÉÕÊ¿¶ú9׿«¶²8‰¿§ã‘ê—<»¿ÑÿŠŒÑ¿š.ÎüÝk+¿´•æÕ¿ˆ¦¤¤¾ïå¿pœ ÕHˆî¿cÙ¼8Ô¿U·°~ž¿IÞrÝþ¿Œ§ù9m]¿Š½ÓÒ´7¿€ø.D]”¿€S…̧ÊÊ¿s˜©HKü¿ð? ã·¿ð¿ª÷wT=J?œZX±â»1?O‰Š˜k¼;?•Çö{?’Ω.Ô^m?Œÿ©Á*Ü>?‹:ú'C'?ƒñ”:;?‚ª±h‹¶?oÈVe»³?x9]ý@›Ÿ?dVgÁ½Ëç?Z ÃtÖ ?PDXè²X~?D‚ »ËdQ?zã0²Åô?z­]îG‘?qσÀÁvw?qfØЩ a?fø­Âz•¿ð¿‡A‹‰ æú¿ð¿· çò~´¿˜U}¨ƒp5¿¨O³„꣈¿‘Š¼ßŒ:¿xXs†C¿pã°°Ì´©¿kªÉ¼Ó-¿\ðö+í¿XúÿÐCs¿.¢¦¦[Pç¿C©ÇógXž¿r`¯ƒñ¾Û†’MWÞ`>òªgQO^>ö÷¢"¢“ƒ¿H´ŽÏ¡R2¿GCä¨Ø¥¶¿3î +º›`¿3Y±u%Þ¿Ûd`4¿¹/[Áps¿ïÿÿüÅ”_?ð4Œê?ïÿÿÿæÙC?ïÈÐù…íx?Îd#71ÿ½™„ —‘µ¿ò]±…¿™ƒø¥þí¿¦3#Ëu¤¿‡Ÿ)¶¿`q» º8T¿Pq»[e?@q»ekeÅ?@q»6cÞM?3»­T¬õ?O‘žG¿?2´OÔË´?$Ž)ïÒžœ?ôŠç×´?7Ÿ™Ù¿;?3»­k”:?C»­:3Ò?'Ÿt¶¥ï?7Ÿr²´]¿ïÿÿÿß&ï?ïÿÿÿPÃí?ïÿð{8¦8¿ž!Ä/´¿¤Æã†á‘í¿xíÃA£Ä$¿æEÚ)û¿ˆçžrÈî¿pßl%ž¿i,À¡G#¿dèOl ôÔ¿[9R¡÷b¿VÇ?ãt}¿8‡k#aµ×¿H6‚zÿSw¿,¶î®4ÎÏ¿ qø-Na¿¸e V¿L¾Q†b¿Xʇ“øyR?@Ÿщ‚‚¿@Gà†pÝ‘?4˺r‘4¿ïÿÿÿd½?ïÿÿÿYÖ?îìóè:×?¹nîÁ(ö"¿´7Éç4mØ¿†BÕRêÜ¿¡59(ìæ¿ò;CitØV¿Õ†KùªU¿h€¦abÆC¿WÂ,Úõ¿Ia1³y¿,XW'ÿ¿K„|ñ?# 2{Žä?ªÏŒ]G?Âlbx>?8)ÁW|?4ÉÓ¿d?÷Ef»ê$? ú{ ? @í± ;ÿ?ü­ã`?#×ÈÚ›·\?åÊœŽêÏ¿ð?ïÿÿÿûš?îìÆ!hëA?“o"Ÿ9¿©Tö{èÖÛ¿|F­k÷²¿•¦FCm~¿v¤iañ•¿ádÑÏk¿_5©*L„Ï¿MÞŸum­¿@‚'«–¿!­Y¦¿ š¡ù€gK?óÉý?ÁöÕÊGk?}6Lž³?‘õß÷M?èHÏ- Â>úÇó?°“f>úAîžv®à? à½ÐHc?ã~= Èw?åØjêü?°muËÉ/¿ïÿÿÿøM­?ïÿÿÿj Ú?îìî£WÛ¿’ÖMÑþÖ<¿ lèõ±¿rƒ-²ÁF‡¿Œd©zWZ¿me­Pŵ¿TJ'¨ó—¿´ÆW)"¿CþÙ¡¥“¿5PH—º_¿û~b~Ü¿MÎœõÅ?‡Ib$=Â?(©[4Ý? ¥‡¿m@?8)µ§6>úK/¯zÙ>ñ¼?´|®>ñL§JuVÏ? åtÞ‚á? 4‚¥gÕ?H‘cëÅ?€SqSvé¿ð?ïÿÿÿßÖÛ?îí1E¨Î™¿–Á˜»ºë¿˜¿ ÙÔŽÔ¿k¯Û1Åè!¿…!ß a–¿f.§kË¿N@-/¨¾¿<‘»ZjË¿±=qäÊ¿/ò£ú¹Hô¿C Íåk¾ûµý”?¼FÖqo‹>þ†×·½~?9ÕcØ>þÉB*|=>ó¡Ø„>/Ø>êz^70ª>ê6¿EÍã?¶œ\¾±?âI}i—}?Œv‰¸ƒ2?¢ _úó¿ïÿÿÿòA?ïÿÿÿçÏ?îí`.P6Ú¿¨ð•1d†d¿üêM£f׿bxJ¼_W¿{ˆÌDÂZ¿]CŬŠ¬¿D6ì,ƒ¿2Õˆ›f÷¿%™ŠcŒ1g¿žîžè¢â¿ù>…Ûc¾ô }ú_}>ÿOpÎôý>óéq ùT>ù¼yÛ&¥Ú>ô2°ëê Y>ê¨È%i”Ç>â º™f>á:ªbSñh>øÎéÕƒµ>ùZ¦¡Ýj ?ø?Ê>÷õJP÷¿ð?ð¯ì?îíL’2¿¯œ+ÊýêS¿}o ¤Wó¿Q'=úÎ%¿ihI瀗C¿Jã xšLï¿2¥iã!ª¿!kMK}ÈR¿ºn´'¾÷m*¹J¿ŸÈâÃy,¾âñkIeP>ìéøªL9Ð>âK"©óQ>>çà}iú’Š>âÁ5á;å>Øׄrïæ>ÐÚ§h">ϯ!2Pä´>æ–…¡3Ý>çtº¤È>í¬ø¾Ø¬>æA׬ؿð¿°?ïÿÿÿÃc±?îíN‘¡¿´»åòìáÝ¿g;>ÿçm¿>IJ‰”åã¿T¬v.ßTS¿6Ò<åÆê¿ 0‰¶óZx¿ ‡.˜1ò¿gñ¸Qé¾åƒaÛ}”z¾Õ±ZcLoZ¿žô‚»m‚”>Ø}Ö'×r>͵-»x×>Õ@®³æ²ô>ÐËxÇ Ïu>Ç!_•±>¿ÖHI8„t>ºe/P‹D}>Ïźž›ñ>Ôø縅‡°>ØœÝ,G9>Ôª·,¸%¿ðÄ?ïÿÿÿñû2?îíÑgC4£¿Á*B2?“ÅÄÆÃ?eAÑ xË%?€K©7/z?`û’:7o?G‡©er?5âpf”Aª?( ¹RÝŽ? *îgHˆ€>óÀ6¬ÿJ¹¿ tãù0¿xT½7:•¾÷ _;|$¾ý>j`/n7¾öð~AÃÝK¾íÝ)V´w¾äfÈSøð¾ã£,ÞÓÜ̾þúUK Š¾ü;”¾Õú¿¯ÚÅ‚Á1¾út±žY䮿ð|à?ïÿÿÿØjç?îí,ÍCó¿»,²±$ñ?{C†v›Æ?MÄOÝFD?gL‰!P?G×?Á.ÌŠ?0^“¯ ¬ª?ާÚ?ü >1¢>ó p_«â´>Û8e Iœ¾é–Ä¿uú½¾à‚0áµÃž¿£¾j¹F¾ä•2SŒ\¾àåŽh‰k¾ÔßJ;I(¾Ì >aP-¾Ì0ý9’ò¾å¾â%Þüv¾äŒ‚¼~R¾êŒ‹Ð:f¾â¬O×ýùοð žè?ðîü?îí7kNNí¿ÃÇ9k´>™?šosaKô?n„qUq?†²i°©ö}?gÒ¼—‰X?P~Â-?>ÉîüùÀ!?1V«&„¼?ZEVÌe:>þnþ‰¡•¿ yþ_r¥¿4 j©Ó¿Ó=*¿ˆp„ô¯¿XL”ÒÇ ¾õtsGZj¾ìø™ l?¾ëÕ†‡žó¿Ÿ…8®¿IáM‡¿ DÜvÑ Ì¿é@øö¿ðÌô?ð~ ?îí8Fr÷¿ÍÀZ§¹‹«?¢1yq,Š?tÁ=e¤‘?BæGObÄ?plïò?VÊGs0¢.?E4òv)‡l?7äE,°¢q?„%p®Ze?Ðÿ·Ž¿ˆ}Žût¿C7— ¿ ²¯£F‚ÿ‡×XWï¿{tï"Âf°¾ý™{ôvÕå¾óûþ±„넾óÚSžüÉ¿ Já(¹6¯¿ ç ÁÜýu¿yHÀ ¿ U;Ü’«ç¿ðCXX?ïÿÿÿÁ½{?îí8›Ô§¿É…xÈ;“í?¤ –0©VÀ?wíˆC`L?‘Í 6ƒ?rÒ+?„#i?Z9 â.È?HJ}ÕÞ?;°÷K¾C ?¼+õS"? Y2œûê¿Ú!¡Ü¿ R\ô{׿ŽY¼´µ]¿ CÆXò¿49û8Ô¿o>c*I•Å¾÷H¹$nG4¾õе‰º`s¿–üóXðŸ¿ÿ§~¿ lmù"4¿’pEXnI¿ð$kÜ?ïÿÿÿ¡q'?îí8ÆÇ"­¿ÌjíŠÜ?¨3êÏ=X?|>±Ê?”Àÿe“n6?uÿ®×/Å?^¶]ª†—?L`*¼êUÂ?@<¦ä( ¦?!÷h4?û´?(ÓS?пo~+ŒÆ¿ y)¥–m¿c†#((¿}¢Ùö1v¿4íC¬m«¾û^÷b„l¿b ÌÎã×¾ùj[÷H~¿Aø‚…›¿ÓÚGŒ7¦¿ }‰µ=¿îJñÚ,¿ð0Êt?ïÿÿÿß}?îí(?¡&¥¿´›)ÄÖ' ?c¬Óð²{??5Þ¦¥R(ö?PÈ<ÊÞ?1s ’èÐ5?Â#‘²?™ùɈ] >ùB DV>Ü9ìNÎó,>Ä´C‚2ø¾Ò½“›õd–hQ >ÚyµaÇ}g¾î"v–ß¾ãÀÊ@Àñ¾ç»Qj5 ö¾âˆ'¤1ÿԾ׌T´îò¾Ïhw1?Ìà¾Ð³5Ws£¾ë7úY™Å濤øáø qJ¾çd¯ƒŒ¾ï†Ó+¾å·âš¿ðn\?ð „?îí3IÛÏ ¿¹ÛQ€8ê?ˆŸsÊ“É?\èGÔ‹Ÿ?u%î8³½?V7+è(¥…?>Á•±ü#?,¾%ÝÆNØ? @¹bL?OÆÏ¥˜>ìá!íoc¾÷Ïä¬ÑÖ¾îLÏ/Ì ¥¾ó|Fó¬E¾î•[©/^¾ä&=ì^¹¾Û(’d‡$X¾ÚAçéfÕ¾ó1¢Ã®dƒ¾ó pˆÉ=È¿™AÐmr8þø‰Ä¥ƒ¬¾ñò”shd¿ð D?ïÿÿÿ«œÌ?îí3º¦Å鿽NL°ŽÜ?‘Ó‡ºÈ?bë\¿–œ‚?}Æ÷Þ?^=Y `Šª?DÐs0@•Ò?3¤·®©Ý?%œ¼â/60? ˜p´=Â>ñ¤znI<¿3[ÿ’éH¾ôÔ„ôÔÕ¾ú&âÊÞÚÚ¾ô}UUF f¾ê›÷CsQ¾áåv¾=?¾áÌR °"¾ûD“½¡f¾ù}_?áý¿É¤öúP$¿˜F˜†˜ô̾÷ÃþvÇÍ¿ð`?îí7öì‹Œ¿¿ŽHÏ!Ä?”%AëÎ=è?g\Þ÷SQ?`W#7?b]1t‘?I‡(kŠòº?7½hA ‡?+"Ò£$·?ƒC* Åó>ù­Úÿ”d¿§"v]©7¾ø×ÃúæÖ§¿3q•v*ž¾ùt¹©’«Y¾ðÓƨ¾æÊ&j°o¾åp Bj@s¾þðÆÒäŒÿ¾ÿ Øªþ0¿1h–Ó¯­¾þ•_n¿Œ•óùZZ·?ïÿÿÿÝ£è¿îé?½8>c稫§>}¢æxËù?6D´Ò†iŒ?ˆ#k—áC?Š7B<{/?zÅRoYéx?u•±ûtQo?e¨¬0¦)?b‚›Ï²w?=|Ö¦Ú{?K®Õú&?* ¼‰Â¡N?‘h6ÑzN? %r'6#š>ùÁ6ª?PðZ `F¦?NÞŒ_*K?@Š è3N??ŽA—a¡¯?0- É¿ïÿÿÿèy?ð?ð¿P:‘]"?ð¿£’Íþƒ?ðñœÿ¿ðUÜ?ïÿÿÑ»É/?ïÎôxï­?‡Vþ=À\?lú` QeD?c5~Jêà+?`†&[àï?l¦»–¼?7Ñ@ev”¿F÷T¡Â“¿D¹FÌöj¿AHZ#o–¿7'™QV ¸¿3Â+Ô¼y¿ÑR ) e¿$0&ÕÂX¿8 ¾²¹Â¾ñÈ-÷‘m¸¾àc0"$€‚¾ÎxXÉ„^¿)â³Ëå¿&èxyŸ™…¿5à­e‘p¿Ê¢ÈH[ ¿uNÈt;?ïÿÿÿˆ ?ïÎó§Þ?sM?ù€pã?TºÆ‰?Fm/:íu?ûþò?Spcf‹v»? o-§ÊzÇ¿.î¥_µç¿-Cò.œ¦¿(2ÊÕah¿ 5­ì˜8î¿¥Š™€e¾û½™ÍÂõ¿ È’œ%¾êê{C½«—¾ØèVÞ!ò÷¾Æ÷ÖŸ°õ¾µÙã5|¿„ÿS±¿µ·Ž3¿§17wÞš¿¦wr¨g§¾ñ!úÂ-‰?ïÿÿµE/T?ïÎókñ¥?ƒ!JèÐ"?d¼›ïÛ !?WÖÄ6hŸ‹?d%þ÷vœ?tËqÀf?0»±Ú`TI¿AtÎ亿?ÎÊŽÝa’¿:5’‘&¿1¢._½Ë¿-ÝšT­<¤¿z†² ¿%ƒEö¬6¾ý,˜ç. ,¾ë·—( »¾ØøJªœaI¾Ææ®%.g¿"úš.ã:-¿!N¡ +>¿!£†he¿º+XrÜ¿˜}2}i-?ð?ïÎó’t?uê™Rm‘n?3¶qZª›Á?& L1?3÷•(^¨?*¦€ŒØ?•ìå°Í,¿Hœ»Ñ«¿ |²ù¶—Ë¿¶ÐˆϾÿÅ;eÞ$f¾ûñ3iÂð¾Û/׋ÉêV¾ì4ÌUZŽ´¾Ê`©n¾¸hEÇŒ¾¦€Ÿ~nCO¾”›6\|î¾ñ+ M»è¾ïj‹&!Éñ¾áLxCù¾P¾àQv™bIÿ¾ÐÉôÕ ?ð?ïÎóN£?lTÅÏ "¿Y%ÞžŽë¶¿K %íC¿XI™fã×–¿$ÿñi§Al?1ÂæÉA”?”Ÿ»¡'?0ØÔÏ`+ ?,pßÂ>~?# kùn) ? N=Ð1ì ?S‚+G6?>ï—1 ,è>Ý4°C|n>ÊÖOè4`ú>¸‡;Ü¢Wb?”]ì©,ù?é‡!¢œË?¹BNqÛ?›lá¹>ô?A¶Æ?ïÿÿÿñØ?ïÎó )n®?lNωüC¿ifæ,ö-È¿\*< Í¿h™t.4æß¿4åae»’?C;·ošCD?B ÄEV¯?¨ÌCü@H?>;Ô—±š?4@«Sn ˆ?1HŸ£Ý·_?U¬Âõzï¯ Ö>>Ü©aëÀiÓ>Ê<íV·ôø?%âáh®ƒ?$ ( öÝñ? Ýä1œ’?Ï• ìÉŒ?cí4•ý?ð?ïÎó ©¶/?d\»^ÑÈq¿lÜÁ²ê]¿_Lf兘ÿk5ä|]-¿7 piE)€?E‚ùÇ–)Ž?D=‡‰–?@Ûe¦ÜJ?¢ÿ4êô 0?6•ch4p ?3C™&¡\Š?S{EÙf?$ éÖ À“?¿U{?¯>ñXçMJ*l>ßüÙ ª{>ÍI‘ýþü ?(h1Î@&Æ?&U£à¶7l?—€P?3I%CÚ…?ÜÜo•†?ïÿÿÿ»k?ïÎó0)s=?XŠ­ÙúP]¿taµ¤F祿f£‚KÔ¿s½¥{3rS¿@À?P\×?Nü „„t§?M,ñ‚)Ó?HT¿½ïý?@Kø#ù€6?ÑE.q¢\?;Ï¥íñ¨Ô?åL Ùê?,ð¡ÑŽôþ? Ä[ã ÷>ùœå>ç°íÇä>ÕÇ™eVN?1œš/öø?0a4Æ#?!¾ù-N¨? ¾œ0ïfn?6ý]0h?ð?ïÎóŸ¡Y­?@®ýZ¥mJ¿uÇ›»U¿h+æRØä$¿us.ਿAç9×¥ ï?P‡oµÀ4?O!ãeRµ??I÷fy)¦$?AdÜ‘=º?=¯s©‡¸Ý?ßP€9°[?ÆEoz|?.ㇺvK? ßäbV,>ú·-ÞÁ>èž±n—ÞE>ÖŠ öh!?2Ìþ²Ý?15ÌÅÞ?"ð>ò^_›?!ß[÷_L?_kY×Ê ?ïÿÿýqx?ïšÛ¢USØ¿g´H þ·d¿‚Þ+ûT*`¿t´3v×ô¤¿„ .èf‚2¿G©_sÝ?`Dq‡ºVŒ?]“·*4{>?Y#õNOeö?Q¼‡Ÿµ?K[ÖAtöó?)á@L¼2?ñ°µé iç?=“·/¾±n?º{»ÓŽe? ‚šËb>÷J¹ÚQuz>åB+¨R‚Ã?B¬ÿò¬è?@£ Tg—?3˜Bó˜Ós?0£ ™»?!¼‡ýß?ðoœ?ïÏ]ªrö¿WJÐX ¿}ñ'“~/ð¿p©à è8¿}¶š[Òx¿Iåzk?VžñGÊNô?U\²ÞSôœ?QÎÔÁ Ré?GÜt]J<¯?D]ünðäA ón>Þïæ~:N¥?9Î 6¯ˆ~?7¡8Å?*¸Îß%ú?(ˆ=5ê?6dãX¶?ð?ïÎó–Ù¿s9:ÀÇ+¿†£„9—¿y!ôŒ^¿…íd<¿RœKl‚Žÿ?a0bügÎ?`/ñÛ  °?[,.Ê£ê?R<€mØ?NÞ ÿ. ?.õäR=×Ò?@DäðSf?i³g€?òºý±Œ? ǶŽ4ë)>ù™õ2p q>çp ö­5Ž?C‹ÒtÙz?Aäú–嵤?3±j~p$?2•–ÃPë?#áÙ”bk?ð?ïÎó–Ù¿ˆ[^‰,ùÛ¿ŠgÔÈïÙW¿}P‡¾ˆ8Ê¿‰“ ¿Uµ ^À:/?d ‘óýÜ{úÁ­>ëV€ðÅ:Ç?FÌj\µJã?Dß7 )Š?6øD@Õ'S?5­6]'Jº?&H¯ °d?ð?ïÎó–Ù¿xQ»dn¹¿Ž—c¢>Ú¦¿€û!r¯ýQ¿ ÜÞèÑY¿Y%ÿ¿ÜA?g:4 ܽ?eß°ü Å?b>.¿ãà]?XpÏiy»2?TÚþyz1}?4ëÔÉ'?E³‰!s ä?$IN´1{?Ũ&?L+’`­c?ð>ï«ôÃ%Ì?Ji£Úï9?H.?ŠrC?:œq ßå?9çr3ý°?)ѦRûÓ?ð?ïÎó–Ù¿…(G]ËD–¿‘B1X¯ç˜¿ƒ)ó_÷Ó¿·‡ý¿\`6ú×Ü?j5IƒêØ?h®OÏáú?d•ƒ¯Ùþ?[“Â.õú–?Wˆ()‚Sö?7šWaXùÔ?H|}k^ü®?&ãÇ¥Y?-§‡³x?„s7ä{>ñÞ<};¥?ð?MÍ_µ¸?KH§®ð?>²ñ_W?þ_?-!/Aêñ?ïÿÿÿ„·ž?ïψÖP ?>7ˆü ³¿|ï¿zÜŠf>ÝÇ)yŸ?8ï»XK`]z>ÝÏ»ÖR?8;BÐr?6.ϨÍy?ñJ­¶ˆ ?(j½wXï?' z!n>Ö?¯o2f…??ïÿÿþñ¨W?ïÚÚ8ðØ‚?D3Y„nÝE¿ƒèKÒox¿x|4„Á¿„jømÉ’ö¿\Î[úø S?UšÄë5cÌ?W |µ¥ÒS?Sq±;‘Pð?J¥H4´q?G |¸v­Ó?&7Ì2Ù‡?8|4‚ó6Ô?ÃØ›ÞÈ?l­ñ®t >óäê¨¾Ö >áHˆ³)?=†·ÊåîZ?;v( !?.?°]º?ñ;ª/ÓÕ?,r-ò¦T?r-ñç}u?ïÿÿÿ¼î?ð¿^Ç1E㿃Ơµfƒ)¿q+bn;·ó¿ƒx½½×»¿A+btOþc?^ ì2Åø?\ù6 ·®?X®]vF¿}?O¢^λ½?K]$×ó`?(ó F; ?õ1yÒ>ä…Û g?@¢V®?>•GLˆ0?2>Ž¿wÅ?0¬Bמi?ñ §%Ž|?¢_.oR?ïÿÿþãƸ¿©Ðã=CA¿yÐΫY…?òÁ¹ä•ÓÖ?ïÿÿÿý†®¿ïÎó <æ`¾¢-2G9j¿$¦ÿ˜­`¿K¬Rf÷†ý¿qpþË“b´¿zM¾ûaùÙ¿kgЉÔþ¿f˜vy±$¿So°Ú é¿FÄÅU« †¾e$ u¾Õ¦#p„ར¸{ÜüóS\i¨Ç¼HÖA¹<ö»¢á.Ųÿ¶¾÷úÜ%+)£¾ë‘UYúÔ£¾sÅš‘8UÖ¾jñŽ¦énñ½ØeiO§e]¿ð?«fèÞû*„¿ð¿rå£v"Fw?¢wž 5«i?zÒ“‰Eý>?š!tÂ5m?ŒrLÈ6A?€ @w0?zËÝábö?lð~é°m?h‹8>ï­_?CMšöQ{?UÏŸèz …?1‰mg@ȳ?D‡? z¥L">÷Þè§;'?ZéP•g‡?YEú(zbd?H¹a¯Yñ®?GÍ#Ö&¾Ê?6,”Ãð$P¿ð¿rGŽ¬Øq¿ð¿€„8›ÉˆW¿†…úª€¼H¿…@Ì¿¡Ò¿&^ga¿bÒQ ”¿L@£fÐt¿D‹¦óÎ¥ì¿-5QêM¿%Þgqèç¾×[‡ÉNš*¿¸®´>ºå÷´æ >Ál : LÑ>¸¸"‹L>¬E •ñ±Ð¿ jߣÔb&¿ 4u¨õ°¾å0Åb¯•“¾å ßqV>²‘KÆ]¡¿á¦©p‚6?ïÿÿÿ´‹È?ïÿÿÙÈhy¿ð?ïÿÿòpd?ïÿÿõ›»K?ïÿ÷MþÆ¿ïÖú8¿qÕ½D‡Cb¿ïÉá?×­m¿ð¾’)g¿ïÜ ± ˜¿ð÷h'¿ð$-/)¸‡¿ð GD¿ð%NóÊ9å¿ðÈÌ®,¿ð3^O'BØ¿ðµÇB¿ï¸˜ßω¿ð´ý˜ßš¿ïÃ-B-ò¿ð U$¿ï¡vòÏ¡¿ð‘;H¿ï¢“A½£»¿ð ˜xåοï² °©î¿ð±—÷|¿ï·¢/ŒCa¿ð îÃÉÄ1¿ï´V‘«€¿¿ð ñá6?È¿ïÝNÆ?¿ð í2=¬î¿ð¿ð Êýð¿ïÈ/&p´ç¿ðHÚÇ(¿ïŸŠ¡p¿ðŽ|@S“¿ïƹ¸Œ¿ðs½rTò¿ï¤Ü/Œí¿ð¨²Ðp¿ïÞRu›>T¿ð rÎÆÐs¿ð?ïÿÿòpd?ð?ïÿý€kï¿ì³â 6O¿MÚ{³)º¿ïõEï›»¿Úç¯OýGp¿ïüYöò¿¿ð vË®¿ï÷®)¿ðÌ.”‚¿ïÕ\ÜmH¿ðD4„¹Z¿ïÕ\À/¿ð»£âS¿ïÍÞññ¿ðæKw¿ï̧ZJlì¿ð~BĬ¿ï̪E{€U¿ðºr¶ ¨¿ïË#ö˜QL¿ð%'qQ¿ïË‘šg>Ä¿Ý€µ¼³^¿ïË/’¤\¿Þ%« ¼Š¿ïÊþ4Ì®û¿ÞI¼'¨• ¿ïÌ1›x¿ÞZ?'pÑá¿ð¿ÞbuXQ0¿ïÌ¥+­¿¿Ü—G|i—¿ïËøz§ ¿ÜÉûÑW¿ïËÈ Ãú¿Ý©ÄÇ ¼*¿ïË9•‹is¿Ý³:]…ë¿ïÌ¡v(οÞ,Ôa5?ð?ïÿÿQ6u¿ë>'o~-¿x*Çt¶¿ërº³Z‹¿¨º]{ꮿë5Ó=¦®`¿Ï‰+1ì¿êî%2 ´¿ð9®ô¿ívÞúr‘¿ð —·Çû¿ïü­ÝväX¿ïÿ·ú<‚S¿ïÓ@ñ.Ú%¿ð@[92Ž¿ïC«Äÿ®¿ð›X`¿îüw¸vf'¿ðî^I¿îhá<Ù†$¿ðÒuL@¿î²Ô܆ÿ¿ð Ͳê:S¿î_Á‹Ããù¿ðüWRñð¿îEZIíî¿ð"à +”¿îUnú4œñ¿ð)ÒÙæ’¿îT‘~¾/$¿ð14›+;¿îÝ.þ±¿ð@×w©ç¿î”'6\è[¿ð '²tÿîžÀ¼Zž[¿ð¼æ~”¿îm°ƒ·¿ðŽr¥ã¿î‰ª©ÿÚ[¿ð®5Þ?ïÿÿþ€®É¿ìö§†%¾âìçЖ„¿íë1Êpj¿yú³¯¢Œ“¿ï‰Î4§ÜÞ¿š+XQ὿ïÃ(ù’•.¿×àðÚ‡(¿ñÿO¶O—¿ïÿ¤q°´¿éŸ¼Ê ú¿ïìA»äûÄ¿êÏÞç©_q¿ïËà}í°„¿ë^G³Ud¿ïˆkü“g ¿ëjOc ‘÷¿ïr_sÉ—¯¿ëK|™L¿ï›g颿ëG75v$²¿ð![¶zG¿ëœ4ð¿äF­`åži¿êðô8ݿЫ µÂ–¿ê§jÕÐE¿¼žŸ£¢õ¡¿êv¼X㼿©=rÓâÈ¿ë)‘Ý- ™¿ðÚµ¡ï ¿ë‚ ”{¯®¿ðh‹`š¿ëš›e–!¿ïòÅ]øšº¿ëWÚ0ù»’¿ïáÂZ"7¿êðsC!·¿êõ¬Ÿ‘?ïÿÿÿzõ‡¿ð|¶+q¾èßdŒp÷¿îiè¼d ¿†änÈ—¿ð?.wè ¿¢Iš¸Q³¿ðW¡”Ç9¿âo98Èü¿î’kÊP:ô¿ðÈ!+¿ê’ÿÔ@¿ïÜxæª'¿ìþ ”ÿ¿ï¹{²÷6¿ì+>PÔ7w¿ïh[©Ÿ}¿ìvà–Mt¿ïKÿ„=L-¿ì/ Ë1;Ó¿ìø‹j×?¿ì6eÇüIº¿ðSŽ±„U ¿ëåÔù¡-¿ ¿)À1j^¿ë¿ìÎí« ¿rÀö?Åñ¿ëiøĺz»¿G¸6'2¿ë0ž«£$¿ 7¤C¿ìNÒæÈÚ¿ðU¯:( ”¿ìy—‚¾”¿ðSJ•–ÿÝ¿ìß{®/†¿ÛŠd²ÔA¿ì>ÃÌ,1.¿ØÝ«LíG¿ëÃññƒŠ¿¯5.Ïÿ.?ïÿÿÿ2ͼ¿ëñC|b1¾èø#Ï”¤¿ïEtØ«(¿ŽïæþòÇ¿ðÐÐFÙ ¿¢š;¡´ô¿ðûÄt·¿å@ȃ 5¿ëÄ+÷è¿ðœÊx&¿ë7WaÅ¿ïÖ£÷Ž:ð¿ìÔ»¿¤†¿ï´ÎO`!z¿ìä•ì˜qŠ¿ïcÏñt¹¿íF€”¾ª'¿ï9×çcÓ¿ìþv ‘¿¸wö©i~¿ìú+P{Ƈ¿ØP,tDy¿ì©¿2ã½i¿T-½°¬_M¿ì†…ãu”–¿ M‹¾i¿ì jÕî'ö¾ÉÃÒšž&¿ëá)¢ø%^¾‰EÈF'‹¬¿ìÒŠ7ýdä¿æ­b;ºè]¿íN»*€¿á•nâ!)Ç¿ì»}Xm¿°X™]-ö¿í ú÷*ö‹¿ª­°Ü¤:¡¿ìvîspO¿jÀ«VŸ²?ïÿÿÿL¨¿á[Æ־߇ÚsBß¿Óqœ+E~¿‡Eö½A׿Äù4Š‚ ö¿˜ø{ãŸè¾¿ÈGLŽ¥˜n¿Ýì —×ü¿àì5™¿Ú ¿ðÈ´¿ãŒÚ†½ÏÊ¿ïÏÙ ¿iì¿êZ‘c¶®¾¿ï®|}­Œ¯¿ìÖž1q*„¿ïZ4¯¿í0´å‡|3¿ïcû³õÈŠ¿ìåkq¶¿ž¿’¹ø™´^|¿ìã¨-5,}¿Ã¸»?=!¿ì“zXdM¿ÅÞ[Ô¿ìqT¿Ä-šŽyû¿ìS£cw%¿º— Sùc¿ì,ÿö\‡¿gcºŽúÚ¿ì7 ÞŸù[¿a·Âê4¿ì™®-Ž¾ôß& ,›Õ?ïÿÿÿÌßj¿µ„9l‰¾ÉÈ5÷œ¹r¿ìÿx.º¬¿yq»+ÒÜ¿Ñ•jèÓÍ¿…‡¥_zUÞ¿ï”’#u¿ÌeDƒûÑÇ¿í­™”a±¿ðô¤²Ep¿í3Ö?¼ú„¿ïñ»ñ‡¶H¿í$=ÌÇcY¿ïÖäÜXÈþ¿í Š¿½ÝB¿ïÚ î@ä¿í ±tZ»W¿ìþ-bm7{¿ìãu9%Œö¿6^[i郿ìó;K›#i¿‘¿X_Ô¨d¿ìÑc<ì°¾†Ûž/¦â¿ìÂ?r>à]½ìÉJÊ$Úí¿ì±µà9-½WAê|’º¿ì£[Á­Ö¼ÅÉ%i¥ÉÊ¿ìö[¶Ã .¿¯BÖ›ä¿ìúàü ^¿£yI²{…¿ìå¨QY¢¿@ã’I¿ìçþ%«¸ø¿72þþW¿ìÓÜñÚ¾µ»0´J?ïÿÿé&/’¿ëD*zi:ѾôOf$½öc¿ëYC¯cÇÔ¿a'˜"!a¿ë/·ÜVš¿³Z÷òa¿ ¿êÖQV?¿ît ýÆŒ¿êDb½&¿ð MŒ¹V ¿èçÖÝ]H¿ïù+ H}¿êÒ?þ-οïûU÷ šp¿ðQ¶&W) ¿ð {Ðd>¿ï3^#És¿ð_öM5P¿í{yxr¿ð h5ñÒ¿íÞúHzÞÆ¿ð žY¨ƒ¿ìíPæ’ø¿ðA ø“¿ìªäqoW¿ði·1º¢¿ì·Ê8ù¥h¿ðläªC¿ì¦Gq YÞ¿ð|tã1^¿îl,”ð»o¿ðsј÷¿íŽ·f€>¿ð ÷ïІå¿í’Õý’˹¿ð §ˆÀ †¿í“o3Ho¿ð  <¶Å¿íJŽâ«G¿ð ¼n:?ïÿÿèÓÜ"¿ì,š4v5±¾Õ%+˜Ò ¿ì‚,Ê,Ä7¿ t²&UÂê¿ì# l—¿žÉ] h¤¿ëÒ“Ë[:¤¿à?ÜñºÏ¿êó‚ó :¿ïéå.m¿é´;-7Vo¿ïù aý$ž¿êe¶ÇT´ê¿ïû Ò`*¹¿ðR—ö™q¿ð‡!Ax+¿ð>èÊoª¿ð°¨q¿îºÕ‰E¬¿ïüU©È˜b¿ï‡bÂZ¿êRP'1£ÿ¿î—Y‰n;¿ëR<;YB¿îSKÚbh¿ë•ªà¿îlas7…¿ë‘’tÄ3û¿î_yN<.¿ë”d‡V d¿ïþóúÜ e¿é´×TÞŸm¿ï4'ýþXu¿éüÉùå Õ¿ï@ÐÀ%°p¿ëç%J(ò¿îÁ@5¡¿ë&ºž'B¿îü½,kx¿ëwag¥?ïÿÿ÷ÙC®¿ìÏ£óVÚx¾»Ádd)¿í3Éï„lƒ¾è)œ±XD¿ìʦ£äÇ*¿‹¥Qw¥¿ì… z‰Û½¿Öú!›q¡Ç¿ë»/E O¿ïÞ/"¿êsØïΖó¿ïøTÛXû.¿ë}‡ÍHj¿ïûÅ!¶©•¿ðSq*Þ¿ðüŒ¸ø¿ð5IoŽú¿ð;ìÚ¿ïû¡*Í0¿ïô²vrÜ¿ïÇ5¸'¿è%Ï™ô_^¿îý™áî3P¿éJ9å.Ã?¿î¸ä—4ØÒ¿éUlDÒ¿îÔ¢åõ#ø¿éXˆŠ™”é¿îÎ18 ™h¿éYô€‰Xl¿ð‚T˜…‹¿ç´`¿ï~ŒÌù嬿çÓäô´¿ïŒëîùZ0¿èèùV»¿ïSþ=ü2¿èñûÖÄ&¿ïL¹þ…µ¿éA½wß?ïÿÿöîîS¿ì›° »®[¾¢R©Ù–9¿ìæoÒ¿O,¾µÊH|$¿ì”Ì÷Õ[¿yö«=½ë¿ìZ¹× ·¿Ò§ò0ÜŸ¢¿ëÒšÌóŒ¿ï×! 6ì¿êH²˜r._¿ï÷t¨ÏÆr¿êÿyY´…¿ïûHž_¿ïìý´î¤¿ïÿèÇ,ÿË¿ð #¡Û™¿ð-ÇÊ=«¿îÏÐ ‹nr¿ïõMq¿ïx90äÖ„¿éžuD ”¿îet’(C¿êê‹7F¡¿îoÂòòÏ¿êù;Ú\nQ¿îVBÈ~Ü¿êý¿Æ“‹ö¿îƒµ ã¡¿êÿå ð¿ï¡G^•ž‰¿èøfUû–¿îµv¤ÏϽ¿éCÂ鬰ſïjdÁ5j÷¿êy˜ÉŠ^Û¿î•`Ù^ 3¿êƒä=èø,¿îÖ:`¹Íf¿êßk$Ê?ïÿÿò ,Æ¿ê¹$ûŒÛ¾ˆD>¸Î l¿êïo°·ó¾ƒbÓ(¶¿ê|SBw®¿gL²Àƒ¿êwôæпÎ.ÿ ¿évI?gš8¿ðLn®4Œ¿ìAZùŠ7¿ð´·®â¿¿î@öp1J¿ïýpA#“Z¿ð¥á-õ¹-¿ïþÎ…6_ ¿í)]ºÄ‚>¿ðñ•š¸©¿ê‹^ƒTg¿ð[YxZo¿êÏ Vž¿ëè¾Zóïø¿êµ"zìs¦¿íƒÖ”+ ¿ê¦(œ§¿íž&í©3¿êÐÊ 8ðí¿í©`ÐðÏ¿ë ¹Ò½I·¿í°y•à©¿ëŠpý=”¨¿ë&”—ÈF¿ç­Äé†Ô¿ë€k•O¿îÄ-ýc”¿ìî2†ã5¿ê6¿«â8¿ìý·'ìs¿íõ0©T;©¿ípÉW4É`?ïÿÿö׋¿ÙÀ§“%ö¾g£ öâ¿î¦7Z¸ãC¾8Äõ€»¿ìøH Bí‹¿A{‘öKšµ¿òœ¢î¿°/C dÇà¿é/†ÞJ¿ïv‹joÒÙ¿õ.~r’Í¿èç ˜]Rª¿ö#ìšßs$¿ð7Ö¹ë3¿ñÂðÑN걿웞c¦@¿ð /1Š«Y¿én"#rç“¿àÄÒÌ ªÖ¿ðËx’L™¿ç¸¸F™Ÿ¿Ô_H£C¿ß—”–DÃ8¿ÕW2ï…„¿àÐERm³†¿Õr¥ºóá¿àHvõ Ѫ¿Õ~“¼~¿à¥½ºƒV@¿Õ†k+ýžÏ¿æ‰$›MYÿ¿ÓhÃ5 úÁ¿æudSÝ£¿Ó° ÁÓ¶¿êê@Ý6á¿ÔÕä ¦TU¿â‹÷û0ÿ¿Ôâ*Ü '¿àÌlq¯N¿ÕDó"J¿ð?ïÿÿÿ…ôG¾³ã«"ãó¾„Ò/4Y’¿f瑱Pe¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð¿ð?ð?ð?ð@˜¨¿ð?ïÿÿòpd˜¦ÅŘÔØØÚÜÞêìîðôøcc'_ac{…•),.0W¤úbW\`fjnprxz|~€‚âú›Ÿ¡£µ»ÁšŸ¡£¥§©«­¯±³µ·¹»½¿ÁÃÅÁ£±äÝÞâæèêòôöøúþhlŠtvz†ˆ !%')+-/13579;=?ACEGIK%)15=AGIK=AÛKž ®°×ÛÕéafhjlnrtvxz|~€‚„†ˆŠÄ ,,,,,,,,,,,,,,,,,,,,,,-///////////////////////6KKKKKKKKKKKKKKKKKKKKKKKKLNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNO_______________________bbbbbbbbgggggggggggggggg}}}}}}}}††††††††††††††††ˆŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŠŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽŽ’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’’¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥¥.XÅ .(¾•_ÿóTò>r‹Ý>2‚?¡ôH°c¿òÖÿÿýÕ¾t¿ÿÿúm>‹ÿþi\/>"þ=öãÿÿÿæ±>c€Dé>ÿÿÿõO>1Ûÿÿ÷œ=ù±€ª=ýkÿÿò¼>@ÿÿøü> Â@ I=íÍC¬>ñ¿ÿÿý">þÀb=ü €># ®>ƶ¯Ôf2Þ?¡ôÙh7>pÏ À)$ؼl>ƶ¯Ôf2ÞÀvÉšïÖè>ƶ¯Ôf2Þ>Ð`ÉÄéh>Ð`ÉÄéh½Eÿÿÿÿݤ@4g ’J‡ó>ƶ¯Ôf2Þ>¿áN=@tL}!õ%¾‹fÿÿ8W>"ûÿÿåÑ>@ÿÿù¹>ˆÔ>?‰ÿÿÿê,¾3þ¿ÿÿÿ+¾ø3¾34¾6ƒßÿÿù7¾J¾ÿÿÝï¾"eð'…¾/Z_ÿÿóP½à¤H`¾G›ÿÿ•“¾DÂÛÿÿüξ x¯ÿÿõì¾&õPC¾5˜8M¾)z`ﾉøÅZŽ?ŸÁ( ¿8ŒX†±yM?rÆ¿©kSï¿…ê×ó†A?r£1:¶É?pÜ!ײ‹?]Ì$‹Gâr?SË”5 /?6»TÆ0R?-ý"Þ+Íx>áo¯öp í?ûì9é×Ä>¿ø½.>™Sbk±u>tCZz >PÐàV„./?|±êÏh±?Åãì=úJ>îŸÃßÓ±6>ë’+t5>ÉÉ0ˬâA¾‰øÅZŽ¾Q¡/ÿÿÛ!¾Q¡/ÿÿÛ!½EÿÿÿÿݤÀpçTQÞ<¾‰/øÅ>¹n= @p’ëÛÚݾFÞÿÿ/é_=Åòð>} 2á>7×ÿÿúõ>ßÿÿÿØW=õ'ÿÿÿõµ=ÿÙÿÿÿýØ=²€½î 2:½äÿÿÿï¾"ÿÿÿëÔ¾ê¾ ÿÿþA¾%{à?¾&öPä¾+çPâ½áŸC¡½«@j¾À Ö½ñÊ€!þ>›‡ÿ´˜¶¿rEYÕaß›?Xã#ªý$?vÆX—µ¨¿½õ¹>r>?uöpÉ'C?n ú €ß?XHJ³ Ü?OáeÔîO¨?1$õ}ìt3?&°&WXd}>١Θs-—>ðë¿`lw®>¥­ ÉkI”>€ã|‚2Ä*>X²ÕVªj9>3Yai –>ö؉¯*Ôr>ôÕû 쥈>Õq+N ˆ>Ó1MHÏ›;>±Þvó¾r$=/ÿÿÿÿû >›‡ÿ´˜¶¾ÏAà(o?rIMVô>a‹ÿÿÿøò=z ÿÿÿ»¢¾8û7ÿÿí£¾ ÿÿÿýë¾4_ÿÔ¥¾6'?ÿÍ¥D¾%ÿàˆ>-BÿÿÿûA>ÇÿÿÀò>ýÿÿ°†=ØF ½µ(î½ì2ÿÿÿòí½Á¯ÿÿÿõ…¾¾`>LÿÿûË> "€ Y=þ‚ÿÿæ<=ñÿÿÿàF¾qQ+hD¾—)w ´£#¿É€¥§pÆ¿9r ›º;¾¿é~±S5<¿è+a5zÝ¿Ú9Q cü¿®zN:R#¤?„ôrš÷O?Œg|É×?‘dC*ì¯'?hI«œ'?x¾8ë¢8?…œ•¾&?kƒ5“i?]eï˜Å8?NíªÙU??:íV42%?‡†4Úž µ?‡alðì?}нr9)?|ƒ€µ; º?p‡ÑD—=_ÿÿÿÿÜ>1àýS Ѿ>ÿþ†Dì=óSÿÿÿêþ=ï—ÿÿÿï½½ð‹$¾ I°=ÿÿÿÿû ½Ø¬ÿÿÿö½ßx?ÿÿ—c½Ìx€,<¯ÿÿÿÿû ½w†E½ÓSÿÿÿú½ aÿÿÿô½¼Îÿÿ½N.·>ah¯ö´ë¿>`ãûÀfž>r` ½@Þ÷«.›¾3"¿ÿÿÿ`½¥ À Ø>T&^(oý½ý0“¾*Òÿÿóa>-øŸþÙÃÔ¾š?ÿÿò ¾7i=B(½æÅt½Õ†ÿÖ§©¼ßÿÿÿÿû ½±,wÿÿÊá½ÄÄ„Á?̽¯!߀M½©ñOßÿ툽Çÿÿ¯&"½ 4ÿÿÿü ½µLÿÒ…Ó½º!ŸÿÿÈ¡¾„¹‹8aÂÞ>™ë3KeBs>R$墶@í%‹Ây>çü±@E«B¿¡ò«Nåcž¿§fK±Ø¦§¿ˆ¹Ó‘9Æ‹?{ñŒP†lj¿–-Yú¯¿ž˜G¿K¸Ÿ¿•ýz6zÈZ¿‹|Î2ö¿=– ÝcÃ?cfð¿¯3ç¿U䱬¾y ¿@IÏ÷ì-¿"\ˆ¯L¿ÚÒüDYð?eÑyÓ8|u?a; Öý?;Wà1@ê?*Åä´¤î¿W ûhGø>Sÿ¿ÿJC|=z°ûñ+>8÷òùÇ–ú>5¶ýûßf£½ñÀ[>, ¿ÿhϳ>ÿÿ‰àr¾%sŸÿÿîB=J9Þ½ç¤?ÿÿçl½”ÜŸÿÍì¤=žÚÿÿù ½ Âªÿ™«q½’)Oýj„ V½QŒÛžÑ³=ËT ;½“M!=—ÍÏÿ¡óª=Z ›>Ž ß¾½•ºVü¿ÂåûËN;>þ‡ðÏO) ¿¡½¥òÚ¿§“ŽêHp£?˜®;3?†9ƺW™¿¿žùл”Ÿ¿£†ÏWXµ¿—!ŒE„¿‡P뻌¿SZ¸³X–Á?xÎpàO ¿'êâëïYN¾ûþê/VŒ¾ÉáéBO'µ¾—½Èrå×ô?—¼¥7Œ?{h³3¶h?3DëŒýC?nˆÝâ †¿1²GÚíCò>Füÿ«!z½mó@ ¶>Oæ4ï@í=¾v€Ò¾A2Pú=@;k½7ÿÿÿÿüG>4Ýÿ”ዼÿÿÿÿÿû ½àf`G½uSoÿÿø@=°Ïÿÿ쌽c¤ÿï½&Gw¿ÿé9=CâpÀAÛÓ;À¿ÿÿÿó¡=ÌH´¼óÿÿÿÿüæ=p‰çÿÉé ½[À>tõ÷—“µ¹>¢ùÁ~“ ¿Æ÷špÂ? Ù³ûRv¿’‚ÎQ»ûˆ¿£òÃe ,?¶‹pÒ€?“WxŽÚg¤¿«Œ!2WX¿±"÷n~šX¿¥ËštX°¿•ýtvZ¿2®˜’N^?q€Ò‡,|Ž¾ñµ¯‰î¾°ÌEÅ×g¨¾iÂÕ»Ѿ¾$.npÊŸ/?ˆ5ËáTƤ?|ÏêòòÈJ?E—n‹ã×>èq÷娿S?λ§¢>FG_ÿyЯ½GðʽùfØc> P?þ~z\¾;ö”9>,øïÿQ©)=óç¿ÿÕ6ó¾?ÿÿ×A=ô _ÿÖí–½¾±ÿÿÿEQ¿ÿÿáA?aÙ*¦@3Y½º™ÿ-åÈ<á2­wÙ¼üy™ ;;Gÿÿÿúk?seö¸Í@&?mß7úýB¦=sB©ÿ³>]=0)ÿÿö¿¡ó0‰à˜¿–ÝVª¦bà?Ì+ (4Å,?T*Æֿ̧ŠM½Îá¢%¿œA5“çÎ?¬¡¹0N?‘X7¬äá´¿«ÊØHv¢[¿± ”ã¼Z¿ žZPàL¿‚¢g™«—>÷Ê©sŒö§¿b¶¤«a¦¾²·‚^“x¾_›ÁÓ⟾ÉrT#–½ª#f½â¿;}\ŠóÈ¿qÛWt*3®??zÒ“?^Õ¤j%¾ÅË»æ*¾1x ]½pT ÿÐfT>Níú[XÓÉ>Ô+û!B¾ë€8½òÅÿÿÒÔ`=ßBÿÈ ½ùSßÿÿöÑ=â]GÿÚ¿œ=ÐR÷ÿÿú)= 7ÿ¡ØA¿gZkž­p…<æâ¸yîâ¼ög±¯;5wºÒÇÿÿÿಿ㇥¦ÃÄ¿u…*HDë¾ß¾Ã|–¾ÓÏ@…¨<¿ywÝ* Ï¿‡¥b c?·ÀL*Xݾ’1Fà\r¿¦ôÄÃqп§Ål’Ô¿™*poS¯?üZÜ°:k¿~ï@0šG¿‹³PS½¿V[õ9«nh?áMÃ>àž`KàÅ?CRæí4ôn¾`: ªC½÷¨¹ý©€ C½ýt Òøo?^7U±‹%?TâƒÛ)h¾ð æ¾ãà/žx¦¾u¢£^äK¾¤Tæ=yhÛ@­¤¾9´·ÿÿòï>EÌ¿Ìã^u½@;k=ê½Æ̃=gÿÿ¿ûÅ=ößÿÿø©¿íµ²;ÿÿÿÿó†;ÿÿÿÿ鎺¿ÿÿÿÿÔJ¿ðþ}VKs¿Z?|WÚ¼¾”–íø¿¿¾{×Ó ¿v ¸fí^?Ž+råªÛ¾¤Ý,E—Ë/¿’‚¸ÚÁ¯‚¿’¶ëúM;T¿„,™EÂ|°?“ÈOæûà¿vcÿÎßÜ뿈þsšgÛ3¿g&Ç7?äP?xÕ¤ÊU’>±ÐFn?!§*h¢£¾/ñ™˜GQp½²¨¶G ;½/§üÔfü¼¬vú*ö?B@ÓKk"?7MïáI>ÅãA©³¦X>¿¹H»v=ü¾Zˆ‡Ù“¾3!ÿÿÿî =F¦ÿÿSµl¾;ÿÿæþ>Ãþ†­c½÷×ÿÿÿãâ>-øþÙ¹½@;k¾+Ä€!·>úÿÿ±Æ¬½úŸÿÿÿë˽òÿÿÿ`Us=í¹ÿÿÿÇh½éRR½çú;>†?Ø|¸i½¢ßÿÿÿû$½æ\ÿÿ=*L½ØµÿÿHо2¿ý»ÞÑ=ò¥ÿÿúﾑçý¸Éç>qÒÿÿøý@±C²ùW¾Gÿÿ„ =1pÿÿ›«\>þWþÏ n¾! oÿÿÕ=ø•ÿÿÕ9º>ôRd>Nÿÿÿ÷ç>-<€s>!Cÿÿæ<>*‰@ü>RvïÿÿÈj¾PÿÿâD>óµ>^€ 0>2`Ì>A7ÿÿ÷„>'DÏÿÿé¾ T¿ÿÿù =ïªî>)ö (1>4àꌫ¾ÁG|.1øÀòÄ.³:¸¿ÞZBiZ?Â> ©-?¼^§œé¿·\̳¼aG¿ y…!¨?wdë* W?ŽlP®e†D?‘Ê"Yoµ?Â÷±è¦?q7á%°h?{ÜÈ"…ÍŒ?f™.ß~?\·Æ *É?P»µTÇDÜ?Cê…?.ñ$Ø-?g{¹Òk?sËà)þ²?s1»Ž®©,?hÝfuŸç½÷ÿÿ~P½t ÿ”„ñ¾4ú;ÿÿù=â¹€6)½zÿÿÿÿÜÞ½¿?ÿÿÿû(=ùÿÿÿö[¾äÿÿÿö"¾€¿>2²à_>@Y/ÿÿùì=óÜÿÿÿð:¾#ŸïÿÿØ©=ìÿÿÿãµ=þ ÿÿÿ櫾”?ÿÿ¡J½è¦ÿÿÿÕ¼=ú¤Ý>@@~¾1Ïÿÿ÷»¾Á†Ðs‚°×?]\ÑQ×À˜ÁMº3r>ü§Ò°«Æò?Ï‹þÁý÷?Úðù†ïÚE?Ù'vÌ=še?«¢kƒ/“X?“„.ûÃEœ?šùOã¾?®àâ±Þ*?‡žÍ’á¿V#a8¿¿U±s˜-¿5Ant3?•b&ƒN'?$2?í€y­?$Jð‡¿DX¥G•¿B]DÍÓ–'¿Wœ) m¬¿U¦ÛGUã¿GMRª,O>j ÿ—ŸÃ½M_ÿ®t©¾2§-ÿ‰ë¾ p >>(ô€:¾º ¾ÿÿÿÔæ>ÿÿÿëþ7±`¾V-7ÿÿä>".ðľ&8Á> è¾9€'ÿÿü>¾¿ÿÿî¾$A_ÿÿäŸ>-ò)<¾ ?ÿÿöà> ‚@'>± Z…´¬‘¿7å+ èMôÀ9Æg)Ç/>û®é@Ï?ÓR@«J×Ï?ßËi¸ù?çþÿUÀð‹?ÇgœÆê?¤·Öˆm¾ß?£ñж(ð?Š½£êQÎ?wÕž´¿A%e½]A¿‚4MI­Z׿mô©£'¼¿^49† é¿MòZôÖC£¿=2 xZÿ7¿€³ªÏHRµ¿€º°êºp¿r Ôj¿~ zqœ¿s!­VùR$¾UÄÿÿê=f»ÿ>¿8¾ä?ÿÿÌ_>WÏÿ2:¾$ÿÿæ¾3À@ü½úrê¾f¾#7ÿÿÿò¿½ôWÿÿÿùW>kÿÿÿúª¾y?ÿÿò˜>Å€þ¾ÀÏ>!0¿ÿÿÝï¾1è>)àN¾,b¯ÿÿÒÔ¾)2ÿÿçÁ>ƒ`Õ¿ݦrp#w¿5.²ÐÔå¿À…nÌ6>é7¤ï%ŸB?Ò ƒ“d@Õ?ÖZ‚ÿ?éMš¶sõ¾?Êsÿ$Þ¤R?£æ¤…—õ˜?£wÆB e}?‹'ª¡?w{­P¿ÎWÕ/¿ƒôŸ'‹ÃÝ¿p,+[kÛ˜¿`R¦ä‰Œ¿O¹cÿBæÌ¿>éÔ›œŽz¿‚T¶Pî¿‚y¨©R¿Q"^Å o¿€\^x'0Ü¿tÔûw$íG¾QÈ@Æ=ˆUD_ö°>)eþ[¨ª½þ[_ÿÿàá=ò@ÿÿö…½Ùßÿÿ†f¾¾YÛ¾ ð=Ò×ÿÿÿõ•¾&¹ÿÿí¾ ¨¿ÿÿã7¾÷À9Æ>þ¿ÿÿî½>q`o¾%0>¾0xâ¾ ø@v½ü¨~>ü€ œ¾)A0É¿æë!ýÛ ?—1áœú~À$d´8>¿jà‘f>?¾Q ›çdˆ?¸×t7*–?ÏøƒÁb)¿Š²¸Ù^û¯¿‹ìËBcÄ‚?p†v³„-á?‘ÞwY¢$õ?Z¿!ƒK?u΀@;t?x`^yBÄ?oš)]aÝè?fâ‹ÇŽªC?^ÑÒŠ¸ÊT?Sì* ½Î?yUò® ?|ëM²ÿúA?sÀÌH“?uPÓSþ?mHˆÂˆG›>P“ ¥½2&;>´oÿ=ÈZ=ÿÿÿÿû ½òOÿÿÿܤ=X Á=ÿÑÿÿÿõD½Á_ÿÿÿúh½óP {½íxܾ@úàʾ§@’¾"3`ï¾6ã f¾(²¾0žgÿÿê ¾=€x¾@ ¾bŸÿÿ¨ç½ûÂ?´Ê«{Q¿Æ¥À¢ Ó>¦·‹ÝM¬?›Zrܾ?•³nÖù»C?¬È{£è6ß¿ªû*<ÉÝ¿‰Ü¯Â·AG?gäD¢Ñð?™y¬²bbÒ?R;b¥p?ˆ5ÜÚ15Ý?u[$IRDù?gEéùìÑ]?b®Å2·m?XÃ\¦†­?IZ7~‹ãJ?pɪ ‚å4?v¤ý¤]?gf©¥ð?qÈÿn/[‹?gñý¥áß>1Qà½Ô´?ÿÿñ½ÖG@N½ðý$½ì&¯>Gû>™Ú>c€Dé>ÿÿÿõO>@Š=ù±#0=ýjÿÿè8½íªÿÿÍH_> Â@ I¾Y?ÿÚˆ¾ñ?ÿLÐA>äßÿÿòù=ü ÿÿÿÝ>¨`L?Áô²÷Ë?¡ôÙh7;×ÿÿÿÿûÖ=ÈØ°É=—Å¿ÿÿÿÒ½¿år~¶TÉ={|ö-&Û½š ŽEeq<ê’0™âj½í:×j÷¦=”÷aÙ5•k=•Œ³Áí_=£‘Š"ÿ½¯––tiy½•(ŸiÕä¦=µ/—=’ʆ E=“0Œ¯½®ÍYTc½”–,Æã•=•¯J3F?P¡’†#'å@‰g†:?¡ôÙh7ÀŠý{áÚ¾ ?æOt¾3ª¿Õ¢óž¾ŸÿøÔâ>t³ÿÿÿòì>`Nÿÿÿö¬=õ/ÿÿÿþI=è«ÿÿÿ¾Ã=Œ-ó½h¿ÿÿÿì°½ #ÿÿÿû½}uÿÿÿ§K½r‰ ½&dU½ Þÿÿÿ‘Ÿ¼»óÿÿÿç*¼Ænÿÿÿï(½a4#½c ‡½JÿÿÿÕ2½UHÿÿÿöj¾ÊˆPd.@H™ÂҌܾʈPd.½EÿÿÿÿݤÀ@ñ4.üÇÛH Mallya/lhr01MUMPS_5.4.1/MATLAB/initmumps.m0000664000175000017500000000116014102210473016061 0ustar jylexceljylexcelfunction id = initmumps() % % id = initmumps % it returns a default matlab MUMPS structure % % Use help mumps_help for detailed information % errmsg = nargoutchk(1,1,nargout); if(~isempty(errmsg)) disp(errmsg); return; end id = struct('SYM',0,'JOB',-1,'ICNTL',zeros(1,60)-9998,'CNTL',zeros(1,15)-9998,'PERM_IN',-9999,'COLSCA',-9999,'ROWSCA',-9999,'RHS',-9999,'INFOG',zeros(1,80)-9998,'RINFOG',zeros(1,40)-9998,'VAR_SCHUR',-9999,'SCHUR',-9999,'INST',-9999,'SOL',-9999,'REDRHS',-9999,'PIVNUL_LIST',-9999,'MAPPING',-9999,'SYM_PERM',-9999,'UNS_PERM',-9999,'TYPE',0,'KEEP',zeros(1,500)-9998,'DKEEP',zeros(1,230)-9998); MUMPS_5.4.1/MATLAB/printmumpsstat.m0000664000175000017500000000256114102210473017154 0ustar jylexceljylexcelfunction printmumpsstat(id) % % printmumpsstat(id) % print mumps info % disp(['After analysis : Estimated operations ' num2str(id.RINFOG(1))]); disp(['After analysis : Estimated space for factors ' int2str(id.INFOG(3))]); disp(['After analysis : Estimated integer space ' int2str(id.INFOG(4))]); disp(['After analysis : Estimated max front size ' int2str(id.INFOG(5))]); disp(['After analysis : Number of node in the tree ' int2str(id.INFOG(6))]); disp(['After analysis : Estimated total size (Mbytes) ' int2str(id.INFOG(17))]); disp(['After factorization : Assembly operations ' num2str(id.RINFOG(2))]); disp(['After factorization : Elimination operations ' num2str(id.RINFOG(3))]); disp(['After factorization : Real/Complex space to store LU ' int2str(id.INFOG(9))]); disp(['After factorization : Integer space to store LU ' int2str(id.INFOG(10))]); disp(['After factorization : Largest front size ' int2str(id.INFOG(11))]); disp(['After factorization : Number of off-diagonal pivots ' int2str(id.INFOG(12))]); disp(['After factorization : Number of delayed pivots ' int2str(id.INFOG(13))]); disp(['After factorization : Number of memory compresses ' int2str(id.INFOG(14))]); disp(['After factorization : Total size needed (Mbytes) ' int2str(id.INFOG(19))]); MUMPS_5.4.1/MATLAB/zsimple_example.m0000664000175000017500000000157014102210473017237 0ustar jylexceljylexcel% Simple example of using MUMPS in matlab % initialization of a matlab MUMPS structure id = initmumps; % here JOB = -1, the call to MUMPS will initialize C % and fortran MUMPS structure id = zmumps(id); % load a sparse matrix load lhr01; mat = Problem.A; n = size(mat,1); mat = mat + sparse(1:n,1:n,i*ones(n,1)); % JOB = 6 means analysis+facto+solve id.JOB = 6; id.ICNTL(6) = 0; % we set the right hand side id.RHS = ones(size(mat,1),1); %call to mumps id = zmumps(id,mat); % we see that there is a memory problem in INFOG(1) and INFOG(2) id.INFOG(1) id.INFOG(2) % we activate the numerical maximun transversal id.ICNTL(6) = 6; id = zmumps(id,mat); if(norm(mat*id.SOL - ones(size(mat,1),1),'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - ones(size(mat,1),1),'inf') % destroy mumps instance id.JOB = -2; id = zmumps(id) MUMPS_5.4.1/MATLAB/dmumps.m0000664000175000017500000000467114102210473015353 0ustar jylexceljylexcelfunction [id]=dmumps(id,mat) % % [id]=dmumps(id,mat) % id is a structure (see details in initmumps.m and MUMPS documentation) % mat is optional if the job is -1 or -2 % mat is a square sparse matrice % information are return in id fields % % Use help mumps_help for detailed information % errmsg = nargoutchk(1,1,nargout); if(~isempty(errmsg)) disp(errmsg); return; end arithtype = 1; if(id.JOB == -2) if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end dmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id = []; return; end if(id.JOB == -1) if(id.INST~=-9999) disp('Already initialized instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = dmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schur; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE = arithtype; id.ICNTL = icntl; id.CNTL = cntl; id.COLSCA = colsca_out; id.ROWSCA = rowsca_out; id.KEEP = keep_out; id.DKEEP = dkeep_out; return; end if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = dmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP,mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if(id.JOB == 2 | id.JOB == 4 | id.JOB == 6) if(id.SYM == 0) id.SCHUR = schur'; else id.SCHUR = triu(schur)+tril(schur',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; id.COLSCA=colsca_out; id.ROWSCA=rowsca_out; id.KEEP=keep_out; id.DKEEP=dkeep_out; MUMPS_5.4.1/MATLAB/multiplerhs_example.m0000664000175000017500000000105214102210473020117 0ustar jylexceljylexcel%Example of using MUMPS in matlab with multiple right hand side % initialization of a matlab MUMPS structure id = initmumps; id = dmumps(id); load lhr01; mat = Problem.A; % JOB = 6 means analysis+facto+solve id.JOB = 6; % we set the rigth hand side id.RHS = ones(size(mat,1),2); id.RHS(:,2) = 2*id.RHS(:,2); %call to mumps id = dmumps(id,mat); if(norm(mat*id.SOL - id.RHS,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - id.RHS,'inf') % destroy mumps instance id.JOB = -2; id = dmumps(id) MUMPS_5.4.1/MATLAB/zmumps.m0000664000175000017500000000467114102210473015401 0ustar jylexceljylexcelfunction [id]=zmumps(id,mat) % % [id]=zmumps(id,mat) % id is a structure (see details in initmumps.m and MUMPS documentation) % mat is optional if the job is -1 or -2 % mat is a square sparse matrice % information are return in id fields % % Use help mumps_help for detailed information % errmsg = nargoutchk(1,1,nargout); if(~isempty(errmsg)) disp(errmsg); return; end arithtype = 2; if(id.JOB == -2) if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end zmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id = []; return; end if(id.JOB == -1) if(id.INST~=-9999) disp('Already initialized instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = zmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; id.SCHUR = schur; id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM = sym_perm; id.UNS_PERM = uns_perm; id.TYPE = arithtype; id.ICNTL = icntl; id.CNTL = cntl; id.COLSCA = colsca_out; id.ROWSCA = rowsca_out; id.KEEP = keep_out; id.DKEEP = dkeep_out; return; end if(id.INST==-9999) disp('Uninitialized instance'); return; end if(id.TYPE ~= arithtype) disp('You are trying to call z/d version on a d/z instance'); return; end [inform,rinform,sol,inst,schur,redrhs,pivnul_list,sym_perm,uns_perm,icntl,cntl,colsca_out,rowsca_out,keep_out,dkeep_out] = zmumpsmex(id.SYM,id.JOB,id.ICNTL,id.CNTL,id.PERM_IN,id.COLSCA,id.ROWSCA,id.RHS,id.VAR_SCHUR,id.INST,id.REDRHS,id.KEEP,id.DKEEP,mat); id.INFOG = inform; id.RINFOG = rinform; id.SOL = sol; id.INST = inst; if(id.JOB == 2 | id.JOB == 4 | id.JOB == 6) if(id.SYM == 0) id.SCHUR = schur'; else id.SCHUR = triu(schur)+tril(schur',-1); end end id.REDRHS = redrhs; id.PIVNUL_LIST = pivnul_list; id.SYM_PERM(sym_perm) = [1:size(mat,1)]; id.UNS_PERM = uns_perm; id.ICNTL=icntl; id.CNTL=cntl; id.COLSCA=colsca_out; id.ROWSCA=rowsca_out; id.KEEP=keep_out; id.DKEEP=dkeep_out; MUMPS_5.4.1/MATLAB/simple_example.m0000664000175000017500000000214114102210473017040 0ustar jylexceljylexcel% Simple example of using MUMPS in matlab % initialization of a matlab MUMPS structure id = initmumps; id.SYM = 0; % here JOB = -1, the call to MUMPS will initialize C % and fortran MUMPS structure id = dmumps(id); % load a sparse matrix load lhr01; mat = Problem.A; % JOB = 6 means analysis+facto+solve %prob = UFget(373); %mat = prob.A; id.JOB = 6; %%%%%%% BEGIN OPTIONAL PART TO ILLUSTRATE THE USE OF MAXIMUM TRANSVERSAL id.ICNTL(7) = 5; id.ICNTL(6) = 1; id.ICNTL(8) = 7; id.ICNTL(14) = 80; % we set the rigth hand side id.RHS = ones(size(mat,1),1); %call to mumps id = dmumps(id,mat); % we see that there is a memory problem in INFOG(1) and INFOG(2) id.INFOG(1) id.INFOG(2) % we activate the numerical maximun transversal fprintf('total number of nonzeros in factors %d\n', id.INFOG(10)); %%%%%%% END OPTIONAL PART %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% if(norm(mat*id.SOL - ones(size(mat,1),1),'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SOLUTION OK'); end norm(mat*id.SOL - ones(size(mat,1),1),'inf') % destroy mumps instance SOL = id.SOL; id.JOB = -2; id = dmumps(id) MUMPS_5.4.1/MATLAB/diagainv_example.m0000664000175000017500000000237014102210473017335 0ustar jylexceljylexcel%Example of using MUMPS in matlab to compute diagonal of inverse of A % Change to true to test example complex arithmetic complex_arithmetic = false; % initialization of a matlab MUMPS structure id = initmumps; if (complex_arithmetic) id = zmumps(id); else id = dmumps(id); end load lhr01; mat = Problem.A; if (complex_arithmetic) % To test complex version mat = mat + i * speye(size(mat,1),size(mat,1)); end % JOB = 4 means analysis+factorization id.JOB = 4; if (complex_arithmetic) id = zmumps(id,mat); else id = dmumps(id,mat); end % Set the right hand side structure to requested entries of A-1 id.RHS = speye(size(mat,1),size(mat,1)); % Sparse format required %call MUMPS solution phase to compute diagonal entries of A-1 id.ICNTL(30)=1; % Ask for A-1 entries id.JOB=3; if (complex_arithmetic) id = zmumps(id,mat); else id = dmumps(id,mat); end % diagonal values have been computed in % the (sparse) matrix id.SOL, which has % the same structure as id.RHS % Compare diagonal of inverse computed by Mumps and by matlab disp(' '); disp('Computing 2-norm of error on diagonal of inverse:'); norm(diag( diag(diag(inv(mat)))-id.SOL ),2) % destroy mumps instance id.JOB = -2; if (complex_arithmetic) id = zmumps(id) else id = dmumps(id) end MUMPS_5.4.1/MATLAB/schur_example.m0000664000175000017500000000421414102210473016676 0ustar jylexceljylexcel%Example of using MUMPS in matlab with schur option % initialization of a matlab MUMPS structure id = initmumps; id = dmumps(id); load lhr01; mat = Problem.A; themax = max(max(abs(mat))); n = size(mat,1); mat = mat+sparse(1:n,1:n,3*themax*ones(n,1)); % initialization of Schur option id.VAR_SCHUR = [n-9:n]; % JOB = 6 means analysis+facto+solve id.JOB = 6; id.RHS = ones(size(mat,1),1); %call to mumps id = dmumps(id,mat); disp('*** check solution restricted to mat(1:n-10,1:n-10)'); if(norm(mat(1:n-10,1:n-10)*id.SOL(1:n-10) - ones(n-10,1),'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SCHUR SOLUTION CHECK1 OK'); end norm(mat(1:n-10,1:n-10)*id.SOL(1:n-10) - ones(n-10,1),'inf') % we want to use Schur complement to solve % A * sol = rhs % with sol = x and rhs = rhs1 % y rhs2 % % check that the complete solution verify % y = S^(-1) * (rhs2 - A_{2,1} * A_{1,1}^(-1) * rhs1) % and % x = A_{1,1}^(-1) * rhs1) - A_{1,2} * y % sol1 = id.SOL(1:n-10); rhsy = ones(10,1)-mat(n-9:n,1:n-10)*sol1; %%%%%%%%%%%%%%%%%%% % TO CHANGE : % usually the resolution below is replaced by an iterative scheme y = id.SCHUR \ rhsy; %%%%%%%%%%%%%%%%%%%% rhsx = mat(1:n-10,n-9:n)*y; id.JOB = 3; id.RHS(1:n-10) = rhsx; id = dmumps(id,mat); rhsx = id.SOL(1:n-10); x = sol1-rhsx; sol = [x;y]; r = mat*sol - ones(n,1); disp('*** check complete solution'); if( norm(r,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SCHUR SOLUTION CHECK2 OK'); end norm(r,'inf') %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % NOW TRY REDUCED RHS FUNCTIONALITY % (easier to use than previous % computations) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% id.JOB=3; % Do forward solution step to obtain a reduced RHS id.ICNTL(26)=1; RHS=mat*ones(n,1); id.RHS=RHS; id = dmumps(id,mat); % Solve the problem on the interface id.REDRHS = id.SCHUR \ id.REDRHS; % Do backward solution stage to expand the solution id.ICNTL(26)=2; id = dmumps(id,mat); r = mat*id.SOL-RHS; disp('*** check solution when REDRHS is used'); if( norm(r,'inf') > sqrt(eps)) disp('WARNING : precision may not be OK'); else disp('SCHUR SOLUTION CHECK3 OK'); end norm(r,'inf') MUMPS_5.4.1/VERSION0000664000175000017500000000005014102210467013766 0ustar jylexceljylexcelMUMPS 5.4.1 Tue Aug 3 09:49:43 UTC 2021 MUMPS_5.4.1/examples/0000775000175000017500000000000014102210474014537 5ustar jylexceljylexcelMUMPS_5.4.1/examples/dsimpletest_save_restore.F0000664000175000017500000001217214102210474021767 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_struc.h' TYPE (DMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL DMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL DMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL DMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL DMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instace. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL DMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL DMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL DMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL DMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL DMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/csimpletest_save_restore.F0000664000175000017500000001217214102210474021766 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_struc.h' TYPE (CMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL CMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL CMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL CMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL CMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instace. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL CMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL CMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL CMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL CMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL CMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/Makefile0000664000175000017500000000635614102210474016211 0ustar jylexceljylexcel# # This file is part of MUMPS 5.4.1, released # on Tue Aug 3 09:49:43 UTC 2021 # topdir = .. libdir = $(topdir)/lib default: d .PHONY: default all s d c z multi clean .SECONDEXPANSION: all: c z s d multi c: csimpletest csimpletest_save_restore z: zsimpletest zsimpletest_save_restore s: ssimpletest ssimpletest_save_restore d: dsimpletest dsimpletest_save_restore c_example_save_restore c_example multi: multiple_arithmetics_example include $(topdir)/Makefile.inc LIBMUMPS_COMMON = $(libdir)/libmumps_common$(PLAT)$(LIBEXT) LIBSMUMPS = $(libdir)/libsmumps$(PLAT)$(LIBEXT) $(LIBMUMPS_COMMON) ssimpletest: $(LIBSMUMPS) $$@.o $(FL) -o $@ $(OPTL) ssimpletest.o $(LIBSMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) LIBDMUMPS = $(libdir)/libdmumps$(PLAT)$(LIBEXT) $(LIBMUMPS_COMMON) dsimpletest: $(LIBDMUMPS) $$@.o $(FL) -o $@ $(OPTL) dsimpletest.o $(LIBDMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) LIBCMUMPS = $(libdir)/libcmumps$(PLAT)$(LIBEXT) $(LIBMUMPS_COMMON) csimpletest: $(LIBCMUMPS) $$@.o $(FL) -o $@ $(OPTL) csimpletest.o $(LIBCMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) LIBZMUMPS = $(libdir)/libzmumps$(PLAT)$(LIBEXT) $(LIBMUMPS_COMMON) zsimpletest: $(LIBZMUMPS) $$@.o $(FL) -o $@ $(OPTL) zsimpletest.o $(LIBZMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) c_example: $(LIBDMUMPS) $$@.o $(FL) -o $@ $(OPTL) $@.o $(LIBDMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) multiple_arithmetics_example: $(LIBSMUMPS) $(LIBDMUMPS) $(LIBCMUMPS) $(LIBZMUMPS) $$@.o $(FL) -o $@ $(OPTL) $@.o $(LIBSMUMPS) $(LIBDMUMPS) $(LIBCMUMPS) $(LIBZMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) ssimpletest_save_restore: $(LIBSMUMPS) $$@.o $(FL) -o $@ $(OPTL) ssimpletest_save_restore.o $(LIBSMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) dsimpletest_save_restore: $(LIBDMUMPS) $$@.o $(FL) -o $@ $(OPTL) dsimpletest_save_restore.o $(LIBDMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) csimpletest_save_restore: $(LIBCMUMPS) $$@.o $(FL) -o $@ $(OPTL) csimpletest_save_restore.o $(LIBCMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) zsimpletest_save_restore: $(LIBZMUMPS) $$@.o $(FL) -o $@ $(OPTL) zsimpletest_save_restore.o $(LIBZMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) c_example_save_restore: $(LIBDMUMPS) $$@.o $(FL) -o $@ $(OPTL) $@.o $(LIBDMUMPS) $(LORDERINGS) $(LIBS) $(LIBBLAS) $(LIBOTHERS) .SUFFIXES: .c .F .o .F.o: $(FC) $(OPTF) -I. -I$(topdir)/include -I$(topdir)/src $(INCS) -c $*.F $(OUTF)$*.o .c.o: $(CC) $(OPTC) $(CDEFS) -I. -I$(topdir)/include -I$(topdir)/src $(INCS) -c $*.c $(OUTC)$*.o $(libdir)/libsmumps$(PLAT)$(LIBEXT): @echo 'Error: you should build the library' $@ 'first' exit 1 $(libdir)/libdmumps$(PLAT)$(LIBEXT): @echo 'Error: you should build the library' $@ 'first' exit 1 $(libdir)/libcmumps$(PLAT)$(LIBEXT): @echo 'Error: you should build the library' $@ 'first' exit 1 $(libdir)/libzmumps$(PLAT)$(LIBEXT): @echo 'Error: you should build the library' $@ 'first' exit 1 $(LIBMUMPS_COMMON): @echo 'Error: you should build the library' $@ 'first' exit 1 clean: $(RM) *.o [sdcz]simpletest c_example multiple_arithmetics_example ssimpletest_save_restore dsimpletest_save_restore csimpletest_save_restore zsimpletest_save_restore c_example_save_restore MUMPS_5.4.1/examples/README0000664000175000017500000000500014102210473015411 0ustar jylexceljylexcel * Supposing the MUMPS libraries with appropriate arithmetic have been generated, you may compile the example drivers by typing either make (which defaults to make d) make s make d make c make z make multi or make all * For the small Fortran driver, see comments in simpletest.F and try for example "mpirun -np 2 ./ssimpletest < input_simpletest_real" "mpirun -np 2 ./dsimpletest < input_simpletest_real" "mpirun -np 2 ./csimpletest < input_simpletest_cmplx" "mpirun -np 2 ./zsimpletest < input_simpletest_cmplx" if you are using the parallel version of MUMPS, or "./ssimpletest < input_simpletest_real" "./dsimpletest < input_simpletest_real" "./csimpletest < input_simpletest_cmplx" "./zsimpletest < input_simpletest_cmplx" if you are using the sequential version. The solution should be (1,2,3,4,5) * For the small C driver, only an example using double arithmetic is available. Try for example "mpirun -np 3 ./c_example" (parallel version),or "./c_example" (sequential version). The solution should be (1,2) * For multiple instances using different arithmetics, a small example is available in multiple_arithmetics_example.F. Supposing the MUMPS libraries with all arithmetic have been generated, you may compile the example driver by typing : make multi Then try for example: "mpirun -np 3 ./multiple_arithmetics_example" (parallel version),or "./multiple_arithmetics_example" (sequential version). * For the small Fortran driver using the save/restore feature, see comments in simpletest_save_restore.F and try for example "mpirun -np 2 ./ssimpletest_save_restore < input_simpletest_real" "mpirun -np 2 ./dsimpletest_save_restore < input_simpletest_real" "mpirun -np 2 ./csimpletest_save_restore < input_simpletest_cmplx" "mpirun -np 2 ./zsimpletest_save_restore < input_simpletest_cmplx" if you are using the parallel version of MUMPS, or "./ssimpletest_save_restore < input_simpletest_real" "./dsimpletest_save_restore < input_simpletest_real" "./csimpletest_save_restore < input_simpletest_cmplx" "./zsimpletest_save_restore < input_simpletest_cmplx" if you are using the sequential version. The solution should be (1,2,3,4,5) * For the small C driver using the save/restore feature, only an example using double arithmetic is available. Try for example "mpirun -np 3 ./c_example_save_restore" (parallel version),or "./c_example_save_restore" (sequential version). The solution should be (1,2) MUMPS_5.4.1/examples/c_example_save_restore.c0000664000175000017500000001177514102210474021434 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * */ /* Example program using the C interface to the * double real arithmetic version of MUMPS, dmumps_c. * We solve the system A x = RHS with * A = diag(1 2) and RHS = [1 4]^T * Solution is [1 2]^T */ #include #include #include "mpi.h" #include "dmumps_c.h" #define JOB_INIT -1 #define JOB_END -2 #define USE_COMM_WORLD -987654 #if defined(MAIN_COMP) /* * Some Fortran compilers (COMPAQ fort) define "main" in * their runtime library while a Fortran program translates * to MAIN_ or MAIN__ which is then called from "main". * We defined argc/argv arbitrarily in that case. */ int MAIN__(); int MAIN_() { return MAIN__(); } int MAIN__() { int argc=1; char * name = "c_example_save_restore"; char ** argv ; #else int main(int argc, char ** argv) { #endif DMUMPS_STRUC_C id_save,id_restore; MUMPS_INT n = 2; MUMPS_INT8 nnz = 2; MUMPS_INT irn[] = {1,2}; MUMPS_INT jcn[] = {1,2}; double a[2]; double rhs[2]; int error = 0; /* When compiling with -DINTSIZE64, MUMPS_INT is 64-bit but MPI ilp64 versions may still require standard int for C interface. */ /* MUMPS_INT myid, ierr; */ int myid, ierr; #if defined(MAIN_COMP) argv = &name; #endif ierr = MPI_Init(&argc, &argv); ierr = MPI_Comm_rank(MPI_COMM_WORLD, &myid); /* Define A and rhs */ rhs[0]=1.0;rhs[1]=4.0; a[0]=1.0;a[1]=2.0; /* Initialize MUMPS save instance. Use MPI_COMM_WORLD */ id_save.comm_fortran=USE_COMM_WORLD; id_save.par=1; id_save.sym=0; id_save.job=JOB_INIT; dmumps_c(&id_save); /* Define the problem on the host */ if (myid == 0) { id_save.n = n; id_save.nnz =nnz; id_save.irn=irn; id_save.jcn=jcn; id_save.a = a; } #define ICNTL(I) icntl[(I)-1] /* macro s.t. indices match documentation */ /* No outputs */ id_save.ICNTL(1)=-1; id_save.ICNTL(2)=-1; id_save.ICNTL(3)=-1; id_save.ICNTL(4)=0; /* Call the MUMPS package on the save instance (analyse and factorization). */ id_save.job=4; dmumps_c(&id_save); /* MUMPS save feature on the save instance. */ strcpy(id_save.save_prefix,"csave_restore"); strcpy(id_save.save_dir,"/tmp"); if (myid == 0) { printf("Saving MUMPS instance in %s with prefix %s.\n", id_save.save_dir, id_save.save_prefix); } id_save.job=7; dmumps_c(&id_save); if (id_save.infog[0]<0) { printf("\n (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } /* Terminate the save instance. */ id_save.job=JOB_END; dmumps_c(&id_save); if (!error) { /* Initialize MUMPS restore instance. Use MPI_COMM_WORLD */ id_restore.comm_fortran=USE_COMM_WORLD; id_restore.par=1; id_restore.sym=0; id_restore.job=JOB_INIT; dmumps_c(&id_restore); /* Define the rhs on the host */ if (myid == 0) { id_restore.rhs = rhs; } /* No outputs */ id_save.ICNTL(1)=-1; id_save.ICNTL(2)=-1; id_save.ICNTL(3)=-1; id_save.ICNTL(4)=0; /* MUMPS restore feature on restore instance. */ if (myid == 0) { printf("Restoring MUMPS instance in %s with prefix %s.\n", id_save.save_dir, id_save.save_prefix); } strcpy(id_restore.save_prefix,"csave_restore"); strcpy(id_restore.save_dir,"/tmp"); id_restore.job=8; dmumps_c(&id_restore); if (id_save.infog[0]<0) { printf("\n (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } } if (!error) { /* Call the MUMPS package on restore instance (solve). */ if (myid == 0) { printf("Calling MUMPS package (solve).\n"); } id_restore.job=3; dmumps_c(&id_restore); if (id_save.infog[0]<0) { printf("=> (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } /* Deletes the saved and the OOC files. */ if (myid == 0) { printf("Removing save files.\n"); } id_restore.job=-3; dmumps_c(&id_restore); if (id_save.infog[0]<0) { printf("=> (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id_save.infog[0], id_save.infog[1]); error = 1; } else if (myid == 0) { printf(" DONE\n\n"); } /* Terminate the restore instance. */ id_restore.job=JOB_END; dmumps_c(&id_restore); } if (myid == 0) { if (!error) { printf("Solution is : (%8.2f %8.2f)\n", rhs[0],rhs[1]); } else { printf("An error has occured, please check error code returned by MUMPS.\n"); } } ierr = MPI_Finalize(); return 0; } MUMPS_5.4.1/examples/ssimpletest.F0000664000175000017500000000472214102210474017227 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' TYPE (SMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL SMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL SMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL SMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/input_simpletest_real0000664000175000017500000000027514102210474021101 0ustar jylexceljylexcel5 :N 12 :NZ 1 2 3.0 2 3 -3.0 4 3 2.0 5 5 1.0 2 1 3.0 1 1 2.0 5 2 4.0 3 4 2.0 2 5 6.0 3 2 -1.0 1 3 4.0 3 3 1.0 :values 20.0 24.0 9.0 6.0 13.0 :RHS MUMPS_5.4.1/examples/multiple_arithmetics_example.F0000664000175000017500000000753014102210473022614 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_MULTIPLE_ARITHMETICS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' INCLUDE 'dmumps_struc.h' INCLUDE 'cmumps_struc.h' INCLUDE 'zmumps_struc.h' TYPE (SMUMPS_STRUC) smumps_par TYPE (DMUMPS_STRUC) dmumps_par TYPE (CMUMPS_STRUC) cmumps_par TYPE (ZMUMPS_STRUC) zmumps_par INTEGER IERR CALL MPI_INIT(IERR) C Define a communicator for the packages. smumps_par%COMM = MPI_COMM_WORLD dmumps_par%COMM = smumps_par%COMM cmumps_par%COMM = smumps_par%COMM zmumps_par%COMM = smumps_par%COMM C Initialize all instances of the package C for L U factorization (sym = 0, with working host) smumps_par%JOB = -1 smumps_par%SYM = 0 smumps_par%PAR = 1 CALL SMUMPS(smumps_par) IF (smumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " smumps_par%INFOG(1)= ", smumps_par%INFOG(1), & " smumps_par%INFOG(2)= ", smumps_par%INFOG(2) GOTO 500 END IF dmumps_par%JOB = smumps_par%JOB dmumps_par%SYM = smumps_par%SYM dmumps_par%PAR = smumps_par%PAR cmumps_par%JOB = smumps_par%JOB cmumps_par%SYM = smumps_par%SYM cmumps_par%PAR = smumps_par%PAR zmumps_par%JOB = smumps_par%JOB zmumps_par%SYM = smumps_par%SYM zmumps_par%PAR = smumps_par%PAR CALL DMUMPS(dmumps_par) IF (dmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " dmumps_par%INFOG(1)= ", dmumps_par%INFOG(1), & " dmumps_par%INFOG(2)= ", dmumps_par%INFOG(2) GOTO 500 END IF CALL CMUMPS(cmumps_par) IF (cmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " cmumps_par%INFOG(1)= ", cmumps_par%INFOG(1), & " cmumps_par%INFOG(2)= ", cmumps_par%INFOG(2) GOTO 500 END IF CALL ZMUMPS(zmumps_par) IF (zmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " zmumps_par%INFOG(1)= ", zmumps_par%INFOG(1), & " zmumps_par%INFOG(2)= ", zmumps_par%INFOG(2) GOTO 500 END IF IF ( smumps_par%MYID .eq. 0 )THEN write(6,'(A)') "Creation of all instaces went well" ENDIF C Destroy the instances (deallocate internal data structures) smumps_par%JOB = -2 CALL SMUMPS(smumps_par) IF (smumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " smumps_par%INFOG(1)= ", smumps_par%INFOG(1), & " smumps_par%INFOG(2)= ", smumps_par%INFOG(2) GOTO 500 END IF dmumps_par%JOB = smumps_par%JOB cmumps_par%JOB = smumps_par%JOB zmumps_par%JOB = smumps_par%JOB CALL DMUMPS(dmumps_par) IF (dmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " dmumps_par%INFOG(1)= ", dmumps_par%INFOG(1), & " dmumps_par%INFOG(2)= ", dmumps_par%INFOG(2) GOTO 500 END IF CALL CMUMPS(cmumps_par) IF (cmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " cmumps_par%INFOG(1)= ", cmumps_par%INFOG(1), & " cmumps_par%INFOG(2)= ", cmumps_par%INFOG(2) GOTO 500 END IF CALL ZMUMPS(zmumps_par) IF (zmumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " zmumps_par%INFOG(1)= ", zmumps_par%INFOG(1), & " zmumps_par%INFOG(2)= ", zmumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END PROGRAM MUMPS_MULTIPLE_ARITHMETICS_TEST MUMPS_5.4.1/examples/zsimpletest.F0000664000175000017500000000472214102210474017236 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_struc.h' TYPE (ZMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL ZMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL ZMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL ZMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/csimpletest.F0000664000175000017500000000472214102210474017207 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'cmumps_struc.h' TYPE (CMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL CMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL CMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL CMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/c_example.c0000664000175000017500000000461214102210473016642 0ustar jylexceljylexcel/* * * This file is part of MUMPS 5.4.1, released * on Tue Aug 3 09:49:43 UTC 2021 * */ /* Example program using the C interface to the * double real arithmetic version of MUMPS, dmumps_c. * We solve the system A x = RHS with * A = diag(1 2) and RHS = [1 4]^T * Solution is [1 2]^T */ #include #include #include "mpi.h" #include "dmumps_c.h" #define JOB_INIT -1 #define JOB_END -2 #define USE_COMM_WORLD -987654 #if defined(MAIN_COMP) /* * Some Fortran compilers (COMPAQ fort) define "main" in * their runtime library while a Fortran program translates * to MAIN_ or MAIN__ which is then called from "main". * We defined argc/argv arbitrarily in that case. */ int MAIN__(); int MAIN_() { return MAIN__(); } int MAIN__() { int argc=1; char * name = "c_example"; char ** argv ; #else int main(int argc, char ** argv) { #endif DMUMPS_STRUC_C id; MUMPS_INT n = 2; MUMPS_INT8 nnz = 2; MUMPS_INT irn[] = {1,2}; MUMPS_INT jcn[] = {1,2}; double a[2]; double rhs[2]; /* When compiling with -DINTSIZE64, MUMPS_INT is 64-bit but MPI ilp64 versions may still require standard int for C interface. */ /* MUMPS_INT myid, ierr; */ int myid, ierr; int error = 0; #if defined(MAIN_COMP) argv = &name; #endif ierr = MPI_Init(&argc, &argv); ierr = MPI_Comm_rank(MPI_COMM_WORLD, &myid); /* Define A and rhs */ rhs[0]=1.0;rhs[1]=4.0; a[0]=1.0;a[1]=2.0; /* Initialize a MUMPS instance. Use MPI_COMM_WORLD */ id.comm_fortran=USE_COMM_WORLD; id.par=1; id.sym=0; id.job=JOB_INIT; dmumps_c(&id); /* Define the problem on the host */ if (myid == 0) { id.n = n; id.nnz =nnz; id.irn=irn; id.jcn=jcn; id.a = a; id.rhs = rhs; } #define ICNTL(I) icntl[(I)-1] /* macro s.t. indices match documentation */ /* No outputs */ id.ICNTL(1)=-1; id.ICNTL(2)=-1; id.ICNTL(3)=-1; id.ICNTL(4)=0; /* Call the MUMPS package (analyse, factorization and solve). */ id.job=6; dmumps_c(&id); if (id.infog[0]<0) { printf(" (PROC %d) ERROR RETURN: \tINFOG(1)= %d\n\t\t\t\tINFOG(2)= %d\n", myid, id.infog[0], id.infog[1]); error = 1; } /* Terminate instance. */ id.job=JOB_END; dmumps_c(&id); if (myid == 0) { if (!error) { printf("Solution is : (%8.2f %8.2f)\n", rhs[0],rhs[1]); } else { printf("An error has occured, please check error code returned by MUMPS.\n"); } } ierr = MPI_Finalize(); return 0; } MUMPS_5.4.1/examples/input_simpletest_cmplx0000664000175000017500000000050214102210474021272 0ustar jylexceljylexcel5 : N 12 : NZ 1 2 (3.0,0.0) 2 3 (-3.0,0.0) 4 3 (2.0,0.0) 5 5 (1.0,0.0) 2 1 (3.0,0.0) 1 1 (2.0,0.0) 5 2 (4.0,0.0) 3 4 (2.0,0.0) 2 5 (6.0,0.0) 3 2 (-1.0,0.0) 1 3 (4.0,0.0) 3 3 (1.0,0.0) (20.0,0.0) (24.0,0.0) (9.0,0.0) (6.0,0.0) (13.0,0.0) : RHS MUMPS_5.4.1/examples/zsimpletest_save_restore.F0000664000175000017500000001217214102210474022015 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'zmumps_struc.h' TYPE (ZMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL ZMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL ZMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL ZMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL ZMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instace. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL ZMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL ZMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL ZMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL ZMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL ZMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/ssimpletest_save_restore.F0000664000175000017500000001217214102210474022006 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST_SAVE_RESTORE IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'smumps_struc.h' TYPE (SMUMPS_STRUC) mumps_par_save, mumps_par_restore INTEGER IERR, I CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par_save%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par_save%JOB = -1 mumps_par_save%SYM = 0 mumps_par_save%PAR = 1 CALL SMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par_save%MYID .eq. 0 ) THEN READ(5,*) mumps_par_save%N READ(5,*) mumps_par_save%NZ ALLOCATE( mumps_par_save%IRN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%JCN ( mumps_par_save%NZ ) ) ALLOCATE( mumps_par_save%A( mumps_par_save%NZ ) ) DO I = 1, mumps_par_save%NZ READ(5,*) mumps_par_save%IRN(I),mumps_par_save%JCN(I) & ,mumps_par_save%A(I) END DO END IF C Activate OOC mumps_par_save%ICNTL(22)=1 C Call package for factorization mumps_par_save%JOB = 4 CALL SMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Call package for save mumps_par_save%JOB = 7 mumps_par_save%SAVE_DIR="/tmp" mumps_par_save%SAVE_PREFIX="mumps_simpletest_save" CALL SMUMPS(mumps_par_save) IF (mumps_par_save%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_save%INFOG(1)= ", mumps_par_save%INFOG(1), & " mumps_par_save%INFOG(2)= ", mumps_par_save%INFOG(2) GOTO 500 END IF C Deallocate user data IF ( mumps_par_save%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_save%IRN ) DEALLOCATE( mumps_par_save%JCN ) DEALLOCATE( mumps_par_save%A ) END IF C Destroy the instance (deallocate internal data structures) mumps_par_save%JOB = -2 CALL SMUMPS(mumps_par_save) C Now mumps_par_save has be destroyed C We use a new instance mumps_par_restore to finish the computation C Define a communicator for the package on the new instace. mumps_par_restore%COMM = MPI_COMM_WORLD C Initialize a new instance of the package C for L U factorization (sym = 0, with working host) mumps_par_restore%JOB = -1 mumps_par_restore%SYM = 0 mumps_par_restore%PAR = 1 CALL SMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Call package for restore with OOC feature mumps_par_restore%JOB = 8 mumps_par_restore%SAVE_DIR="/tmp" mumps_par_restore%SAVE_PREFIX="mumps_simpletest_save" CALL SMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Define rhs on the host (processor 0) IF ( mumps_par_restore%MYID .eq. 0 ) THEN ALLOCATE( mumps_par_restore%RHS ( mumps_par_restore%N ) ) DO I = 1, mumps_par_restore%N READ(5,*) mumps_par_restore%RHS(I) END DO END IF C Call package for solution mumps_par_restore%JOB = 3 CALL SMUMPS(mumps_par_restore) IF (mumps_par_restore%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par_restore%INFOG(1)= ", & mumps_par_restore%INFOG(1), & " mumps_par_restore%INFOG(2)= ", & mumps_par_restore%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par_restore%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ', & (mumps_par_restore%RHS(I),I=1,mumps_par_restore%N) END IF C Deallocate user data IF ( mumps_par_restore%MYID .eq. 0 )THEN DEALLOCATE( mumps_par_restore%RHS ) END IF C Delete the saved files C Note mumps_par_restore%ICNTL(34) is kept to default (0) to suppress C also the OOC files. mumps_par_restore%JOB = -3 CALL SMUMPS(mumps_par_restore) C Destroy the instance (deallocate internal data structures) mumps_par_restore%JOB = -2 CALL SMUMPS(mumps_par_restore) 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/examples/dsimpletest.F0000664000175000017500000000472214102210474017210 0ustar jylexceljylexcelC C This file is part of MUMPS 5.4.1, released C on Tue Aug 3 09:49:43 UTC 2021 C PROGRAM MUMPS_TEST IMPLICIT NONE INCLUDE 'mpif.h' INCLUDE 'dmumps_struc.h' TYPE (DMUMPS_STRUC) mumps_par INTEGER IERR, I INTEGER(8) I8 CALL MPI_INIT(IERR) C Define a communicator for the package. mumps_par%COMM = MPI_COMM_WORLD C Initialize an instance of the package C for L U factorization (sym = 0, with working host) mumps_par%JOB = -1 mumps_par%SYM = 0 mumps_par%PAR = 1 CALL DMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Define problem on the host (processor 0) IF ( mumps_par%MYID .eq. 0 ) THEN READ(5,*) mumps_par%N READ(5,*) mumps_par%NNZ ALLOCATE( mumps_par%IRN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%JCN ( mumps_par%NNZ ) ) ALLOCATE( mumps_par%A( mumps_par%NNZ ) ) ALLOCATE( mumps_par%RHS ( mumps_par%N ) ) DO I8 = 1, mumps_par%NNZ READ(5,*) mumps_par%IRN(I8),mumps_par%JCN(I8),mumps_par%A(I8) END DO DO I = 1, mumps_par%N READ(5,*) mumps_par%RHS(I) END DO END IF C Call package for solution mumps_par%JOB = 6 CALL DMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF C Solution has been assembled on the host IF ( mumps_par%MYID .eq. 0 ) THEN WRITE( 6, * ) ' Solution is ',(mumps_par%RHS(I),I=1,mumps_par%N) END IF C Deallocate user data IF ( mumps_par%MYID .eq. 0 )THEN DEALLOCATE( mumps_par%IRN ) DEALLOCATE( mumps_par%JCN ) DEALLOCATE( mumps_par%A ) DEALLOCATE( mumps_par%RHS ) END IF C Destroy the instance (deallocate internal data structures) mumps_par%JOB = -2 CALL DMUMPS(mumps_par) IF (mumps_par%INFOG(1).LT.0) THEN WRITE(6,'(A,A,I6,A,I9)') " ERROR RETURN: ", & " mumps_par%INFOG(1)= ", mumps_par%INFOG(1), & " mumps_par%INFOG(2)= ", mumps_par%INFOG(2) GOTO 500 END IF 500 CALL MPI_FINALIZE(IERR) STOP END MUMPS_5.4.1/LICENSE0000664000175000017500000000501014102210467013724 0ustar jylexceljylexcel Copyright 1991-2021 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, Mumps Technologies, University of Bordeaux. This version of MUMPS is provided to you free of charge. It is released under the CeCILL-C license (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and https://cecill.info/licences/Licence_CeCILL-C_V1-en.html), except for variants of AMD ordering and xMUMPS_TRUNCATED_RRQR derived from the LAPACK package distributed under BSD 3-clause license (see headers of ana_orderings.F and lr_core.F), and except for the external and optional ordering PORD provided in a separate directory PORD (see PORD/README for License information). You can acknowledge (using references [1] and [2]) the contribution of this package in any scientific publication dependent upon the use of the package. Please use reasonable endeavours to notify the authors of the package of this publication. [1] P. R. Amestoy, I. S. Duff, J. Koster and J.-Y. L'Excellent, A fully asynchronous multifrontal solver using distributed dynamic scheduling, SIAM Journal on Matrix Analysis and Applications, Vol 23, No 1, pp 15-41 (2001). [2] P. R. Amestoy, A. Buttari, J.-Y. L'Excellent and T. Mary, Performance and scalability of the block low-rank multifrontal factorization on multicore architectures, ACM Transactions on Mathematical Software, Vol 45, Issue 1, pp 2:1-2:26 (2019) As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the software's author, the holder of the economic rights, and the successive licensors have only limited liability. In this respect, the user's attention is drawn to the risks associated with loading, using, modifying and/or developing or reproducing the software by the user in light of its specific status of free software, that may mean that it is complicated to manipulate, and that also therefore means that it is reserved for developers and experienced professionals having in-depth computer knowledge. Users are therefore encouraged to load and test the software's suitability as regards their requirements in conditions enabling the security of their systems and/or data to be ensured and, more generally, to use and operate it in the same conditions as regards security. The fact that you are presently reading this means that you have had knowledge of the CeCILL-C license and that you accept its terms. MUMPS_5.4.1/doc/0000775000175000017500000000000014102210473013465 5ustar jylexceljylexcelMUMPS_5.4.1/doc/userguide_5.4.1.pdf0000664000175000017500000313762414102210473016721 0ustar jylexceljylexcel%PDF-1.5 %ÐÔÅØ 5 0 obj << /Type /ObjStm /N 100 /First 817 /Length 1605 /Filter /FlateDecode >> stream xÚWÛRÛH}÷Wô#TaÐ\tKeSä²ÙÂÂdŸxÛc¬Š,¹F#ûõ{Z’`äÝÐŒ4}ºûô™ž±¦€R¥¤C’büW$"!f1F1á… $IAR†$5É(ð(Å!SR±&%I* *Réßc ›L Š„ ­) ÅŽ£DcÅÀÕ)bH)D(©†% ³ˆ’˜Rx‰n„‡   Hã‰A„`ƒ4 ‡X"8ôXr>xr^:¢‰ÉOd¦f‚\U„'ðt ±­¢A<&„ð…Nñx!2K"v¼!@SàE -e¦¯˜<ö00k5ã;¿M‚&b Ø5È)“Îü§š“À$M0Ì¿Œš²È€óæ:I“j"’àZP…Ô0à2‚))Ù3ˆ—Rs–Š«—rº¤\j +Ý$Ž3‚‰Ôš@Ö bF}dÀ;b’¡–Ì!ëÈaÃ#xx+#®j%ãˆ)r(æV>Ë$"býh¦Èi‹!œ@1m6Á*` T ɃƒH2ð'Ч!,¿0ÔNɨ¡–µÉ–$ÅJ+Ys<( â TP…œ*¨8/‰ ªæÌ£Št:xÿžÎÆtö¥¼+éì#Uvê³²8ÇôáÃàèká]9«›wÇ{Ëvñ·Òۊ楣º²®¢rN¥_XG˜a]ófô}t3~ªžlÐÖÎ/¦x°WåCÏòÎýEV÷LÓr¹2>›dyæŸ{,Ukù}õàÌ,+hbý“µ-³i8›[SÙªEÿŠ2wå²M”ÂSu’/7SìÞ† ß„;Ûp@ï‹Þ„§rNöF¿ ìÂýu¸ÄÝzC%eEåMž^BYUÕûŠ° Ô)aŒºáå£E/N28o Ĺ5¾v¶'ÅäQ¾à4ØÎ18$ÇdkCY77SKO™_¶¬Ï*2ÅŒnŒk'¥›YÏÕ!Èr/òøòúîòÏúnØÍþv·A¾^~»»º?Áýñ;ÊàÇ4ì:;Ï »´…?Kïb ƲÎaŸ™ÂäÏUvPDáŠl"ªVÆU'{Xøá‚Ó­²™=.ÚÓŒvYrÓ˹Y1‰¹}´ÍdÖ<ˆÛß;¶F&+h^ÍKƒ6”Ù—Öw@ P/bYÕž–Æ»ì'÷UŒz ;-Ü8»råÔVÕëñn›tAß”•¾””µ¡÷Ѩ¶þÒP/aÚQC£[´lŸM«ž4:u}«óœVÙcéÉ•O4³Þî;¼¶­;U]âì¨}ÛuP0CU™×/³’šfÈi]Ž°ùR°[È»obö*yã®SݸÌ™k–™w¦¨Vee‘ósåí²¢ëßK÷dÜŒlžáÌj#ŸÕ®« /]ö9 ÿ®å;´Ž%ZÐtsf÷¦kÚ—h*SÓq߯:´†wHý©t?8à$HK×ÐIntóu8wÖ®î3“›JO²‚½ ©ã²Î=²wÖÌPtœ?`µê+„X_"ªu)/®ÎÇdz[p@ôåÓht×\‹ªç%ÈO~†ŒVí«kÑiüºöÃr>œ–ή·ésŸi'ðØŽ…Rôumo N­jNUpƒ ຖv>ìmePo-R´gÓ²˜‹=ƒ¬'¹]òqoŠæˆn¯û£ñtQ»æ"—7-¤©kf„Ù¯ýþþ¸/”Nåy9ýAWåÓðÖ?àïâêöþ¸Žú7C6Ï.ôºkטËÀwÛÏ lÚϽuûZnQ¸ÙÒ.Ëæ¶[TõrÕ8ª"€>ºM;6hÔgtk+ßHiï娳\ßsq¹ß*geM–TM—Åòê¡Ñ¡tJ<_­r4Œ&ðW⪵¤ÍæÍÂ5Õ_lã&¡›'Nä¶2'tÞ5'ôy»d'ÄÙâaøGРݵ{§‰ùþè¯ë‹}’Ûu¾¾•®ìÎùÇo˜ÿnÌmT¬­á:n¬ý#Å“9×is&5÷¼NG—Mjÿû†¨Þ]×¾þnÛ'N²åĺC õºAl®K[Mü\^F'ts~Ë,ý ¬=F endstream endobj 206 0 obj << /Type /ObjStm /N 100 /First 870 /Length 1601 /Filter /FlateDecode >> stream xÚ¥WÙnÛH|×Wô£ X6çà$rxoœÄ° èe$$") I;Î×o5¶lÑ»6©!§ººª§g(=Ÿ<’^LÊ')<òñK(Šù¢I‰kHÂçkD"ˆHJ ® ®>)!R¤"ŒÉ˜´Ä|呪ù‚¯š|ÆQ!ùQˆkD‡Ó‚Ž§%…xÚ§0R©Š8†Ž)òñ>Þb¾‚žâ«¦8Žq?Oñ z1Ø‚™ƒb qðOBz ‰Br®AŒ›añ'”çÕ¹ÅB$®!‰ ¬µÆ 5sŽk’HTøE@ºÅ‹ ·¦‚îV9ȸ_þºËÿSrk3$<µnG†ða¡Éº’Šá·bäE9Ü–#)­C·–œ%Y]ß ‚' ¬sPÀÀöû")€„ È·ªæ³á$wv“£”=ÜÚ5“»_ÅÊL,ñš…1Ö$¡Ø ¹© ëè®›} XÜûZ¥)­’Û¼$—ßÑÑê7¶¨ëÔ…·î]ãÖÝjf¸„¶Ø+Ѭë¸ùrÕc>«{ósË$3Y¹ªú€¶UøWîMÆ©Á§U]‘ ÛäÙ@õñN´ê:™/Êá¢n?ÉÔ6}(O«­UœÕê È/±nMmV ¢Ào\òšæÜ ²kH¨¯ƒ˜íŽÒ W=ÞÀ€{'Bôo{ß;^e2©RãhbÀ¥QìÍäMê boyóNlÁ/¿Š-s½çzÍ þã“ÀÚÛMbâN{ñp?ºÛg•«SoövºKÊzá´š>çGÙ”«éwDü ËôÜì„Þw\zĨÀ2Àøøž›N±¶§zßqéQ ]dÉÙ«žðêEyLàÚ2+þOÀÖ¾¼õ4EŽÓÆnOjÕºDV ^›BKoÈ;!ÁqåáŠi ú}šO~Ñe~7¼6Ù/ཿ¼†ÿ3kÊj{S~[ë»Wj~W癧Ýq1hVeõ[з¼'SâŒXà,šÖÙöBn‹€ÁÞ]]ôš¢6SòªDÀ Šw™]åÐ/Ú{cnY—¿¿½ÃÇ¢3º¶u-´cÑF½”‚NŸË|ÒøÌgØú‹nß+8—‹^xÝÒ°©ÝÞ=7(-Ïa¿Ú :Í.–«Ü•¼ù:»48hðGT íÚü75ÓêÐ ^¯7üq’uÂlÏâÖ½,ß±zÁû/ƒÿùy$Tøãæüºz[çõYq‰Ãâ¼Ï‘S´ÇÅ[®¿²j9Æn}[ÙìË5Óí®òTnqƒ.S4­<Ý:@>Ëf]€Yiç¶Þ!^6¿-¸kkÒ³¦?þ~9ˆÚû° ÆIÝƶ¼³üÝ°zꫦv)4ßõu{ÜŠü/âÜ©– endstream endobj 487 0 obj << /Length 1154 /Filter /FlateDecode >> stream xÚ•VKsÛ6¾ëWðVªSÂ`ou§é´gÒX™Ò ’9& €âº¿¾ .¨—Ýiz,¾}}»Kší2šý¼ ÿ±Þ®7o*ž1I8«D¶ÚÂV‘Fð¬%áJe«Mö1¿ûЇnëìt¿,xEó;í}·äUþeɪÜôÏxü.~i§ûÞ$Á{Û£ˆ[~ZýšIA„äYÁiXBÿ“V4^‚)å¹)‘e v&îÞÝ#dEaéÁ¥íT’ª©ç'€;‰eEÓº—Z?xãü7ˆ¸;tsB© V@l‘ ÏJRÓ Ÿ}‹ˆŠƒ&ð£˜À«»ƒˆX~‡+§|²áEèAS•A¨ëz2SB§Q¼Ixkœnÿ½çgï Vï5¬5erqõÐy0C±|cÛÃ`Æhœ¢ùÆøÖuk“.ÃÁÍ›˜(ë@鈂M…zÜàæG;=¨ªù …nÚ;|è‚flÒ˜LÀ1ÎE†MàÞÖ‡®,ÁÀ[í»`%Uò!µ ä‘ž$#w`„_ Š=jÉ芪¯`A .IMUUèÞ[„eQÿèÀ0·©¶f¼={ÐÛ8ož"eâAHｎùŸ ûüfÓùÇWìfMM”ÿÏð©Ï0ýfB’&¶ÿs*¤œÅÖfk§öû))°êm0óvnÓýW¤l=1v>˜½?J½âH¥ˆäì+a‚ EªÁ‘gßù4£^ô‰t~ì—S­$Ó7Gs“•ÀÜ ] Sê§Õâó"꤃’¥¤uÖÀÌ„?‹vX|üD³ ÜA_#%´ú§Ir€YcPÆÞg÷‹ßÿ'i$GŸa8sZgJšŸMäI ’")‹b@r+•ˆ&Iý2BN†¹ Ʀõi•Ü²érŽi8ì!³&ùÝÚ}g^&夙ÁôRòõœœ¤8xDùeoœˆs®~Ö ?^ÃI°í¬ñcŸÆß";ò1›w¿-®Íc¸ùBØs3†½/–̪˜tãˆu»›Wÿ;.þ? ŸòR4ŠÔ  °­á%¢³kNüþ­¦ endstream endobj 547 0 obj << /Length 2191 /Filter /FlateDecode >> stream xÚí\KsÛ¶ÞçWh)Í” v¦ Û7ÍuÇN<¶ÒMÚ-A6¦|h@ªIúë{H€EÒ¶^¾¶®¼ˆùA‚ß98ç; îhðñ²ÛÓñ»÷¿26ÀžK=NãÙæF\0S<O_‡gi’Ë$ÏFŽƒÁÈÅð tq—êàú£¹—pνâVhàä˜›à‘ƒBÃó$×#,†ét1ÉUšØ›š ¨ÜvË!ì‰s¹ƒ7 Ü "ö9ŸÒ\f#‡04œ¦Ú,2©íùtf·ù½´¿þ=ÂhÀÄ–Á,àÝhãÝ°'2¿šèå—Ë«›•iaAqÜÁ^ÏŸF’4F;”ù®Çà=ám™°ï閈 ÏîÃäN^¤w«P~uàÚ¡;r¦fãmºÙvÜËj\ % <ôWÎ>¢rÈJ!¨¤@¬NUêFg&i<su«"•ÿh?úô ù} O-ò_æw:œªä΀+óoR&æ VIµðµŒd˜É¬= áûo¸6qõúqé4î1…¹B°UKèp0ÀÌ¥.³šÖŒc×#ÕõyÚsËÀ%¸e[Ë0×£×2³+·¦.ûhG¾´4û¤"Ö•ŠCÀ+ Ñ– Û—lˆAr/²Y‘öñʆïK6œÊ~eCŽ}Ýøû’ Ú»l¬´W6ÁÚ²ÁÑEW8%•%¨¢²ó¶>\%YFQXF æL–-ºŽœþâžxÛá;ኺ€ è ³ŠB6”@î9·*¯àÍeñÓ]Íd˜/´ìð$¸æàÒnú ñ+'¤®Ø-.ƒ\ÔgL¸ëÁ“ÖD±‰yfÐ¥61*Kãg‹¤,„‘Ê•|4ߎˆK¹X7'´’zʃ¼šNÕ¯´~îÀ¿ª)´N¾Ÿ'ó…%Òq˜kõݾZªá°#î¬ÁzƇ·\¨´Îº_i9×éDfYßêÚÜMUú½”ÙZUþý*Ír§![s+‰¤²K»S™:Z§ëâÝ|èËgsÞéc~¸íÕ…Ñíõ»>ôPÒÕè'ËAY®&Uç88n\~E®ªLŸ‘%Ks«Ë¤¨È[eN‹SßÌÁT沧eà«ãùäÈ©·µ’W¥³4"ÓȱVÔ5´ žF‹œ–6g¢ “Ó¡Bõi JjÁCpRenÞpÄ}kïö€UUž›4ú»övu ë0Éæi&+»ð#ËeÜÉTsô¦›Oå¦h]´ùµpo©þVR m‘•‘ŠUÒPØéB·ÙGžjõOØg2|&ˆ÷íY…«ö‰Vù},ÁkÕÍO¬n~êpiñºìý v|±Ôjöy¿ž`&X‡GQܶFpc@|\íÒ°¤ú¯Ú|ÜCDS%nÊ°Ø_›Ö!qt:¿äØ@~yuîÌ´”{ÓñÈ‹ÙŸCÄèÞ­Jj…¹´ÈZ¼ˆrðZ†ÓŠËÌCFøݬCh8Ãä9ùöðQß—¬KýN/NlN²,§Ïe’Õääã‡ËËq¬¸a ÎWWÞ×pf§IÁú]ÒÙšiãÿ žAáó"wÒ™3Iµì$}:m¯Bð7±ø™ÿ?ë‚w=œ°·Îïç¯)ÄεEÈÊž›ÊjBL¬;ŠΛŠOY6|œ˜K<:`nàû¼lÛp<âŽì³!ܶ#4h\Æ\ŸñºÒñX¼- 4{øªìÊ ±¿~k£.¡~;…;”"¾–`ˆåûIšLÁ¬æNˆ2‘°Ò·ùåAið…ŽÔ«VWœ*ªŠ7“û…6‡ÅÇ‘Iך»–.vtùÌiýÐiñ2½iᾊnQ¶Ü¥þä]¦Øß1£‰…Ñ•Ó(üeqaò—Îu˜Ø3…ðO/®Ké,‰ÖL§I^E‚O&/ñ_5b·.û¸|TPªë‡ ±)šµTX|œ¶Ê_–)½ü'2œ¬—0üZªíÁöž¨lã* + U—œÆ2N—_'%Ù"ž/a\,Ùlx;Ãäuu%´ëB ÌB½ ‹lK³xöÞl®e–/Im;,÷Ù‘ÝDíLÍ7϶ˆ|ɪ^dã>ëò@½¼C[ö„=…à~m½¨ü²´àb=M”b9ÝGWcNÌÎé¤xâ|©IÃ]™Þé06'Îëù¶ŸÎ±†„nÖ}RaÔP_V·ž|”‰„ˆ¼“(¤øÿ@_B“w*Ír,ÛU®ÂÈúªŸŒjœØʱ=,‹M—fÏu¥Ò"UÇ #õÓŠy²Gã‘_4M®C šÑÓGEêú¨5~û|ÚÓŽ¹‹i}Mdex¹†E+<ÑE±þva.'ª"E‹ª{±·?LÀ(ÊZ¯õPìC¨úâ=ðÏÿØ^­]¸p|î‚ {äS:Øå®ÏÉ&šõKP}°;«íj™yÙ>U„Ñ·ÅRXÔ¡uo#ëÏÝ Þr¬qu@YàuQ«šÈa˜ÍzÛBx|+»Ï?îx¬ƒyc1ƒæ¤Ly`f—`N„+¨WýÍ‘Æïþ:Vò€ endstream endobj 608 0 obj << /Length 2535 /Filter /FlateDecode >> stream xÚå\ÛrÚÈ}÷WèªL»/êÛTù!ñxRɉ'>¶§RS™yA¶UÄ‘Äx’¯?ÝRKºØØ.…Xkïµ/½%èÝ{Ð{w«-HýQ/Ñ;Ê7WïŽÞÞüF±'€dÌ÷nîÚ÷/:„ßô»±‚!`[œd\ÄP‘Ó’}›…k]‚3aeâ×^8Ü1å‹r·øI>ù1´ ¤¢Èç6oØÁÛ]œL‚lõ¤kó{µö˜$Ìso! é³P”`}GôAš†“ÛqùvRc¥)¬¨8A9*äýÙï7õ¡´t•Õ°B\øÓ)4ß;9ÎÜ:3M§Ö«vj}˜…!—° XÞÚš1SW&¥ Zl ý5Jv·} {ólx9ð!ýqð¢ŽøVryŠŽñ1±1®Ã ¹‚Ut€•AœK ¬çãp¢Œ6·GúÝЫýˆžÛ:ý=f:²=îêJ#¨#Ο“(‹¦÷&ª>˜ - : YlP+Yx®^¡øÀe˜ÀöðÖsQÂKLy™„³$†iª þ¥? Håôa2™gAÅÓeP¿‡I<¸KBCÁ( îãié ÚNóéPiºâk5Q!äéàB»ex¤Êð.›° Z@Ô¤L}”–3³V*ëJ O]êÒÁB ¾°A/Ó³kcQë@T ÔC¥0•Ɖã„8ôUlM ]ÉÓ!ÃîÀ!âض¿FeÒo“I¨„{h ÇJ­¸„Ù˨4ÛêÖ!¿Ò¡ëFôŠÿôí…ÃL™öú°eç¼Û¸3D¶#bÙ*ovªû'Ú!;Q µ‰(µé]ÔÇÔÀm°“Q˜lÒ+!”~{à—3ëmrCÜ6³vvÛäÏé¶9ÙbíÙÂ\Uú]´Ô¡8Í–EY˜(×YðX€›„:{œæ¿e’L¾¨^J{ˆá*¶l-¶a’”¨<è[Yê.תûKXl 07šgƒøn0Œ“õ}E&r¹?ÞZ€™”¯­ÏEÚׯ1`7ê…aís_èˆð5Ãp±f¢‚w˜¤Z8ºÈoà‘ª”m›I«È´\ëÍÓÐx÷cÕ~çjÛ‹Òä¿C+#@ _-v¥áâ÷ùØTb3£öX]³é"$±Þõhê6EÏp‘M­[Ô"vû[»füežÛ;C€R¶êAªó½Ìa8š–wÚäãnr$ešjoö«Í È6J9ÙêPéQj¥XlÅ“ÙR%R®W;í[É$šÓlCm¢Í@B¶¦ AÄŸY Ú• !V¡ˆpÁÆo:Ÿ“\œ+ Ç‘†AÑh¾(WN}6+ WÕb6GxkŽ(%OÀ†“¿CàQ¶J|‹RÐpÝ?dƒ‡E‹4…«]Óx~ž¦Ï; Å5ÑË6¹ñ»–w»S@ pe¯-½Ác„Ü«ðÉóÑ¡s-¶_€ý¦ŸÛ”2ö,ÎÇA¢ß“Þ0ж¯_é G‘Ðûêdè÷šŒ_t"io˜§HyÄÕé)ˆHÉ{~u®x&kÀ¨®–T™Ð›âŸx*¯åœåíD!óP–¡Ή¬G§U¸v‘<À‚*qÔÆçÎD¨]„ŽàßÖ…Ýî‹^éšß¾Î@É&K “µ&k–³‹Æ:‰âèIc´KXDèpÊ ;•AYëꊶF£[ò@Æ¢#üJì:ú3³”.Ì•^S!rÕ-Æwô{Þ{Œ²‡â“$͇š!½;®ŸŽtŠiv×õ\\WýI“4ªÊÈ'¶8¢¦u0ª,Gðõý»Q¦±Rz/̃m]s1ê¿H™ÝgþF[Ï à–M–µ‹%ÏÆLõ˺™æŠ¡jÀò°ÛoK­Ê ]/)— °Í2 b_Õ5mß ÄêÒ0ò€â5Z»Ô5«á®!Ôníú—ë¿ÅÖYžDŸ@O;4c%˜¸Œ—ìÇx‡*N¦ëm«]röC‰à͉¦ÂÍ U8IšŠâ´j·åUE9ÖÐ{«·ç–ˆÙC®¯ñ0Ô¼Ž\¢]°8-N‹-ZÆ»«?¶w@9¾o-±!Zù·ãxøµ¸¢…2®‚é×.o?^-֮oXBÕ­gÛc1¤ÝÍï[*J;íF7в1»“dñSd Ã Á€sÛ†iÃΧÁíØËUP˜çÓ|M)Ef8¥Åðç·§|!º'Åæ*Ì3‚åÄ­ÍÖ]3âÀ‹w\÷`¥î~Œ‡µÔ jöNƒI˜6,¸¦†ôm–ý ‰_0²ÐjY?„ãpÍŠu3€K†Òd'\Ÿ_Y¶ËÑ“5¼Y·Æ·oIP´˜†÷ùbÔwLƒ{çà4è•ö;@í¾ùq“p…™ã~Èé|r[Îb–ìÓ,œ^\–&a0ÚÐ2dÊǨÝ,@Ûw–} Ÿ×OkÔO¥Kë¢XýØ|B‰iñ“óá÷òÙ(}UÅ—ÏG©ÍøZ ÕűrÄkÍ×/5X½­!O ÍÃ@²P«Þ}Xõájji¾Ÿ¼ÖG~0²ebÕX®Â`|R4<5öÿvBž3ö‚ÑhktËû’õ©ªsn£Eûè6ÌÃê«™óNA‰ÅË7^Aœ<ÈCiìÍD€Sä©@jôjù?Uâ󨿾Πendstream endobj 407 0 obj << /Type /ObjStm /N 100 /First 865 /Length 2579 /Filter /FlateDecode >> stream xÚ½ZßoÛ8~÷_ÁǸ“È!‡?ÁiÚîhÑ¢é·[äAM”Ô8ÇÎÉrÑýï÷yÜ6ÛÔÖíY÷`P”ɇÃá GÁFcMpÖxFáLò(‚q6£dãXþÍÆe)‹!‹’È—Òb´§h(çY d¼ &à?ï Jg|q(ÃÐ&Èý<°ž¥M‘wdXð‚7œ¥M$; !™Ðb"” ¦ƒIÃ{6)‹³É2.“Á!D29‚~9cÜM!š…˜LA›¬)2nr2OyÀ„¹•sYš`ÊD+<¹Lxˆh“=’< æ; €p"œÑ‹…) \tòñÀÉ0æúaÂäeR ´K‚x–l >‚Îf iS)Á°…(—2ž’,Z#•Åâ+Öú0EÊ[œg]·êÌÕ¼¹Y®ÖýürO²íq†æËóê—WoÎÍu·º5g{9—ÝäO»®ùÝÌ—Ws°;Ðe7ÍõzÓ®M×.š¾½aõ[sfšå•y¾êú®YšËÕííf9¿lú‡'ü-¬ßÂ¨_è¶Þn–ýü¶5‹ù‡®éæéón•úö¦íþ† `©…4ÈÞ-ÚÏæªé›þ÷;Ìm¾¼?ŸÈq‹|ÞþgÓ‚`?µÝÿýxáœÕ>—¢&ÃX¯Nß½<}R¿¾ì›O-(ômwÝ<¼*;]ÄgŸ™ÁÚ¬®ÍfÝJ1hÂ^ÚÎ}ÑhèzÝÞB[¯DOQÞêJ_º¶hY7‹±]ý×®[ÞÂ÷ò¿Õ`…‘@תY›µü!Êz ×oÛ5´³5×mÓoPʼÞôæõµ9ÃûC£óØiwÏòª_bo.×ûªHϺöjÞ¯0ïå°´æ­©ŸÏû izr2«ßAÕMý¦¹igõÙ ê¶ì×8z’´œ ËÕ¦ƒú §èðêЛ'«Ïæ½Å 9`S¡‹ :ôÅa¶íN—Ë ÞË96 {1»7äðÿ¬~²ê®ÚnÀ²õ?ëõ*p .dôË´m®\a**r&qpð[¥PÐê|óAökýr¾üw}zr2àקƒPêóú—·/ä÷ècßßý£®o7·w뿯W lÎjÕÝÔÁJ‰}+£ýú”ÊÃgH8D—›ÅââG휵CC••Å‰úmc©.VÝù6±ñÛ>ošÛzih[}ö¹ÿùF§Å´åŬ~Ž…0²|ÏA±ºlâç·«ˆB» |‹²EÇ°õ3ç-d‡±ž>7õ»ösÿgùÿiÉ9|·är¤þÅ%/Û%ÿj[&-³–e(Å·Ú–NKÒÒk´d-£–Iˬ¥â9ÅsŠçÏ)žS<§xNñœâ9ÅsŠGŠGŠGŠGŠGŠGŠGŠGŠGŠGŠçÏ+žW.8=ŠÄiðÐ:Fœ&è0—0— ^BEœÔ³?Ì…'à’bEß¾pɱòs‰p‰\y˜à/\ê‘sIGäÂ0f0ÓˆâaÔ2BþXIÀ¼o£{lŽº­w|`åD&$ΈÄÂì«ÒHBlnœY ×8„ªy„ÉËȆ`û³3>Ú [§jÅ~”dò$Kål%‚‡kÊr%‹ÌÉ$DÇ'7«*p}¼åj¸³]†÷6’Ÿ€<†ŸŽr¨œÜrÂ8ÇÑK& ”RáæÂúàÐLøT±„‘„xB1VÑ—OB. a¦“ç‘„âñ½¬0OOÃ’É%j`ØÅä÷:ZãÁs•­ÜyÃá ˆvê|Ð¥ðSxZ¢‘«]Â~ØïW.t˜ËÖ888Á° G§óÂÍWÅûÃ\¦ØÝž'"b¸r“ï¨*iÌfòG^(%ä‹«J„{Ž]í3Ì Ütëx$¡ VËgh/bV‚3 Gt h9^­ œQŸ,vR‘ÌN)XœŒzɇ¹LàŒ"ŠÄ؆"'zÉ @™Ëa*ø¢öÎIÒ̪!†.¹RIPñ¹*96ÏÅ° ah„ÍËp!„ p%ˆàR€jq„Å+0qpf>D}1Ä v„ÁÓ»öãr’ 17ÑAY‚‡F™àX¢«åA‚DcåfõÌ#ÈL`é(#šOYòЕcèMA˜@#,›Ày „8AçBFR¾0Ã!¦d&°»Ø7CàMpÊ)‚†c>‚̆—B©äò•ý''äp •1Ë4é%Ø;¹¹¡*z茸žeŒ—Žï÷¥Š³8yðê =ýŸÉì$ã¢xR8lå{ƒÃ)1zDÝ¢¸1ò6êBŽ¡;ãÜ<7IàíJP7!ÐÀu汌&0.s%©Qéâ3ÂCµ¯ÊñUÙEÆ>‚ÏÉ'4Ib„ýwåa!Àûò Â'ùJ'ˆ3¼—Æ&ÏÉý8üÉ^)Ä(ùàQÀ“¨-¼†’$ÆãÎ`†ð„òµI9X(â˜~6–‘|Ž¹‹¯YrC^ÕÊç^$×FP\')ŽùÜ5]sÓ5w·\¦N±Uq»EÄM’vìFÊæžOóÔ¼—/ÑÆd™ïµs$Ž¯7 ~E8pÌ,ó½\ò½,ó·ùç(×Ï»Š|©Å»f^.ÎéÉ?Çm*÷Ûüs´õ“ùôk›WÝ•šGeÍ£²æQYó¨¬yÔ¨yÔ¨yÔ¨yÔ¨yÙ¨xQñ¢âEÅ‹Š/)^R¼¤xIñ’â%ÅKŠ—/)^ÚâÅ]^;+nÞÕIÿWü¬øú•ë'œ?+~Vü¬|u©YןU)X¿-à¢xšßgÍï³æ÷Yóû¬ùý¨ùý¨ùý¨ùý‹ãî̈`cÈñ sÁDûr|÷7ç—£îaöŸ endstream endobj 633 0 obj << /Length 961 /Filter /FlateDecode >> stream xÚíXßo›0~ï_Á#H‹ëŸ`?vU7mZÕ©Ížª=xÄét@¦í¿ß m’®Zµ­ÁØÜñÝÝç›opňÀO•èn.ß½ž¿"HÅ1æË€P¨`A,"ŒóEp&ÑŒ`ŒÃwÅ2¢",«•n²²ˆfTàðVWzeSÕÑçùûÞhp=£ 3JáÇïs< Û0ÄE‘ÊÛGÄz Z†Öó2Õ¹ûÛ”îjtúÕ»V•©©ë²{Ó$DÑL¾ûÂöžù¤Ëw­}á˜l Þw¸LïXG‡ßmØu–ë/¹qÃýã<a=IƒDˆ^¹'¼£ššu)­¢Â!.}IUUD$””Cq‘離¬›,ÀȈ"4TtG5µ¡µ†bgHyC§©¬¸±«Á=¶ågH(ëÚùçŸÎ?^ùYÛA"œt³–Îë•óútZù±Â¡Š«ü™PˆÊ®ö¥÷¿¯ý“ªÒ?Á¬Xdmc³*¡8þ¾$Vò‘¡6Q×k¿Derݘś¯¦K G…Ÿð&"vûh*íé#-W«u‘¥º¹‹8$þG‘dÉ ïŽ/&uÏåùÄ—‡Àp˜ËuÑd+ŸÅyö¥ÒUvßpöÿ~õhøE¯BcKãÆTÇá«Žk:©× ðÇmÞNýá7PÝèæçmGOY±›ˆÆÚ0!Ï•'†5ö°^™ok‰ÝÁøÝ¢ÂÝŠ½‘Éfù­ì¡ K Ì®R««Gùy~)Î?œ¼>¾Hmå7 z›.­¡ßZê;$¥±Úòs_•Hˆsæ쇶嫧\ºëº6ýÀT?JhÏ’‰|ìëÈ„£$îå&Áä@‘û!â’U"!V& «»Æ¤®Í Ú•EßžÀÍjÂà2þo3ZABoà?”Uq:DܾÀ.:q›eÿ9•8àÙãg#àÛý¯-Üaݦ÷ö|SÇw6}ô¦ï†=;ÊO´Ùºèì}’ÔNÄb$¾$¦FAâ>Hðàá QI÷†Íe$xñ²o,¸¥pk£wÝü¹òg;V_šz0ïÛÒèf]ùinS‚?ëÆ=¾ð®ŸÚCœ¶êPŒB‘Ñd‚¢xþT÷[ Ão»»½?±Áo”Zò€ó‰ÃÒõѺ„ÛãÞ±2¡N |ÈRSÔ£¯`1AŠmöoÂvIY·d¨8˜3rÚž$™EÖÔ{êe à}±}¡ý’$F cÖŒâÄ­âƒ5gó£_kÛž endstream endobj 667 0 obj << /Length 3637 /Filter /FlateDecode >> stream xÚÕZݓ㶠Ï_áG{3â—DµÓ‡K“t®s7Íôö¦Id›^kV–IÎÞæ¯/@ú²¼»¾Þ¤ÓE "A~-îÑâï_EþÿÛ»¯¾ùAëWLªX,îö .4Z.b£—|q·[ü´ä«5¢hù¶lë7ËjwÞ¶yU®~¹û †¥q¬ðûh±2¥/ß|ÿãO&dÂ0£P;ªŸ#ý,„|ÿ±hó}]•mV¬ÖfzŸ5M¾zùÛŠë¥-ž¨ûGleuVÖ~¨ "©a rêÏúÏèï”m²{K}UÓCçå½o<5­=ºÏÒeµ§Î"/mæ©í¯ç WïGX,›–’b©öËo8•tSI q:ƒ,ÖA o>y = à1ã=É_gÆHY"L ØÌÈZ3“v¢þøQÑòñ`k;3,BÁ®ŽfFƒåq™ '^Iâ•É²ÑÔ~ÉÍ)«ÿ|ÌÚ:ÿD4í!k©w›•ô°±ôÊæ °šúÎeót:‡&¨UVÞŸ gYRÑü¢ÜÍ ’'Œ‹nøó4I:Mr»ÃO§ùY¥Ÿ•­Ö NÕÛ½'r–«{KÏa5ÓlméO_ÌÁ~È9#øZMÍà&ð%4å;¿WŠƒAL“$v»1O &‘ß÷»gJ§L'|±|€Z%žÕ*øWêE­¢ÓªïæwU)=R+ †³¨¶ø˜‚mÈî«2[ñeAÝÆÝ#ÖÁ Q8ç}U½sº<ô…ðÍ’þýNv“Ô¸ñÆÂî@—¤Ô˯L´´ô®¶û0Žâ´E*ÃŽ¶º¶Ù.¸€SùÇàHOÌÒ»øÉ‹W£Üñá_ üŸ–Éx7Ðï]£uÚ›è“%ç7N âg·.Aògé­kHo!ºq~«”nÝ¥n@Þ:ík–· õfŽnêͪw«TÕÅ~ép2íý¹(¨kgÛ,/g2¢±± õ¦µÛC™ÿz¶°œ}í±Kq~§=tX¦ôਸ਼EÖÚ®ÑÎß’[pÉÔJÞ…©(L˜±åJ2)ÕõÉs Þ\ pä)A~5yäS[Ïö1 Àþ©ùóÄk™ˆÅGGÎRûèM|b"Gˆ€kç‡ß€Sxj€à‚Í°=ÙÀïε‹»b‰BŸÂ~%’NµLºµ€4ºÚÆZÏ Ä!ðÓ¤^¡A*†ÄΛÆR”êÚ’‰©Î¡×v³Å ©mqÞ x¡ç»^¨Ý O|Ùd] ýîvÂ$à¶ZæO3Ùã˜+HGöþÓ¬¶¨ØL†á1Q¼€ !J0ç2N•Z¨ð褱?*°ŠŒþ`u›ªpèZ—¨Žh]ˆK %xØsš´ÎT³ÈÈ°:ÔÃé4D@5E ûKT9Zš‚Ø<’ƒX ႪcÓÓÉm16Т࿛0Þ$VÂWí¹™B×}~Tÿ%&<=f)v3ë`)’T®l‘óÒKÐñàr-Öάa7ÓéÄ6=ƒ‡ä…øøÕ‘r¶Ci‚ض(úpÝçÆú§¶¢W¶isÀ–Ö÷,u—çãv¢±¯‚½©ì÷£öÑ3v–yFMé<À̉º¦eA5Áô±Û)Y´ü¶r€×¼.MÔÓÇËÆ‚—(Û<ó/ºˆ»Kí@§ó/&éU1Ø(ãtÈÛkû ×& ~Ø\X¶),"cXÈ;ÛÎcÍOÒÉ9N¢‹s¼†RoœOõœ~pŒRÁ=ôt;[V­¸ËÞÆÑ dn÷çÚ§d Ã§QÞåEKŒtCKŒí+–˜M]‘†hÜŒã'qƒ+úa¥½Æ¬Öà¼ÚÜà”P9_²&ný™Û6¶ô†I%‡Û6‡ •®Ç)éþg< ¨‹LÓJþϸ~.ÿ?¥# úy²åÎïv>z`¢´óÊR‚c~òûž‚i lI—Ä5ݪ§'¢S‚³Æýbg0  “å‰&¤ˆ/@wîsç+úoé9|ŠÇªnZ¿ —n>G"Òê2>×v’” ˆ „\:³ ˆ¤à€•[K…Q4¶‡R^jCúÎ?bcà%ðÓpRzzÕÙHƒ‘^ H°xÃךwEÎ Ü$e˜\OFd¾·–:†0rÎ Á•é_:çŒíëÎYTË ¯{ª{øŒ)|è¶ä8£Ÿ1gÂtÉFÎümà·Ë;}ª5ÚL@d Þ*«ÑÚJî0|s¨ ×Ë“Ï|ÃþW-Õ.€ˆÜR?âú«õæiíŸû U Ü5O:žÞE Ð{‘ Ç—Áãó¶ÚÙæš:¶.ÿµ–1龌•ƒÚØ®NùÄ5°ÏCGj4èš·D0]9†sìt iÇX Gt¾ÊŠÆn1Hù§¶g&/é4€já˧¹5llûh­³-€ ²æÁÀM²´%zú†?´ $ýÂSTüÀöÀÆ`³ÉñÓ¬´Õ¹)žV1ÆSëvà¬=~φÈÏ(8ëcr‡:Ž Æw]8ÇLŠB=Ôsž.ßì[‚ 3GÐEâ*À!µéL¡…n<µ§|@J{j©u©ƒÐ‰:œ—ëmUw• ý|‘;MŪH=®ŽÀ°¨¸éQ’Óª‰ä…¯•llŸ[ð©„v‚«õ( aâÝx¬2B7òtó¡Ã»/â²À:îÙ"ï¡g$:4ðiÆ7k&°Â4Bñ,gñ§f1çCH@UÒ ÷@æÓ HÀÅ+A‚°—AˆšæUFóa±T¿aCØnâÑ ëWxèÇ çÓ,÷ñÿ…¬®ÖA´£‰>c…/Ìx¥œ–°H¦/­Q½vÆQÄBµT«s3­s4' Š&wD0ëtYÙPê„ÞLÎïx³ÄŽ|"¹‡ ‹{óA@Ælzh×ß`”ïæ6&‰X«ç’ K£nþ ðå6÷iUAÝ-‰Ö¦¦‘§P_N o±ö%fK‚Ÿ &Ò‘þûqÈ£V›6Ë»8Wu¾?„ø¥+5‚qÓ9Â=niU?"tºœ[J&S>›ó IÙ9 ¢Æ|\¢~÷4w¶ÕÀ­¿6³üy§:aŠë—- (¿I{8Ç´άý!\+fôdïÇɈ5‘¡pKÎÔu3™ñVì«"”ö½Òlž®ë 8[Ù;ÛM¶}¸¢,*‚0>½UYlŒš08ë[ÁÂ'`á_á0.„öâ=Í×°Mœ<Ÿ•kËŒ»; °hZ±Ÿ÷–ªÿÂ[~™ÅÇK–/tŽ«Ä霚Õ9îï– ¶”*Q*E·˜ùšgP ;ó\ªbZ¨¡(87.{1¿ó_ÀΩjÚ¡m gþáÙUß7`ÿüÌeH©ç½šé¯ÃP uÂð}öÅMöÔàËÙ¨©Ä|Xðc÷Ì]‘¨Wµy™$BŒoè ïÖÅèžíqSPøžP$º+¯”mŽÛ(ºœ5QOý¼f$Ð5­Ç ?€FÌßD<¸Å=;žËAн3‰‡ÀyÜOE¹ŽúÁW˜< ÄK¶Ï€aÐ °ämëꃻ„.P­}¾ËÔã‹ÆŠŒ¶ _]‚DãÅÓšJ5¬`«öÃQæiG„r0X39…ƒ/ ˆAbrZ^¼_.ÖÆUGåÛï]†@Æ·b§6.—’zÜ =o)#C.u¸‚£o,ÖSZVñÝ«K²H<,`[3Îø|)`+Ï‘!Pvub¦ñlåM·â­*CäY¶ô‰§Äãk|hÝo!vŒ³FÐá¬{r“ÁW̤fH€ºá.3ŽØýz %š$ö) ºÀG_©[+Ì —Àcæ¹ñ7‘'ÊxF‡B–îo PÓ«ÐÏ/ao@¯wáå²m¯´&ú95ÛÜU’¾pIRö€9ÎÏëbÏ‚O'yÞ}>Z_Zë×°qI9| IjW¾VáòŽæõ#Þœ¦õh*ðME:Ÿ·.ëö5uÑÉWáÒ2öøÚœ«Ü¿{¬sŸTUæšlÖûÅó²Ñ½Ã §ó¥Æe«è)xÔÀXun×Õž2aÄrU¶”ìl]6:õÙhä18q:WäÎu4<$2­€¿±ÄÆxY šÏ§Á+­c°$¬Ð3µ§Ðs1zàtp§“và $~qè÷½ €«}ë9ñ=nb!ÝÕ Ò¥ÛéÖéøÿPÆUq;u¤šþ³¢=øRÐ]`øû[øÔÎKk2áEõ˜º_mQøCWyE~®[ñå‡-ÎqÕ€:ý—F.ß¿YqΗwïÞ|ûÍ?·íèâûÑzÐjA¢Ä—>ùnf×F_Ód¤¡ÃÛ{xrÞËÈQåÛ¤ÙŽƒ­ÛtôêId|5(º+W{SPjA±ÑLàÍ'ïŒö[¾øþî«ÿo;ô< endstream endobj 613 0 obj << /Type /ObjStm /N 100 /First 920 /Length 2821 /Filter /FlateDecode >> stream xÚÅ[]·|ß_ÁÇä!\v³ùu È–%aÁ²$‚`¬îòÁç;aoVþ}ªfgOþ’–±† `y†³;dmw³XÍæ¥d.¸”’ã5;­ ×â,²]]*ŠksEð<WñYÊâ$Á:ãMt¢5¯R6tù}¦Â›ì¤HÆMqR3ŸT§‡×›ÓiàœjáhâÔä0¬G*Ñine•Š\äGÉi+ 7ÙEQ¾^\TŒ“ÐE4AÏø8òõŒF,!ºTƒ‹ÕðVÅ“Ö 7ê £¯²àFñ8ÕèÌ?¸š3ÂL°†áëÙYM|˜BàëøX V©xª 0øÏ"ž4¡íd•šò—àmêo`௷pì°e—#;l€k‰ýT—ù8µær‰x‚Ë&Á«®ÑUJ—žÀ7Úx“]‰°|Žø(á'gü+¦Íè½´À‘“«ÁpU*oð$ Ƈª%ƒ5 œL˜pC-‘7ÍÕ ógغ|VqMðà·µit®™ªšk ‡¬ÉµBàš]«&«Œ[«|«"~Dù¥†;EÐÀ¸3~CJH‘faœÑÍ™A ~k†}¯ð <Éüň,‰C >Æ^гLï¢%ˆ@¼H© ã·¸1rßΰ‹ ùÆ@ò Œ¡œÙ0†–Ó[e¬£‡Œpmˆœ · b‘w#*›a‰FG`D‰Éø)ƈ™cpÎÅÊ10ë0~â]áyý«ûä“þ[Kª>ÂÓ9Oû Þø{KÀs{/–_Áñ2Pg9Í“§0ë|Ì©Ð’ªÅFO¬ðØ–) ºê-ä?Äóf³Û¼ÞmÞüpÀ²¨yŽh1„·}˜æhñf¥ ÎãHöàuÓì•L€«ÕÖ…&ˆL(ãZ‚+—$0©O±3t–Ä3OtP¶O ãXªŸˆ- ]äôD`,¤žk˜Îc²sùóXe»ŒGLt,ž«`TLªhwz+.ËGoeñ\fbP_©/@Ó¹ÙioÙã¤à3õ #x’w ŸØÇ‚6Ä[ ã émC»äN@#¼¥ eŠÕ&ÓÜJ é*å´·Ò,R0¶ƒñ¶G×TOCÉ Lo(R¨¬ëP° èvIY‰5ªÈø˜a èmr³ò«°Tó-‚ü@À©^†è= ¥ €RŒ‹é’ûYÐí'a– l) æ±M¢¢Œ “ÔèîPÌ~,c]©Ìv1SX›øרJ-w€°t#ï÷̆bŒž9r)ÖŽ2dí6i@€¼œ h ²ÑÚ h@c¡Lê&"§5A;·^Dœ1¿5“ö "@=DXS·Ó–ÔˆaE Çš)°°4(ˆ«e“þ?mTfYñ ŸX¡ìZì”ÊF™Å+o²¶h½ˆ¬ç1ÁòšïÈìh¥‡GDQ§‚õB N=ÆÿÌÑWX´R¨ P5&Ze§Þ 6D#G @€0rh;µÚ h+ÆÐ<7>Ù7dAÛ9¶^DXQ[õÜ µîA$E°bî6‘-?¿´Vꯉ CÕI–íP©2€~´dÏMQNzÈ2a—ÜɇiDD+–Óiÿ_š|]ƒõÑš@Ð-OÀÊT†0_-õ"°Ç£fcˆdD4d…ïjíáÄ<À<Ñ ê¤Ï@Ô ì¦œ˜‡D*…AHcýR°vëñyH ²t¦Ôcˆå#´^@#81 ÐI )4 ©Ѐ•UjCj'@uņv“^DˆQ XºÚT¥hM°²HЋh€.(ûDé ´KO_–×ebÈz\$ÜÿVyÑ~Ãf$#l1aMf’†× ízr÷iYÞ9bQL&®ç©©°Âö§¡ ØKJ)HŒi{P”eLOW~Ã5Ü‹ øÚ­ÿñÏ9ÌÉhÙA«¸ë»««—ó÷Üú³›«›Ýó7›ó­‹‡¯?Ûì÷ÛݵÓCóó·û'Ï÷›ýÖÉô`µ~|s½Ÿ €äâêÇ3ž›_‹ðOœ°Dr¶V/¬#ŸÄòÓÅö¬Õí‚P˜ð/ Žfa…í4‹»Ýö¬ÆqÏ=´wqý5ýÕA[I‚sÀÐ÷SKɧ‘¼¾»º; q³ ”Âbãaò濲êÈS‹§ ¼Ùm®ÎÂ’F©q:èu¤QƒÊi$Ï~xô·'ß~þõ—_}ûÙŸ¿(&ž¾ˆ÷~b™QjëòÓYH¯–n♑(‹Ã¥c:¿¾z( "QÈaJä™XXžŽµÓMŸ|ûôéW߇º ž¨¾ü&y‘ÖçùÓ‡ß}õÝÃï‹ŠížÂ\©ÇSèxwwöqJì7XVƘßaá®UëàÞÝÍÝv¿,”7ûdšÖá§ÍæÕ««ŸÏdÉÇq'õ ’¬é¿Na¹Ú¾=_Ö*> stream xÚ­˒ܶñ®¯Ø#·ÊC“à;9Iò#J$[%­Ë©²}ÀØX|… µ^}ºÑ 9Ãݵ69 4~wc‚«ÃUpõý‹€_ݼøú»D\å~‘¦ñÕÍíU(_$ÑUš'~…W7ÕÕ/Þçë0ñÔ`t×^Ûëßnþ [£ÅÖ(ó“"¼vÏ»ŸÞ½ÿÈPËDîç3Рþ3éAÂúîý¤Þ/¸ˆ n@Jqðáû°#Nx.3¿ÑæÛn A£Œ‘E˜ziŒn´"ÛŠAä§ë0ðèÜÔ›Œš¯eÇ#oõöåGšz„$ž“ôÕƒÀ—wø N‘÷öåûëBx/¯ãÀ{ý/‹æj—¦~,¢«]øERã€0 ó7&_ K¹FBÓ‘lqöÔz?ÈA+ã_ï"`×å ,šjG-kú^«Ltm}O£AÕÚ²ÙÎÒ/3uIõšdC¹ÂÈ“5Ô°ÂSáTL!qôu§G¤#O½}7iÔËAÖ5hœ 4« ¬Þ]C#€F÷ô¥[ú%-A#ÇAÿA”¤Å’’0÷ÓI¼Ü .”À† †¬Î®Tkøœ[TZYŽÝ ÿ”#rÛê‡ÈB?Íâ5sHÁ‡VÕ(¾,ʼ7#ˆ˜\iäî¯EàM#Ê'í]pp‡ûºá~EÞ(Í'†M‡ŒY÷CW‚µuƒ5ŒEî1VÚ,[‚Ò*˯A Tu¶> ’`ÆyìÌ!áÐÆÞ1X_ŽÝò*r:ü¼^ àšl ¬QÃ2‰ &d+ë{£ }õGiZQ–Ϙ€Eס·àÒÝ–]Cz‚G‘ø ¤cš(蚘¾™[[wB&˜ZâdO†¸€æ¡ÙrFg¥4<ºôêlu&·²ñ• Pvý§ªÎ]†¥A:°…rD?¡Àã>8bÈšöôn&0òË„¶p©:9±â;¤ Žó‚½;Ž,#p`î›F–ø™VS»)@TàÚxl Å{Ð{s°š ÝGÞ£;.¬˜fJ±â’dºa·Sq3.BOšû¶<] JÈ3=ðX–GúºÓö–èÎï[ÙXºaÚ”GUMµuMø¾‰Z€ßê§ÑjÚ˜]C1" ¢Ø{¹µ@Õ uÙ sáÇѺ8Su–nìð_’Ò¢Ç92÷,­imS>`ØOý])ó N‚[³uŒÃjb±É‹ãî2ËÛìc~á¡ë¶ÔÅÝ ch­ tƉÑÜ›Q5ϲ5 .˜£ÿ3ò&ˆ¯È”Ù;G…6ß*´Õ>7yÁÎÝê4ÞíçNfc£Õ”ƒžAþBÉö¯ê<—÷‰ÛúäwÈÁq¶÷êí‡S"·Lo“ÿBçjrzs–Íï?ŠóuÖýÈSTš$Î1I ðøDt[w²BÝÁ9jÇãÈjXX`‰º§02E£fîŽYH(ÏeqÝâ–¼h¯‚ƒ£4„oo› 85L<èø—ËýÖ) ”ÍPÿ~+Š…ÉEϦ׵8 š•®·úHõr„öMoesI§zè©p/H–ëV›¹9;ù;W»¬ð…Ï_Çå‹NüÒI×ÚœÕï%d'_Ý>¯o/üp»mo_Ù¸I]OõRUm©§T¼FÞÎv…°±…øh‡Î GL,VÊ"·-Fœ•µéhÙO9è=Ïï¡ä=¥5Qh›Ó=X´«èH3)FOÝ[Ü1 ÙÁÖ¼Ûá­º–Gø–†¿÷ÝĨBÙ|˜Ü»´°R„Ÿõ«{.¶_ÇÒÌO>™‹üô >P»ú™¡ÎÿëQøE˜Ÿ@?b\ù)ÖÎ1Ⱦ'¯å¶#n¹†Ÿ‹×§œ_záwêçy+S*û¾voÄÇÈI²&:«Ø†×Ö‡áùÅüÁ‹¥~0{ÿ2§F¥"¥§þľâ l8òÓUºÚðíÍ‹ÿ0¶fÛ endstream endobj 727 0 obj << /Length 2581 /Filter /FlateDecode >> stream xÚ¥koã6òûþ £ÀáäkÂJ”%[öÃæµuωÇÁÞ¡=´D[¼ÕÃÐ#Ùì¯ïCJ–ìtãäƒ ’Í çÍ¡=Ø ìÁç¶~Ÿ-?üråÑÁ„¾?,×DZíü‰G×,£ÁÖ—áĶøðÔõl+eX—¥œ8ÖJd¬xÆažnY%V"Õ3~ÙðËßšMx¼A!ÉšÉâó‡Áê×»zUò°y†¨(¡úGdS9Ë"üçCêYOH¤Êq±Þn i.W¼zâîõô0ÄSolÚ¡“¶/‹M? ?L°Y'×°Úü?V]Iõ…á¼mžÁZ¯ƒ:>ÜA¥®KÜÑø‡"ôÉ$ Ô "ä­þ2Í¡&2ÃY®yf8Õ¸al%+‰Qß&tÔkÅšÐyrˆo›Œ¿×z•fþ<“ïvà;dÔ4Š1¨öP„:ã—0þóÊñ¼IG(²ïÃM÷O· eˆ"‡½Î󈮂M@ãv®v»{uŸ¥ûä;7Zªcoän>t&ʲü±Cž5XFÍ5Œ6Jüðw’wì ±ç8Ñ»¾óÙ;^ðvÙKKù¼Æiå6z7’rŸBïP9¼\@‡×Ù¾¢ðžJ­þð*z^ç*MÎ÷o2-´ˆžuUÙ 8—qíSØr†³:]ñÇèDŒuêïò¾&QúRÏV‡9ѱ'×ì«l¹sÇú‚z¾•‹=ã8fòúÊbùW¨Îêسî—¿¡Uï81ÙÒü!Žè[:Ù»¹K%¾×µ¼iSÃÝKŒÓöþBWPÒ‚ãÅšHÐ ä &ØÉI÷Fð&®vº3²›he %|xëˆ l±í6Ñ¥ ~Ò¡]š—ºÐhÌuD½ƒ¾É#yßPëÕ7Ö™×›XSÉñQ_‘Õ8êð²:´«¹Ž*w À¨¯œzâjËHÉDW'ÝËåË凿¿Kt endstream endobj 768 0 obj << /Length 4287 /Filter /FlateDecode >> stream xÚ½[Y“ÛÆ~ׯà#Ye"˜ UJ•í؉R¶’X›rUl?€$–D ZÚüúô5¸–Þ]RJ$æìééãëžÙp±_„‹?½ å÷«»W¿û6ŠJiéÅÝýBé(БY¸$ ”Q‹»Ý⧥ìj­Â0\þã´o²]QíWk…Ëûf¥’e}\ýr÷˜ÉLfR&µ……hŽïÿñýßÞ­Ö&‰D2d²x¢‚$5~DW_œV©g³"-Q`…#úíÁP½H‚Ô9‹#×*µAèâ T²·ŸµŽ&£?­£È-ßT«µqár›µ9–Ô²¾çßê\–Üv*V:ZþºÒá²î¸q—wù¶+jýs…2{(ø-\Æü@Tš•xqσ7_¿½û'ÑþŸoÏÅ£6 ¬Jü@ǼsѨGè_ cÇÜQa`Cí{„¸ÚWRn•ö3xÂͺ' Ûp|è»ü~¥Âev.…¡¿"‹³òœ3C‹Š«OMN¼/êsË-M^æpV-®µXkDªÎ:ÑIå¬å4€/nDHTâ<?‡*–>cî¡$jèê üM +J%+YcÓ8v¾‡[˜ {ŠBégÒQ?X-ê)Š.ã€Õéb=Iƒ"èdù^ú§Ó³ItÏä/¹GŽ–L‚0Õn¥1÷B?^ôO§°Ë¡ßû Òd&»@HG?ÐÙ¶üÑÕ5Úc†…ŬÚqáà{mò¼âÒù´Ëº|ç_8He£ déÅGùÿb››²–õ²´PQÄj¦)ñ3‘Ú|s÷ê߯)¯ZXc€³Ñf ¬IÛã«Ÿ~ ;hü Lnâtñº‘vƒGP.Þ½ú;›úÉÞú©¢8PN¬áÛ‹[ÔIŠ¶Óp¯Ã%ã½6Ê05)´xŽèózÍ6þ³yŽ‰?úDÏñbK™ª·“?¼yûí_Ñ0EÏJàŠé•êJãÁY»Gkº­™~šÑdÍ?á¢êÙF&ˆÓÏ·S^õÙ½F.Hþ~Èt9ºœmÝ4àÕý'ÿviŸ¹¢}–Š–yÓ" `o Ê3qF½©ƒ‰Š†‹½³k½DlÁÓÍÍ!ŽÔ² ¦fMòµV`„û9eÕ‹ Ÿ•ÐÔž•¸Óë`Ï$}´ªºjÕZøtjêmÞ¶ž¥ŠîÀ¥ïÿö† MV½¿äMB˜^~ÿpÁË¥™z2Cñ`MþìùÀaN'Ïшj税Eò °)ëí{.–5ŠÎ‡u“­¡Jå}žuçF:ßE lpÐËšK ß  Ÿ!D<1ßlùð].Fï“õ æ· ÏÃL‚”ï.eöÒÀ$=†'É‚]ìrƒ 8îšójB&Ñž#Ü‘EjAT9¶˜ϹKãÁâÇ©,°)sþ"ùÅ_ð"\ºoê#—Óáïè(©â0ž¯q}R ?Ú\j=bÀr¿ûl»¬,Gs¢¹ksOÕaꊒÞ>˜7oßÝ­R³üò»ïV©Æ*;ýRLRÑ[!©?8˜Ç›ÌbÌÍ%Õ‚‹y eNAƒŒEÎçaÜçÍè@ÿò0Cvg’~Ñ!¨ aøQúå˲;Ôçý%ãeh™½bÕIèÅ3 ÁTîe>ħHZ ˆ÷P!_°  §`žáá#ZƹÓñ­G7ð ÒuäÒ&g!—ð2…‰Ó™égå+Ê¢Cÿ¡Ö?øm»ÚGˆ°n¹ŒüÁ%G–É€‚‡8`2o±¯ T ÀÆWsðݼÖ~“y -µ,ÔÖÇœKÛ2㘚ï/áC ½¼õÁT¤µ›ª96rÞ;¨!¿\Õ×lnîϪIr†kf^«nF¡€Q€É¢Uc1!bZ™´<Ö­¬v.ˇK»Ú€Á`‹Ö $eZNAYíyó/JG ÒšZœ&?fÍû>{.g·rŒAaâwˆ)d*q›´ÊN&hA­Êï'o˹ L.Û™Íÿ’ÃôcQ!R£b½ k‹ñ:G\-÷L†Ã=nŠªïçXÔ‡\‡[~õÝ\%5Ü-<8ê$v/Kjˆ"Väeqì +¼—¥Þó¸üæ-"ÓÌ…<†¾þˆ@æÓÐR ‰A£ûQŽÆ€SÔéôhF™[Ô P]F{xg9wŒ-98à$„H0É1†»0øÈÎ] ö ³]åWµp Û$&Ôøž?eÀ/§¥™~IIü¤#Iõhøwr¦IñÚ @„ÞÜ`aàpÕB—çÌ–ú,Í.ßýþÊT¦ @v­‘2™zLÈ©¬‹NˆœB¬™ rÆ|/° ,¨Šô40hë’MÆ•—TpÂêB¾éZ'ôÚ¬Ö`ûI«ð7ãŸ1†X{ø ØÛkÎ!QñÕU¥´Ž˜ÅS^aÍ„WX!öÛ ŠfbzÁf¸h”$ÀIúòGÆ?“d]ü±{GŽ Ö÷¶?vµrÅq˜8ЉýtySLBQ]p: ´SWDÓ¼JpÝ–Ö&yµ³0àvIC°c’QDo@CjŽ„$b‡æÞqõöP”3‰/ÑAÕˆþ9’Æ&ÆxØW+‘Úí¹iÀ­¡„Nú=+’@!ýòu+;`ô0^˜{ÖÞIÚ€«¤Ø&Ô(œøÉ™H¬Àô”Dœà}¢$||{"ƒ}0=ŽY•íÉqcD¥nH`kÎ<6˜úÙçW°u¥{©rÖ“ #Dè<¢ &óT½D¨Ù±>S¸gÂ>ZíwŠíeY÷áƯcæ80Æ< ¯RJ ¹^ßËm!r¼šÓ¦8A…Áý Îã@‹Ø5ìn\×>¦âô"à%•ÆS†H¤lÇኽå6 ƒáUÞ'+€„£4EÀÐä`gsÊ8ûg @›À)¤Bá´*­"q…ªÍ÷ò—ñtõùúJ”@ì2¼|Ø{hÇ ‹Hñ$P4ðZ/—&HÍ,Ò’”"Áì‘èØêcB0XØmv:å˜ÚA®Aüðí¹ÁÛ´£ð …¯®ÓQ­Bs›ŽÑFÑú ·Š_\ŠQð¡zÅý‰|àËE {œiàæñkŸÅO@|(yŸH"N½†ç\ËûŸž€‚·Ô÷Üj2l#ì¿¿MwÎÊ~‰0E‰D ^çS*úåúì~l³S¶%„_—³J»‡*;öqXö&ˇ?œ£ê_3ÖÍû¾©ß‡Có\pÛ±gmO™¿ã.¦©pYf”œõÙã¼Âtço:* quœø ÙËÇìcq<ùÃAl§ ëJ1htÐ û¸N¹cô@7I7lbx7K\¢f—æq꣮¹L•Ç/s“ök´]}’e侜¦‘×1à×)Ì÷¡fŒ×m†T×ZqÅ·ñ&%¦³Š…ƒèàß&oO9>wÁüBìøÐÇr}°gâø{´Jû]wÐ. L<\ ®UúLàœél>ݑߥ-Pø/ôS!ó¯¸S|€;ËÑŒM9!B—Jôb\â/°ÒÞŸAÝ ›„ˆÝ×ë'÷¨ÒÀ÷ £û¨´Om xä|Ï–¸fçÚ5ˆ7e`¯”òÍ÷e =ǃs.Ú7lòîEÜ~÷ŒJŒ¥›Æ)Lc«#W]'BïN ¹@7ŸÎø›Ï¸øF¤C’àŒÇìA.õäIÝnÏÍô¾v]ç·ŠR“ô5Eµ+Ø/1Ÿ²n¸ñ£Â1+úg.0r¶‡*ΫŽõΚ&£t]Òû½÷È:®fãÒû4¼ê/*ym&’´‹}Ÿ‹Tl'¥Á~ô`úùó!#Jm†Ö¯%O+7Ì>`û«N0üRÙ/=œ¦\8Ëîýs·ß¼”ÙÇ~»ZØâß½PxÄ O39=ó¿Ðì)´õ—P½‘:Zˆc0Ñ:|/ðgñ}C¼Ð¬lHéZ¥ù I…ìf Q €ÿý‚*ÉØ ‹Å#å4±TâÓê[ßw¨¼X‰ž¸4 œ[ì‰TMøÇ°‹§ÉïùW2m Þ?PÅèñ$Žxüx;í Ê*“g8—]‘·Á%H$xˈ$š¸w‚ôÑõÍãwÏP‘È+‹\š3þÁåº3¨ÚùI¦¦qÚj:Ä?*ŒEÚÔêa—IF¡´'.“ÒÈ ^Ø#(‡ .«×ö'až¿~Ûô¯næ©ìß‚”¾•í6Vy¾{âºí+Vqúß‚´ÊJ\9ÄÚøºÈFZ®¹+3ûñuTÝh ´FWó8H}ÐPŸÉQE5Ä ;%r0Ó:Å?YS¿e§±Ê[l“ä•À­x‘ÍUä5,gàs YZ(sa}J€ºv¼œZñ–$;¬Žù÷@zª†Ó¡å³N&g7g•d §ÌJYÚùèYãv1ïáÿD(™ŒøæîÕ¤`U endstream endobj 804 0 obj << /Length 3792 /Filter /FlateDecode >> stream xÚ­ÙrÛ8ò=_¡·•ª"šxÎ>e²™Ï$NÖöÔVÍñ@‰°ÄŠDjH*Žçë·ÝÑW<¶€&ŽFßÝ€?ÛÌüÙ¯|þýþúÕÙ¡œ%^EÁìúf&dèÉPÍ¢$ô„³ë|öû¼©öz±”"š¯³f!溡ފ¡ÙnW­³¿ä¹Ýê’Zí¶0£C3j!Ãù-Ïn+†/¤?ÿ‚ÿª"_üyý3 ç{þÂYxÚÎ刭êc'žˆccð\.SžOÇŸ-ñüXÚÁº®«Ú¢V2ÞŒá²ÎÊÏÙ›sÕÅÚú¶ØíøØða×TЙ-Ey2H¡á{i˜Òîù]™í‹5Œ¾ƒyaÄ(@ãP5M±²àÏ áÏõ¡¥^~¬‹rCív«©ÑT»/ 8wÛ¬ÑÞb©d2?¿=6º¦Ö-.\w¼ë® x|ÅkÕ®ü¥ÈùCÆ[¶@ÆiU-êUiNìÊ›û°j›í¨ÉT2âݽÞWõÝ" ç¯ pËSj½®ö{]ò8·œƒÕÍ3%& <8‰9{qýþ?ô¥‚ÿâ!é /‰èo¥L=!Âá/õŽ1)#Ë‚èDÄr£³öXkðh§IØÑ8ñk ÆÎN5>¡77ï`мܴۆú ·xV×Ù/x~ñÃÇn!¢À©¼à¨IÈ –MÇ ì$>´´f³k~ßP ø΄€EÿÀxuÝóCÚAzñ¶ôýù¯‡MåìÂ@¨ë…Rîy Õ_B ±’Nx>üúáÓÕbÁ"¡ç{rj×DxIêÌÐ}jYé¥ù¬*z«¦ Ã2 KéÇ^ò¼ÄðÁÝ‘<Á‡z»E±`Ò«ÄÔ'gTÕ·A ¤úZ‚vˆ%8Ø:Ì©²3MÛ(8±y®›u]¬PTÌkø¾ÜÙ¶”êüâêzí7ïß/R‰ €2BÖ_âCF¡­àåšà$ŸÙþ°³ÈÜÔÀ;³H·-leÀ©gf£ s˜àÛ[öúÞÀŠÌ`X_xÀO3\Œ†ü¾ !ข´csGR2r>Íe‚!¸ñØ9wðÄàC©D°­‹leŽŽ óï®Ï¯¨MjŠÀ«·?¿~ûüy³¥ËŒÚ!QHãïx•ob—š‡"'ð÷®:²çL¤Š‘ãœâ“Š}š ¿kã­°…¦b4rt‹Z®"°uïk»Ä¯üá™ì؉³A§¸ÐLçd=—|¹Þ`¡žÅ¿+½Î0b›J-TÂt,×(ó; ‘ßîÎ ü†š€@‡½B¢Ÿ™x€vÔw0f¡¿ŽEÍ›lÁ‚éšÚD7ÞŽDÁí¶2t u8ÄÙ)²õçÌ©=ä;àÇëÑ­!í"%cUÛ‘Ç'‘¹˜btWqšÞc¿Nˆq×%8”Ô)5#í¸TK†¤b"²Fí™:&‚©˜Œçïß|BkôÙ÷ö zJ¡™Jãr‚BJe CÊ_ ¬Ò¼œ‰˜éÜ¥N¿¤Ë0šµ@Æw¦Â~éút¾têÔ“Ô›Zã8pX=‚ԇй6Çoö׊¼éÐ"ÿþ’ òSÆñ,Öh`uul‹R7¼éù”ÌHÈod’¡®eUèÆ›Œ$ ChÔ $$Wz.±@’~qɸ?‚åªh­hõFsæ@B„!”~<¬¸O¥ô’@¼D1æ6j&#²˜Ø )†€Â@@ƹ”‚=¢0Ê°ËÌqL Ðò¸_Ù匶LC¾YØœxx1«Ó¾UaìRÅÒªh^›m»ÜR=à „òF Üv¬8²xc¢y„l¹’ŵ…E!S£Ñ]š¬"rô©Ô:×¼™IZJÃúà“Ñ]¾2’óÿ¡D"%ˆqIŸÓÄ'Î; u`¹ L –côáÀ[¾×YI­l0ß´7&­ãN Ô¤e£pPkDwåüGß*…^ÇFg/ò“™òŸÏ§/÷ò=l-{ãÀ¹ûS[úT¸ð_Lœ56þз«„¾’Äsôš8ˆ¼&¶@{ðò…çë©4ìehJˆ¤zQ¢f2Š½ –/"é'žŠi%+'Döªb[¬mœXß²õâ„ð${fáÖ!{¹Z”‚È=~²Á÷LPin^â³~°þ”×NU£àIWìÅ{¤$š¿ƒˆÂ(X€lP“Ë+š_´¸øK'£¡·Ä/ý¤‚çÞÐP[ûìãiq4]¤™ÉþÏ>áЬ6‰%ãE‡Fà UVBHXß\½&ØIZ†@H™_ÓÈÓ,Ì 0|ûtÎ|"<|Úc¢¸aúæ•nÊaÔÎÊ3 ©QǬ­=–<ÆÅùέNG›Aj²¡G›©—„â)ÁfêÉ.”œ tp¿¸kž‘HB/07ß(GK”p‘ ¼í^¤«Ý5R4‡“2å§aO¦$L{‡wæ´ [™í®êª?ÔT)ªcƒy Âê¬h¨b-¸Ül‹`Ac@_zv‡Ð•  µ²å=l¯Ä±í®ë¬´á Òf si¯Bˆγ eñ“i€9ÞµP'£ïV§¤+‡;“•v÷SÔ³[Á9û¾ ¶¹Ýv°ö¦Î[jråZûʸSØŸ”j%/ìîØ^”C‰ zšX‡â!©†˜:IFןùF7ÿ¬‘e22JºH:â„`ƒ„ú&¡ŸJ; •aÜw}‘2›pI¢Û yÊfȲ¥qÕW^ÒEd—?]=¾Ò¡HûF„p —¬s®ÃhÆ‘*Ît'#£Œ")Á7€0ãx=w;-ɦžöžw.pÒi"N^Ä·ÈÉ>¼Àªýó6Ž=¹éÑ2öTâîþÂi;STpo˜ á«y€äÑÔ8#y¯Ú HLüîPß®¶Ð§Ek-Ä°æÜ猒¡3Z*ˆÏâw¥õ ÆQ2¥œÎÍ…?säÊJ–ô‚ñmóð±—¹;™ûàsOÁÞ³^-Äaü4y?vÝD{…‡ˆq¬„Í_Ã6ûŒ@àÊê¸Ù˜SÇgh=¤la«z¤/Sn_| `wˆÇÈ·¬ñ0£—c] mèóHdáû8õ˜.ÄSº0R_|¤Ô×…×½Û¹g¾•J¼H=*n„XŠì˜AwßOß’q?}¢­Š¤تa}èk±?îí3‹ªt/ïÈíùñšH(èðžÝ՗ϯ °ÑðÕ„³–.ÏÅ!5F@÷¬-D2M;uÇ—åèŽó”µ ÈÕæd+ûêÛTiAìj½ÏÐ>!ÔÕu†˜Ú R ˆê“QÈÒÜwe"¼ |e™QÅͳ6£·8(GÚÛ`U3»2«Jlmßõœ_^œýüöâ5?ä¹¼8-p(‘x1pO€‚$|{}Cáy-䮋ÀÛ#Û‚cP‘ø¶ !>Åɶ&ŸäÂ)eÀ*µÁñàQ”kìØ‹%«ŸTi§:y?ÛÀ`l—ya@-S¤ö™ô¥nQæ¸$p*N½1i2€15uµ‡ÁûcÉ…z‚’üa+3ƒ§·rÙ9îƒyF'’¼ß"à>OÚáû«©¶|ÕÖ›²@3Zñ{Dº3”>èÚìP¼Í—Í°-ÌÓ õnÒjÝôš—²»dôss4ç„–µ¸ôð†>ò"6G÷æÀµ7§®»/ÅäWb¹@’nš£xƒdþØ °T endstream endobj 701 0 obj << /Type /ObjStm /N 100 /First 890 /Length 2693 /Filter /FlateDecode >> stream xÚÅZ]S9}ϯð#ó€ãr}ØFh¤X¤» <4ÝA´ºQwfÿýžºqB§§;É€ÉJ‘îõ¯ïqUùÔ‡mZC ¦-h0K!W¿Ö Ô‚Á?VRÐ$¸RPñ6mÞ¶`ìí¬ÊÌJ %{»…Rð¿i¨¥P”„ñ€åœqƒ'ìCãà ï›2ÖPþ*±$üÕ¨Ì >“ žhÈÔ2n,dæ„‘ñ—À·&ÿáF8ÐÅž¤‚)‰á¦†Üªß´À”uVðg|¸Kò·j` \+®h[Æè`_θÐY \2É]É„kžõ>LAÌÁpR*¤ÃèÜ­°@¤þiLYsÂ8lA™ý¯)«µäOZÐ"Y ˆê² –Oƒ´V\¼Ùç+¼ø8®O…Ê &o.†"®'ö›¬AÇE\d‰ge5´”^×ì Àð ˜ÿï*(¯+fÛ0Ý¢jò–hÚ'sª<ýÕ¤N³pU^‡òkqs€òk„å×s+Ð`£ ®xlP9”‚«ÚðGn0'(©)5 ‹¿\Ò€0†mZkæÐ`™—JÙ' s… út0 %×qA_J“ÑÂ)UØYiwMÒ¬@–D©ø î2Œ¸&Ø/1„†YãN`äP‘Bn5¤>m¨Œ0 Á]ñ;LU¦G€Sݼ ªÝ¿?›¿üï§E˜ÿtvv¾œÍ_|~»œÚ¿~8û8›ÿ|~ñ~qñ*ay¦7ó_æOæ^ÑԘ͟/Þ-Ã+fLYj¬˜·+dOZcËý~ ÷ï‡ù‹0|þò<̆;—Ÿßúï8?‹)ÒáÇgø}; I)L“¸ÄM‹Zt€ "ÌíV@ Ç2 „öMbªÐN¡˜a!0‚Ó¸JÇÑ®¢x^¬/…çaþþ &ÙÙ$S8û|zúæ¶~YxGk¿³3L;*,É2C`eOçÚ¢ÀÚÀO1Ãœ‚>Šƒ?¨3è#j=p‚ Ì´¸³A Ž\R¬Xí{:»Ù€È9ÇDÛ#‡ùƒóÓó‹ŸNÞ-¯Þyv²\..ÎB^5ÿöÇòñ‹åÉrhz0›?:?[NÚ~®ÿ®ú=R'cZ7@Ñ-õmî[o8ñ–õ iôÜhÑõ;¸®'J[aÅ$æÏ.Îß½XÀDüá£0¹øcÞl[ý³“ÿ,f˜êÙrq¶¼GO¯»m_ž¾x·¸œ<Ýôè·Åû'?Ÿÿ¦Õ`äÄæöýìäïâ˲ê7-¤K|Õ½°cq'¼ºr¿®¦âxuå~]?×~]éêÍ×.ÔäŠÙ,Ô,9 "€ˆ ž9+GÆÕ¬[n^¨ï>,ñ·gOî],þý-Œ± D_†=8|‘ Ø> ïß¿ÿý^K'‘¢X»µŒäí8$XØ‘±¸òE¾@ ¦€ lZùv$—ïNNO°F?Þk#9j4Ä/–ApUÜÏ€cÉés¿{¡4P2p$jΕ-bAe‡A \âÃ]’ùýó½DE‡ã¨&—+|î^ Ÿ§§‹{©ŒC‚ :zÈÛ‘LŽÁ@òñäãç{­žŒ3”ŒDÅC4˜-bƒ…D@”*í3”¼Á=ysH°Õoí ‘ÖD²¡^쪯Úòb[ŽëŠ³ûZ¿ƒÔçºßÉzßñDpÛïx ²òµ_WNµtÀž…}“_¹fV£g!†0‰à~‘•DA ³‹E·Œ ³G·3r¤N£Ta¹ì¤Ñ-(žôñ¤'}<éãIOúxÒÇëùƒWdV×>žöñ´§}<íãiOûxÚdz>^ÿKÿKÿ‡Ñ.Òø©„¨‘jÁ ˆm^B$y í>yðô寯ïdyýÃ@vaeª,v ^øÚd…ƒG Äò„¼n.À¼¤‰¬òÈX’Io„ñüÉÓG}G‡âh½»Æ‘¥¹šöð‘0²€®`q Çì^yŽÇ¯ïÐPpËZÙ aEr¡õ0$ö=LD‘ïñÆD*C’~ó’™TÃi¨n’EK­qd¥è%pÐPH뼆¯Öb#TŠ 1Š´KÝE!ÿåÅ@‰øF8Î+¹ÚêüÁkJÙ¨”±šñ68ÉNOGF)ð…짯ýŒ¨çZGòt†´•ãIámƒÃ<%)GÇáµ1?‘¾ÆáÕ<ãÝòè{c«¼Ê^G ”kT,ÆtP’Uªˆ'š¯KÙ ã鵈©ösƒû"¦­~›½ïÂp$r`g~3;°sÂX°}?ö°Î¾‘Ä|ôMõ­ƒ¥×B±í€ëKĶ;Æúj® é endstream endobj 832 0 obj << /Length 3311 /Filter /FlateDecode >> stream xÚ¥ÙrÛFòÝ_ÁG²ÊÍÁ‘ªl•c'Yml¯w¥Tj7ÎH E¬I€ÆaYùúížžÁEЖœ @Ï`ú>A¾¸[ðÅÏϸ»þpûìê'-1KÂ0XÜîBj&µZ„±fB‰Åm¶ø}¹k‡ÕZÉpëMÞà½^æEcVB/ïLE‹ŸðÉTu^ئmÝ”›&Í “¹åòxÊyq·úãö@‡Ò‘„,¨´¼ùõÍ»·mH®LX,b¿ë>oötôKÂ{ªÌ©*·¦®‹]yϹJÝýúÕõÛÛ›ëÿþxöb-eÈd°X ÎСiäJ¥–?!{eÕTȈ~äŸÊScÇûu?Ç»h¹Þef·|™¶‡f "[‰e'5É—ë÷p.½Y—GÓì-µøh>¶ù ù„ÿÒƒ÷-<3'SdÝ6÷¡l« m_>·Ìñ9¶b>Ђ}LQÕxsÈ7UZå¦ÆGÚÞ€öÖ!È›w×Ïië¯_ ž—7îùf›¾~ñn•È%Áqð1ÐáótÀ!7ž„º$¤P„9Ûad`†5ƒÍI°ümo€ÉI.—•ÙY Ám³ï`iÖWýâ{)ÕõÛ›ÛU¢–/^¿F‚¸EÎåÁmËB¼Ÿò !ŽÜ!ªSºýÞ¹‡Õ2Gõ 8kz&!ÀËÉçÓ!-R´¦zŽár{5w8´×`êÌdãµ_-šª<8 `ä·¨ó? ˆŽ¼K/„\àeà^€YFŒ‡.HÖ*8çË_OwUšuGˆ—å±säÁB(ÆÁ©Fž¼á€[|oœÒп*š;W²$ˆfŽÕŒ3Ùš@¬!¾°––TÒŒçQÇŽ«kLµK·N®NCQ¿1MîäJ:ƒ›wÖ½«ÁRYypꙈ…Ê‘ 'Òð+#B‚a©2“Ö Ú>ŽQbˆ¿&Ò!Ú0`ºüQ¡Çy¶ù‹w×Û§5Ýl÷iqg26¥A1Bð%Í€”:tÂBÝi­(1®ÝÓ+i]·GãÈhö)yûZ¡íG“ LÛãÃh˜Æ“îø÷\êà ¸³GHs °uÀƒaª;…žãcÖÛæP¨Äo¢˜¢³Óʲ¼¨ˆµ&]ABæ„;,çv‹U‚ cÅ„þŠðAž­i†¼¾ÁìT_Xè[y °@…cyn LÝ“g}P²9œ9ÃÀЭð&Èn¶³ïôÙ5ð§!êán AoOV`(ÑYÞhé„Äm)À'ŒÔ¸Z^´ÚÖ °´$ÒiöÊ)J ðN›#Éžk^P ­+˜S½`aש)Ý<ý¶6rjŸvðfÄ©ÑœE¡‹ÎU/3ì†,ê£áúÕù#/€h¬F ‰ÈøT[ãµ—± £‹2†0-ûÈþnä2c¤!SêÑR ƒ¯J™³ 줬˜D'FÊQÊHs'eË– t–¯AªDÀEB³XGcù¯_ÒÊÊVÍ7u²%û_šE2ó¶lŒÏ,èígnÅ™¸²yÌþWçgÆáÄU`3ŸìS¬.IÒ)Æþ… 1®b¨ÛÓ J[“ùaF" Òg}½$Yœ$#!L±Ò`R CžûD,ˆo^þ«ÈÛ—ŸÊæ+¶õt}š’Õå”ü¨t EC6(rbæJBÈiØ%zAqÁrqŽ=†+é¤ t[š{È>Ï™bQOå;rK(Œ¦)ð_JÉ!äªDùrÇƘzí{+XÙ”³|@™B”ÉØÒ‡ü`¶˜ã(„ØÕ[ jr.œ3'óRâ—N‡g’%9ó© ðw4Lnla%Lí|sÔÙZsÚÍÆ``DLh„mÐnƒwŸ^TØwû‡ÿLÝ7ºUd=CI&£d¡ ¨ròîêקɋ1¨Ávs”Š /žÔL¾Ô„Âoè*ГÎ6 P9&‡ÈIw͸î¥Fñ²ÒVp÷ƒ@ÛαÍÌ°äœ!ÁŸj`b­“xySº‚异ÈÚÊõ¾^a ÖâÝ v5Ï©±î–GA ‡ ¦z>¶VÛŠÛi…=fÜà!®’®Ö«Ý_»·¶4è_‡>?<Ð}V†Ðl$Í2—T§ýv›ëC½-›íÞužÚ¡Úçëiˆ£A•§]Í–;kucL2éŒU†úXªé:F|¾T±ýZ@:mZhJÍÁªÈ66¯V¶…€z–ºY¼Mñ£ø€’£[.èZŽd¬X°GK]ÏŒðû}¾Ý»3jÓnœ°†`mÑÖÄ8B}¨5žNyÀ÷VËçÖeÁ}Ù|H8e©OÒ½üæÁl>òêB¶„OA}`©VZÏæF~ž•OŠ/ßÞ¾~Ï5þ‹ïVØLqµúɪÖ8lÈ­š sıÑW;ÑkÇÑ…ð.£aZTŽ ‡½áå°žLûG*.ô Ð@öåëWÃë4>q—´'âüRœ…J< ;¤y‘å[L‡<¦Ÿóc{ı,ÚãÆ—YÞF¼ªº2Ì¡‰ŠÅØH«¡îÈ8sr(»ð7D_—‡a¹×ÅÀQý”ºú™ä0vZ3¦˜;ÎLZt‹ò7.³ö„_îçêK4#ü¥¡RËi}à‡›¶¶Š€»Ú4õÓ,*ú8üF“IÂ`0Á²¤t)hþ¶‘O‹*?ÀG1áh¨-x¤òÓMq_eR*åeía‚íŒëÛ$’N•šÕ)€Ç:]+,o÷¶õPÔÅãÕæ{¼qZZ;Ä’J^*}E,™§3<|õ¢ûk÷.쨿§,d‰¸(YXìÄæ(Ný[8­N•A¡‘KBïèIïeÁ;@V46±ÛÄ©9 ç³ÅãrÇãœÿÌ]~ŽæuÑ{Hö*€š¥Ìr|ë;Ú@vI ×] &–©#}ÛЦ¢¬ŽéÖÐ?jLè!xˆ¯eVØÚ77áh+:fè¬ xØÓLqà/J¾ÅÃÄðÅÆ‹ÐÓ³€OÚ픦CAµ9ð)Ü‹4àˆÎ¤­£q ¸ÅЙè…xIŒX-‚p©²ŸpÕŠ.±ãŠMîP͘ n›Š;o¦M@±>kÓk¿2’ÍÅàêz‘/öñ´å¬b Î*1¨XLE_ *ß¹§‡‡:Ĭü7ôsk‰QDß©Tã0Ÿ –‡¾Ž»¨a{¼] ¨L‚`&ò‹GØeÌ»vúž d Êá¬u#©È¯ӣ!PÝ€Öë&ß:gÕ+Á”Ò%M>I@‰b"˜$Ž'È®ÿDû½x"~2•$ß ‹·{ñ{¹Z¡ôeèS‹ú¡×—ñC¥p‰ï¿¹A§²¦t¾~‡œÑ\ÌúIr÷­Ù÷,ct%)mŒÛÛ6Aó–¥Ô°fùZด¢Çó?W¦u×aY.Šáœñ ÊXün÷Ýâݾ¯˽{`® ’i²DïÒ Ês~5–3im³¥vŸdØPR…;úÞE÷†cÚç䥳MÛÚ­¿› ¢)ûÈfÒ~v~ ‡ÁhÁ/Óå®,³‹«ë<¨ùLÕ‰ÿÚ €mzÈ›‡áªêWq¤×â·ßeFhZ<í9ÕtÇÒN@à@[Оc~·oè–*<¸!Ž ·Ù·ƒãíÈuð=)ñr™ý!‚—ÒhŽ»-Ùþ“6•Tn“ yì;0?æ Ÿ.à»PxÖì®õ4WÉaw]ŸÒªö¥Jb½ï(¬­ò.g-90@ æP‘Yá-…r\‘B׸#=>:Å"Dtä£ZÚ¨{qOþ)»/þ—)hø¥žÈiªn¥ÿq=¤îU[N©ƒî –ŠŽqÿ¹£ÿ¥C™7¾CQ! ”Z:YIsArƒ«ûy…ëžI'ö¶k’‡û½ÅÓ“í‘ÝoF\CÃEÏyÝmìC\ÐxÏ}"uT¸sAfˆ§Vé’¸™ýÙ+°¡Áð}R %d³/«üOš2Æ“>%~ºUàgyÞg–§™…Ö“âIàtÁC2ŒƒŽ¤Ï(}¼K¼v¡ß0Õ¿–Q¿QôÇuÖç¬!L'“B~ê| Îq]ú„‡ŒKõäÚ)šd37“¤ÑŠ:›î×8U´øqØ[^&L(R}¹ùØAب:ïtúãí³Ïp¨ÆbÁ ªŒ®—ãd±=>ûý¾È`Œj«xqo·"DHÄaqóì_ݯûïhX’‡öP.åà…ÝÁF._& Àú0xcŒ#’(û°ðw¿ùö/CæÓýàpß4§ï®®îÀ îpb]å)ÛUWAÿb®¯hP~5’Àôj©ëÓ€ˆ(êë `œkÇŸÊðÿ=BOF endstream endobj 856 0 obj << /Length 3499 /Filter /FlateDecode >> stream xÚµ[YãÆ~ß_¡—`§Í¾›† v²† _ñŽáÇ”ÄY¦H…¤v<ùõ©êê¦HŠ£‘f'X`Ù쳪ëúª¨IÉâë7É3Ïÿ¼áðL|Áµ`©á “*æRµXïÞüö{²ØÀà·‹„ÉÔ-üÔÝBò¦Zh—‹÷oþ5ÚD2Ž›8ÁìÙ=`6g©Öa èd° Ó‹ ‹/?ýæË»7Ÿ½ÓrG ³¸»‡CR&¥…C “صYü¶üæ«î¾ûw¢Îá~óûÝ·=“ÿ¼(€xÉåõ$ž"”`š1!ßÿòýOïonM’,ã K<)#¤4,µ¯A´’Y>OÐÉR3 á”eád‘^OÁŒ¤m¬ÓWs!æj“–o„^få!?%¿á+œ-LÂRgÆgïò¬*ªOKî–Î2°µ î%võÉ3{èó{\`áÚ1%ùµWÀùœÜ` ·t_ óŸ½sÃy@/(yB’3 ñ2¢Æ ¡$sR‰ú¡&{Ê›¦n¨™UYùØíÓJò ÄH•RŸ@L¯8WS3#se˜w%GnNä<£ÏKôeGŽ%*À ºt|æ¹KôoK6ùý ‡CÙõAeVÔ¯@¥„KVJ^LåEôõÒ¿šÀéKÅ´à¯"}é 4uæg¤ÿ²#ÇÒלÙÄŒÏ|w(KºÎ¶Ëº¢íŠõC~*¤óãê%Tô2¼šŒ Á´Ñ¯"CaDâDœ‘áËŽœ—áðÌëdø THˆ \M8ÿ>+ª*zÒäëz·Ë«M¾yÆ@¯¦oF¸'Í+Ed¸1 jú·ç"ò9鿈¦yáiºNøŸNÊ^Y=&âG÷dÞ¼¥gõ¢P}-¹3¶Pœ_ñf`y+”YèT0¥ñ|w〇U™7©YòÏI9`¡…«N8.T ÖFíø2[ÿñàï©ÙÐ"°‰=mU”E÷ˆ]zY´í!oix•wy^…å`c.RfŒ;ϦZZ@¡!à ²j3·+>0½ñ¦HHŸ=M÷[•".¸ÉR¶ùT ;=3£Ò¸ü\â:½WÉÙ/d7·JÙh p‡#äպ疛â¹Ï›¼Z‡a÷`Ì{qxï¶yìèòfßäx©u¬ï/‘ô‘0Ží̉¨E2/êãJ…p¡õ_E8?0"íG]†µîy9®0€+´ª•Ë_·pKY”n6…›½…RÒÄUÝ¡tUrLÕñ.eê#Ÿ !ÒhHÏ1õye€yõ¡»­ïo›¬úÏìï³rË™pü* „7t~ûXìò Q“…3z¾®Ú@YS|Øv·[Z ³Û"Z–ÀËôbt9Q³×E~4 g¼vÁª¿M1:»ô’•mM-,`Ë=Á¾Lºtê¯`áØ_W@êgÓ~A·Í:šOºsp.2×ÒP»­å†Ú«0}ßÔÈÅG˜F¼õàì}Ö´á^¸Œ;7¾p;oËèu•þ½•ÊAÇe"‡Æz×Þ^±íÕ?+| â;¼,juÔ¦JÛöe±)S7Œ7E>ÚCÆ=D$ßwïÄá q·üfÖð¤÷<‰#d>hÍnÂ쓺`~/­àˬí‚ׂÉê¡Í7Ñé’ÝÒð¬þpÃD*¦ú3¬žêÏÀÞ7©)ú0ý|{Ø»aAR Oþø„Gp×ù=Š¨ üú¾lC’‚ÁpD±nŠ}ðÌ©¸Þ3ƒH„’/ðÌG5 þž¢Œè€€±.Úy*¥WJœõÌóyÔ3r'b†œ(K4Èa$ΪQ-Xc¹? ÃhTŸqì {E¤BóÀ÷Â;a\¼,YÐ=‹ PúoÁ‚9fn€ðÊýå*¼ÛÏÁœ?|UƒÞÜp·¬Ë'(.=clä“9û¢s¨“NÄtpËLð‰†¢P=TGv”Z¶õ.§±¸[K¯Á?Bë!o”l¿Ï³Oô¯O„%l§×†%Ùß,Àîe ñ°|æTˆ…ÊLm&?iËà¤={rP3[1Ö¹»­÷µ.]Æç*_gàiÞ"BPèiªëŒÎãöÄæÔŒÉ3C#ÜûÅ W˜1éÞõŠ@!‰)ßÙ‡ªFlLﻼm³yà‹äŒ-¯ èJ=ÛóR†+Jô5RF}gÌdt½G͇¸Þú˜ë3ÈŽ:·ÙH™ƒ8Èty$›¡i‰ 8ì_o´‚v´Uv*êC3=)9´qûˆÀ+t?MfDš³0 7;xSôÆ7`q]7àNišØ ´8â³ Mg‚熾À@VÇœ£:‚+k2´&:Ò,P9ÎWC2ÌW}à…|5†7¡X¢'@çÄVd÷Q ›ÅÀÒ&’Ä‘ö€‰¶Š oGu„eYè|R-Åu¾PkÒ¯x(º@!h”˜ýutöø U¢—û”7’Ÿw!viJmG72*1ø¢¯üê­4ùŽq"¥}]-¢©šHŒ¸ø)pô£Ž@3.Lp$]V”Þ {á[깈¤èÀù 9Å·WÞ%sÒV þ¯gN¢Œ›"¯kïAÉ•÷ÍŒ=Õ#yÑén7=â kdÂ3ÈÍ,ª¿à4M• Å÷‡Ê;Å ÜIœIo<±ƒ-¹‘Ìžæzg°úm\r+À#Èt ¶e’¢ÎBBj» [ ‰‹‰ÄÇŒr#wJ,SrEóç|‘ ÔI"4¡T€$Ž–ÙÖep27Zû"¤Ëw[Ok j†GŽ®PÖ¥7MX=Ÿ”X¦f}’TÚ»öº‚·S†8ƒþ0ÁÀþMöØΦQ d¼7ÜÝa·Ÿ©é H8gjáyö§‚yð8þ©Çຠˆ<¥L” òˆ¿xžCzœi®çJŸ& $3ú¤I }u¯ÀƒÝ˜|ÊÃ,œÇ b7bÆf(=Ù…h_•!‘X=öcEsL7¼ž‡\l›QÑäÈi_÷ÉÐ[Ä.y_ œQ€å6„>óãj„—1a ˆ˜>ÌÌØ~y1Ï™—La–Z-a¡ûóÂ^:ÚÉÆ’Ó¹Xè?§Ì¡7ÿ•Ð›Ä‹@AX–˜P?UU¬jÙe]SüÀº·º®™k™£Î!¡#&T×Üjóã×±&+©“T±è±§of8T©Ø :¤Ùã*B¨ß¹ŒV†í–J½’wƒ‰>â`ˆòAçº4 p;Ζ#×äsÂM@Íè_3îf>½ºë¾ÇÅÄ?q'Ü´l–Sn¤€Í¨0*øŽåì\…yía¿/ ¼j|Ë"ÖtC²ÁrÒ#ÝYÛæ»U™oæ4ÎÚ;Ü"œµ®ëfST¾hï÷¤±ž ¼ bö×a~H+ªeNÓ@-×yÛÖqf¿òÀvRÛÚŒ ª QýaK(çzŒï{HÀĽñ‹Ñfù#’ôPøZ£LÕ²èh¢¿<à >—‡o}idxyø+mwD‘ ñˆ?¼™þ&fê#Ã#W #°ÔŸØðvãÉk]E¨ˆÈDy(1®‹e}A,~§é}Ë12¬ñËJVÆ×XDëk\Ûºížü”ÖG À8áO NÕ‹–ºqGìÜÆÏØ Û#ØOW&{ægƒÑyÇ€½”dÁ¸pÏ憹t˜Ïㆡ$ãýaÕ£D\nþñ)ÂÆ©€uŒâì¸61> stream xÚ­ZYsÜ6~ׯ˜GN•†@ðÊÖ>8vœÍÖ:‘mmåÁÉ5iX™!'<"Ë¿~ûHCÉR²å*.Ý>¾nH¬îVbõÃ…°¿ß]_|ó6ŽWR†y«ÕõíJª8Tq´J²8”‘\]ïVŸ‚(TëBWÍZf9ÑO½5m[Vwëß®ÿ û¨UæI¢q±ÚÈ4Ònð¦opÝ&’yÐí 7Šª8<´e˽Ӿh×20—ÐÒ ìp8 †éŽº9ØO»ÚŽ6@ ‘1ÛûXtMù™·p‹Åïk)»Âmišo¶{SœL3û¼ê¦)·ÅY#fH(gfnq—bÛÕMù¥èʺ ×›$Á5}êàTl/î¨õíZÅÁ­iZž,x¸)ª;»VÐPûp< {k‡›A©µÞ,JEªüå[]-l•†JÇ+F"åE× z’…i&WoÕ%®üôêÓF* ¦ü«ˆE ÿÉéôFÁ}G9Ü7Ü@®5ïqÆnèVQ˜ÄÉxKKôäùp¨g2ÑqÉ<±.€ü;WKkN§C‰ Š+ÖmÓ‚Ê$I˜ fñaïEÄ,\Æ„dX®'–6#%·­ý±"ñÑÔ+èªHi˜¥Ê‘ø<…iiĆ·è‘ót˜äùËŽ[ 8Ê ´Œ7‰|—)ßIC.Ü#÷në’¤^û´à“`YSãØ=wØÍC×2ö=Ÿ/tðSÝY¬+„Sî9ИñèùÌíÒR5èÓå³BØè!w¦-ï*ç79h‰Y Å{éjHgÈ(ëœs5;G‹`_ÞíI&Ð.sõ¦bajiy‚)P7ì±€)@éͱnì·,Bü¤<+@F|€¿ÃFgdöy 7@ÃÈÂf‡¶3§–.$fÔ¢¢¤ÄûöºL=kEÛ .Ô|Ñ 2B«á~Ñw5ÜânMg‘B”8Þýôæ×tîð2áèý¾ÜîQ'Sí,–#wñ™ ©†ÕÈ&îÙ[î•UÛb`0 ¢~8Y•#1Grœu ÁÃg|ÿöÕ0w6? -¿8ún'J.=rlPÆQ’ZD @¤7S“Œc‚`‰ô°&h ýQßZy(,#0MTðË:cØKövuÛ5uu‡z‹½Ælkà‚ÏÍÆsû–Oe°‡¿V”¼ü‡ l{ÿ’uŽ·á™à€$û\û#w¶ûºÜšéúÎùªF¾-[¶2lK8‘`)EÈ ‡²¿*Ïm'ÁGï¦caã0êŒíÔR'jY/¾¿¾øã@ ü“àÚÓP¦r ñ:YmŸ~«L‚È(„ßÓÒã*ÏÃ$à |X}¼xoSµ)¸ä½t. >0º {Ë’I2‘ÍBÎo Û¸1¼®ÿÔwh 8jJJx+óø³®ÃøFCŽTÛéÒnYZØ”.•)PB©L0€çSÊE¿­+PF4O.à;p|+"Dø¯¼×ùðŠ"ò+LˆýÇ×?]ÿ VegPi&C…ÀŠû0ä,‰="12Î}‘S “ª¿M? ¥ÏH¿JêTºïð-Ó€¶Bþ?I§"šÛ#_–µµ c^äœ0†©ÊK‹t¨¢sÆTþ¬›ÉÆ›akK}x#3@VACcÖ úŠ¥L hÃv?¢6*çå ±-ZÛbÐìϦ[‚ñ©-)[£À]F‚Þ‚ÙD:¥hIOuÓUÇ]WPäÞ9p3Í“{c\é!5†NÄTDztªDNTÛC¿>b¶`ÀzSƒÇ-:Ã3Dzbÿ‹³;ƒÈ莒zÚÖ;™‘WïÞ\òÜ'{“¨‰¤Øø€î4Hfþ5øÍÉ(Ö(‹¥à7¡ D6Ò ]:ñé‚Ù{ð[VÎcˆÀî}Ñ–›©Z»é^yÓ!.]¨ædá½efŸ`O=ÂÞbLJä”=áy`gAÕá°)íbÓÀJ–ú[3p³ÅuV‰qâ¦î@›þÄ3ôñ\”`IÑ÷pk{,Ž,PÎ4i«JåaÇÝÖ é~HòzôûoÚ#ÃŒ ý‚ôi£m,X³Á!iÊ_†¹ž Šw˜à·ûþðÅp綩Üúoåe!\ó¢qDð{…Hâ¦nìN(²«Ÿ?ÐUJõÔUjõ¨ªªÄ•´×?¯l_¿þó‚uÒ\-¢tÄOjO”‰ßd–eüš!4–xÇ¥„*aþ;T¢ÿÌ=ÒLÛœ ÍÆ}Þ™ŽÃVê“é9œDiÐ&ÊÕpÈ»²ªL[wÅ’š<Åè¹lCvv¯0°$ 3A»6mïJ8U4Mñ€šé0IÀrõý‡wç SÅQ˜åé*ÊQæOL ù bú§£aœñN2·þøÓSq`¶"¡´É˜¯ð¨Åñ±¿iÆ>`›ðLoÐ$—Ñ€R€Òg¡<̳”p:’.2BÃøRÏ> ð£„ö>ŽÚY‡­(8ŠÉËE<©êÃZò½ç[1΢ :­?\¯Á 7žâTÊæPì²r[wé4fX½SƽMÇêÇ1ý¹dy}S½%ÝmÄ«BbYêy ÖÕ(ÑYJXðÏ| òÄäQá‘ôK'¡”òå¥Äå-Š’P€B=a>*¥~-Iƒjaµòµ‡ª£4yyº£C‘¤g :ù*¦ÛŒLOEH›ÓÑÙ‚èYÓaÌÍ åG3•±aÒ÷¼bŒ…EìÁ-³^ƒTĬ(xµÇ„_GÊGA:’ìÈq¼hßÁö¸»¦ZcÛ!šÐÍÐâ§ÐZ4w'—.¦ý•^Š[èþÛ53“áñ¬]]‡xÖTî)mkâGpáöÌv±ää<¶È Zl'8™b9ò9±-ZaÃÿPº(\5pn19ø÷§$êû ½ù<L!„È3e•êe ûýMîmß`qâX7ôX jEdR,ÈÆ!öMÅ9>æn"Px¿¬‰}vÁИ!+€_HãHÁ…­‚ —âçã+6LòòefZþ{†ïÜWÇâÁÒÃÊ-®C×Öáœd˜À™A±)o¢WÁnx¶w&ÕÀð%'Ç\ÆÇ ~ÑÄÖÅÊC Ƭ C«¶#»HjXØ°˜K½ö<Ų—j<×ÑψÿäTúùržYÙ çìrVÙÜ( U”J}¶1ÿ]SœöHñ‚#€2=}Ÿ{,8~žUbWÔ§R >«Ø‡ ¸i‚W#Ó0é߶‚¨ rüú³Uìá9.znôE êõdôÕ2ÔYôŒè« ò¥r!úbó/DßLGgÖš=+úæ~ôM†à0ùSRr*Î%‘aÚ…dLÛók8^l·}Slq郩,‹î/_Zþ«÷. gÙ,w5m‡µ [WÒ©ÿtC¥’~¬¶x¾OC¨¯W[1‡Ò½?‰9Ú4)a‡ßí¡~Ù5ÃÖÄíÁ…Ûnâ˜}-®¨ ^š𞤨GS>;° FD…Ëñ…—ãèàĄǼ¿Ú GnÖö+rö‹òol=¦ª†—KÊ·}Ƚôä‡ ‡M½Ìg$Å™‚©<=¯å™}ûÍ'UOì–€ý–U%Õ­`ÄÁ»a7Ø™vÛ”7”=Ðwüû,‹ÏP–Ýó€äþb¦kž§t¥L1{ô‚È·ÿEͦÃSæÿSW¤¥Zýmüž/ÅW}•ØäWPJ°‘z:+&9ÍžÁÏþ@Së endstream endobj 913 0 obj << /Length 3285 /Filter /FlateDecode >> stream xÚíË’ã¶ñ>_¡Ü¤Ê ƃ '>LR».»b—“Tk(‰3Ã]‰”IÊ;ë¯O7$AB3šYï!U¹Hx4ýB?ÒÅÝ‚.¾½¢îÿo7W_½‘rÁÑRòÅÍí‚qI¸ •IÂ[Üìï–‚ˆÕšQJ—?­8]Öm·>6+–-ëmѶeu·ZsI—·ù¶Ü—]Y´«_n¾7˜5ÑŠ+DLk–J³%aéw]Ñä]¹btùþÙ¡ø™R^‡¢êR¾È©J<Ò”Pæ輆…Y²üXì÷¶õ¡ªW\.?VØ˼ÚÙñ¶<÷…mwÅö¾*=ùnma¢©WL"Iré'ï]#ßnOM¾Å©Ov¤¾µëz¶ÞŸº²®ÆÓÉr_VEÞXÐöSÛ‡ÖN”íd‹S[ džG úÑ–G@dåä ‰â @ˆĉ„HC\ ŠR¤OˆRi’pæqÕZÐ4c×oëª-Û®µ½yJز±­þa;1¡jð^nþÏ@2ççd žŽ+àšñ±X'àbeHxÛV }9á‘Œ I2=2ÁbMЛÔÃ%V» ‘4 9¸‰ëv“o?|4úmÜHÑ4ucŽQÊ{rÿ±+m4Þó#i[—õ·§M[l£>†!>=ÿ€‘ã|ä×,a$MX(€SÕ•ûØ¡åà`ÕÀÖZ°dùW #MaG&^âtÖB“ ÌzÍɨsƒƒûÇ)—ìëˆ%xˆ¤7f€ù(ÚÁÊf1L@È–×*òí=¶ ÌuÅñ6ÕTdž:n-`Þ8´#ÀžÉ0Ãã†! ÏE(¸&<96+µ o`íýAw”¡ÃñQ3$!I¨¾¶«ÇÞSAÈÙ8W4õnŒ¨l1Ïž˜!È®JR­@_pôµôÒÙj½¼ÇP't¶ÜEe‡Úû>Áî;·nj Ƹ—LO­ø»¦»Ï;‹ö#Ø„««ý'7kôU»Žÿ¿‡èµ„#ei·nÝ­ý/çö‚ŒíÅcòHúðŽ½m^Ù(ΙñrK r°ÿmyW•ˆÖuH9˜î4?ÛjÈXÞ`üŠéî1«BM‘·uÖÀöùè¯Ù¶U4À¼”¿éìŠQHªÆŒƒ)laúyñߤlƒ ,UŽ¼ç©ª»¾Úúê ”-# f+  ÌÙÏ”+©Ç&ï@áPð$(¡cÉ íñ¦rkd•iå¡Ç™a–(ÚßÝhŒeøw¨w§ý©µÌì¢ÜþYQ¢³´}ÿï‘€rÿƒ#¤¶ÿeµkìŠ yqdÙò`Q›2 † ÍpåuÐ'w¹U÷ù¶Ï3ssc…UQ¸Š6 Jw Û%ª ¯¯µZ°p¿ƒ?NIéHúLyJ››8å þ}D™œÈi=àJ8óz2À™:““+ŠÀ¶2¨ùbd/϶¬€&Iz’KPH¢ÓTõ,­¡²t(Js\^ß\ýz…‡Ï‘:[Ɖéb{¸z÷ ]ì`Ò3ŽdñÑ€ä§QûÅÛ«Ú{Ô€¹Mˆbr¨T#”d–Lh–:$„Ô‚15@ÃøæbŽ!PÖS$\GàÍîHþÆc”¤$“é—Tz¨…Õ>æNì fg3ƒœˆš‘Œ³A©jÐ!¸¨„hg§Æ,r dBŒöŒ#"±^GŠ_OÆ%;ðÏö8v¶)8:r\âÖŠåÇûKr;]ؤ÷˜Xyô~÷ª®~/šÚvlŽ?¬J U5:Ʋ –FŠ”ö;_Ô^;¤­óQ&csƒžÑWÿ;îêò@(?ß] }Þ_)Y&_pÈ6ìõˆ¿Ò-fê1Õã§üóWŒ³øB"‰³3g1Á#Á’È“îöC„£Àa_G(±"Ž50jŠaf>¹½à4 ¨p¯tÌ‹¡Œ&#®>Dgó%ÔuŽìlFöYÇ-$Iu6uÜéŽ[‰dpÜœ¦ã •b^åc¾3U¬\4E̵Àá£ìBm¦6$¡V™iHScïÝÎjlÒP¹†v'ëk7ÿ´8qŒ‚§â')ýè4C0àZáý€!íy‹“£Í·aõ>wwJx‘„}šK‡z{VHO_|Àª×.ÞXgb·»—P½„wî"½=2™–¥a,ÌÛˆ4ÞTÜC8ôAñ`”BǘŞf‰`Á1vwæ̉ ¡¨` •y§íEe^g/ÀD•°s§å£óÎRpJ=}a?!vÙ÷Ó·î…xï8eMf¼)zŽÍ¿)é ¹³U¸ãŠ!W¯b ¼¬×O1<ÉÀL¥£³0Ùy- ¤Ë‰}–ý`±ÚO„_ÐW¦?__óíšbòîÛ?;<ò4ØÚÛG|*ÑšÍîvñ2ÿ‘·äþò`§•Dàã×gDª€aŽÃ‹“¿cëé²yo¾í&„™ž¹`  ý©‹¿&…Œ$$åú#sÛ8ÍÙô¹œí:*(l’i¨Î%-?S¦¢yKŸȢGÁbȲÎÓúE2ê¾%àAõ¶˜‘”ykš’4 $*]'½Àà¦g*`Ï”|~ ö&2}ÖÞQú Û[ú˜u¼ôþO^¦ùIݪf’`^dùòöÿJ÷Å•n”lùÙ—È£“T,¬ÍÃMì·"§ÈIö¢Ð–àÔ$ËþsÁ¢=[ü¢Ônì(0ïke‡_§P/H3Ec—ï„Ù¸GQ™ÛSØà ÃkÁ”¹? ’Îg0~adœÔÑž„I•)¡½«5HúûÕ¶kNÛîÔøkTqÐe˃ 奩º¸Œw¹uI âštÄ' JýÜÏò‚o¨ËÿYšÊ'joJû诤ýÄ‹š/ D¹LZ¤î͇ìWÐÈoñ¦¤¸³ ¹ž}_„ƒ‡ºqˆ¶uÛú^D枦_õŸHïJ—ØÃ"ûeM¬.\ݧœ¸,âaÄÚ,¹ ²3ŸÃ=UÙ­…â ªP†—o¯òxXåYãþ½ûrÅ–îswèÚÏÝmÃjUw¶óþÔvÁRÿ¤jœ˜™p*Äo·ÚÚ¶6´)à Ø÷UÄP߀Åmi¿€2ëÜúÓñèÍbSŸ*·Ê”an_tÒtR€ƒ±/XãuÜ™jÔô¾žßTŽ?'Ž_tBÍÜ£ÇäãÐ×7Wÿx( \ endstream endobj 948 0 obj << /Length 2752 /Filter /FlateDecode >> stream xÚÅ]oÛ8ò=¿B÷æàjžø--pm/[d‘~\“ ´û Ût#Ô¶RInšýõ7äP”™8É.p/9 g†óí¤É×$MÞœ¤þùêêä_¿*d$WJ$W넉œè4K”ÖDÐäj•|ž};ýãê7ÀS#3pÀU‡½¬¶7û¶ðN>¢Wࣩ6ûîe6}9Ð" 31‡³[E?BÅ8Ú7ÅÒ8AÓPÂEÑt±¦{‚x> ¡—l îö³cÄ'^ÔÅü§~bŒÒá4b‹ò¨-¦D©©)µ> ¡il}–uNdÜúba1`‚ê$ìIö^ï’-Ú)’x™Ýb°|»ën¬ñŸ­cõ’ÊÕ}Â|ù{¤x¡P˜d¼CùwŒ %Œõ²½ŠÈÎ+DL¹ö)B¸© }»Ï‚•‰7dФÏñ:WàÚ-ÀFö¬«ØÅÂñ«!î;E¤Ø4®Úª“Å»“{Ý‹Ôâ—•—ªDßÞlL‡ïÓ¬†°5§šD-îÍRV¸öºhûœé#mwÃöDíJöÞç,“³4fÛú%9Ñ’=x=É„÷:­´òì!ÿÉ •4pWê›. {÷Á"y\X€÷q‡wX]F«v ô°jW>}]V›‡‰¾…Z§¨ØùLsþ³=žPÞŒŠpëŸ,sž ¸óº1¸”7nŠ3NèÐÊÅ”—‘t0ÿ@NhÕì#.Ãf[(øŽë±lt+noÀäÍ ô~ÆÁ1ù$rÞ^›ÚD˜eòŽ:’™¸î¹u!D § >o¾ï‹Ú ¨¯¦îŠh€UõÊÔ±é‚&<ï c9V“œ÷]t3ƒPÑjÞþÞ?Êûc¨¼ŠÆ–œ¬â.Mó8µ&Ñò §ž†M ùì:V‚×I-‡±ôh¢›‘‹¥g¹Ë¡tf;`ß%+Wã©óÖê°É&SNR>š–ÌE.gï*WhR6ÄeW它øWË¢ñ+kæ ™ ¬«+šz…³)·å®+âðè·SöÝð1':VÆxn|Þ˜ØØvª–â õšÎÂb3Èé…ÏOÉ1AsºëæGÅfƒ½YEÓ\:ÍoÚç·_íW S§OK)ÐçAN jæûÓóc¹SÔÛiÐAÔUMŠêôÀkÿ6¸h‹2Ï(TŒ$”ůØÒDçO6êòëu;¿Æ™ìœ•XœÇq5䙸OÇBd"ñ8C:,³½žƒ<‚ú!]jµ€@­P‚×5¸ Ým;^B‚£VQÕöÓÝw¸XxŒUÙ,¡Î¡"íÂÓïZävŠFÓø]‹Üfée±·áÆ¢–;¶.¸Z†" «v›;„¡ÔöÛbùm¤GxÕÀÙmÙî»Ó³'Û‡¥b¿÷Ú‡#»3fåY´„’ÄLgt{RðþöìÚÉ!M_,ØÕ®)Í2Ÿf,¸k'íz[|³bÿj»_^ãª1»Æ-=náŸÕ¾Wëù²ª l¾2¶æùÙÆúeóÔ†nmAm GaÙ˜^zûÉhö;'=.A‘ú{3ÌÌáͦ*VXáÀ²íÛu]mq&ýͯº¢Ö‹ª½žð0vÈgëb0"ÛÃAÆ¡àì,Cî¾~ΉâáÇþÑàÙž é çÌÏAài›ær¹ßµõ<‡R5íÆ ’m|±?–ÔøâÖÍgíÊè¦ /Iqè)í½ö57@Üž ¿Çß®Ðõqµ´®¡DÞU2öC¬d`å*(Éð^à+Xu–§øð6,c–1– ç6,6ž•þeFæËŒ—uÙ^o \*r?~™ºqÆp´m¾4CÛ\~¸ë·M7‰äýØÏ-Aw`ÜÅW™šB„#ùðƒîcÓ, úœ3;û–ŠrS@=óKäɈ}éþñìåEŒ>%’ íz„ t²}cþŸ÷Ÿ^]œ ‚B?|<{}~yþþ]l Hªõ£É¾~ÿöÃÅY¬é‚öS -ý Tjß{í¯G„QÚç˜ãûѶoË‚W“¹†CÃÓ ²õ ê†g¥I+fí¡.*ÀŠûáÉm†h‚Ø#˱2ePèlŒwW¨øÌÚx*:ƒrå[Ê6~½+¶% Ú<wyušóÙË‹‹ÓœY𼵞XG¤®*rëéÇæ ÿ€Úù•×ähfÖB÷Ce8‡ÖXåt:‚íü{U-÷Û~ˆVÜÜlJÓýüUõžßßjê}º±)8ôùnŠª.`ôç¶ÿýÌþz†Y×MÇ|žÀÙŸ'òK˜^æœ0nMD@«+üII šK©FÑÊŽY½ícWгʬW£û=Þ@¨‰ôä60…SgÕÉ\G.“C'Ÿ З):trü/Œ¿FZdˆ ê‘Óã#”ˆóퟱÀ"¥ú¯éð°•“üyJ<£îQ¡C…3s#ʹúŒ%óœE;» kÓ³«“ÿÊ…7 endstream endobj 835 0 obj << /Type /ObjStm /N 100 /First 897 /Length 2832 /Filter /FlateDecode >> stream xÚ½ZÛnG}çWôcòÒÓuéK F'Y'² #ò»ëø–éËZµxÿ~O [ ¥P× ¾4‡ìé9S]]uNu7¡B# œm ¢~]ƒÖŠ¶…‚ßY¨™BcüÖð=S Ä¸9eà Ėgk å†oZ \2nÎjâÐ}Z¥S #´Š6—žž(F«%”‚Ö(Ô˜¤Ìš5<_ð s -çÀbþüTÔà¦Úð[`slbARb¼‘á'¥ "@¢Œ÷,mÖT‚”„7T RqGÓ¤UÀM@ÙÆ õÛ[À›ù7TÉa¤ 9c@ãáv\hžµ,AÍÇÉ5d‚!›4|À»V Ù­]qÍêï€ÖöÈ‚^­å€Q1,Ì—«?&ÉF\j( [ñ©1¼]±PÄ suƒÃÄ¥¸Á+‡R}>«„Òª÷QX5'UÆVK¨ÜlÖ0ßUݶèWsÁ#*f½b^ZK+˜w@©†Á07òqš;ÇÝBüÊ åæoÍmÈMÝ>Œü0i–ÜðƆÁ-Ácð~\ƒ]L0°aRLÕûä`¹ù‡¬²À ­¤™%Œeã€$¸‰QrÏô‘à·”Ô»øW CÛø?×]2e˜Ú0‹øäÃÃç)ƒÉ§J3#v Æ>H…7™»|jÏ}>¹3ûÈãù­æ³?Â|`Ø”€ÉFþ ö3øo›=y2^þ÷|†ó÷‹ÙðÃòl½8[_À˜Œ•ùëløuq±¼\,.F÷¿úëâíÇù÷ËÏá•Q`×jüz†!V¸ói›~OÏΖêÕ¸Àñ͸À7mímë­mZN½¥Þro¥·ý>¾º/íëÙwßm½ÊøÜÙp|ùf=^ÿòñìÓlø~¹z»XÓëáçáùðÃ+/ü%OÖá•VŽ ³¨¹F…#!E÷-%eô{ž< Ãq~Z¾\†áÇðÍÏï–Ë5·ˆômŠI€°i,XR(bq Xä˜àáRS,…vyþÃß^þòÛ7”~ûvB °yH’ üW˜cÎ¥[¬*ñ.¦5*€¨Q̈©B9":=¢EÄ¢g D!¶±’g\Û‹ƒ¦ÄA¬‘ÛY`,xªpeÖG³˜Ö¯p¸} ä±qpi™ø‡<¶>>2‹fx.§˜‘Á˜[TDHf|ŸwYÏßœN?(Åä H5²#—Õ3BƵé>kðÄ«%#r"í°DOAÜr¬° ®kýb »žŒ hk}ÔHž›% ÜÓãD1§ˆ¤æ¡¼¿Ëø*ÃÓ'OÆ OOÖ—gÃñð÷_Ÿû¿o>¬×çGÃðþÝrõ~?ž­>Îã»Õp¾ZþϹ.N–ë“÷ý1¼j²É_Ã?þù/P„²‡¬Háìòôôõ]ý(¥±cá]ìŒ÷© uVƒ/‚‘ÔYÌ8Ö™«DçuöPe÷ Ä3s†S°ŽõFçšrº\ŸÏOaà À=ÖëÅê,lÃð—Ï럎×óõ"lÆœ ÏÀlF_{æÙ6DΓéê"ã¢ð Tôóê8__dÜ c áÅjyr¼€ÏÅÏÂðrñy}›’ÜfW¹ü‰]eýRvÅ]qgWÜÙ”ôV;«ÒΪ´³*í¬Jûýš{ÛÇÑζ´³-íãuC¸êØ´}¼,S²1h¸ ´D#ç` ¬´Ø¸”/¤k¬®‘ú!C4ƒ%B õs¾ ¬»~ÈÊQ‹ÓCä6(ì€è1Ã:¸¹ ­e ç"% âKÃå~z:17ôlt™Ä9ÃXÄ ©µì¥§:iÒ‡@€hÀ„´è²Õ]U!@¥¶hÜ ‡:;nrCÁJáÛN±­ÐÝ©Û×h†ögÍоX3”ÎõKçú¥sýÒ¹~×7­+ /êoÚÎõk×µk‡ÚÇ«}¼ÚÇ«}¼ÚÇk}¼ÖÇk}¼6­v0'¤:VpÛXBP«K°zd/1äɃôÃ5Í`hÒR§eì`Ê T¬lV­Hòò¥x«û•ƒ}/Ël—ؽ „«F×ûêâ®Ö10¤²ÈÉÇõ"ÎûöÈÊ„Hœ”Aùª íÛ¸:£:0d;jýÈââÈê„@0£oBÄ€ y¥»ú&§H­Þ äâäÃåQ¢é€æ"!ì+Bª—0É€(ÜÁÚG ç‹ÓÓÅQšÐ$¤iS‚JRFžJ¾l^ãµ»‘|šº<²6Ÿ²€‰uâ»´X¿ìÄÅ‹â{´Qv+Ý‹ÕïÏϦÛxëkâ±Ì7…î†pqùÆÿ^Q÷¨S2ËÀÁX0^qGšf¤ÁBÊÄûbI™2”ø&Yò hM ñ®ûȸC%wûÈÛËOË#³ùt@ „|·ßU¿óv*Ö„’&äªãþ Bð&Ph§[ìÕ7C´kÉlRÅ+¾“ŠìÛc¹ù†Ó,9ÿ{@¹Å°VÈw°l½dë! ŒÙj€-î­DLJ’h³;W}· ¸’BòfOÃü€8n§_¬]Ùh¼²É¾„PÂéî}¡î©ç«£”§tLˆy€¸3w¶è'1ȵäÿÇS]´LÛ¡¼žœ@Í÷vf­XQ5WƒmÚíˆmÍpCføѺºðã5dßظ¥S¶v-¾PgÉmá'GѶ9Ÿ±¥3ü¬cñ£6›–{+½ÕÞæÞ–ÞÖÞ¶ÞnÞÖº=¦Ò Õ÷!¦5oD~µ±öPÆ}ËÝqj~ú~yònÒíÚ¦1sƒZ)V¯2¢‡\²W¦Hñ‚?k­>è¡œ[i þŠÈŒ…SÆ:…ÃæqDA•éAö6)E^Ëa¬-#°;5,ÉO”˜Ë#/œñ8Ž·¾`  2âÄv«ÊÅ.çÝI¦,³cd<à‹u€Eã\Ô7s3 C÷ᨷ½Ÿá<$Ñßèw_¢ßݹPér`g?²‘ï¯ÌžÑjáú&˜Ët_A^ˢ㱑v¯ÝjàÃÙÄØÝ× ³ZÈ`”ÎAœ³ï,܃˜01èÜ¢Ò>h>üÖ—ÝÞÎÜA"©ä|Oç²Ùóg‡¡ü8üo«f¼§æL~˜vrÁm–xƒLÞ8Ûâg,ꘚvU°ÅgŒ¿ŠYn’Ü`–Z¾”YöS.&aöÓC&aJg˜Ò¦t†)aJg˜Òf?-cý´ŒõÓ2ÖOËX?-cý´ŒéÖÙãÿo#·m endstream endobj 968 0 obj << /Length 4150 /Filter /FlateDecode >> stream xÚÅ[YsäÆ‘~ׯàc3v® ×(ô0R¬½Þ•d…DÇ>È~@wƒ$4h cFô¯ß¼ W9œ±#ö…](²²²òø2«¨nnÔÍŸ¾RòûíÝWøcßhåqlnîîo´‰#Û›$‹#mõÍÝéæ×òÛ½VJí~ÏeW‹úvobµ»T·Zí>àŸv¨š‡Û¿ßý7P47Y”'‰C‚êf¯ÓHi!u÷Xâ§z÷Ðz"í=÷11ã‰ÑÛªç·CË¿eÓ]Éï Oª=qG³dOïŠãqìŠã­ŽwOÜs»‰òŸŠ±ï«¢ºuu®šb¨Ú&ºÝ[mvïxØÇêTÖòùØ—'\#­JÐr^ÕP›ê£¬Íóü¾iqIeŠ¢ùd ùd:Š•‚DèRtCåÙ¿Tž“jœD &—¯ˆa·û®mz`Ö¯&”‰Ç¦:ŸËDÃçÚ¿¿‘Qþš]?”ž*ISéÄE&1~®*ÄMäTâøíüNߣzÇ¡íª’|I‚{«ÒȘl-ÈðSv÷7¥L×üp*‡²ƒÍ)Ü¥:š„÷>ÀZ%©õúñøÈ$‡GX5SK£mi5‰õ·À|&Š§•üÞi@ž¦ ¾wQ–XS¤ë¹Ú½ûº L—ÃÖ'7‹±~Æx¹Â(5KßÜîã4ýû=0·É#—¥«Ékfóå0Ø-=¼¦G³jUAÈš xb¤8 ½ ,<‰‡þ¯‰ºJ92pdד­ôd9˜Sšä»ŸÙxûkÖD¹K_2‰$J“™ûæ4¬ÅœŸÔÝ¢Óè?’=].àŠ¨£òΗó«H¹Øü.@œ~¢3?âo*VȦXG)6êPÈzm£0Æq`KÞ .º¹o»³ï09û?xуÍ#—Ô'ƒÛ<7É¥Ã+X 9X$5p½Â!äD ÑUÃþ‘XÄèèË6 춛œÕ!謲<^,[ó‡Q2ñG¢êÄžtâ^Ûz<‹3©R›®¥s€•X#_`cÖÐQç¤ü®ìPt4Í꣮hÞïÛFžÆË©JPË>¾ócŠÓ¤\4Cñ ]è{™n º\º¶@·‡û^rÔªä÷ÐŽÍ©Ÿ¹¹‡Ž bxäÀ8ûu‰ÆDáê sbÐý€Êž{%l‚4*Iq¨êjxºMb0=œXÛtw5ù_Qdž4cùyeµÂ`Í’Óvw,zi‘0à·‡ êû(ðË^¾^°‚D®~sµ0~1ÍÐsoÁ?÷c]Ë4hÇé“SudƒVHc Æ|ßÇ° >2÷n~/â¾E(ÔõoÁRmÆÛ/OOMqÆ… !aǹ=UDË~C&8½šç@!‘îB¶à(bYPû™V@m„5Øì ,«´eÙÌGzíL²‚–02€¡÷XÀún3_Øz,poS/øE_=4$†#X wrÂêxT;Q*¹CëzO¾ ©FCÿr``‰Å¬‡ Ɉ $e[°2@ƒÍÃþÒVÓ0zò•¸ð~w›Áñ¥Þ!•qâ L€º^)®¹V\Ü9§¼ŸÑ ìêøž‡Êa@LS´óTËee—ÐpÐ0Á.uš¼;èù'|5¡jë¼Ç{x:Úš6ÞºkˆàÓ& À ƒ{nÑ¢~}Ê]YþÁÍ>•tW—ÅiϱÃùUmðöfë€5½»jeÿØÖ'Ÿá<‹Ás©tÂA Ïà›«‡§·l홊ãÖóý¹™½á5sp…ÊÉÀñ‡xß9¥OÛuSbÀ!.{ƒeæ‰@¢¯C a-@žÅ8 ©•—¡ôä^~  1={³·€·Op&˜I6é¿Œ(‘¿t³ŽÕ„Y¤rw³öº‡lÞÄ! tg´8!ªõŒI” ä <OT²{ìÉVÀràWÊñ¥€ýTà^Î4h‚Ïÿ¿d빿Æ÷S­d«Ê6ŽÒÔ,ásF`rù hHžsHßÀ!ŠÊÄ÷„˜\L?Õ_`—Û1²«© #8²^§¾‰³µÚ@];çao:å"ç¦õª bê$i\€ÔìeíÎ ?GDÖâ¢D¥Ë‚‡Ê “ÿp±T…úµX—xžWxdL±–\¼„ 09†ä3[{£òÝàOæ™\«ب™úMhO4šÆ4dR›Ð8¶,äÒ6'ñì ;y™lƒ©Zƒ)\R³¬gA咽•fzR ä ÁRA¥§3ú©ãcÛöe(ó5:ƒŠ·Û¯¼£Y8ÂÙ*ìS³u"+B`Œqþ’N¤‘Š' ÉnæÚý»˜5Ÿ`v¶$ýL¾LN¾èYè üT²vŽõÀýî%ÔO*àô&Õœ.N÷°õP6€.k®W*ÂE>ýjWA³®ºÜ&r‚ͨž¨|­V­™Ù*„à¥ÜKn(b7 `4+FsÈI)Q~ìEãÁ*¬êEñM‡ŽÔ?üL^Ø.\™drßýx÷=:b}åˆ7 Ù4Jâlv&\ëͶWpmXV¡+µ`b“à¼L%ß乛ğ×ZtGIŸÛf3^Ü•<Ðßù^fWßH9B Õ>3ïÁôë¢[ç׉øs²\u KmìÓÀØìΠ‰Õ}×6åðê\-nKNãXrwÁ?÷Ð_Ž¦ 3·©ê4QF%SÈ©Ò‹  ÕE` »]sU=7í8Põgbø¹Ôsó§}?žÏäå3È êöøý^nAÿŽ¥®øB2@·q¿ÔÕù: =QÄ56–Ó`.«Íî/$^S>/5'Ûd:B™ëxWG Ä™²Ì;69iÇ.Ý©ÂÒ?^…¾Mj¬0‹"/¯æÁi”¶Œ»áEÓòo+:¸¥Í„¨œÇL¬Î‰ËöKªr³KyZtßž‘”^ žØãi'z/½]y.(eÇbD3{³RûwÌÖ1P¯#TĤrD½+§òÉ RÍ'O‡Ì]Ç:´N¬¸ˆÆ©ªøËù”Í@z˜s$À‚Mª ÷«²D«m€öE8J•^{… ºE¬é¤vàg¤?/†ê+PI QGYž. ¤T Iw?¶Cé+„Õ…]ño'ܪ|¶¨·p”S:Ò© úS’šÔÛSé½^íÏñ´ï6³Åá£UT÷,­áé"-*­Àï¢bªø(Ozë —BµòËôÔnq¼†ýXƒ|Ã51Ù4îg½øRãÖbvNeLê/üXÀÕþf˜f~ÎÛ¡ lË!¬=-ÏZ¯g†_}¶ Kó)â3pÐM~w·:1À^`Ú3HïXøât|jã¿_V… U´ŒK0Òcwðg ø½?zÂŒ/ q üÎ='·glÇDy–Ì®íšüåSYÍ ZÎ[صÜæÊõ•…®þ ‚D™kç¡UøŽnª÷äŠý¾=ôàþÈái™*ærö ¿]y©‹#<á©Sôï'ÚhÝÖòÖú$«²C¬…%Õu§¹òìÄ@λ|.› tœÐHœ‘ò0}A…Ï9×õ¢hÊ37öàŽôeù (xó+ þe<ô¥/µÃ³ Ó^gáþ˜_“é"3ë3 f•­Ò‰ø½:ch †§zdœü¼°vØuŠ;ÁÿþúÃO¿„Ž!p¾ùœ²{ÇÚ·•ÓU¯Ã¯GΉŠlºÎîUÀ9ßž-~š«û!ÿns«¿ ç‡Øí&ø|>T/;\º±ªs)yIâ(ÞÞSÀ»!6'ÇVtUÏÎHܫͧBN žEÏ…ðÐ5mª žu¸ Ï¿ŽÜRðÏRôqö¹c(IÃ¥â߇uÈx¬÷’éŒo¡÷Tõ34ñ‚û`³ê$mºJúîñ¸QR+yõ«ì$n3©6ÈÎwÚl úï‘Ïêò’Â3ÙH%Óµ%­äÞÒ”ÊR8m»÷“2ü“…^ …Ìâ_ïk Ÿ¼Éä53GÇ~þkzD×èüÙ6¨ÔâðÖbôrKÉGÍæ#t«cƒÑÓÓõž«"_KƒÛ€¿Ð¥3’{ˉ˜à·Oü É9«gIRå$JòMhà8ÔUTWø,ë¶6óɺz÷ó‹…Whη"ÈëKsøóúȃW‘žãøEŽ7áje–Ëg… [`§ºÄú)Áå5¢.Y¥PÇêBÉvðAwJ.‡n_P¾Ýs§À±qg]¶u Á›Ià2uóI!4&ÓåÇË#¸>-W»ßFâR¥»5ß#©’;À¾ù’~$i#}?Yáò½K}Õ–fåR_ØŽùÍ ^TÁ™'èÂ…¿@Yˆ©ž´XÓm¯uj6›°Iµ¶T.àköšÐ/BW%{hV'ÊþaÌt^º$Á;‚]m΂ ½ÜšŠ6‡_Ñýi³ëàUÅC¹-!¤c§Ü}fùÍAzi_k¸xä3_dS’Yb¡ññ|âk ×2'€¹¬.Kš/ºöyS¾€< ÈÒÏXêTðüFóJ§"c’å¡´4NAYéú´gCë#Ø’4 rÃï¹Q?†WNÉ%<~A!UÈÑé—­O w½0Sy> þÁJ$ÖaöæÛZý“ZŽ/¦l®ó§—±Ãë>ì×r¥É¦~?l‚uœã#Õ;KÑ%ñ![x}`™†Ì˹©[¾Z‘`ÙóÜv|¢ÿêblÏg^ŸgÚ3\ XÅç>ro Gá‘yã®ê|(jÂeŒZ-D¥·¶ï«5¡RÞÖ£›dlmu1á9_瞆VM5ßL˜ _¡5Úà+±š¬öÃOÞß“Ê”B„.˜˜”»Ã/ã²uÉ^?S²G1\ÇœTG‹¾"äè9äÌew¹Ž.1†º`-+Ä#þxO 'w5]˜,ðµ¿K“[]‡G—’%²s#âl/ ôs ó/EÏ~ƒ6ËÔƒƒtÛ%ªóÏrOÓƒåM”¸v6}à%€m’6d2½û/ü‹ ÚÝB†òfy÷ F…ð˜>d—ˆä4@lëÊŒUwuáX}ûý;œå»_ÞlòÖ_ŽÅ÷ï~ºÍñÖ?ø¿A‡ ­§8ת~žÏVÞɽ%VèRn/ùÌH®Ïºép¥‰YåÖ~R¡9_f­äbVQ÷-Ïå‹rÌ«9œÇ»?"¤0tOªêåU!W·.åqº”Å2xâ?ÅuÚg­/ ãE®9C‘b’VmºÉ¢Ùß:»“„³ìšBzºò⸳žŸ›²”Ê’ ßF0`$K_a»ù\§ãw$YðO á©ò\” jǪk,OE¡yµ‰b|Þ¼”ãr·Uò/ý‹ µñ;Ç7_Ö±ˆ%†oühí"å ÞÕŽ2œ‹ËãÕ7ÿy÷Õÿã†\ð endstream endobj 985 0 obj << /Length 3474 /Filter /FlateDecode >> stream xÚ­Z[sÔÆ~÷¯ØÇuºk•<„ 0u’ú‰ßóÒð"ëÎlz–/š óáŪ°7V „½aâÊN8üòЂ5mÕ´†8Ä*4~u/K1 h¨Ñ‘F·k¬ €ë¦ *>ŸþR': õü…±ùI «˜¹ Rí9&¹½ † *”Ž£å‘Eç”uÓl‰Ña¾¼ÝY²8a¸‚ ür°-Y"ê˜H Ú,ÀOdd!¨ãVÔš¨3¢ƒ 3¬Îéà½4p¼Z µcÑ-Éli«(’ûÓ™c÷ÙUÕ¡¶›¢gÙOB`êjÄ| á3á ùtè M¦.ÜÝÆtvèÝÌ„%Äó†N÷ÕnÍ–<à—¶wçi²|"ƒDƒ€é×­Ñŧ|! Ÿg%çañ_Ɇg{.¾ 7ÜÀõ|ÉÞê™Å~Ó·:”½íw­)¶CßãU ƒ?z„FäáƒjEOA€“@á¡é8W˜y~ª~›çâ¤ð#Ï›jmëUŠz;¥ú[i>?Y¨7‚’c€%®}=wY=ŒÆ š u<[o/íŸÉþ†Üz °íØ<ûicè¾”?™‰†B?óØuø×—ºÚÏèoœx~<„{Ãú¯Þ~ਾ-”âÉýݲÜË¢a‹/nFñ›U²),Íëº7ji-m«–VÂ2iÏ< TIa“X^æ–ÚfaŽí´oX_uL,yU5u©Fr¿ð,Q݃!à+Kê/ëCµf•MÅkÐW,M'[K ëÐYƒF¥þÈ¡S«e²oäãEÁèœ%Ák]‘c7Ýœušƒ«Êœ!¸$½¼w \Í‹«³/g$?þ"ÀÔËWá"ÎRDýñbSýñ—¿Ø¢’ïEùjqËC«EèqLZ.>žýWsËéf¹—f²RŠü÷|ûérfOŒˆ’±%¤Ó§;^ýöáų_çòƒ8ð²#7`?að¿Ú¶©+µ>fl`òs¨¥¤«ÔIIYt9¾z Èq”r¾ÚqoþÀe„>][ð·ǸÓ0ø¬‰ãÈKƒà·ñòÂÕêG왆^ž­{°™—…'’|ï^B?žÜ a" Iy{«Úb$+¼«mÇsM³ÈoÆý˜Ù· ¥å4h Ã!x±ë@9å'$‡ŒÜ©ÊOØÏŒgH A( 4æ]`ÍYŒLü!ù¢ ¡þqúM#™/Ê–¶×:Yá–œŒíNÐ\‹zNPOQ;ÒŽE ‹–,¨¹èÑɼb¨i,c·t>=91ƒÿ>pç h#Å¿‡“Ð3y‰ ¬¥é¸`)F ³h‰p ~¤*ê‘®Q6–Åì7=ü†4¹ BÓF~èªØêl–™L#ß=ŵÚQcwööILÁ9°äöö{`çl;ùªBnEº4„'šj5m'½"`¹¦2?“ãDØÐÉu3éf1È'Itî2äœ|½0çÐ Š#ncu‘Ï(H Óå­.ÔA»ÞÍE¶ˆ2Á4C„&;‰úrlJ€h#AœÂP¸ÁÇp•h’Ð$BÇiÇ›£–çd>&o JG ŠèŒtß‹E¼é&Èp“`Êݹ2ÉÊŠ s½¦ÉhàXŒij#(ÉÌV¡^NÒi›-­ÐläZz™ª‚‚‘‚ ]ì'ªî{´Qè*:‡ÔÕªÍҥţ Ø©˜æáþˆªGf¦‘f¦Ÿ:©¶Ä‘JXìÌ%Aæ[oj­Z¢ùêÅååá’m7w„ïî 4}k7Ò¬ Àß.ä3œ(òòXÅlÏyn³=l©=œ×“¼6¡ªI'_ñ3I$ÊBÑP“ ”X%(ŽB󈩓áS¢y d€HÔn£ý–ó!‚ź0;3wuHÃV3¯Æz¬vÛ8<¼'¥ž7‡²P”徂 ’uXH¦š6’˜+ʧg)œ½©öpRÍÅ*Î`ùC¥+riu#’…ŽÌž§³7uÑØÂÂù õ#hÛÚLœ.:‹ÊHËú¸KÔ =°·›Ö®9 ÇgZó“: >/ôû½à2Ï¥ñÚ®ï÷ÝOOŸvÍu €$‡³?5õn)…Œ—2lk¾š’r|j&`õ5È‚•^ÍɤïÆTUÿOÅßÐÕ_­¾+¤ˆy:Ýÿtsî™ÇÙh~kYåñ“Í¡3ÓW™zaKÛë4®­y×ZÁ¨bçâ y(ª5©¦ ‘Ζ‘n tý‰4ÔÙ 4‡òÈœS¡‹OŠ®ª°Š‘¢¹6é¹&Sïhå²Q2÷~Ãݺ›FÓÀLjÞ4±ÞÎ?Ù ‘%÷ÓØ¿ãú°´ÜvãR€^IçÜÇó¥Kó¥õø×–`Ï‘ ¯-¯Ÿ¿½zC\CfÈ?(=7ù‰î…ÁŠÑ䘯‰æ(w% hEáWz–®š9s/ãŒz=y„è ܶ¶ï[·‘¯JAú4ICgV³kŒOèýŽ[yyNžhy[–‚ZkqHò`%Â’YŽ‚œ_Qðéšò ùD0ì…r„¢ÇÄœü ‹yÇæ$pn†ÒÍÇ“ôí8È—nå­Vt œ;ݾ*è$ºÄŽÖaGôƒè™xU-¿ÕúE+œW’V¾5ðåæäµI«á:€ê[ô•¼–p·;[š“·-[oè úHE¥ûÍîdÙ™{ä~°Þ›Ó²+ª5héáfE ×ÑVRÉ…‹Ñ‰áAϵqŽy%e2üÐÉx2&¥¢ƒì„¸Œ“ã]’­ËÞ’_–QSyǸi®Ê+62t=Aˆ”Fn›J ÑŠ(ˆ¤\H(1T Si|Ór¾\´º€)mekÇ_ $Á ¢ãœu±ù<Ô!IEš¢OÍqžC&Ìd陈æ¨è> stream xÚÍZK“㶾ûW訩Za €É¸|HüªM­“”gör|àH˜×)“ÔÎŽ}ºÑIPÐ<6³ëfDM ÑèÇ× $‹ÛE²øñ«Äýþíê«×?(±ÈY¡uº¸ºYp¡˜Pr¡sŸ䋫Íâ—å±îî÷{Ó·Õúb%d±Ü—øl:xK“åMÓRs¹Û¹‡¶ê·ðAµî¨á?‰Jºª¾Ý™WøXnšãµ{áËÖ”;×¾nö‡¹àjù¾áŽ ¬7禲¬|¤çª>ûz:vñëÕßa©+ž°B´œ«m…l©dÙúª©éÙ·­›ºo›ÝÎlèýúÇ‘%ŒÃŸZ´(;ÿòó(A9•`™Ì$ÐØÉÞ|û«·¸|)qAn,ÿLöiÎRžû‰õ—šÉ”‡+xkzì}ýƒÖÓ™SÆ‹aâš(‚2–'Ü\Z`¿uM»1­{¼™õ91ŸNZH¦…öcþ52©fÅ0ç+'ë›û‚‰DÎFÒj:K3ßÿMŒ–‰àí»/\±,-< nK¨Û~¥ Û^ýH udº•Ö,Éôb%2ûf‡Ü ;£Â¥É<›NN2•§-*H«K+‘«¨ `™y6Ðþ< [ò6Ê“ÈB¦ˆ&›Ð(¦¥iÝ:ÁÕ 1<ñ]d”Œ ©çRÔ^Š`hŠl*NX°h­^¦Qqà·@µG-HY3¬+r§ÿŽ –€m  +‚È*"“Å„L0äÓë8í-+ÇÿY¢ƒeÓÁ¾è|±‚Ù GUU{@·É…ìvä³bæ™Ã½ u~r/¼J¬ƒˆd‘ÁNæ‰wØÎs0½b±šPÙó©¶lÃ"SΊ—µ›s¶|Þ˜OÕP=G ‹/«†‘}™.cš”0{P !dj™[éƒ|”ÆÐÓeWÝbˆæœ¢÷Q `‡L»¯ê²î©ÇqèØ—UÝ— ãÐqÜ’üvÿŒ9¡Ž¾-׿QMÀºÀñj˜ .wÔ|€É`Ìc_"lp*œ-/×ån¬lÛò¾ó¡›¥* Üe œKPü¾$>`eRÚyê(×ëæˆËÁæ¾i@meŠÐ†º×eg\ßÖ å§£¶x2`P¥9˜OK#‚òB$Ëø¯©6DÛ Úú€ÿL ÞY6B-ïÜ@yᇷDz1ãÛÝxëõ±-{ÃYˆåœ¬^À‰º¯º®¤7‚wð@ÀïÐÔÆn(vµÆÃ2̃²ÎJœvw?¡55"¿]õ‡'½Cƒ·Oµ1 ²Ù«p)ÀÈ@«R™[©bÇȶÒÀØޚߦ:PÓ°¹÷;ÀUJ¤[å™F÷jéÂþ`¦¦Þ¹A*P8TÂa|Ò?þ9E›¬dŸr¹Üš×U™ÅO Á³ÈÃæ,ýÓOï~ú×eÄp%xêd¬ý¶ìݨ~žÔñrÝ#j—9Ÿä Ø»¶J׎|SÞݵuèÆ<¿¿Øo/×YœÇwðçI¶Ÿ}åEV0,zš  pÖ{ÕjÍæ¸&ûžjp‹*o§ùýXµfjK)J¡s, Ý®õm‰v •d\_ÀÔI²üÖêÔ0~gv° ¯»0^[™nÀää¨åtdžC(Iù,Ö¤\o‘Ø·¡½qʤ"eâ‚8Ý‘NCР;j~€ÑÁÕ1éüô¥AáüzJ©Õ²<vÕšÜ$µ8á‹v ­Îà¶ê©eâ4ˆ}2vŒ’±zÉà ‘L† IÏSg¦Tj¹+Û ž/o/x’.꿼¶‚ÙÊD,ß ¥î›®§'tƺ6i=NwO=ãÆÁ ù0¡F?ᾡlVh'†ƒ f¿¶b|µ©ÊÛ†bÐ8²å‰®?pÞɱÖìŽûЙ­ñ}4KLF f¥–xÙÂÃL¶Ÿ»a‰´yÈa>SÅ1p¹‚’¡H`^ðËD0G "  ïûhVªSp]#y#XÁµ[ xå[¸úÖD˜É'½ +Å”ÅÌO'‚¥bðº±qZ1ºeÌi„}¦MÍ&›º½ªú{z#Dá Bi°yªÍ?kCàÇJM0äu_V55îË÷V³¡¹#Àþ­£¾ê†~É‘"Eß×ýѺìøôMçÆŒå!"I ‘/!v¥ÅTìd§À‚÷JMEžYi§ìk ±åÆú¿;÷å`÷Äþ°ÔXŽ.˜RÅcûÈ'ûh÷CꜥugP‹6WdM›9ø'Þi±Y^ðõ4q^jñÁ†ÙešÎꫳÄv¬4yæ\Î?øÈð[Tu,E&¤Æ:ÅŠg|­ÿdL„#<©þpÇ ðt©LQ#ÑïCìÎ ð5ËçÈIU”‚/‚Óe>3d®xP¬xÉ{NJΛ݇׀EºjD[¡˜´¿C…nÜK[•õíÑ}F¾ïþ/~hDuTX¸Lý>Z;KÅÓ+šãú뇖ª,€³lÎ"A=àG,oŽµMZË¢/ÈNq<8…BògŸB¥)D”È)Tò¼S(ÇŽ­NCŽ1YBgzz§KNs39zÞ"på}«ì!×›³$ÑŸË÷ÎÙHÝm+›€É4,•‘†V—ýIÊ'±…Ü/ÎVM%}JA®·®~‡€d‡€4ÖRð,Å~F¾Åês®(üZÞ¶áA„óœ7 Ìt* &Žˆ\Jç0xæ*‘’kB+ØD®‡cõ•N™å µ®!~´µé:7Ôëß:Ä‹µ¢´7ÂŒ›ÈH`«>›Ë û®Í®©o­'²œ4³OHâ»ß•]Ï"Z¦¸Ø‹’eþ~JìBŒ¥´žU'¦$ jp‰ nV SˆXr" †s&tñ$ÝÎÎ'êÏÒmãò¼w3Nóy™ÑÅÌÒnV)`ŒìL<‡ñÿ$ñR²™êd´àD„Pƒ~Éè=©¼ šøMl¸L䟨®o#ìk{)õe5„Çì÷$¨¡%1=š¥É,kyÛâÅØž©R ‰ãdž7±=¹ÆûXBä“-^q•žÛÁÇêÔdwÞEu”§ÙŸáL¾3"¢)€{YšêÀ™Ät%‡Í»ŒzöNöå ¦SE¡…xüâá‰[BŒ ,󷅎ݬü>Àîd’¹B9$oáCd:‡Ÿ*g2ôò 0“R³ó„îˆ@…¸+ûˆPSÙxIý2²=eGp÷Mdˆ ÚÿeÑ_p½XÓ!Ó8ËX;šñ+¸þ2ü>ìk¨"9™æ¡ŠØóÏû&‡"Ó/íëOñGeÏ‘ê‹A“Hw2K¿$„d$‰Üõ+RõžöG¬lâSw0ëêæž^,Š‡_w˜ˆ6“(\áʺÜÝwööŽf@AeS;Þ ýV¯Û›pÓÆÞ'&È—ËàÏÝô;Éÿs—COjó”NIé8Èjr·äOLéâ»9󔊉4ÔOvOþ·;#'« i²tõ*,ørdu®@»FýV†Ê‹9 GØ“x™=cÒBžôß_}õ_.s endstream endobj 1032 0 obj << /Length 3175 /Filter /FlateDecode >> stream xÚíZK“Û6¾ûWèHUE4 é­ìÄNeËNeíñ)Þ%A#V$R!¨Œ'¿~»Ñ_‚f${²µ[åƒJ ˆG£_7šÍngÑì§g‘ýuóìù›„ϲ0—2žÝlfŒ'!OÄLfIțݬg¿VÛc3_ð4 Võþ°S{Uµøœû¢mÊÏóßüóù™ÊeÈX»Ð 4b´Ufyì|ËeqPhÚ¦ Õ7ÇÝŽ:ì>¦½œó(8ZîÊvKÝër3çI°Q¥. Úûƒ¢V½¡áëRÃBv…²®èí§(‰´RH$ð& ü’YƒLrïz6ûÍ þp\jµr“³Û™ÄÕÙ‚E<ŒÇF˜'9qS#“(Ø×¢ÖZµE¹Ó!ìÏp‰aœŒ§ÝlK`ŠH’àP4mYìèa3gQP¬Úº)ÿ*ˆ‘È`UTô~©èÿ¨Õš^µ5õèz÷çœ%òH¥<”iâ¤òÒI6&wC¾÷­Â„w‹,=²ÏèÓÒR<‘’|7g,(î5=uYÝÒØvû˜°`C1$ $ÂSáöüù‡_nÞ¢Ô¹t¼ïÄ7!u!¸„‡‰T@Å^µª™5!åÁϨu±•S#ì ` e€ozP÷VQÿ®¬TÑP§¾×­ÚS1gÖõª,ZZ*uŠ?œý‰sQV@TY7ÐŽéõŸÈÕ¢)‹åNiê2šˆl‹j½Sn+TÄh|ÜF­+µ~¾ª«µªè8 ¿My»m8{¡ËµUjcÃF¹õ LÍE1ã?Q M½ÛÕHÛ«™RêÕQkÐæplQ`ižM2Ì‘L¦rËrËBÖ)é€ZÇÖÑG5áÈÃÁ<¡b\¯^ŒË ÕkHf…RöÆdöܤ)8'a*;~a,ÉÂ$Χ ¡ºƒuŠ†B°²9¨àhïdSOec´¨rÜ945èÎþ…ÏÔ~‘"Òå!gV4/i Èãó4•$Ž(’³И§4Êž0fƒQ"”I'µx–A+vž8d ©Ûå³g‘$ôR2B9¦£u|8—‡)Ï&07Ù]œo+ùÍ/<²_ðTOÀjœÁø˜F¾®À›¡U Î HáßHQp60OzA6Š­UÝ4JÀš RqVM“Jè[¹%7M½-Ê]0€CSÆîJ)»KU·ÔXZ2´² fClÉè €öͽ5ÍjÝ+"h­ëvþÒt~>ìÊUÙîìK³º™SÓÿ_ª©Çj][0ÿ ¤, @,X ˆ’])À°ÔÄj(8r8Óá÷üš¹H冴ê }†‹EldéÏß0P8ð¼F³iÆ|mdã´Oç>å¡` ˜K‹o=Ê*Á­²Ê'¶ÐQøê@1Ø&òм§GT»Œj~†jñÕ°ÿÀdÇ,’ýó©T³d†PȳN$b¾{='´æl,œ^ødqz‘p¾ú˜ŒÅÃcþ·¨á]X/Œckd±8¯-<8¹k å!k;?*9L<Œß—@ åcÅh±…68Çe‹qŸ’1Ág<2cû³xuë,lð4tcãõЋ áˆG|NO„9†#qÄpä²Å®âȹ ^ÊÎ8f ÆkŒŸÄk@)èM†Ñ'Ü#;øMÙ趱À‹z@:²áàºCåO…Ñâo‚äAøjÿK -¿ î=ôÅ ] ùvØ@ó/[ìü-X‹P`\}‚âB,x9ˆZUlàê䃌‡s;_ßb‚o1Áÿ œ³ì2dÌ.BÆ쎈«p ‹Ž„âà``αÁq{¶ð¡[$ÜØÒ¨Kù¼Ç̦ž\n­èóP‡m¡Õ§¤œ'yª”;—’¼N¥¾E_`¨ãX<6ý%OÏ‚Û—6kÝa›jœMO\Ü|ì&ä©[åF­½b°Å,{š3 @$'A Á@å¨ß¨¦!Ò“ŽôB[)%Y˜±l,¥.±tYú}šà²@³ŒÎ ñ+ é£îó%V(úˆŸ²Ÿÿ¦`Šáëlç*2¡äÖ< ÑeäO¥èÂó>7_$©×sÂi„ô^;F.1îð¡ð¾÷i ¼ÒÇ%TQ è'¿¶ø¹Äœ¼¦ÿ¥e€3MÐå„eæãv—zÂ(ÊãêrYîÊöžúðk§àQ?Ȇۆ0X£aØ==ç"d¼ãù¹8E\b(ùèüG¯’ylª2ã}_Ï:¿-ñK!KåËÛöfú‘êô3kç™Oì °?%œ¸Âà^>•~÷/eÈcñDÞŸ?äý“©÷1ØÊÊ~ñßYÇüò—ë„·q6Ô/t¼s–aÇ×™³ý§ÙÕ1 VŠÖ  o¬`þPk°PüÄ*,øãÛóæ–çtŽ/¸c\DŸ>®¶DÃÏŽ±ÿÒøÑ›ÒárÑûBz×htu¼L´¾œØ3z”Gp0?I®sèn³t„SÙÈ¡Š¢È'§0“é•lâOÇ&~…È]õ„-ècñ¡Öçu/Ç.Á9ýa‡¦F/ñ'´zt€xø}U$Eˆ×'2™àç´¬'å´FËóŤAÛ¤øÄÞ,¸ÓMjÙ.¾p9.—ãX>wÜ­©¹T®«ÂànðlÊgð¿¢%Ôx~5-_㶌gH¹[ÚÐÅv-wõêwç û"³lPƒ7¦‚þÖµÑTj+R~@‰eŸç³lÁµá vºÓ箂-²!r”‹ZhŠq³Ð‚sƒâŽ½¶|Å­f“À€4 ³Tž¹sõ|LJ¾Fas¬L¾¦0á¶ÄË&/Aç“'pL8_Djú(esØ'Š‚WFf©·5Òy·x_T¿÷qÞ«·ï­Y`ü{ܵ妙à Dï r6£ˆô”»Xa»3W¡Øj«Ec¶LU tÐk‹²Ð]¸Â,Mo@UXÿÁ¤»VÀ”r¯ìƒеWûº¹§6i¿©Ù°WIWèч¢Ñvòºlàºoûlm'T¾‚4]ïÕ¨8I»R‘²¿PPõÊI±×¨Ð°ëU6ï¤'•R=­Ãs5šïð–bŠfÀÛ㱉h[ÀÿªÝQÜëŠ:~Åu;º`ì§tAïë]ðˆò믵UèÙ]•—DË1wx§·$Hûh€Â3%3Eq0Ó©È)P¸B@Ò4AÆTÓÞ¿€û©dÁÂR]|±VèhL’F¤Fàx¨Åº,nkSR†ƒ ij•HZ• u¹"£4@¨¦a”ôKm‰+ü8ú\î©6‡,ï}:3ÑÿÜœ³¯"Ž4N'—31—/—mAñ;tÖ à5YCn5:·n ;º²(è¼Û–&Ò†æð ªi¤´áÔŽ-ýÖ· TÕ«ØùµWE¤˜ /íâz1` éöçb›.ÅŽ>Ž‰ã>BT«Œ ²ÞÂØ1­Kc!ê¨V–áÐû¯÷vÞôºŒÙ‹> stream xÚYIsÛ8¾ûW¨æ$WÅ ÷enq¦ÝÕScWzr€(HB…"5 •Äùõó6píN¦t ðð°½÷½ òWû•¿úõÊ—ïíãÕÛ»$\å^‘¦ñêq· ¢ÜËüh•æ‰DÁêq»úsýÇuî¯õõM”ç냺ýõ—ë q”­n;Ö[î)þ´ÍM©ªÊQo«¦üÌÍûæ:LÖ_oT-”ÿø‰{ÿŸ€ »ÆU7 ¶Z¶úóúÓã?áôœÞâ°ñðëœ1’!¾Þ¼ÈKKÅsþOÃþ]ƒßbmõö\ÊÖÝAG}lì3Î^Ý‘'ðñ½")XV»¦éNÖÔpü°ÖªÞrƒæc£lŽ§s§:ÓÔªH•F‘~3Ý3Óš|Ï–ÇsÕ™mêÎMk›Šõ`¯“dí]ßÄQ¼~ïcuÛÂ>ÓAÔÜØ RZº‰?½„i#ñ×Õ¢±I«ÀWñ§³çºTýðÀßÝu,e×Xó®È䯦;p«lªóQ¨'ƒHø‚xj:Sï=:Ê‚Lß0c?XkU°®ëf«™†·B É S9áÐLâÈ´·êtxí˜n„¤“²qSî<FäsëZð©©·pøA`Š€ k¯ÏUõ̽ö|<’•@û ÊCY£6•nátQ®û0xgög«µ¾hö¶ë¸7˜ƒ®àò8#Á!¯âÏV×­; ²!Zóø=i‹&ª·€¹Ôst™Þê@UªÖlPÝgi„ÏM<äû[nŽ ‘ ú! @.@ ª*n Šà>‰¿n2ì¡„÷cy@‹Âµû«á1èX¦ê¸«ºÙ Ú­Mb“‘…K( ŠE™ È݈²Ìƒlý®e\îÜv–MŒ2ûGq€¼Á¥S¼‰Ó`Ø™|Á+G5rš^ãÜÝo ó;XJÙ-óìÀ0o,F¦ñýr¾npçÂTœ.É ÉlX™3ø”åÂM¶ ”ÎbÛŽGÂűJ+r(Ôaï‘æ™­ïðpoïÒt·Ã¤ðÂ"‡#ÓQï™eÚ /ÊRÇ€ò»\%H=æÏÓÂ" (î9 ð)%¢È¼}cÅ@ÈI8‚;ó¹â-ä°!ìç>µ""å´…£óN)ÑR¦rùÅ [íyãbX(¡)tA‹öG,BÚ[Ê1Ÿ§Çž\Or¼n’ëÉÅ´u)\Û¹Ô4+Ü'uß:\Ï›ˆwþýåñ ÓtLÖƒ(ô"p½iyI¯ÊãÕ¯¼„ǨICnžÞþv Vÿh®>ÀÏ …>x¯"s3~j±p¾ø€Œ ²½Ñ ]AU€Á…)T¾—E« ¤ÑHÔ î;”ÚC/µq˜¡4™ÃÇ éu”ŽuÈl÷H­1­ PwõDASøß„x7ød^d||±&¶–¿C Ñôv°Çi÷JUàðÚÔúâ”nLÍ ÝçW?°®Y›Âö² ™«ÅÅyW æ›?\ßAHà‚‚*¶ql{| Š4žp¢=ñøœXuÔ”"”óƒŠÔ0»Ï"¦î…‡ú`]N‰p‡¦ÓKÑ}©:YŠ±f}&ñ†Ká­Æ”¥æ¼$•r ª,ÏV•âX¢”+²K0?9N:lóÍIi-s¹Bÿ¯ X`‘pòK }ÿ€¬ýFì( ¬e¹’Þòù80‚e“$¦I.\¶3ø*f˜6¯Ì$³jæòóW&9¾ ës‹ 6 š7¥)!5è@AvQ6–0š¬ËªiuõÌ«+ o¸JãVcÞxšN$#pñA”£,hX/Yô=‡%ä–ëߟ~ÿ÷GΡ5óm4%šÉã ­`éÊÏq@æC`Pñgk,h‘‡G—G¡º}¦0CŠ33Híxë‚s«¼x©6» Ðãt ‡uQ¾=Lõ«GP€ÎÕMÝèy”WíÄ+.ñåWq‘µëÂÎko]Ùâã•'¶œŒÂˆ ä´›D®,÷ J¾ïËC^ëòJ_ÁFÕ];  ]c‡XRiz´ºt#(ýÌóƒÀùN¼¦Ó ±ƒ†º  M <·¾(æÔ¨¯ˆàòùŽ§:Ô‘5·²!«F;w¾:PHÅœ†™Õd÷òºÒ€xÛçã©kàØÂ=¶2p™´ÁéãTä»"D2R>åARÌõð;i,:O?Aä´ºær©‚òNX¯½Â’ øâ=TÕ6nW0>”QËýz$öŠ™û×,‚2±"pŒM×?[ò ²tP8—2%Þ™D»‹¯H&?¡Ó¢x†kl W ÚjJ™a”__p«½a(ìÜ¢þ=d¶/'P-¯hêatáv—Y Érbi›çYÊF§'èb­ZÙÊ8/Y÷^¿TÌòâ›+/N0òó¤3¾!¡<4ÿâ”7@¿#Ac¤t&гpJð RËßÎmAO:UÓ|¦ "e¨pîÓÝÇ÷L¿TèKÏ®èK·º-­ÙL-%ý¿<+äo/AØ8à7µÃ¶+F*0s—žûò ä'Ë,!JìPý¤û‹O2cZïF'ÀÐId ãõýÆówR*„’BÀ×'ž“¹60*pWu)#¬08–, øÁ¸|]Z­Àã•÷p#8ªecFìԋǚ̳¥ÒèºÕ±(­_ñµ§9µoÛ¡ºÀ~·à„óÍ,"cðù>3x%©æ§×ÍßñŸÞß}äÖÈDð)ÒÖcœf!ã¾?‡SY ’ ˆ£äqGK‰9}Ï\nž…Ój ½+!6ôöYŠ=ÍÖÈÿ~0¨.mO²ŒƒÙs¦—FìÅY“V€ÌZd¬æMyü¿2P‚€“šŽ’^Á!-¦î Fvîw„DRœ|Ê…¬Tø·œýÕå öLäÊRB¾û3 t»©Ä±ýpMƒkŒkì¿RÓWþ8˜J¼°éäbfZüæD¹x h4tTÏÜh+PVWIoËñΪ­^®¨dÊfER¸È‘¶HV7ýß]ƒñûèò L"¬>*ÃUa&²Äa¾øôïhãZºó?e‰e‚i‡£ÐÎìÛ³ux\FqDÝ*ôS,£Æ:™¿öä¡—AÆ{“^œ‹9ÅdÊ/WÿäX endstream endobj 952 0 obj << /Type /ObjStm /N 100 /First 930 /Length 2753 /Filter /FlateDecode >> stream xÚÍZmoÉþ¾¿¢?˜éªê—jdäƒ@HbarJ¡Èg†;tÆKÖë„üû<Õ3cï‚YÏ™ñ*’­é™í—êz}ªº ç]ïHžä8žìÙwq1Ø÷à’Ú3:eÁídÏìÈ—‚†:b‘E‘‚™lŠ€)#Yƒ¥ h°£¬ÖG…1EŽ}ÊhDÇì#űØïžÑPk$ÇuA ‡CƨHXÿŒˆŸ’ÇÌô§ˆ/ šSÁÌÎ…?E'DX+&'íKv"%-JT'[/±8IÉöæ¨Ç<‰œ7JG|ÎuÛ¡’š‚ Æ”]FF*.Ä‚]b=|àEÉ Œ"ì6d|&p:dÛ2– J˜Yƒ‹ÞšÑ`ÂÌ9º(àMÉ ìW°S`£HVsŽ‹¢øb¿—\\"#L½KB CÉ¥NH,Åb¢…øR•±¢é ²H™ñŒJ;(àuRò òØw2e—É$2ƒÎ‚Ér`ô.ärÄ~ ¶›³ÇòE\VÓ•\¶ÙJ²ƒŽ’ 5É/JÉN$[ Á~*N±,Ä –ªšT!LUH‚<$®ßÑ"´°%Š ̇O˜Æ›Jy›Ð+4Ä› %™Nzo¯-2ÁXË„¯`ZØSɶ*õëØ„Æ ÏÁ~gû `M[!’çªQl!kfc­¯ªÔFªš¸Mž0Œ:¢·‘Tê”PZOÖÍì³Ù–ì#f³ÞšÑFa£DRüâà`ѾúïÇε‡ççËõ¢=¾üy]ß_¼?ÿmÑþ°\½íV¯=ÌØ¿iÿØ>o¿¦ú²h_v§k÷š¥4ÞÔ$”† |ÖÒÀΠ s@·CwpàÚc×>[¾Zºö‰ûîùã?¿zñÓwD?=xà¾ÿ~¿o§k7¦J±„†Ìô95PL·"»Èà0' 2`îWdˆPýÚEÇÅåÏû~yÞ` ó‘"ž³¢˜¢€_Š ¹¨xÍq'Kâœ,¬o†>Ò ó»Ùà‰4qF-IÜ$8“H¡aX“4äÍ5â=åý1…’4 &„&@m™´I°à¡‰äÛ™fÔY–Æ|;"ÖFŒ–&3âOÁk.{䉤Æ|f€±ˆ¹mÐ «°Ó„ˬêZúÕG*€Á*¶ä’ç5à Pï/Ð]B`¸V)åv_B<-ùM@Èh êòNZº]žTJ F3* ç†a8BðïØT`S‰Ì˜âgdŠ÷`ò5-¦*Hq1\ ós…¡¼`”4Õh(PbÄžÛՖï68…˜h ‡‹@iâ•…%7ÔFJXc£Ü)ÙâÉ÷º@ã½{éÚ¿ýýÀx‘fÀ¹ó˳³7_ëX;&ÐâÇ&uŽ šåË´Î!jÀt“:‹9yxÕI ‘œLêLˆïÈ&vÍÑosõ—gËÕñÇ“ÓÎI?æèd½îVçŽû×?|Z?;^Ÿ¬;Gõâ}º<_W>4G²Ð÷{Š(Æ«ËbÆC‘†åyì‘¿”á_CÇD Ôã˜hîoƒ-å±l¢=Z-O;h(òÔµ¯ºOk÷f[™N~éØêùº;__ Pn*{±¼\v5}«ŸþÔ½}òÃò“«Jžàüs1·rt²ÂXW8÷ýª}\`UKDËCûgž:<ûýYÚ?ixòð”á†g?ß›™&Pà ÒV$ —i®7¨‘‘-PºÑ‡daÖPž½óÜ€Õñ=òE Ÿ¿X7ý%<æœn ^Ú‚+EÄ2C`Á@ Uš\h[fÍ]$ÁOçk2‚ìSÈøFéx³æ|ÁÃIÃGcÕÔ;¬\Cs¾¾_wÍÉÛîì‘ŸQ,ÙJEØ?Ræl«v¿9¼¾œQ/<ÌÄêPœ©a«¢í `[QãÌ0#ÃkC4PŒbU‹’`?§Pø¬ûgH‘.]`þCT÷G€ArU¨\F­ì1Rê ò>ïø(µºÕ·Ìfkíªú0B€…ä4Ȥ›€ Ó#‡ÞÙÉ4$c‰µÖ:Ȥ™ÙLÝë´Îˆd5°ÄVdߊ¹[l¢‘”o„Û@cl`‹»"_ •»"ˆyxüâðÇ¿üxøO_f¤Ò1=0z’ZíÓÌðvzVËËnýèÛÀÁg”¨E² Jjºx;%HäW«ËGsâ!0…¨Ue­g)bÁHJÿ»Suý¬5“Fêá‰";.—þÈ îŽB2çñp „›¯( R‘ÃTJæaHf= Hñq„”fNµ@ x—zXàí÷U˜¾L¸W Šv|Ó“bפØ*ti)'oÏVÌxtΚ±âð¨·ûN’š¬ø  ;Mˆ>; ¨¦€–íŽWGêkåiwo.œ•ÕŽ^Âm½jj†™’N$ļ­EÞÒ[n´^?BIûA9ÛeŠÍbÄ×kõ®Tº©f±U©7”|g¨÷¤tüMí­ÜtÚ²Q÷¸3îþw‰¿#îªW¹Œœz“«oP:6ÊÐà±3™Ç†ÌzN¸ÞB° »­2ä´É.‹ä)'ÿaÞ“Æ>SòX<]“="WÚ™À¥Y¯VmÄ –ñW¬M6. W){$$—FûdÈ®cˆñPB WÒþÈ°ë1¦, °HcEJÉpÈ|küž3¡µ[THAFJ$ ÂVÞEÉýšàC#—ZO±¿iŸ¢)V›¶èÀµFgÂô ‹Ç¼?:lã–Us‚‰êžÐÐ$¥ßÇÓ„&ÆìÍŽLvž\„~ZT¼¥7ÂoÎv¡Y ³t[o«ÂÉ–çrKïë;ÕT§ö†ð˜&÷F²#%NìMàbV¾7@°uÒ°}¿a« ²y¼±ö·O46ÅTØBs”Wbü2ÌÇigèXúŽÏ€È?Úû—qŸÃ¸ãØHcc<@±1ãð0ãð0ãð8⇸qFò?Ì âŒ endstream endobj 1041 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/BLRLU_step1.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 1060 0 R /BBox [0 0 457.725006 422.008942] /Group 1057 0 R /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> /s5 1061 0 R /s8 1062 0 R >>/XObject << /x6 1063 0 R /x9 1064 0 R >>/Font << /f-0-0 1065 0 R/f-1-0 1066 0 R>> >> /Length 761 /Filter /FlateDecode >> stream xœ•UÛNA }߯ðcRiÛs¥7 Ñ íKÄåZšB½|}ÏÌ’eIšl«fÇë9sl{ï6‘%!6ÉsNXsb›•®iïŒéú±Q#Γ•`88RëŒ&Ombz¸¤«æžö=°úŸZk‘'jÕ¸PmÕ „tÛNЋ„ž«¦90Z±ÊƒõtvÐhAdQ¿îT^¶€@eŠG¿íˆ5Dò&‡W}1lb¶šF²h“Ö±€¬ ˜¥¬Ïë¼ñê®t:†° ý-ùìÒ¨ÕÞàˆFÁh=Y ýñ¸ú çÚª–íš!dñ®fCmÿÍU«uƒÅúd8ÖFŽŠ …$Ï|¥çûv¿ð{ óT·w¸žoÌ⑾ƒžæµn978¶Må – tUÿW?Í!ÁURDcÚ€¢®E<Ÿ|˜z7yZ,~ÑÉÓr9míäò‚¾Lcšœ=L³LLäkYýÛs.CCѨ¬F˜÷Ò[6鋘®XõcKN¬q9{Txƒýþá1}]ܧÇo¿/7¨–© ÓùêQ0àÃ÷ _³C3Äç”cf> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x13 1070 0 R >> >> >> stream xœ+ä2T0B©k giih`j¡œË¥Ÿh ^¬ _ah¬à’Ïȵð endstream endobj 1064 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 58 -0.991058 458 398.008942] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x16 1071 0 R >> >> >> stream xœ+ä2T0B©k giih`j¡œË¥Ÿh ^¬ _ah¦à’Ïȵ.ó endstream endobj 1070 0 obj << /Length 1078 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 140 2 220 238] /Resources 1079 0 R >> stream xœ ʱ€ À>SüŒŸ@ Ã,”ZÝÿ=©®¹G¨ƒ%{5œË Ö4¼ûIÌOJ#¬íæb³Ú´ûn9äöÛo endstream endobj 1071 0 obj << /Length 1080 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 58 0 458 399] /Resources 1081 0 R >> stream xœ‹;@PEûYÅÝ€1ï‡YD¢x”¢D"Q °}œÜœâæœ$øèjä“`»É°VJ‡']MÚNÃaÁB-N˜¿È>yë0”ÕXϪN 6j~‹S\+zDŠôÄf endstream endobj 1073 0 obj << /Length 1083 0 R /Filter /FlateDecode >> stream xœ]Ánà †ï<…í¡‚Fí EšºK릦{&CZ9ä·/ª“vÛøÿ¬óK÷Þy—€QÐ=&°ÎÂ9,¤gÇŒÓéYÕ[O*2žá~N·I ü–›s¢vo& ¸gÀ?É 9?ÂîûÒoOýã/NèÖ¶`Ðæq*^Õ„À+|èLî»´2ö§¸¯¡©õq³¤ƒÁ9*¤üˆL Ñ‚´¶eèÍ¿^³ƒÕ?Š˜<é¬"&ÏçšçP¸§¢L(_}YÓ QvU÷Qí#Îãke1ÄBÕóŸ/q“ endstream endobj 1075 0 obj << /Length 1085 0 R /Filter /FlateDecode >> stream xœ]’Mo„ †ïü ŽÛÃÆ*fcÒl/ú‘Úþ„akR‘ {ðßw†Ùl“”‡aæå…!;÷ϽŸ6™½ÇÅ °I7ya]®Ñ€á2yQ”ÒNf»ÍÒßÌ:ˆ ‹‡}Ý`î½[DÛÊì×-îòðd—„”2{‹âä/òðu84\Cøü&sÑuÒ‚C¹^õ 2KÅÇÞâú´íG,ûËøÜÈ2Í ¶d kТömžw²u®àí¿µ²â’Ñ™oE[=bjžã€\2—ÄŠY!7ubD«Lb0~âø ¹Ìã Úš5kÒT–ó-1먤S1W”Ï{Õ´—*8^>ûiÈO ¬ä=Tä¡æœšr³Jì˜1ûQÉÏÈ<’>Ç›ç³(:K£9®ÓÞnŠ®’z~ƈíI#õ…:2y¸¿°ªJß/О¦ï endstream endobj 1076 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 140 1.008942 220 237.008942] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.CC= K# #c3…¢T…4.·ƒà endstream endobj 1077 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 58 -0.991058 458 398.008942] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.S ]=KKC ËÄÀ@ÁØÒR¡(U! ÁA  endstream endobj 1082 0 obj << /Length 1086 0 R /Filter /FlateDecode /Length1 3964 >> stream xœåWolÇ3ëûã?Ç­±1.ps,çŸC †‹½ÜíÆg§>ÎWöœàÞÙg0j(V츆ðÇM“]B…¢~ê?Y*ªª6æphM¥¦NU¡´Â-•ú¡ª¢©TáCI©D­ؾÙ[[˜|©*uæÞÌû½÷æÍ›y³{³@ f@6r,7þç›ß; @û‘G¦&Ùú”½¸öðø‘cS¿Ð~ à\@RŽƒ«WÀgÞš«ƒ>ß¼ù§¹uV}®ÖêoÍy oý¼¹¤nDFvû°‘k Ï+8¯Åùª ¯-æ|v_cõ·æP^øÍõ>èEæ_j;j$ýPÎFNE[kDYV{ÂïõãfhÎé µ´†º¨“zz \,‹XÑÐ!l¶µ†R›Ÿ OâBk7Ñím%v %z.â×ü­Zc£ÖŠL$çmìé oÞKw¤Ú7lhOuŸÜëíéi°vFqªª Œ>ý&Q²΂IR$G¦Éò:½Jßeõ¬•ífo7›¦È7Ì’$‹úÓ¶¾õ+úO/çx—|›|—|ë¬]¯b}‡¼ó™#ÿ»B>!¡p¶ÿûBP…Ï›,ÄùsIr ¹dÆMݲ¹üHCØ‹5rÝHÚ}´¬/¡]H¯°ï¡zá9fKKe¾¥¡ë vbŹéßè‡Ð ä©G°ºÿõr²0ýøzö˜w$‚ÿ véÔdÿçŸîëMôìïÞ×µXt¯ÚÕùTdÏîŽ];ÛŸly¢¹©¡>´EÙðÕVË^OeE¹Ûåt”I”@“®Ä³Œ×gyY½ÒÝÝ,°’CAî>A–3ÅWÛp–µÌØjK-?`©–,ÕK"³Dš›˜®0¾¨)lž & äÏkJ†ñÛßgñeõð qÓ}cã$ËtŸ+èY ý++bJl´¢¹ Š•ÈV"Ç”ñ"iè$CôÝE n˜–K!=—çýIC×üÁ`Æ’AÌòÅ1î²|±£"fx•› ¯ÍË0œ Wå•|îYƒK9TôBá¼:Ì·*ßzò¦—<Ê›Mça%¬L@¸#$+¬p0xåößWKr¶Ä’ï€`ÅW¶ õË<`l!®/±¼:¯Â0>“4J˜Á°ÿ¨-á §Y¡YXÖ¬K Í̲fexV ŠTéYû75æã3ì¹ wßú…ð‡zÆ¥úìðȘès£EÓJû6`pUCFÍÙkÕ‹­-hŸËâ"ŽŠmH¼EçµJ´d€&rp4eXCìa¼6Æ!;bâ-º&âbz!«•¾”¤q¶›7Š;˜n;쀌ˆƒ×Å0)õzÁÈæ¬?çó03üA®fpû2Š1šYRd¾õN´f´FáÚ°^6+w…ÜÌ ~)#²…ÇF‰FP!cº,(20ƒøaÙ g±-·Ê)ë*I uûƒ™`©|FH~;&Gˆ»ïó%£`%¦Ò<ŸZÉZ´•é£Ú}®rê°´½=œ»Öî°Ÿß8¾Þ”xNa2‹róæÌp¡¨ª…q=;¶[øQöç Jʈø­ð§ý'Åtk!AÑæ&|ùD‹ 9—,ªä\jи‚ÿâìÜ€Q¤$š§ß7† Ä—ÎòbsNeÆ ÙŒ8ÚP‡‰?Â‰Ò œ*EBU¼BòJ%*ä]BÞU’;…Ü…i!u¤Ù¾§]»ö÷ßêú¢7r“n Éo ?5DÿÛÙk›#fÄó¶ôÂr¼Å•nvØJÍ<îùêóž·?qã“È?¡|ƒôGpЖ‰›Ákâ{Ȳ–Å»ïEüÆ¢xki €ƒ9ÿ_äçPNP})`{=hÖŠ¤"IÅv‰š ¨oïˆ_!„À¥Z÷úÐ)!n¸@\&Nì˱w`_ièB)/ò~í?H™ºD_Ѷ^FúÚKí—*6¾ªå3HêYrö„PÏ3Órà4²³§È)d½/’yO’“ˆà„|‚º½_!¦¢[“8ðy¤ñh>péËHGAEAÊ!e"¥‘RHI¤^¤¤n¤8h$Ƶ.h×5ªEýØÞõˆ’Ñ¥("¿–æžFwÚÑHÓeÈ{פ++Ò®Fgš4Bú—ð0A*G MŽãçJjžÀ\qyr!1ï2$¸»ÿNÎñPJ´jr;ÏqH>c ùfæ•óç!º1Á7¦ >»1“à3ÈÀÆbD3á0L„ÃËŸH$<1 ØN¾04Kð@gõC¨žÄŠEg•‰Iá†L¢Åä aßü°Ê ¨ endstream endobj 1084 0 obj << /Length 1087 0 R /Filter /FlateDecode /Length1 7476 >> stream xœåX{xU–?·NÝêê®~U§;òê<:$& i#áé` À  D`t’€ 0†„  Šˆƒ2Ð êypÜ]ã¢;3³¨3!¹ÙS :;3ßþ·ß~[·oÕ}ßsî9çwÎm``*@ðÎ~`fÙù…[@_ M›½øA/Ì‹Îù€‰’²û(¿yñ|Õa÷}÷/)¹5û¯¨¼ÀùÁÜ93‹¥’¡ß„þšÚÏ¥k@¡ñ¡ÍTOœûÀƒ—7ÛÞ£úgT/¾¿töL€÷½a#©>÷™—ÉÕJ9Õi=ð–-˜S6Üô'*†àsA‚Q/—ðíD­ úù­ò5P®1•WJ2¤·œi¿ œgÚÏ´g„èqº/N+‘¡k!Fv})êMö¿üy’ ö|Á“yDÀ`?Û ö½–:½{庰§ô5ýL6Èp;û9»Ú3Û®¶_mw^ùîJÆ~Gdl¤Ä¦3Ï –àÝ q™ƒ‡xì?TByrÉ¥å= :˜“ÁòK%ó/ÿZ¼*aÕlRõe>ëìŒ{Å1ñ‘8'ŽÝ;ãô˜1ìyv›ËžM,"œÛùYPA/ÜîOˆ€:‹¹Îõ«³¼«kªËÁÊ#¢™!Ê%ÇDvÇzXNNÎMÞ¤5'ãuG<#Bu"0û椄 >"ÒãVL1Ìã–âØ6òÅçž{Q4³´O=µQh’|©³jiÝK¢ãZ÷WÒ‰îOkV¯Y)•ˆ[K”—íxk_í6··õéãÓ9ô&½fHõ»”:YªƒÇäWUÎL²Å íL‹A“AQ¤E!q å„8­»L*èn|ŸÝ%ÆìêB*{{¾§ÈnîB3 )5v}…5»V›Yuk$Fyhý«9í™´A[[æÕ–vÝ–“±¿Ôó–‡D¢géîÐ,bš Ù$¢ø$¶7°tiÝ«Àíû½}œýŽ’vtÏ|þù#Û¥Šk {JfwàNRsx›^K7I$þ l’m&Óf'~›“ûy/âe¼ƒ+´-ÿv  ¸ÿÚn̽EÜ-WÊEà`«ý·›TɬƒÃ¢k‡]w€Ã¦[m`|ì6‹f±êšfɳif'h¼kךv›ÕbVT‡ìÐœÎ3ã-…ãÕŸOi üC§Žotåž·†Nmi!Á:šyµ]ÏÑs\9ã'M19ùe“SíË}e~9,sj<ów(ÀUÅŒ¶PK˜ÍiK°eÛÆZî´L°M3O³Ì·Ôتll. ·jvÍÆ<’Svò0‹[s[ûÙû9’!‘%J^ÙËSճϒ¨%Z“mýíý^}d³l)CÎàC-ƒµÁÖ¡¶{Ž#C¿ üÌ/ùÑ/û¹_ñ›üjž9ß2Ú6Ö>Öá× a"›(Mƹ€ß­L6Ý­Þc¾Ç2Y›ljŸê(ÐKX‰4×2Ï>ÏQ¤W¨ÛvÔÂãæ•ÚJk­­Ö^ëxÆ\§ÕY7Û7;¶kÛ­»í»úïô z>g:Lçv–ƲIrË2³,iÄK7ÜGaVœþ»—ÝûÎÜãlS](OèÚˆ÷“9’,kH·N$ãþ6«dפ˜ØÕ,™,RllLžE‹‰•= Sã_w¤’­ˆMMO½3{ñ&^ñ¸CcYÐpãâ“’³cXVЦÓÙ –}sbVf¨öòúõ;w®_ÿ2îýkûÎâ™l$S)œ)<­—.µR&}q¾™ü€ýɲÎŽº„Šñ‘‘ú%1ÈC™½ŠŒpòÎ3-aA•ùw‹L @%ðÏì£åÑ|.ÃhRÀ$©²Yñ0·ÔOîÇûCK’RåTîS¼êPÈ"ã!àC”1Ïò¥±òX>Z™ w+%Òþ}÷1~öZ˜üug{û@Ò% ø ÙŸ«…™íðJ˜Òd×½Õ±‡¢šúš0+„a8ù'-Uw~IáäƒôË-mW»È %êÃiÿ¯2¢3b2b3¼qñ¹ÉþhŒ?ÖïõÇùã ¢ b b ¼qñÉeÉ+£kbjbk¼5q+ã×%7$w$Ç\Ÿz}Òõ E1E±EÞ¢¸²˜²Ø2oY\ULUl•·*.|:É>ˆ!$í[ØëN1ûæÁYq½Ò7eÍN:raÏc¥Ï4¹Í«ö´v_cÒË›ŠÎ92í?;¤¬’ŠY ÏíO½£û±]%3ßÞöÛ·\•« Ú•œÜÕ‡8ŽÎJ‡ ¿[Ñ)4¬±ÌÍ&‹¢‚:ÊåìjéõÙdkgNƵ¿ äù#ªê¹ö†ãbÇØòrSÓ°C+CEá~—Þz¤ûu²ó’Ùœ1ú<½ö‚ _­„‹€ð|õ,OÂùÓ§…è‹Uæ“Žrðù­Á@…Eá0lŒn#×nÎ0˜ª°J–ƒn¢”ïIèšÁÏvžÝEz@kðBZ#„ìoŸ?Û¬šÐ¢è(#×eó<({êÌî:ÛcšÌÔ)F µsKD„¬çº-QV9:”-F¸¦÷l#®RôæÊqýÄuó>7à1l ï‘Æ3.)h’=`è~(¼|Ì'%a²’dJR“ÌÞ˜Ál°4Š’æòEò"þPÈ*e•éiåiS,é8yŽ°DžŽ8Îk„½¦OÜVqë©soŽ[ýð'ï±ã ºVt׊õuuë¥æÐuŠ¹¬²~Vw-?ûáGO’îì¾R³bÅJ“‘ml'LÒz1 ›¬sS¸g#¹)\®ÑáV…DoŠQ~À¤£?Á¤^äªfÐ/dJ¤›ÉÒü’Pèe#w?9l_ÅIèé9Y±oXS“”ÞAÒ]Å3E³ø ¥æ™Å;‰š^¬\Dz¨AŒó‡(M.h²\kÂÍ.ÇDtyòÃ(Ù õúr#* B©4Uª•æJK¥Va­´UÚ+•ÎJ½ÂÕÑ¡ÿÈ‚èÐ’ 2!!ÞxK 7îÙ]·aÏž Ì%®tüI|Ãt¼péĉK_?öõq\´‹Ëö9„én64¨»D#^"# × Õl•l¯¶­²4érSXÀ¸ˆ¸l0ÆO‘¶ë§¸zÅù-‘«9"‘U‘ë""9ûQ€pÝëÄ÷]HðÒ„ç Þ8zô‚ç&üì¥éÝâC6)“·ÉÙ{ÒÒ¾8uê‹´´]‰‰tèvæbàφå-tŠB»TÕÀs“Þ‹æ\–tÎå<•KˆÍ°É¬p&+ª!k½á¾Ôéö¶ëq|ùºFeRi§ÕPé²dQC¥d)•§©wK%Ò}êBé!¾\ªåOª¤z¾I}Qr™¹Y‘4´˜R0YNáiJšÉo‹EÖZ\)×ò'”µ¦Í¸É´ _æLïš>4}ø½Ü!÷›^† °NwŸ„CM’ïÝ{¥_vtkRÜ]óØÝW»÷H ÝŸ¿¥$‡c$‡d¸ÔçMê ó&ÝóH>µ²»ÚSnÈǸçÝ©ÚMª;>?ÅÀ¶3?‰óH`ßsý4λæA²qDY¢´(ë $h¬ÃÍÃ-õáVÍ ^Š²S,)Zÿtwº§hJLJlª75.1¹ÚR­U[«m.Cb’¤X ­hC;:ЉØ#1JŽ6'§§æ¦ÎH­L­J]—ÚÚ‘NPPþ·¥’ðßÊÁ„À¸zÂÎiµµ³6涼ôýGÓÞ¹¿äèÌåkæìöï~ú³÷Kö˹{SR ýcãìýŸ©Ýr !áHvöÔ‰ã |ŽÄºå[÷ÄôÆb7îS&HóÛ•#ò>h–8Se¥:»Fôúƒ.B`Íiö› ÌEæ23ï½Z‘/0®W€\t­Aqmèçò1çéŽe†çüýT 5$ÔMª)O}šñ®"™)ç'ã5º:YƒW'Ÿ.o 1®NŠqjÉléuÍ?F^㎔ǥP)I-5qMuhᩦ©^m0樚qÉÞcnWïÁ©ê ­ˆI%X$ñYj¥V¥½¦EÒ1Ó]—‘Éfqå8¿ûi×2i÷¹hg×ù ;Ñ×{Ë0"$+ÈÒúÆP4…`‡Jèa“ØLö0{”­—ŽJŸx“¼ÞaÞ=qñ==Æ#ÐÀîbEÔ¿¬¯?„ús~èÿÇ£=>a›Ù¶•RC_:Jé8;Ný¦2×ñOW¾ñHAžŒÿ4n<ΕuPƒ_ëßmÅÒW£ì!Ïm¦oH°Å¡ô–ûúÿÒõÿèaÙ€VJoÃ.ØÂvP­„šË©¥AzVÂ"jy‡µ²Zi µí€8M#k wÉÀÆAµœã\e…°ŸÖÈ!Ï•c¢0Gž ï—ï’ò%ù ‘ʧä"y!ËÂmün¾ƒr¾+¹(^Š…» á~YØ,”ípOá.ø’v1ä× ka;T-nV •R…tµã§`3¥Rê?EZzš¨;ÄVÀYxei leg‰¯VøV`¡TIŠ–%•ýÇh­S43,”ŸeRµõ´×¬à;ò³ÁÔAVV…°] (nSíbœØökW6@œÆ_`9žg+åy§<ÖöžÁZZ{³1G)aKˆw#U«KÉEl|-™fÑÚïÑžû¥»ˆ£h¦üâ$ž†³•XK”½ÑpÊ4NN§ù´‚iq PŠÙ0ŸJ°^‡Xki¥ ¿ÊþÍÜ"N<¯eOHßÁ) ©P"_¡³&Óz€ƒ&…Óe‹Á¯³Qò-nôOœâ=>5nà€¿©z&o#4Ú–x==SäH>µ‘G5¢Om”} Ÿÿ£ÎÏ_0ÅÛØ?²oÕü¢‘Ô6i 5S{þÈ`Ÿ±i#÷ÑolQ£wö\ïãÎdž=îœ3l ÑBºÇ"I;Ëf8F| ±½ððþ·­‹¯¿ÿ°k¯my2UÎ^|¡·éMqñû;'Úôµßx"HCKx=,äËà„¼Npì•ràm¹n‘VSDï†S+’Û¡œÊå| 8åKPãàõŸ—Ñœµ”Ý4æK(—K(o£r”×É2üQð1þÃþ„ˆZCù3b¨˜rÁÔý½™S]I¡L%ÓFbãA3õ[-Z–hëiŒõ$ñDãí…ºû ð?0Ý߃üòo|¸_àõøºÀ}¾&po1¾jÇ=»}|O1îÞåâ»}¸Ë…¯ѯtâN/ Ü!ð%nøâ6;1·Ùñ…bl ! õø¼À­ÏYùVÏYq˳|K1>»ÙÉŸÀÍN|Æ‚O ÜToã›ÖÛ°Ž&ÕÕãÆ v¾17Øq}'>µî0JີÓùºÃ¸®J^û¤¯Žkýò“>|BàšÕƒø«áãÄæã·aí*׺q]£©¡¦«é¤ª}¸RÇ_ \±\ç+.×ñ1U+ú{]¶Œ?*pÙ2\ZŒ…^áÃG.ø°²âb .ø`'.ìÄXÞ‰eKþJàýqøKóõ<>Î8wÞG•s œ-p–À™Ã°¨ïµât?8MàÔ)>µ§XðžÐ~O&Þ-p2í<9 =8‰9ù¤p¼ËÇ…ð‰ 4¼Sà„Ÿ9ù?sâÇSÏxãÆ:ù¸mãc8Ɔ£ŽªÇüz)ðvi ¿½óãmãÑ/0Wà­·¸ø­n¼e„ƒßâÂÃm|„¿ÇÃm8L`ŽÀ¡CÜ|h'ìäCÜ88[ヘ­áÍ1˜eÃÌ›4ž)ð& 3Ò5žaÃt  4óANhÆ™˜ÖßÇÓŠ±ª‹÷÷aª S’}<å6Löa’OãIôi˜(0A`¼ãˆÏ8z‹1¶cˆ…˜bŒ¶a`”ÀÈNì—‡T‰^ŒatRaCiRhzº†tÑ—@xÕóй Åhh³†r›@+¶†¢&ÐâD³@•†©MnTŠQ¦N™4ÀƒÔŠ‚ÐßɥȜY€¯|‚¥ý_xà›€úDÿPÄiS endstream endobj 1042 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/BLRLU_step2.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 1088 0 R /BBox [0 0 457.725006 399.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> /s5 1089 0 R /s8 1090 0 R /s10 1091 0 R /s12 1092 0 R /s14 1093 0 R /s16 1094 0 R /s18 1095 0 R /s20 1096 0 R /s22 1097 0 R /s24 1098 0 R /s26 1099 0 R /s28 1100 0 R /s31 1101 0 R /s33 1102 0 R /s35 1103 0 R >>/XObject << /x6 1104 0 R /x9 1105 0 R /x11 1106 0 R /x13 1107 0 R /x15 1108 0 R /x17 1109 0 R /x19 1110 0 R /x21 1111 0 R /x23 1112 0 R /x25 1113 0 R /x27 1114 0 R /x29 1115 0 R /x32 1116 0 R /x34 1117 0 R /x36 1118 0 R >>/Font << /f-0-0 1119 0 R/f-1-0 1120 0 R>> >> /Length 684 /Filter /FlateDecode >> stream xœUÉnÛ@ ½ë+x´ ˆæ2ë5Ý€ =¤qz1ršbI´ýûRIž:±\ ¶> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x39 1136 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úÆ– .ù\\¶Ü  endstream endobj 1105 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 58 0.100006 458 399.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x42 1137 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú&F .ù\\¶³  endstream endobj 1106 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 227 244.100006 237 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x45 1138 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú&¦ .ù\\¶È  endstream endobj 1107 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 243 300.100006 293 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x48 1139 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú& .ù\\¶Ý  endstream endobj 1108 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 147 164.100006 157 223.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x51 1140 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú¦† .ù\\¶´  endstream endobj 1109 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 163 220.100006 213 231.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x54 1141 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú¦& .ù\\¶É  endstream endobj 1110 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 147 84.100006 157 143.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x57 1142 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú¦æ .ù\\¶Þ  endstream endobj 1111 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 163 140.100006 213 151.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x60 1143 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úf .ù\\¶µ  endstream endobj 1112 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 307 244.100006 317 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x63 1144 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úfÆ .ù\\¶Ê  endstream endobj 1113 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 323 300.100006 373 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x66 1145 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úff .ù\\¶ß  endstream endobj 1114 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 387 244.100006 397 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x69 1146 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úf– .ù\\¶ô endstream endobj 1115 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 403 300.100006 453 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x72 1147 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úæF .ù\\¶Ë  endstream endobj 1116 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 147 4.100006 157 63.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x75 1148 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úæ¦ .ù\\¶à  endstream endobj 1117 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 163 60.100006 213 71.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x78 1149 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ úæ .ù\\¶õ endstream endobj 1118 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 220 -0.899994 458 238.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 1 /ca 1 >> >> /XObject << /x81 1150 0 R >> >> >> stream xœ+ä2T0B©k ga & ɹ\ú‰ éÅ ú† .ù\\¶Ì  endstream endobj 1136 0 obj << /Length 1170 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 140 3 220 239] /Resources 1171 0 R >> stream xœ+ä2TÁ¢týD…ôb.C#c =3cs ]#c=3S3…¢T…4®@.h k endstream endobj 1137 0 obj << /Length 1172 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 58 1 458 400] /Resources 1173 0 R >> stream xœ‹1 €0û{Å~Àx!‰æ^ ÑR,DE,¢…ß7 Ë2ÅìFbäŒê•q¾¤•xv­Á—TŸzѼ€c'‹º<ª ËŒí&'J¬K#ñF¥E²<& ô­dÜ endstream endobj 1138 0 obj << /Length 1174 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 227 245 237 304] /Resources 1175 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.## Ks=c3c S3…¢T…`…@®@.A¡3 endstream endobj 1139 0 obj << /Length 1176 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 243 301 293 312] /Resources 1177 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.# K=c3c  …¢T…`…@®@.A¢3 endstream endobj 1140 0 obj << /Length 1178 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 165 157 224] /Resources 1179 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C Css=c3c S3…¢T…`…@®@.S›c endstream endobj 1141 0 obj << /Length 1180 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 221 213 232] /Resources 1181 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C3C3K=c3c  …¢T…`…@®@.Sšc endstream endobj 1142 0 obj << /Length 1182 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 85 157 144] /Resources 1183 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C #Ss=c3c S3…¢T…`…@®@.S‡b endstream endobj 1143 0 obj << /Length 1184 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 141 213 152] /Resources 1185 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C3#K=c3c  …¢T…`…@®@.S†b endstream endobj 1144 0 obj << /Length 1186 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 307 245 317 304] /Resources 1187 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.c Ks=c3c S3…¢T…`…@®@.AŠ2 endstream endobj 1145 0 obj << /Length 1188 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 323 301 373 312] /Resources 1189 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.c# K=c3c  …¢T…`…@®@.A‹2 endstream endobj 1146 0 obj << /Length 1190 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 387 245 397 304] /Resources 1191 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.c Ks=c3c S3…¢T…`…@®@.BJ: endstream endobj 1147 0 obj << /Length 1192 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 403 301 453 312] /Resources 1193 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\. K=c3c  …¢T…`…@®@.At1 endstream endobj 1148 0 obj << /Length 1194 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 147 5 157 64] /Resources 1195 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C ccs=c3c S3…¢T…`…@®@.Ssa endstream endobj 1149 0 obj << /Length 1196 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 163 61 213 72] /Resources 1197 0 R >> stream xœ+ä2PÁ wýD…ôb.C=3…r ¨gqEÇ*è(¤p™(ø**‚ë‚(…ä\.C3c#K=c3c  …¢T…`…@®@.Sra endstream endobj 1150 0 obj << /Length 1198 0 R /Filter /FlateDecode /Type /XObject /Subtype /Form /BBox [ 220 0 458 239] /Resources 1199 0 R >> stream xœ+ä2Ð3Q€á¢týD…ôb. r [šY*”ż€8‹+:(j Âe¢à«P¨`Vª ¢L ’s¹ŒŒ€†Y(šé™*›é™[šƒiSSK…¢T'-…@®@.YO endstream endobj 1152 0 obj << /Length 1201 0 R /Filter /FlateDecode >> stream xœ]Ánà †ï<…í¡‚Fí EšºK릦{&CZ9ä·/ª“vÛøÿ¬óK÷Þy—€QÐ=&°ÎÂ9,¤gÇŒÓéYÕ[O*2žá~N·I ü–›s¢vo& ¸gÀ?É 9?ÂîûÒoOýã/NèÖ¶`Ðæq*^Õ„À+|èLî»´2ö§¸¯¡©õq³¤ƒÁ9*¤üˆL Ñ‚´¶eèÍ¿^³ƒÕ?Š˜<é¬"&ÏçšçP¸§¢L(_}YÓ QvU÷Qí#Îãke1ÄBÕóŸ/q“ endstream endobj 1154 0 obj << /Length 1203 0 R /Filter /FlateDecode >> stream xœ]‘Én„0 †ïy §‡KÑHR5½pè¢Ò>“©„(„o_'M¥À_¼üqììÒ=wÖÈÞý¢z 0«=®ËæÂ'cEQ‚6*ÜNé¯æÁ‰ŒŠû} 8wv\„”}Pp ~‡Ã“^®ø {ó½±¾.=»ú͹œÑÈEÛ‚Æ‘ä^÷:ÌY*>všâ&ìG*ûËøÜB™Î·¤«úÁN(dž· DZhõ¿XQsÉuT߃²z¤Ô<'C\2—‘æ†øT'&#d£“!ÿ™ýgâ2OLFÈš5ë¨ÙhÎבY§I:sóù®:ÞÕì/¢>÷sŠý”Èú˜uë>>/îá>7µyO#KËJ³ŠS2ïût‹‹Uéû è™ endstream endobj 1155 0 obj << /Type /XObject /Length 45 /Filter /FlateDecode /Subtype /Form /BBox [ 140 2.100006 220 238.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.C#=C 0S°²ÍŠRÒ¸¶´ endstream endobj 1156 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 58 0.100006 458 399.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.S =C 0S010P0¶´T(JUHã·0À endstream endobj 1157 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 227 244.100006 237 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.##s#=C 0S04P0µT(JUHãÀ!î endstream endobj 1158 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 243 300.100006 293 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.#cc=C 0S05P04T(JUHã¿9Ý endstream endobj 1159 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 147 164.100006 157 223.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.CsC3=C 0S04P0µT(JUHãÀMð endstream endobj 1160 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 163 220.100006 213 231.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.C3c##=C 0S05P04T(JUHã¿eß endstream endobj 1161 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 147 84.100006 157 143.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.Cs =C 0S04P0µT(JUHã·×Á endstream endobj 1162 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 163 140.100006 213 151.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.C3cC=C 0S05P04T(JUHã¿yà endstream endobj 1163 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 307 244.100006 317 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.cs#=C 0S04P0µT(JUHãÀ í endstream endobj 1164 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 323 300.100006 373 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.c#cc=C 0S05P04T(JUHã¿!Ü endstream endobj 1165 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 387 244.100006 397 303.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.c s#=C 0S04P0µT(JUHãÀÑõ endstream endobj 1166 0 obj << /Type /XObject /Length 48 /Filter /FlateDecode /Subtype /Form /BBox [ 403 300.100006 453 311.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.cc=C 0S05P04T(JUHã¿ Û endstream endobj 1167 0 obj << /Type /XObject /Length 46 /Filter /FlateDecode /Subtype /Form /BBox [ 147 4.100006 157 63.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.Cs=C 0S04P0µT(JUHã®Õ‰ endstream endobj 1168 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 163 60.100006 213 71.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.99 /ca 0.99 >> >> >> >> stream xœ3P0¢týD…ôb.C3c3=C 0S05P04T(JUHã·± endstream endobj 1169 0 obj << /Type /XObject /Length 47 /Filter /FlateDecode /Subtype /Form /BBox [ 220 -0.899994 458 238.100006] /Group << /Type /Group /S /Transparency /I true /CS /DeviceRGB >> /Resources << /ExtGState << /a0 << /CA 0.17004 /ca 0.17004 >> >> >> >> stream xœ3P0¢týD…ôb.##]= K 0Q02¶bK…¢T…4.Êa ? endstream endobj 1200 0 obj << /Length 1204 0 R /Filter /FlateDecode /Length1 3964 >> stream xœåWolÇ3ëûã?Ç­±1.ps,çŸC †‹½ÜíÆg§>ÎWöœàÞÙg0j(V츆ðÇM“]B…¢~ê?Y*ªª6æphM¥¦NU¡´Â-•ú¡ª¢©TáCI©D­ؾÙ[[˜|©*uæÞÌû½÷æÍ›y³{³@ f@6r,7þç›ß; @û‘G¦&Ùú”½¸öðø‘cS¿Ð~ à\@RŽƒ«WÀgÞš«ƒ>ß¼ù§¹uV}®ÖêoÍy oý¼¹¤nDFvû°‘k Ï+8¯Åùª ¯-æ|v_cõ·æP^øÍõ>èEæ_j;j$ýPÎFNE[kDYV{ÂïõãfhÎé µ´†º¨“zz \,‹XÑÐ!l¶µ†R›Ÿ OâBk7Ñím%v %z.â×ü­Zc£ÖŠL$çmìé oÞKw¤Ú7lhOuŸÜëíéi°vFqªª Œ>ý&Q²΂IR$G¦Éò:½Jßeõ¬•ífo7›¦È7Ì’$‹úÓ¶¾õ+úO/çx—|›|—|ë¬]¯b}‡¼ó™#ÿ»B>!¡p¶ÿûBP…Ï›,ÄùsIr ¹dÆMݲ¹üHCØ‹5rÝHÚ}´¬/¡]H¯°ï¡zá9fKKe¾¥¡ë vbŹéßè‡Ð ä©G°ºÿõr²0ýøzö˜w$‚ÿ véÔdÿçŸîëMôìïÞ×µXt¯ÚÕùTdÏîŽ];ÛŸly¢¹©¡>´EÙðÕVË^OeE¹Ûåt”I”@“®Ä³Œ×gyY½ÒÝÝ,°’CAî>A–3ÅWÛp–µÌØjK-?`©–,ÕK"³Dš›˜®0¾¨)lž & äÏkJ†ñÛßgñeõð qÓ}cã$ËtŸ+èY ý++bJl´¢¹ Š•ÈV"Ç”ñ"iè$CôÝE n˜–K!=—çýIC×üÁ`Æ’AÌòÅ1î²|±£"fx•› ¯ÍË0œ Wå•|îYƒK9TôBá¼:Ì·*ßzò¦—<Ê›Mça%¬L@¸#$+¬p0xåößWKr¶Ä’ï€`ÅW¶ õË<`l!®/±¼:¯Â0>“4J˜Á°ÿ¨-á §Y¡YXÖ¬K Í̲fexV ŠTéYû75æã3ì¹ wßú…ð‡zÆ¥úìðȘès£EÓJû6`pUCFÍÙkÕ‹­-hŸËâ"ŽŠmH¼EçµJ´d€&rp4eXCìa¼6Æ!;bâ-º&âbz!«•¾”¤q¶›7Š;˜n;쀌ˆƒ×Å0)õzÁÈæ¬?çó03üA®fpû2Š1šYRd¾õN´f´FáÚ°^6+w…ÜÌ ~)#²…ÇF‰FP!cº,(20ƒøaÙ g±-·Ê)ë*I uûƒ™`©|FH~;&Gˆ»ïó%£`%¦Ò<ŸZÉZ´•é£Ú}®rê°´½=œ»Öî°Ÿß8¾Þ”xNa2‹róæÌp¡¨ª…q=;¶[øQöç Jʈø­ð§ý'Åtk!AÑæ&|ùD‹ 9—,ªä\jи‚ÿâìÜ€Q¤$š§ß7† Ä—ÎòbsNeÆ ÙŒ8ÚP‡‰?Â‰Ò œ*EBU¼BòJ%*ä]BÞU’;…Ü…i!u¤Ù¾§]»ö÷ßêú¢7r“n Éo ?5DÿÛÙk›#fÄó¶ôÂr¼Å•nvØJÍ<îùêóž·?qã“È?¡|ƒôGpЖ‰›Ákâ{Ȳ–Å»ïEüÆ¢xki €ƒ9ÿ_äçPNP})`{=hÖŠ¤"IÅv‰š ¨oïˆ_!„À¥Z÷úÐ)!n¸@\&Nì˱w`_ièB)/ò~í?H™ºD_Ѷ^FúÚKí—*6¾ªå3HêYrö„PÏ3Órà4²³§È)d½/’yO’“ˆà„|‚º½_!¦¢[“8ðy¤ñh>péËHGAEAÊ!e"¥‘RHI¤^¤¤n¤8h$Ƶ.h×5ªEýØÞõˆ’Ñ¥("¿–æžFwÚÑHÓeÈ{פ++Ò®Fgš4Bú—ð0A*G MŽãçJjžÀ\qyr!1ï2$¸»ÿNÎñPJ´jr;ÏqH>c ùfæ•óç!º1Á7¦ >»1“à3ÈÀÆbD3á0L„ÃËŸH$<1 ØN¾04Kð@gõC¨žÄŠEg•‰Iá†L¢Åä aßü°Ê ¨ endstream endobj 1202 0 obj << /Length 1205 0 R /Filter /FlateDecode /Length1 5716 >> stream xœåX{xTE–?uÏ­~?îít'„$ýHÒ BÚ„„‡´@äå`€€À-0h(!eBx9  !""òˆ‘a a< Œ®€3ˆ.ŠqwÌ̠΄¤²§Ðùöýö¿ýöÛªÔ½uιUuN:¿S``€ @pÏ|lzéå/×£@š2sÑn˜“`ö0(}ô±ù}Í° {·$Û”2•úûhLîìYÓ‹¥@î÷$¯ßlb˜‚šéJ2Ñɳ{bñ(·n Ñ#ˆöÏ+™I²qŸ½ŠèaM_\*—kæ}–hwé‚Y¥´¦®BóñÙ A@ÔȾ“´ÕBw¿I¾š[LÇ—K2d4_ÝÊ…Ð…/Jõ¨^ê Èбã:¾5ZËßþ²@“ v}ÉSyÄB?wó+–zCµÊ^z¹:æyu]wm¬|v¥»ÒÊ OØz3t3¤Üøî†ï 5Î'±©Ìч%¹AUÀ“Ù/Çaùˆæ©kÏvhc ƒg¯æ^ÿµØ/–²•lüÊë|ÆÅG¦‰Sââ’85í‘ó#F°íìQ6›mN&"œCü"è@7 õ'ÅBµA_m{†Uö»T£NŠŠuq°ÄGóØø>zˆ·Éž°’d±“——wd„"ºæùX)ª’‚Ù}S’~èxII‡]£u2‡]Nò°MlØ«/¿üªhb½6?ÿüfa”äkí˪_m·:ÿ$éü¬jíºJ) î-Y0¿t×ñ·Vï°»[^8ý ícXß$ÒWi~›¦Z–ªáy¿Ž3-ƃl«v¡9¬SX%ÒÈHEyäjIgpJg©TÐÙð>¿¸GŒØÓ™CG껾”'ÉevàG= …iª,ê:k²Mf½În#éà~Í3/”I ´¶fÞl©¶˜<ßÁÇq¹(JÍRíÑYd4u’²ÉE‰)¬>¸lYõþ`pè[Ož8Í>`G¤]Ó·o?¶S*»U·/0³ wÓ1‡ôX¢±“GÉÑb2-¶Äç7+ÜÏ x/åm\C Ñô'‚Aýï¡ðØAb¢¼\.+[ëªÕIz¬Õh °¨V°šU“Â/‹Ù`4˜T£Ñ0ÄlÔ+`äUø¶ÅؤXÌ&ƒ^ƒ ³ÊV£¢\Ý`(Ý +üå¤F0‚?wòè{a¸ßu|F3o†Ô<5Ï–ç=~’Vá×µŠîN»Óç×c2''2›¸N£Gs´!Ƭ˜“ÌÙ摆 cÌSôS s Uæ ó&³Í¤„‘›Œ£5†9$EVxŒÁn´›º[º[S!™%KnÙÍÓt=ô^C²1Ù”jîiéiu«9Ͳ%Ÿì㹆~Æ~¦\sž%ÏêSï?óK~ôË~î×øµ~Ý}¾a¸y¤e¤Õ¯ÂX6Vš€rŸ¨™ ¨{Hÿa‚q‚i²e²µ@ °€4Û0Ç2ÇZ¤–é[[WÃ}¥±Ò´Ú¼Ú²Úú¢¾ÚXmªµÔZwwšöZöZÔÔ+j—:k*LåÖ‹eÓiÌX–žeI›Æl^¶iÞ…Y1à]6M{wö饵#VÊc:6ã< GòeÅ„©ð´ Ù$YŒ’ÓåÔé%­Ar¹œC F§Kv0p¼bßÜ­Z•«a³—¤‡Ó`tÅi!1.Ö’®µ'öP>mu„ZU[^$H QZ#€¢œ$ïÝv˜å:uï¼&'°¦Q¬r¥e¤=˜†·ñ&Qã°G»X$p=‰)©ÙN–‰é Ö‡e÷MÎÊŒ–G,<ûÈk¿}j×Ò«Ÿ‰ks¿©( -ØßTU[võ}óíœOøÎ÷rúU,š9ËÛëÒ¡KŸû2>Ì¿ÕÓ/suK?¾÷dkJØî#ÚŠÁD˜âOÑØôݬ IÐ:LU n Æ5Å*ZP­:¦@ÕY â»éºßŸ¡ŽŠÁ0 Øzs`s(3‘þ(_rAriò†ä:ªï$_IîJÖ4ÝKêG;Ô$•P‰lûÇN–#"”Óò?ûæ±ÆO®ßÕ¸à©çv56nX²t/®^¶èÛ«KÛ^Ùzlgg•´mÇKï¼ÚY%Õ?:cYØwÌ'ß-'ì¥þdp0ýJÝ*îxƒñF;Ú­Ñ4­‹sH:‡FK6k~|OBÍ ˜ߪܠzó1|þ´Á ¥ u &´%ðÁ0˜ –;ÇñÞÚ ]†¾·¡JX‰Tâ(‰ÓOΞˆs~L Y™ øP+/ï8`:wxî©3?ü•¸)N±´Ž«L”^[UÛh‘¦M9vªoßúž½Y.3°(6T|Ö¼å`ý¶»6M!\R rý±ÝÁboäºu– Û‚12è¤áªÍ˜Ÿ1$3 Œ¡VÂE¥ù†ïP‘³ÂYçÄpJ¸‹‡RD¯hv&#›;‚Áþo-ké‚®–eoužz}ãÆÝ»7n|IÓþÚ]< c:ªÃ¦ G˵k-Ôè¼(áÜLy@‡ý©²Ê5U 5á—Œ$—TÆ`ÊìMÐÈ(§ ¡\hŽ‰ä«ÌŠX: ÿ Àž8\Χ`9®@­´’NÖkÌ.u—»óžÂR¤49{5n].dQp”òÍÈgùÒHy$®™ 5iŽ<‡/…El‘´D^ŸÔTè^€-š4ÂO˜4ªóäyv‰}òQç)~ñVŒüu{/Ú÷2Ú÷t:KðB“?5ÖeŒÑ[àM£Eu¯t‰oL ªëbLƒÝ(?]¨³ç§Î^ 7¨‘¼ÜÜz³ƒÒàI:SwpÚÿ¸/Áçô¹|nŸÇ—88ÕŸàwú]~·ßãO,H(p¸ Üž‚Ä‚ÔÒÔÊ„*g•«Ê]å©LÜZ—Ú–ê¼;ôî »ŠœE®"w‘§ÔYê*u—z*œ® w…§ÛTò}CÈÛƒXÎݤ˜Ý·_–ç¶÷µÙ‘°“Ž]Ù÷LÉ‹Áàà¦UûZ:o1éõ-E‡ g›ò×6)+P6c᥃it>³'0ýÄŽ·Û–¯íÓgOjjÇìÀQ´W*øüv‘ˆU– ¾IkÐè@w¿Méh¾³)Ö.œ ×Á‚¨íQá[Õmû1þcp”kdï­¯76ö?RÕ'ÚÔ–c(Î39`ôezÔƒ \­†‹…n?äêœ,GÒåóç…ˆ|>‰&¥1ôvÒ©E°ÀrèbãÙt¶˜=Í6J'¥OÝ)nŸ»¿{Ÿ'±«+|…:6Ž‘¼üŽ<Šäy?Ⱥ0ZãSV˶²mTëîÔ“TO³Ó$×þÌXëÏÎüc‘"6…ïŽ?Ut‘§éŸÊÌ‘§‘Îõ?N÷¹»ÅyÊw(ÍÿP«ÿW…eCZ¨ž€=°•í"*@ìùÄ©“@%¹Ç7 W× {“¾ø)áé½GLr7tæ»3k~Ñ0âŸDÝ0Elâç‹È‹6p/ý,jpÏœí^£¬Iê¿F™Õ?"h!=dxøºCX~ ®Ûððûo[Ý}ÿqG½y~ÜÆŽÛøBOíc" ãê÷·5/¸Ãÿ±(tB¼òr8#×Ânƒz)NÈM0HZK°b‡*m ‘C0Ÿúóùs Êp!ùå;ó £ö)-¸ŽÚç¤l1µ:‚ y·'ZÓƒ%ífRñ =É Jøÿ­,„^0›0O"Œ1l…ì¢é-¥ ×-ívü»ÿ–‰ß×àwüVàMõâ_,øçlóâ7kîãß¼Qƒ×k0ÔŽÿÙŽÿ!ðëþø§!xMà¿gâW­ãùW5ØJ¶ŽÇ/¯fð/Ûñj~!ðsW2ñßìøY ~*ð² ?)ÇKGñ?¦Ï?.Ç‹†ó‹åxa8žÿ(ŽŸøQþ«À~ ð÷ÏÕàÙ'?+°Å‰ïgâ'+U~2ß‹Æfï ü'øŽÀcßØ$ð¨À#*6®ôòFÁÃGyPàáCSùá£x¸B>ô;/?4Õß…‡üòï¼xPàokð€À·6|S`}1î·à¾½^¾¯÷î±ñ½^ÜcÃ7Hé7Úq·À×îøš w |u‡…¿š‰;,øJ1ÖÑ'u5¸]඗M|›À—M¸õ¥X¾µ_ªUøK±X«à‹|Aà–3ß"°ÆŒÕ4¨º7o²ðÍ=p“7¶ãóŽòçnX?•o8Š*äõ¿ñòõSq½_þŸ¸nm¾NàÚ>¸†Ì\s®^eä«í¸Š®Ĩ*Æ•´S+½X©â¯®xVå+>«â3+.èïzº¼œ?-°¼—cY¡ƒ—yq©À%[ð).2à“ŸhÇ…í¸ ç·c©À œçÁ_ œ«ásÇã³ËñQ"g ,8Sà ÓûcQ;N3áT¿8EàäI>¹'ð¡èXþP&N8Vž0 8ž)||7gDZ£¢øXF|Pà˜_(|ŒÀ_(ø€ÀÑ$-pÔH…ŠÂ‘ f>RÁf.ðþ̯Áa‡Jé|h;9Š÷F¿ÀÁïdã÷ÚqÐ@+dÃÌ| ¿ËŠÌØ_`žÀÜ;ÏmÇœ~ ϱc¿l#ï§`¶û:1ËŒ™÷y¦À{ŒèË0rŸ3ŒØ']Ïû(˜®Çޙث§—÷*Æži6ÞÓ‹i6ì‘êå=îÃT/¦x<ÅŠ^#& L˜hEÙ鱡»]íè$œÅ˜`ÆxÚÁxqíØ}Æ+°[1ÆÐNÅŒ¦Aѱèh%ÐFØýÂHçêTÊÑZŒfS47 4Ñצh4 4(¨¨£ÏtµvÔÓ/…ËtH\„Ú —Ò‘)YW>Çzý_(ð¿­ÀÏ–„ÿ}ª¤ endstream endobj 1067 0 obj << /Type /ObjStm /N 100 /First 991 /Length 1681 /Filter /FlateDecode >> stream xÚÝY[oÔF~ß_1 ïÌ9sE)!$ ¥Q•h <8“¸Ý쮼ޖüû~g–\6à`‚B•ÈþlŸoÎufŽ×F{­´2Úe e‚àqà•£ ¢Jl$•‚€am2Â8 ÂÁz%A2V„ gDO4‚„¡Í¹$"΋ò艮ˆƒËûŒò=ŒìÙ -Ø ƒFƒAuÂ!%–Xô&\¦$Üdé¬-Á/C™ábfEd3#Âk ÈC‡ÑZ‘e 6@2¨Ñ¤È9'ˆy†1`xqÚÉgd³ó‚(eÄŠ-gd‚‡rŠÉ÷<Ð’€–Œ¨Ø/ (b­8dLã !3:bf c³„„Sf80Rf8VÖHzLÐÊZmAâ`­#A,HÈ´uZ¢2Ê $ù0H”uKFJy”¤¬×¢Š¬—8#g‚¢ èð9¦HèˆÐ¬è@m‰Ô† Qt 6l$T„R¤a£¨¥¤ *Ht@iP$:P6I9Tè€r§ItÀp§Yt "œ–úC% ƒà¾“D1RdÉ4ÐNÔÉ=±^#¿Žr­æ,Ô.òër iä×y±Ê•‹$\‹‘SžÀK™9åI⢭Wž%oÚåÉŒ¨¼—i› Ñž< Ÿ5UÙNõ`TÖÍT™ÂpaÔ»'m;{<æ»ÇM9;©GóbÚ¿{øp0üµ™-FÕíXOŸf…g³J Ÿl·÷Û²­Ãý_Êù_ËõC«½ÈÊÀ®u9®¿ÜWÊñ¼ú:;ufoM'-ˆ‹Ã6_4‹J †å¼’‡j¸³ûfïG¯“v±¶SŸ€±U7óöÙIÙ(¦Áp§ütÝ ¹YÍGM=“`æ¥/›ó|2šÕ“c5|SOÖ'óúüÆ7ŽÚ“¹z«ôý¡V?»ç£~8L_MjØQ‰¥œ-½m„öŸïímüþh³ú³|½Ø/'óュmU€l÷1ÖÏ›ÝüòÓÿ:i‘â28Xž®„Ê]Ãcò{¶Ÿ8võX†²Œ“ÉÄ2ÏÇ£òø)£”õ؃ä™ÅÙQæ3ŸëNrÏ^O‹û<-RêH‹®g'å`¸-r¾£\Xæˤ,“´[žV7Õ?o•§õøL=X>Qù „­qy<Ïi¡éG¤m 3Iv,ltÉEøø²-Çõh}r<®”Æ*”Sª˜"kX®1…ËÙ‹J†"¼i«Ó×*ê%z‘Q6¨WÒDº«ª÷ŠwËûJÜìœF×,Òn|Þ!½¿Ù=ŠWÜ#vWÝfÿì¹²‹k ’«RçÓrÝËk $—ÿhPnG 6æ0 ÍÀY®„t»™.f¹¶DgV6Õdt¿U‹EãáÉfõw=ªö¶7γqoöé·¾}‘­›{±m/¶ëÅö½Ø¡;öb§>lֽؽj{Õ÷ª5îUkìîS'&/3?G'f}S'öÛîþ›Ín˜Y ¾OØ5¹]عÜevÙ‡-»/}Ñ{}Öy]OíÔMç:ÊùŽr¡£\ì(—ºÉyÝQÎt”£ŽrÜQ®c>|Ç|øŽùðóá;æçÿu÷MZßÆ¿U+Ö½î¾I_Ôµ³wÜ}ÇpÇòñ'—?¹üÇǘoxÝ£—¯{V£‰ºœÃë“Éôjÿ±SO°¶mL›£ªy›7Ñ÷Ã×Ãg¸À)¸WZõ–è±mZ'Å)‘d˧‚,Alæ(Y$·§S¼2â-¯n«¢,Çÿ<6î¡Z×ß«¹ŸQÅél­Ñ…榎O›Pö±$7–PÔEÔù—Y'*Š¡ HÊÛXXíWšò¡>^4Ua¾Ÿl‘“ˆ_X‹ÍAòÅ.cúQF-¼ü$(ŸY’ƒîÑE\;^iÅ|q8¹žN Wô«kyñ(4…ΛB>?EÐÆá:ÙÇ…üÎHÊ3ÈÅŒKï:"×æŒKEþ&–dܤlÀœÁ{c.qú¤9-›3Lšïg 4ê Ñ‘o(D©1S+ØÜñô½¶¦é„ÓÖÊʶʸ˜‚Ä7Ôì]™b"¦ eSðÄ Š÷ë–|÷ô˜ ù°dRÄRf•‰ >Ò¥}áLø–0Áwù6|>Ë4Š–aVš¯ææðÜ ì˜L endstream endobj 1220 0 obj << /Length 4219 /Filter /FlateDecode >> stream xÚ½[[sÛ¸~ϯP:¡fV,›ËîdÇÙ¤¶3Û&ÝF¢cMt[’jêýõýÞ$ÊvbO,‚$|ç;ÒlòiÂ&??añøìòÉß~ÒzâRg„™\^M¸Ð©Ðrb¬N¹ä“ËÅäC"SnS1qÆXr^,öóåæÓt&4Kêë"4ÖÅz[Þ„ö|»©öë]½ÜnÂ…}Õ>ðìì|úûå/˜VL,¦5Š¦e“ÏRÆã„—Õw2¦× =¸•èëûœ½‡›4SYÓåjÊY’ÏëmYMgÒð$/ jH¸Þ•EU‹pc±/½„ÔöK¢NÝãË?sZL:¥’Ë©eÉ6t.IÅÁƒ.èâÕv[ï0xO‡" /Ö1™I™: 5°Ôiä¯Ð$Ú&ËM8®¶S¡“/³2ß|¦+f(×áÞ¿™fUáÇó”ãOOJÚëæäüç'“¾óÅþcUÌ›=² ö[Ç'8 äa,]Jå7ÆŸWÛÕ¾{vwWE”³ G(cºîŠ’DlÒbÁ6à9Xiƒ 1С(ß,"ìò›ˆûæÞªÚ†ÖLjÍ|>/VE™×Å‚Ö±.¯—±wslœïëíÛ=X¾Þ.çñÖ—¸¦€âÁãnIkøý„‰h\¦J×òª¦'x|’·âòd·­ªåÇUÎêxõ3­½(vñêu¼}µ_­ZðC ñFC€ö²šçåâàñCŒP_çQÔë|*–ÆuâÉv³ºizícÿÈ#kÞ{C™ «ÊToKâu/nŒ´,"=«K¾Ã)®÷õ@w;\b°—¸áÕc$Ç& ¶‰‚EÛá§)vv¹‰>Ï7C¤žÿî`REÄærÓ@kÙ>Ti¤-=Ⴣ¾ÿ ðŸé×Eº½È¬a¿…ÃyAô0嶹~Uäõ>^¸Ã’L’»¸­eå•F¶WñqÙ{\[ï"±¾~÷úíÅÈ$Â¥™¶M¯|Qg ÊØ$бê#ëxÖL§¦£ó[guM/PmQnòU˜`‘×yh},°ïE\bŽùúÆ憄¸iUÄôŒ®óeÔNU»*Ýé<¢dT{è `w¯Ãfm/"ó븩–°.õˆCò×=èƒ c¿{ù)ÅÀÐ9|@ÊÇÝöÆB@îÔ‚­ó²ŽG» ÷®Êíºyp‹GÊ 6ÅR)†JÛ•Û9¼q°@Z8m7ç¢iGèøúí«hÚá‘‚t#2Œ ×çÑâ›G$=BKø.\ýxŽ¥7rEÇÛ%„M3XÊÝû%;›èpGÃÜÑôA þÚ²ú<`ÈÀ´^7p†`5ÔN@!ƒ6òuÓª=sR3'“bŠ†ðçmïõv]l/F{@ë‹SÕŒÜÙá"ŒçM”ž€Ôà`e\òc4—î4Qïã ú>¸I–u轌Ӷo„nEø`²^nö~x¤Þ–ŸÃÄhYÖסµaâeUGéä5æñ~°~Q f"‘€Y1™¯Ÿ|øM¸-¤pè“/¾çz"RC¬²š\<ùG¬÷gSL€HÃ@f¯·¼+ÇÂï‰V5>«ÆJ†XÃ2=ÖpáD,¢XÛ™Ôºá.‘»¨ovc% á¹;±C…ž¥®ORâmø4"ȶ²0’iŠ8—çïžßÝ/ bàÍaÍèCµ˜ÿùû‰”Ì)ä7 Þ—EJ›Z.‡‚Wu¹Ÿ§×éÝÜ/&:uYæ߃‰³‰L-‹»$n#ÿ ˜j–ywœ™¬+üÃO»CÚZ$¡( èµÑ¾¤ôºd]·ó7SÓ¤ƒëVË%¨ˆ´”!× 7(¤ãü:ß|òum­làuÙ$®tÛ—Cè’·>áº[D( ´U¸ÝS‘§%J-Ôq½¯êÞ¤’õÒŽFš›þà’öáצ 7HÈʪî²Û6º ¸Ñ”î~lkx›ì:_4!;à–Ëë^šÝ¾¶ªŠ?öŦqÆoq ct +­/Þ¼{vör:3ðïoÏ_>uñêͯ#âZ›ÊŽº†˜í¿êXm·ŸoOÄ}°µeÒz[ãðQV{¤9SÍWSÍ“_§ZÀÝ¢uF?ïèôµ^¶òuÃH²¬ Øž"bqÖáâ.œUã.ÁqJáTogVæĵvR‘OÈ, ¥³&¿3×AŽr ÜÂ…Ã><“g~$œm¡ hu8Sœ¶V‡3O«Q îñ^Ëù‰˜%¦³Ïá,gŸÂ9~%¼)ÛÀß°ïëpØÒÁynWý—¯}ÌÈèï>£úÁãì>˜Eݲû0ߧ9²úh‚šghJÛ˜<”¤CÃztá‡p0÷…/hø­,Ûµ"ì÷›×zñè·ãE6ðæ,zVv†>m8qŠ•G·AB|ËÌ·nC_’¶Á¸Û¶af ó˜¢w áP†Ã>æƒ{ûA—Q ú¶+sßNñ÷gx ·eŽ@ykú}׶‰ó©}AaOÄ“åý áwmˆ TZj»¨dBò4C ô?¾!¡&9?CÆÌìÿC™Lóž»T’Ü% <ê.oA~ŽˆQ™‡Q…¥÷mÜ%šý'?ý+?ý¯¾ý£ÿ=‹Qû½ÿ}IH<ô£‡ãÀ¶ùô©’²>„™qã+nQ _L5•ÂW¾ÙÕ缾7±Žv¯Í ' -"ãˆüÄ„kžj$t¨! ³<Œ$å Î2’ *“2ÓÚOu½Ý¯aY”Ó±,v«|^4WoF³P ½Û|²:U¤OÀf_£20{iî¹F™¥¦ûjglfJãêà[‘ù‰upZ€Yg)æqZ†ñÉŒí2f¶¿+Ò ÊÁ[Èýy rvií#¬ChD ™}ÐB|JÛS…%ReÛgž¾x:Vî$0ØîÝçR‘©fm™øÅ©r$T]·øŠæp(µÊuˆy“Z+AÉJ;Œ ‡J>Uù•D¹íF©„9þ¨ìéÅÓñ»`jÌ€à»ï¥Ÿ>ù„mË(n|y;Èû;¾‡šh œ(×t·«#f°ÂC÷ÔÕ›æÁSc0Žìœé^ÉÙw$ çEZ‡2r½Tèö½~£¸})Ïů[Ú7ãÚØÓ¾Nöªè†2˜ÊšÛŠ]_XŸé¾T@|V\5ïø{åÍž°”­ë¦Ðu°Ç{ßõPþkÒØáâ‘Æyjé)óE]Ûÿvçù­òÈ ‘ÎæÛ²,ªÝv³åXÃZuöi©^Û²Vèó—?žLÅ; {ï¥Ç"nH÷½º@6çcŸDžÝÞ@2eÒÝ6•IE‡«ço^¿={ùÏ15#"3fŒ{ëÒX¼«=Ÿ j¤ðLW*TBýEû…;Ýˤ>g3ÉEû͈<`‡^Òwë9MÑ'°T@gâŽbtüˆ˜{:G % +Î`øÂŽóv¢‹½"óÒ2|¨¬aËæÖƒyf”RŒèÁ í퀑°h»“©6ò!ËãÈW¨ªŒ‘¤‘w¬N¦Žß†>Rú].“ŠgVÛÇÝmúÑ$7î˜UB*ä âšù*ü7H>ÒŒó"bÙ™þûK0"ªY>|_©¯ÎpúëdØÓÖoÝúöZqŠ©ô#¬Eë”×_Ëa€Û[9Ò!ÝwÈcNŠu_gœL˜û(ò»äÜS~2ݧ†cÖ0SØ1qà˜Nå¶ Y¸9Èü\daÎ=|@]÷ ÙÉtÏÙÄüâS Î!ñ½§øªÍîuŒ¼;Ï#·éAþ шû퟈Õe—î_Bé="܃ÑFH vãÿWé_ endstream endobj 1242 0 obj << /Length 1122 /Filter /FlateDecode >> stream xÚ¥VKsÛ6¾ëWà(ÍDÞ$®q›L2“i+—º>ÐmqʇBPqÜ_Ÿ¤EšqÒñE„Àî~ß¾ÀÈaäÝŠÅï›Ýêõ[-HJ­1Šìn —)M˜$&Õ”KNv{rµÞŠÍV$býu#ô:ëÊì¦*6×»pYž]V U‰ÍáV}ªÎŸZý¾[}Yq3‰à’Ž¤$y½ººfd{£Ò¦ä>œ¬‰ Æ¢"—«¿¢«çÖ7TÎ]=f]tl‚*¥:1ƒcí-¢Ùg}Ö?‘š>\¸ºüíâïëŸ?þyù” •Ü¼TŒ2f¦x.wŸ>_, Œˆmµw*«*\ô4`¢è¶í&{b}ìZeM7[™èõûÞ["[¡e©%[ΨÕ6ÚȼÃÖuÖl¸^?࿼­mS4½{åbÝ6UÜrmíÍh‹ŒƒäþPæ\f]‹a¯lú¢+\7ú¥è),N®è6Z¯½«ŠÅ”ôªáD7wef"¨n²* cSXÞ(‘@×1ËÿÍî °c€’Ë€Áð~Nž›óõÉ;Ž ü™›xy_üØhŠ=ŠÛf¢K@]-þá9<÷¨ò©¢,^­°,æ, ¼yá\Û9P®ä@ìx-‹5lj;f¾Ûçÿ]ÿ¨’SÈh•£UúE¥j5 ­Ð¶ë»SN É…¡|(qˆ¬ î‹®ôýê«ÏVÏ|5D5QŒD#w‰ê²‡¨ò¦ˆuÁ•RSÒË&¯Nû _ûTÃ/z¡C¤Y«bäèçBP-Ô€mì9óò74µ#ÝãRS ýwâ^ˆ¸R±n®<Š ÷Ÿz` ö…ý™’ÑT­>oW:_h ¿cÙÜE[ƒîtÓµ§¾lŠEø)4Óôw惑”?6éû²?ÌLeG`ÿãªh-M Ÿ2##«‹>+ú1– ôjmòÓ§©Ib¸…Á“¼hÈ! jòß熜±1Ï «iÊg)qqÞ¸b–†Çnä·¯¼þÔ-Fˆ¥”ñk£‘ªRN Ü1ÕÌFf)OP“MÏÎFÈM>¦&–œÆljxÏ'N@ߢ4²ÀqâLoºCë;Ê}3(˜ÈT“Î?«†?ŸÞ­ ã8”ôH @tümywêbQ>ÈÆÀÁ#IéiØÞûÖÂel-°¸m« ý*{‰Ðç¹Ê)çc/é6<]YõÚ®ªø¶Àœæ”é1¹¿œ²ªô½5´V08©”àIhg\ÅQ ¢ જ»;l©Ø‘;W¶ñ öaX k~ûÛS-Øä”–˜•ðôš4çü³D¦ðô€Xgn%« ¢Åœ¥åK–MAšìq…Ï+©§<ÁFä VÈ“_ÌÇ È> stream xÚí\Ys7~÷¯à>-YkNp©Êƒ,˱]©ìæð-Ñ+<´$åÄ©Úÿ¾ý5†Ã!Y±GÞØY©Jf84úF£1¢õº%Z_?[õ“þ£/žYÛrEô:´ú¯ZRÙBDÓrAVûVÿ¢õS{¿ceû¨cU{­g¸|ŠÖ^çEÿêFÕºÑÔ‹·4¿ÿ÷NW)Õþ‰*Û‹NW*Ó¾@eÛçéê÷ôÛ ª´jO:ÝÚ×TƲ}Åí†z´×ôïG’:-ÙRR*Øk×:Ÿ<úé…h]Ðß´D¡é§_ùÑIKÑ̵ƭޣïʹ×VÒÔ~sîsxÆ@̸½$½n˜”m_¢ 4Å„„:.»Q1úV×Ó­Ô[¿cuû‡Ž5í´r¨Sª ~W¨#œI¡Ú½Ž–„m*vQü˜î¶‚iv¬ r˜˜Z'hõn"JF¢‰$Êz[x×Q2:ê‚{²®œYc÷1öiÏn)N&¨:RzT|‡â¬¼ôÄrÔÚM—©']ïI«"ê²'™ºÚítíý£“³~jžìœîîõ÷N%4©ÚÀåÓÝ­¿ìƒÊ ³ùìåx8I¯] _¦£åh6½ý…n÷wÞ›ß ç©ïŸ…½¿éòlºx;™ —óÑùãt?ʲùvR”s-ž7C\»$ø†µ7Tj~=œçƒqõzê™Æ”·C×{5L/Ì^¥új@}Œ‡ãÑb²šÐ½‚ër¶X¦Ö¯³ù/£éëÇEÒ¼dí‘élóÙ0[Ü£}¡ëЭ5S?©"j}]µNsšIZé•xëA=¤¨KbL zãH†Tlï 8%I“žïÙþ¦Óµíc´ý$Ç^NéövgÓå|6^#ŽP>œ/Þ—qnņl€Ž¸BÆ>©7 õAÍ>Šº¶ŽiK-ãÛ.UåÕ-t‚lZ¹¡úæé…aª¨\{œIÆ ³j·cc0%£akàÈTÙÔßmà(ÒÄÁ7æ#*d•O„:ä„Ìõ#í¬Ø%j6#6/*  Ý ZæH#Û$S,ÌØöí)*6z¸ºNÕ°=Ä Œ@…›¸š§j”ªßrÌLádÈñÚÎb1œ^»Hì9š^]—Â8bø-µ¿,UÑb¥£FSbáWƒóáûpqþï£HºñE•!%ð•´¨¼CVô& U(¼2uZXSòQ㚪Aª¦©ºØ¸9¯n†è˜^ò“T-S5LÕë+°‡º“ü^‰ö?HQ×/;]bž_©dOJ‰‡$¸‡*2[Eþ“aßIBjÃy¡‡ŠœxG‚ ‰(¼­^Š)¡0¤)±|véá:=x gR‘#Š±E°u¢xzÓudl›ô´Ô›R¢^ƒ D¦Kâ®XIÈ”!‘+0™#áûvâ‰w/$âù âz=ç:Ò‘æÃt¤+y¨%ü_ää‡\3¹z༞ h'ܾârÌw†Üþ-OM!«^g†!8DÇS8}ûÉ¥b¯c$ ´úáÅQn¨HÚUm2Ž"áËT%Æ¡'²PÉP˜'mÇbDpµúhí¡uš_­¨ 2š‚\ôå¤U…±[ú‰HµËa,G¢²jÝ"*Aß…Ûp;nc…Ûð±q»6jˆ\}¹A xÒ²Ü0nÃÓ‚^MhØIŠàoøþ&À×,¶<Õ‹Ñ‚ìØËëåÊÄÕíÚ<³·Yƽýy¦ËÜÄY”Š]³ÔäÖJX„B›Ø²B†ÜÐF+aYHê])2‡ ƸZR(ï'dîÅt–ÚW|6¦3ÒªÂØ-¢ƒVDå>Z{h}]µn5æ½L'ù7àvh ÉÌÇGtËĤ°ñYáºRvÍ4x2,Yž°…Üðˆï¶ÜæXnóÑ-wXóNNÿKSØhîAÿ71®lÂÿĸ~ ¥á%gZd ‘ ßâÞh ãCËÐêÅ„füC¡œå®TXó/FN=í ,P+ÍÝTe`Ó´ t÷šÖä Ò’÷&h–ׇÂVµɆÑv,ü‘"šÏÙ…¼?7G~Z.d$/g'Ã;Ìè[†ükš1l5øÐÁüט‡|ªYªÎs.”’¤”Ê-ÛϦƒ;BB0€(»êz_ûJâ*ý:~£á€ilght’ b‘øð xùŸ¯’¸ „dÄõœêÓddáí+—æy€‚w¾G±“örjp*CüüÎY­8|žÑz4kãZF…‘Rk¢õD,5Ñ•‰:°ºsˆØT½©óD8£Oö“&ÛM&×ÓÑù`9+uÛ`ºRƒ´X½‘ÒûP-w‡rû`ݦÈP똹$¯ö˜ËC*=•´¦faSØ%,÷ ÷ÑzzËN†2ÙŒãùÅp>š¾ÞBÍâ|0^oñŒÊ…÷ëÑ›á45_¾Mõõ¢¾Ç5»ZŽ`¤ÚÓÁøÝûOÝ÷øC‡ïÂöƒãÞL§PycMþʸԟ‚C5„OîÊQW«ÝªPálÓ>8](}Ã>(Þy‘J§ˆƒÊÛO Vóÿk¯½GŠÑè »mTôP𽬌 Fœ‡iŽžž¢âŸ(z(vQìdvÖZÆÌî;ïÕq|Ö¯¶ì/K¦ÐzÓi>z}¹ì^®µ iâm4_ߺŸÛåÏ*2A?8Ÿ¬cáž'ïâ9ŠÞzs^AU¯fø(|ù¼J†¹§e“| õ§ëCeɶ(¢aWçš´¤7É›ÔF‚ h´†&¯À¢«´&.sCºlçXï!NÏ`tU•Œ´ÉO>’mzX+6Úò°êd Aw&¼ÊR^E"!8‚´YT0rT@“lò¤' v*€õA~*‡ ¥ÀÚ1sxæT—eU««6X[„žÕ&À'Ró¬~{¬Š¹} ‰ŽÊÜ h>ÙÙm\YÅAhxˆM‘¯îr@%ʬ"ôdoô}€§•È‚ç8–èƒ'xšw¬Åï–Õ¶ŒSo3¿)<1ý}€g}¡TØ&,~Î%$40q=GöX­tÑÓmŽÍ Ñ'>Ä–>a¿ 2™Ëk9y…@ã¹–²¡g O B *×Aϸ„@höA±Ý}ÊÙϹÌÚ[È`î0…¡ßÌ0`&¿c¤ ßÞoEÒ ´s‰Ã溜ƒ|Ä9ÉñJidÓ(ˆ1÷Ž¢‘wn`2„&m®²~ÄUŽ) ì̽€h ç\ÞÑlodnÆeé=«c6.;\Že:‚…ÓEc¼š-£—ã2¬8™] 0{‘ 6~¤ˆ«-ôZ6Óš9­iÓšú\¦D§œ++-^,ñ‰&^mæZ`OQ9îJˆùÇ<ü _åx•sÅ`!dVË©6ÉÆÝLñÞ éd)e"-7c9‘šÞr@$]ŽÎKÕ"͇.{éR§!µcµm¿M ·aß“¨Ë=b¥nN÷žW„®«èž·˜“;ú@üšð§‰ØŒÄŽ µž¡uŒ¨¦â-€ùw1@ø ÒË>ZRšÛ)Êé¨ßùåõGsLHè_p[Ù|ǧF}Š^n ´ ¾¥”$%Øèdhˆô¼æž”¯ƒ°Ëƒ?çö—§)÷î\ÀYO*NPœv˜+`c©›v­5ð ζjœP3P>þv7rÌÉE8]d4ž 8èÆ€ä=*¾E9zÀ¤×ôÇÖ–‡^õØÚ¢âÛœøXYxã“ìOšôÒ±Xòxgâ ­ÓÜY]Ía$ïš›Õ%—Ü—iÀ Ãa™l’—²‹]•dmac5°¦±^Ðl|m>eˆÉ¤¼ø”ÁqdUð£`üã‰R¢ „ÊÐ-…U¶Ò¡2Yá±øp/✎°u0*Oó{K¡2>d4Í#IfŸ£G5²Æ¾§ÿNÌ«Wç ­‚«M3*=Ù't¥õJpqŠ8 nILóŠ`x~ÂûÇ|$ÅÂYDԭŇ,Ö¸iÀɘù˜Í‚:\]UIP«l§«ùìÍèb;qxvxÒ{X¶~”\$i¨ ßA#½”÷5üT ïô®³c›d=º¯ÎèÞÌ–‹w“M>ÐíÃ4»åÍUxóé¾(øηòóÒ(Ò“–ul#ý.È kî kþÒ¤cà}¢ÇíþmYó´ˆÈ1Ï÷Ãù Hé{ד—ùØ£[´¤ÊÖðfÝé¤íº~íó½ò×,µ t¾9´ªû 8l½—Ž]g¬­ú׺û+x`’—v45—®ï8§ˆ~¹€V‘±Ç”Õð/uÈžê1’4¤`uC÷QÎiî ä• NÒ!©‡'5ørú€ºÐ2KÒ£Ádë(é«Ñ¸¼³œ•ÎëÉUᬟøb~¹Øzp´øå³fˆ-vP‰lº²éjÅ‘oy)G_µÊ­=rh"|#^ ¹&‡ ]Ù«žJ`£x‚â Á¢UÒÛbÁËá\öóõ²;{Õ=ŸÍ‡ÿùk ·KôÓuá–6)ìZÞ/ö\9Q"}Üi[®I¡JÛ¢¥klCZ"§{r¶"å*ݘŸ¡ØÇå¿òg4û€)ÁŠñQˆc(•'VÁ-Ik£Ò#-‚Ñ• qõ53û°Ãéà ' ¨ØÇe~u¤$‰åFôëŸúzJnˆ Õ÷Ñà X“ÿ´\,HÀïÿûh8óŽ4Âye3dqÐ!pW^Æ;>vã«|Ü[,¢S®ädM>q²"±Š.u÷lôúzŽe¥Ö¢­ÀÆc]2â%áà|6¹šM‡Óå¢|&ŒËËÕ{‹åüú|‰~Vjp=¬rŠ&í*D÷žîþø¢ZÌlâÎ(ìšè–7Ø'êbˆ[¨«j4!—¤Öë"¨ÕÚ»z¶[qBýÙBªÊ?½þ,„šbùÅsM3“ÂþxŽÌ•‰?ÓÜç¿¿˜!Ï|`P:W8|`»ä¾Éܤƒì¸–#ïÇ…44S ¸ÌÍŽž2ŸYNiEWM³ ìñ“Jm> stream xÚÅX]oT7}ß_áÇöÅ×ö|Ø®"$> jEDx ò‚ÒÂ.Úl$ø÷=ãeC‚`ÕJQv|÷ŒÏÜ{|¼9I )ä$9djfh(µ›Ñ|¥%ª= À¹„\rÒ¶„jØ’Sè†-Ó$•, s'{†T†#‡ÌZÍLœšY˜ºr6 _´jÏJ%%ƒ·$ÅÄ5 ( ) ÀŒˆdÀ)”Âl¾-Ý) ‘š…9¨}©¡p V=¡(Ä^´è5CÅ<5™£ÊðKÕðGcã p´6^ ÌoGi¤‚:r:rȈXÁÁ V³¤°ÚÄÂȽf›…á¡b9%Õ$fa¾jCä°ºù¢8ÔØ8„aµá!:Y1PTêmxÔÀ© «ŽÂZº RÍYCsàQÍ‚ú³¹Á dÊ°xx¬nHó($*Ì<ÞHÁ!d( ËX+3k1ŽŠ™µšÂàjõ/( W˜¹¥á™›GÅÌ= ÌÜyx ú>²ÛRDæW•ÔŒ…—LæÑV5ÆAlÑÀX:<4eã@à‚äÛ³)2 +/ ‹K@g8ðÐ,pH7„!JæÑÁ¡mx€£–áŽZ%“V†8Úؘ“Ø^IàèVs«j²šS*°Æ&E4YÍ ËQ3Õ†‡ÅÂœííͦgÞÍÃtw±X®gÓáÅ‹õÿ~¶øg6Ý[®^ÎWG¶ùÓñôhz<ÝÇ c0›žÎO×á…V@¬‡Èت(R´-”ñ©œ»ööÂt¦‡ËgË0=?ž­çñíÉêÃ/¹þîÜ™áï{"ÉcpIâHj½#Gµ€ˆÄê'9ÖB7Fr~ñâÎgËE”˜åj0ÂZƒâi˜žÿùWè=b+†Š‚,.Þ¼9þ"0sbý°JDƒº Ò˜«1ZºŠÓýå›åêðÝÉé<ÐÆçàd½ž¯¡l†¿¾_?<\Ÿ¬çV<˜MûËÅz¼è>ö=öÁ·'²`Ïsß̦éù“[Íëñ[kμ™ £b£OЃÕòôpŽt#’ûaz6¿Ç×+xpòz>Cè‹õ|±>·ö9x­PçË‹Õéü|ÓøƳ?æ/ÏNî-߇Q[4ÔP{A±NVð¶ã£o€c]œƒxœ(Ï8Q>yk\~E[ƒ·†l ÝuÇ;Z€¥Å ZŽã´i-&´UŒkùÖøƒÁôs²–#‘ЗIŸXcŸÊƒ¹OÌ» ¨FE¯ä‚î„6Ñv™JìéæäüöäÞîøÙË%?N’ˆ“è¿ klkα¡ÝÛrévh•;ÓÿPæÈØÛ€pfDÅÙt[@Ÿ¢Ñ]“"Žê@Üpn@PUÅrÁ²Å°ßÊÇ8úî‚ Û©ØÁTG‚Ñ>2åå yôj¹\ƒnËÁ¢l6¶Iªš@C‰ª†M“ù¶ÒPÌùó³Ìô¸ë,»ÜžNÚ%š8õ¡¥·h ·¦Ö£ UêûµÞ†F¢LíB÷ÅìE[šÝh%DâF£wr£¡!ººÑÔcï~t‰©¸Ñ…cw¾³ÆÔÜèÔ°Rýè¡­œèÜK4!ïD7ì|÷ªÊhNv‡»yt<Åú®;UvŸôÛWešyÏÛÝ…èÇ„ÜF^rœ¾[ÈÙMw‡ ±D»ƒJg(WÑH¸¼)nRo¾‹¼:{}±ú¬wJnðWÚå.åùõR]—çßWªzC©äÛJu-ê<>®/´øœÕ‹Æi'7nÆ›ç¦(äFãR&êFC³Iw£r¡¸ß÷R7š!ΚMÐ þ|—+»ÑÇuõ£q¤&7´‘-%MÝèV‡Ìu¢!zñ£!™Å6áÐÜht±”ÝhèçÄ~tŠ©ºÑè ^4ºq&7Â!+{Ñ&º¢ýèëC£óFûyÔ‰6áÐÜhÊn´6|úÑø¬n´”Èɶ«"‘MYÝh܃¹ûÑiüªçDçEÜhÓ Í‹¦Žjv£›Ýkýèµ/º–X“Kn%7ݧªî)áF§ØŠmwbq£Ñ}Zs£Ñ}zv£Ñ}:g7:Å^½èÒ)¦äF7\ËÉÆÕÙ~t¢µãÊïGç˜Ýz—¨˜¯^ùÿ<,p‘ endstream endobj 1352 0 obj << /Length 4107 /Filter /FlateDecode >> stream xÚ½[Ksã6¾ûWè²UrÕˆƒI0[s˜L2)§v;vv+;É–(›5éÔ:Ú_¿Ýè_¦4vœÝ“À&4ýøº‰ÅÍB,~8üûíÕÙË·a¸&Ð&R‹«íBª0P¡^D6 ¤–‹«Íâó2<_I!Äòõ¹ —wwE¾NÛ¼*ÏW*Ëõ¹´Ëê¦NwD¸(Û¬Þ¦ëìü׫a|µ°AE‡‹•Ò |cÄ¡Z¶·yƒ-¹l²5ýâ|ec»¼ÏˆºÉšu_g¾77vi^R‡uµ»«Ê¬lzSm']ÿ¬§už^<æn¿»kųï¯Î~;“À›XÈ…Ñ°ð(YDQˆD.Ö»³Ï¿ŠÅ^þ¸NìâÞuÝ-TýÄ¢X\žýe9\«Ñq`CÉ6Q´â»´rKKÛ´=ÜyaéÁ+-a -@úA²Ì>_~÷æ_¿¾ûéÝǡÜKkàs˜34°}ê‰Ü'—6"ä>ÔA¢5Í}yõé§73Ûª7« ^¿ˆP4™[¨š€¹ \Ô¨sþáÓg‹Ï+mÔò’6üôÒð7¤ž4”]ÐQ[™¶Ôk·o\K-Q#Òdžp ‚Ûw$웬>7b鉖UMä~°´æžuÖîë2Ûp‡jn 0\Èâb•¨@Çáxg®°¯Ò79Ýe` =¯«²­«¢ÈË"´¾g ‹GÍ$õd£:j‡ÒªïHªŽ­í¾tK‹¼Í³fØ0ð]ºþ’ÞøYjO­«s ³å\§ûGÍË»}ë–&Æ‹rÓ†–G†FZ×é¡™QW±•^ .Þ¼¿úÛ¼ª(i|¯´ÜÌŒ$Á;â>Ç’AØõ ˆ· f6K×·Ôêý‰Š¤ó'Híý >ù%n²6Í‹ÉrÁ§Ôj:!‡É²=—ËÛ9ƒ•IDòÿ'‚•ã´ÐíXi‹û+“Øé±Lx=H` ÀM*‹dXf^s»ÈѾð+ôÊH¹a%ÝÉJ~U~ݾñÓξñ!šÚ7³q >&Í×<ÊÄÍâÝvµç7y¹­ê]Ú9´5ü¢*ç´¸Ú·¨ß‘Ä‘T-­¦!R/èÁ³x…Ùx.þÀâã#‹¿8½¤xà™ð ]Ü€}Û›:RwùÍí¬¯«ºÎ’høq⤠b/ábï< ЋjÃ.‰·&è þc5 zQ|ŽþHÕ2tda’ZÛg„Q €A„4’„‘|ý˧‹÷o?#)­Ê ê ‰8 ÿnŒÔ Ã‡Ü 3­ˆ!’åíp¤ëŒ"‡²6PBw禨®Ø?T ´:lœ+Á–„dÜõ+x„n›z>µO: ´L!p¥ãä9û¤“@IÆÉdŸ~˜,åúŠ ®>Ÿ£a„(|ÈŽãwŠ#¹‚Œ¢É~¼Eà61ñA,µI¿œK±ÌˆìÂP×8¨ö@D5-îÿÀ>eE@Û}C; dô¯H¾«š&‡ýôpGh UХζ™ç£¤»Ø…òÙÖû5ø Ö8§²¼>Öت,´×ü ç55»ñé±gôWjn+î’¡|~OwwEö‚(÷¬Œ€“æÂìB¤Ì#"£4]ütë…!½ËjfpÀÙaú¯Ži–°àFa&’ÏÆΗ7Fè^¯Ž¬ÉØÀȤ*Ô’. Û*Šã@6}ÂÄœu’ó®²2«Á=øOm«ˆó) ë¶û¤ûè¢| ñ?©@ ¿×MÞðã[çKÖmU»]ºˆÛìŸSŽÿ=éSÖÀg˜úyÊÕ9è`Vïòrà»Ðæ¶Ìˆzûñ÷3k“xØaR!»N#¹¬Ê6'fù$±úC³~dÏKO#0„‘uK¿¨OÄK}3‚qSuT"r¸gÚ›VÇ_$Óφ¬‡NL'¶^Ý€ ƒš”ô›—M›–ë ŸÈí#Õ)!6ÂÊ’8^¾&"éö¿ÏÛ[¢uæ yW`‰î¼ï«‚Ï2¢· ·,7"Ù Îrí™Éj„1¸oø赞—6wàð« l’ÂT°&´'k½m@Ë¥ä6a£³à‹Îî¬íß6¶¨åÅ‚‰aI`‡ (¶6Ù5;Ý-MÑédz ‘\ès xb÷j;£œâ åÔkã… $’ñ3¢”IÆ4’‘ötùF‹ vT¾Ù#ä7Ò,Ó†~/Þ€, Â1DAÒýmî{íÒ5(e–S©{ó%"«´›ýu“ý¶w8Ÿq§®®hðå˜uÐÁ˜äéžÑÆË÷U›y•qÅ ‹9U1q Ë}¸½ÜË«X‡³´ Vƒ>Ý;¥:ð××Ü‹jU–¹ÆÆ>ˆ ·€:v„|5dTÆŽ…ÒÎ=ÐE²Œ)c D×¥ä¼O{è°þ›$æ”HÀ$#€…¥^ÝfMÖùÉq¶»’ « £í¾GýŽgÔÓ@Ⱦ:òáÝ»SÞ+E={1a 0g¤?(ð~æÏäëòç“lñÍ‹>AšðgþOøûøúÓãùãlIH¤ÞEVB²$¥½%a+ßz ¿"åÆ™e/šÜºÒÉrWmòíh`uÜ膩šng£Ø%B4YI­Ûìeãg&³tïf=o³Oe=€}¼ùXY=ÉzTo¹Ì¿Kyzнóå?Ξ¤dUò4ëæÊ1xR©YùPàí¾Æ¸§ƒ¹«—¿m'Ö!\ÑEq‘0‹H;怒@¨Ó&Z8äiÉ‘ ø0™L SÀÚCÇŸ/¾›‹qEìA( ¹¡ÑyÒdY§å"¹8!zýZ©(”ˆ'¹Ô$zTXK U¤_άa·/ñܺ<(åCŸùiCpoáÓ±±+ïWûÒB›9c‚é@òÚgw÷?‘vpd"Û²ãýÕ+šX BÂì†8rÐé¾À¦aOå´ÀîgÓ•ÈŽ6XóÞ&掦TÑzK{Ô©–K˜Û¬û4XGsg[Aç€Þý-ø¨¢8œG¡ w\§nºËýîÚG|æÔ׋É_¼Ÿ«†€0±Òkõ¨ª5 Ñ@"æ”éýOï¾ýþdx‚HÔWžµ9X5ÑGwçxªgbàÀŽc¡óèOõºˆ„['´Ëôðwàäø„a5zé¡â¿vîÈx–L­™úqA×9 áH¤ÓœV,û¼£µôb@Iƒ†ÄíY•4H8CA#ÉA)m.ñŒ±,ä9ã0't//°¾¨ [:öT²\gw¿e)´Œ'¾_:l.=Ô—vtŽ¬ ŸKLÁT«5Jv#”\q7Ímµ/64Ì5÷FŸŸyÚÁó1œÂ½¢ê,Ò¨‚Œ´²šÃ*[Š½„ (rÍÙX© Ò_O– þš©¨qHwG[å„'>\†É\^;9hÓY¬Æ£gÐC=Ž!–U¾aô—~8P»ÈÒ/®Biä2où=ƒ8ø¸hH+«ê:ˆ;ÓM'ilw ´Súñr{’g„¬Ôô¡”áËÀÎÇ8Æ°ø TĹ–âY§ ?ö– ªj¸•¸âëÍ~×#›‘—øíWmY‚7Òp ¶á³ªâp¤`¤S¶ ÙŒ’qµü'!_XVµoWÕvµ®êî¼LÑ4œSú¸c»R˧ãHªÎ%p¥|½ù˜—õ_I®‹(ås`l¸Ç•™Öâ Ã/B¨"ãe!Ac“Þ1 Ué‘çÂg—[y¼‹Ã6lPˆ ^Ö®0ÏCm³´?B(h£ñAÐ#$†™ì b"²Å+Rs“ðmÊØø:sÞ H´EØr‡c#àÜ Áå 5S}Äb9 Éñu®š{ *} Îιë¢<¤ÉÙÂüM¿g®Xnüiϸ!ª…»`¢q¥ëtï 畮Àéžîs*î'|œ`y?ïŠ*oé@k›ðÛmžÖ¾Ð©®Tjša./3îê½ã©ýœ¬xÍÜÓ8‰„À‹È ¤„†K¤Õ¿œ‘«ó7¸½x/bGqÛ}ÕPÂ@Øš‘‰:åÍ'¹ˆnÀ m´Í\ò}æ'g óé´oQgë€h&ᩈl;EnÂrn-ŸÕÃl_sÏ."í@¿ä< Á…cüq5´Üqµ1x½c‡Ù%)œÆýr8Æ 9ò;ÁÙxh3©÷™N9ÀБÑ×­àh.æùê2v$‰:Á%î®ô·z°@F'µã çÊè}Î=ïn/›‰üÊq=Žnƒý×·Àa?´¿“­mˆŸm]íF,J°¢ô¦reì°o\5_¤ôÓ€‚v÷ŸÄr]ƒ¿«s¾ Òq…rŽœeá…P¶¬î, ( €‰¯YPVl”õ3jõÁ}˜¶Xû¡Wˆ¾Ý¥mÿÎU§dts/ ¬é”òõüÙW¨TFçî“á Èg鯊®b—ÀúËsµ+JAºâÓÐ}ñôoM%ceg\_ãnìù8ÅY•t‘Múûˆ´uƒÓf§Fµ×§‡w‡Ü·½æõ`“…äÚΫq¬¡-áÇa 5ŸW“Nó„ýAPq˜¿ºVR>ËVýsP¾úpäÂTwM¥«›”“ë|í¯Xõ8Œï=ô%žôiøQ$'r‚õWª?œÖXCô“‚ÿk.VwmŽSüHHôƒom\YbïÞÝò7}ǽFï„„çödÍ]ž­,WØ趎¿ ­u bò7¢WßÁÛ¤CŸ 3VI½Ø¥šÜèæNÚ¥¦»nWL‹†e†F÷…|¢vÉXV¨'¨—™Ó.8à[×Ìö»Wä0¹d›&ScÕ»pÙFè2g¡gfCÅkxsr’bB/NM‘áu÷Üù‚4] ‡þÈ^øa_΃Σ톱ÂÅ<â¿;Y{lj(À=ÐÞèQÚ;> stream xÚ½[Ks䶾ëWÌ%U£ªCP3Dg†œðaYùõéF7øÒHšáºrP âÑúñu£¯îWñêÛ‹˜¿¼¹øë7F®Ò(³V¯nîVB'‘HÄʦ&J¬n¶«Oëï«Ö]^)%ÖíCÞbI®sjØä»5´Õå¯7ßÁtj4Í"«5¬åçùøÏ?^s¯ñ¢2‹Ò$tz,ÚìDÆ‘€?³ª‘ÚPùéÛ‹Ù"Š¢_仾äá´Çùm4ôýBÐ.ö]ÃÛºåj·q[·åÖ'jÍ©6-–«T¤…}™Zkƽ³HÑ“{äì,¥²Ðã)­ "«2\o©É÷'X]É,‰¤Ò«+œ™Œ†eÓæåÆEóÓÓs%œu #u”ÁÅú‘òµóÎ" ;bò®¾«ê}™”)ƒÂÝ¥ˆ×ù¦­êâ¿y[Tetye•^hé{׸ù²Û»º€‹ êï—Ò¬ó]Gý’uu7ë¿ÏÛºøƒÎÏfcÞ³q”Êþ>Þ;bÉáÆuu)Ìú÷‚¸æöÜ1^ è­©ôKlâƹ7XŽÕd‘I³é\w·Ûày\B‡xm"MÏo<6‚>çå– ž,%žv>ÌpWWûYŸ¼ÌwOMÑPíð7üI?µ¥L"e“3q`Ü/Ä°Ð$Díˆ-ÜŒìï3³‘‚u^¹Î4Šãþ6#’j/µ(ΟÕÞ .¦…@:ä4, d5à·x]µÔÔ¸ÿt$‡jpù[*m»º(ï©Ü†¹žñ:5ïó'žìR¬wÅýC»ã†mq‡+Þ!Kù üNæì À½ÄS&ª]ÛÕ¥cÖ@V}åúOd×O¾ósöÔ‘x™=a'^¡&²&yU$ãHê¾G ¿ÄÁ¶Èï+ØÙŽ·»­öE™—-߶”&ÊâpÛ’—A}©³uu -aÙ¡¤ÿQ4-ª Šªªé‰:XÔ±©¢ß¢US^™ø'ðƒz¦®zEužÍ„³°ªß凯¾¿ù;’–zîzEÇhÅ*ícÏ‹¿y{ïÂÁΕËȸÌõ›'†ÂêÈ&fª4ÞÓ‚¬Ížß.€ØÔ ¸HhñYÀH¤z™>–,¤£“bÑ#£±BÉçÛ^@-˜“È¥8 ¬×ߤÇ#Xdq¤ùò¨¹Ó&;^pE –5~ê©èÉ$ ¿w¥«óÖmY"R ä$S­âW°áRìQˆßÏ ú( ñ†dm`o]pM¤©9§Ÿæ©iÝžÊ+±'Ø[OxsÄz 0.j8ñ÷?s3ÌD§3X?…1Þ@½r­è2©ÐLɱ)ÒXÍŒ(° ˜¾$±RÐoêæÈ,&JሯF½Žn(† É·6¤^Û¿P˜+A Ïý·­«KÆj±²LL™Œx5³Oüº²,ð0vøÍCÕíxà-?äGpø½+7 ‹÷Ž»4…Gy£é’õ.÷ šX÷áÇŠ¾õkãx\Ê£í# í4»;ן6JŒY¤>½0à¡+»¾vpQj2ÙúP5Mq[슶ð ®MNf3[ßÀ’šÁ§ ù¦î>QqPGÀ êˆ*/cB#½fy]"±ë§¤TÝ„öƒÁ¥Šgœ”5œ†H^&È$À„ý þü¶Ÿ‹HI,7mÝ[Qs-GUº²åe»ýÁ+—‹¯o.þs >^‰•Ò@°+#1䑬6û‹O¿Æ«-|ŠT–®}×ýJFc·º¾øÇ‘8:PQij#»Õçï–Hxô¥¡J ‹tž QZ*1æBËMáÊ žÒ¼mó¢tçºcø«'êÃ÷ßüð­ßÍ›î˜50¨èɆ(‡×&b ƒ.`ejfñÊ8ê-çØ‹Gä C„VëÜ/YmOp¿²ôsܯ |s»Xó õ¬„5‰;þŽÓZ‘&Ö^QN·½$0­#ÛeøõÊ¿¦2Œÿ‚ØÛW)¢¢BàD£Ñ ¥Jÿ¬h´>Ç[»îÇpŒÐÁ˜iÄiÚCE¡<ëSXÁ,Œ€Òòþ昢ªqËÈ° ¦^H‡ŒP¡JŠ¾ÃÚ0Š bëŸug/ˆéø”ÐG"ÔrÙ( …œéŒ·^[ÒH¥¯¾¶ÀíÆóÇ–?%ð*5‰'+šß,àd™ëžš“±õlN†ÃȲåÁ#\ÿÜ@F€²EHE §'#Ü-Ç­RC8)3­o}¢ÖœªŒ0Ó™VFæždQ´Ngz±îÀmTÁEzuÊ)`¸3½u8W ᑱ³Xý"Ž±ÃUœÇ1è6Ä °þ¦ëªÞú04ùÇTø½«£´î„k(ŒhüSÅÁ5hÃ#¢‡W¨êjãJ!‰Szi÷k<¸’J·¼FÓV‡ƒÛö9Q:wK<&ÎRÿ⬲„ã¢;G­žjhݺkCÛÐÿÞ9çóS 1§Ÿ±ÆÚR Ô¡kh;ð‡0ЪGtœ‘Qšðz¬­ú, 1qºLB®Ð²&F­¯OÈQâµÜ˜ÔbˆÍ>{k}â_ì±Ãž‚ŠPÚº6/vÍ;ŠÁ<Á!¯ÛbÃ1.¨?pTÈW¼š‡ÙšƒÛwOÔøøà”ý÷¶_…A¸î;x 3þ:½ù#OË!Zz²Á¬'ü˜­Qoó"ßá¹jl,³`,Ó>ûÛØ\÷’¹Ìzs™1`Ÿà*l}¢_ž+˜Ëìöñi>=îe]ÛÏ0—™Ë4‚å úÅsìÎJª±½Tqx"“rúî%ψÕ]Ï?¾ÿétY~wÞR:’ÃØë}|u¡tüÄ{~æÊC¿©¯~øøêbR—×/Ö?J²Ýø‹Qô¼%§NÁüB …ùEp|:û ,wåçr¥BNƒÍ{À>ª‚'"(=ŒµÜ:ÿì¦Ôú±.Ú–*0„×¼†ÂV<*ÅI% m“ðÞ›Sþ'¿Ÿ‰’Wú¸’‡vRòP`%û”¼òƒPô³@òDó£çÉz}”‰ˆ:üYvå ØÑÏ«J ¥{+=s}&¦ýó¼n|I{•E¤7 Òq§(|A‡Ôýqpu\—ïðÀ$²îö78y¬°“¿þåßÃ1pÏàͧ h w]ÛÕ—pæîXÚžI•$³÷ ÕtP÷¤=W漆øm×'ÒtȈèÚ«êîjC !ÇI'Tn%³iªM1ä±=ÇÆ”àgBÛŒP&T>þø!è=ܤVFÀ¥a6èåd†_ü°÷ËùX›áE+[×÷¥ãñ#û5î<Ù¡ùG{­óBfÁ™1¹1» OWò¼§«ß«RNTV)¥ÓC½†Ú6uÞ=¢‡_<„™±\ƒÜë_'Ò˜;óýaçÞÑ•ƒvÒñ<%К†“õw‹O2O,PÂ[¦W׸é ÎÉKO–æGí¹aC•”eA[ÌäšF›~aòõÀUamWnªa֨ߑÛîÊÙJ9ù*€º™V,ò?u@é±ðN”v.ßòWdûðfì\Ù´œ#a'Û«¡GO,:°ˆÙÊgkbþÇÎq…\2Ãnÿs0ÛÕ+ÞÌÀ©‹œ™QÎÕ™ž,èe¸ Ò‡ø˾¬¦†ÿ%_Vë¸ Md±ÄÏïX)#_|&‡qÙ÷sÚÍs³µœà<}ÖxÚÚ>˼€áB}²ºeï ùá°+6á_22“¬?ôØ¿,Á9ü¾¡eïÀ?ñè°ñ?´àlùcÉ…²¢N(dGX×¾+™6¶y°Ïüÿ$Á°†„{2À!+™*ês'1&$íÄÂJÅ–Ñ@ŒHb®N¯¯ÑÛ IÀ]ø¿Öžw†¹R(êyêêüIŠ;]‰$Š…x;7ä÷QúGÂIj åš9ÎÎd ¥œ“F{º“Q>UÏv ”ŠìéR‘Fvˆ˜Ýºö‘°)æzóTQÅg¶4=EÓTÊTÉû„Ùt}})Ö˜¹>Ù] M6Ïbý/y á6ª’–²Ì1¥§¦Š×rðõÞç8Y9ýß?Ž{N9xôÃh2¹.É¢ðà¦u´õVÛõû†ºÒÿ`W¦xõc³`&Ïà÷‹ãØâ#IÍyw¿õøùŠFËÞ0\øƒ‡"C˜)2îq.§ û¯£ðëoΧ¡PݧšÑ¿k4m]Ü"íFb~47œ¤þa)z¾¯A4èB“°ð6JûY›f |}sñ?f?µ endstream endobj 1420 0 obj << /Length 3712 /Filter /FlateDecode >> stream xÚÍZKsÜ6¾ëWLí^8U‚_Nåผ¬R+Ûk+©Ú²s f( +rBrì(¿~»ÑMð!ÊÒØ—=ÁÐϯ”«Û•\ý|&ùùãÕÙw?…á*i¤£ÕÕÍJéPèЬ¢$ʨÕÕvõ!€¦ÐB­¿ú¦›Ñt )7í—7?ò” ÅX¤Æôs~H×ç* ƒëüf­Ã nÖ* rkëòØu…½(ø\t;ßm××k-ƒc—oi°)nwÝù.«¸ßÛ¼}ÎëëUëG××:*Vý²²ÛÕÇ[&Ýíxíc›7´nÑÒÈM“ó»®F²«shaè¹’" S¢whêµ ƒO°üú\G2Øíw;$†ù¹ÂŽ‚s¬U0:Š;*¾¨oh¶Û 6Ƈþ;Ü3lÜ MÎïnóŽú‡¼¹©›}Vmúäßµ=ÁM},·´Ø5U—7y‹ ÅÓÉé± ÜšQH¾+ª[ìÈ© `÷-Í!Ia«=ä›â£”zCs`[]‘óLzÝäÔÞdeé)ÓÉ‘B]~B~r÷°ËÚ\¬Ï4ÁGÊŸð]ÝÐË;eûC™3•züâPÖEGH~áóóÀäØ4bÍ{‚›µ’A¶éܺÐßgðÕÆ)fyÀô²Ø»å`h›uµšü‰k¼û×{8ŸÔ{AdÏ«½ñ šm¤i¬{;üõòíû%H…±¶Ÿå„“ÀHV!ÂUƒÎ ï¼ûùl¶ŒJ„I’™‘{2[LEBÙ‘±;Ã1Q(;3œM†¼Ð)¤Žƒm]å4âX ÏúºË žÕ7;šWTNÏ;0&â'Œe739˜˜ùù ¢öæXRbñwÖùQ©Nc‡­Ð©þ*~h>oÕÒN‰ EhÓžìÅëŸÞüŒQ¨B³ÝDñô;yQ~”:$}‰ÂѤTÄ:îçÈ…:7±qMåé8jB6¾¢cu62 Þô¯ª®¹[Gaðì´ãF±ˆ¬3`+îûWWgž¡c—+µÒÊÂ^¢Ud€ĤÍþìÃïrµ…—`÷¤Éê³›º_i!ïÊÕû³ÿpœXÑrHÉ%·hYo¾(梦1íŽÝ­ I» ¨e $2¾p˜¸yæÔF.ß^Ð8MÔ\t÷&!Oa0¾ýÝSêh¤Ì³¶;Qw¥q¢ÆŠƒz£Í‚âLÎgÆ+Žk\±W=7aÑLõb˱ĭZvwÖ‚»ƒèzš¦G"IÌͤc¨‹³…å÷Ù ee[ÓDmˆ2¹ ´Ðub ä—aàð¬<:oO'9ÍyZ€?‰÷/__ýÛ±\>ÆòPŠH°¥Úž¸0â·{˦ àŸö«öìð†ë$Ÿ—ÅIôcÐ;ƒ&'J©ð9ÂJ[~S=rªÕ7ïýñºÍ7E<œ0“ƒÀÂÏèåç]ጠš›6}sÞ‰5”÷!%¢_á]A4á€èã>¦¡É•z|l+J)ƒßà3äMë÷Z÷לÆ{1ìyÁƒqžƒÿ‘Š¡÷o¯Þ½¿xóú¾¿H+"mVa¿KNôwãUUl…QDÉ–áë_/|õnÁù;O!$”ÈÉêÖ)z'm‚ÇBdŠ×w à%²À?óv,ì¸ :1â™×ø†yíÚdª³eS›´§-Ëàif´.¹·•Ñ–8IH…Õsƒ(º"+඀Ȗš§cØ­¾’+ Ìn³i,q<‚-¦ÄV6xI̎Єà“xž?Álá»÷Þf¡“ÎÌÕ ÞÐJa°§Ä†nó*o²’:#_‚ûF ×Úa<…þ|ÓÔÔô’œZ‰•``K`!Ó͉V2Ñ{™ -‰’J뤭¶ôäàgÚæ˜ Uœaj‘Úä~¢e$gØ(ªMyÜr¿/óvA‘‚)åQè‡v»ùû÷ýqh QJŽ%„L8‚Xô Ð(Œø% ”È‹Ý‚ Mcñ÷p˜ á±6u…Ⱦ¥^Fò#”ë1ç¸?âÎÔâa€->t±ÉFQpµNdpw(ÐFlžø¨èH Ê‚*„}Èbî|V"GsÝë»ç ¬vÆ¡?Ú?·ùM™K~ÿ5lüJV!p%Öá7IÀ ÇŽR¨£™âþ ˜ò‘$€(Ò1ˆ‹aúÕ®?»CGîÔÈë8E«wéŽ9;Å»l~ÞÕÜ(Úµ|©¬%Ò37èJH˜¤'3iÂï¿¡µm½)2ãdçj‡¯Ó`—g[šœ°¡ €îõОã‘I¹¾ŸUðÇÙáP‚¾t~èäü2›z€Ô´ê–JÇgp›Z‘Èø<‚ôÇ¢ÉdŸ]þèÐ5< Ý€™%7ݱáÄš`/4úLû:Û–w4Õ…&`F'‡ƒÜMÛP„­¼f£®K^ ¾»­öÈšx ºS«…ŒÓY–ØôkS7 „êNÜŠcÄÖ ›& ÛDZÀY:€3Ëàì%øW5«Ëé2‡ "N™—E»ŸÆä9ªÖ ×ÒÖ—o./Ÿ‘Ù½}ñna/àk¬%Ü3ðý(ËN‘ ®µU´Pá!zEvÞæ 2•&Áþ¹¢k]çôtðL¥)Â37ÀµÐÄ×B“€j±(å’œ›ÖMËßrAoòýî¸ î`ó+J.‰±RãhŠgEª|µà‡%GaØ#¢ZGj`'Z˜Ù€¯NfêKlÔfªšTO‚Í.«n AÇ™¸ØÞg5E† á´Ûe™ˆ8ѳƒ|éïˆé-®î<ýÖá!èïm¡ùGᬠ“ñ¶c»ŒåÄ)ûº©{Ïé™­Å°Wµ€—À`ÊátÀ¿Ùöèù€±ëyÙ®{D1Ù ¾£ë·A'¦?1Šp¸Î_LnŽ²°æH’L“FÃŒ¨sj°ª$)û®öáÀ8¹!¢üûÞøû{—›‰¯öáë¯InÀ\Ó*±N¿)¹1Q#¯³ ¨gŸßàÀr~ +Ÿr‹­†ªI\«G|Ø&oŒ õN±3œaW=¤ŽF•1]Îp":>¹ ‡/:^oËqÕ>¿1ÿû ÿ?ó´ oÌm@ÇÒIqÈ]æÑ‹¥BŽÚzç±J˜Ÿãߢâ¾y|ƒ Øiñ Þý›ç?yuuö?c™†V endstream endobj 1325 0 obj << /Type /ObjStm /N 100 /First 984 /Length 2625 /Filter /FlateDecode >> stream xÚÅZÛn7}×Wð1yáÅb‘Œ¾DŽñ–w±^ÅŠ3Xkhi xÿ~Ïá ¥È–Gl«ó"±{ª‹ÅbÝN‘1…â‚‹)T§Æÿ͵ˆÿ‘/ù"â©ö7âD2ÉIáÏQ]ŠýMvÉúsòÅiîoÀ·u>Íe $¸\+ÑYRÄY%±$W„Ä¢®‹ª«`AvÕ8gÈ@"R&Š&ÅEµþ!h-ôwÍÅ’(]ëjyOܧLXLÒ¥Äeõ‘:IM0>“Ü9Cb¥OTœÔп­Nšö_›ƒâ(¹‡eð~ÀW…#q–KÖý€#¨¬j J­kO©4%g…Öbå('§ÔT,Ð_2î8Ul–‚~ATÙf…º•Ì tÍ-EÒjé{ Õe‘>=6!e*²VŠ™ñÎÅÄæ¹8anË6ìMè\,9‹•s˜bã"7Z5í» í[.ýÛâ̺TV±¯Ü›dÍYëJá”ØÕâ"]Øé­pÈ}Þ °DE• [0n8ö¡Ôn ®!rè§FåŠJs˜ŒßbG*Ì£èjî6õUë\jrµt.Ðtm0–Õ‚’´Û¨tŒŠk©ÏkmÚç¨ðŽÜ%mÁµÒç«VûM\k}Ž†?a·Lš[å, äºÀrbBÚ-<.£1ƒ'FÖ_ò÷O‹JBmœžô1fê›ÏQºcR× ü bV;zðàhõÄÂo îýÚ­þùö_`<­ ÎäéÓçŸ>~|wôÃwP§âe2±4çJ=Ìc"qL>M¥ Ù§©Ä±7ŸH\›‡#O%ŽÎ1‘¸$žHlÙk™,G.>‡ÉÔÚ|ž¾F>Ûdê”|n“©%{“ÉÔ±xË“©CóVï¤.Ñ7„§š}APø#±[=Þ|Ü\œü~ö~íÒî“WgÛíúâÜÉîñÇÏÛ§'Û³íÚÅþâhu¼9ߺÜê8gäÅ=Ý1â äv¸üôë°Æäc˜Ó;ͳjhB°0@ŠÉuôRìÌ­Âüc}q I^üýù£gܶ^QàQ&|C¡|HêåZ5 óiFÝÀD=€¸Xg‹Î) žò 9˜Y EÌA9^¿| 9æS ᛂ 0k Bb"öBd—Aa‚|1HÀ+<¦^L€ŒÂ{ ° @Ü ¼9€´–P¶\yÛa7$xÞoXjþQc±7Ђ86ÆyÿEEß"‰‚. æC¢Ðà…ðJŠ—´@@,#]Ï_Sï÷.6¿šôÌ8ÐJ È *€e >Fe\’…°Üp…¶„*SÓµ{KK À6næ}-üG¦/òШ״„ ò”^‘£U=pÖS¸½–%‚OÃ…Ž2‘=ÿÀÓ1 q ¨És/`[Ô¬0¿ñ|”§RxÎi¹0˜P·æým™R ¬š.ÛÑG>@òC6n¹×ŒØ’p*/Q¼fTË̆¨—Œ!ÁšyÅÕtºÿóQ)pýZ¯¨¨¦åàü³£€ç]MŸ‹™Í?ïyâQò܇À&”%rueQÀ+OŒ—= ¤~‹—×8ÉŠ@ýèŒ÷WxfÉ®)ï™E›”©ØÀ×P¦PÜ ¼¾º·Ã svú§5÷oü¡Ó¿:Fp´"__PûÓg¾>ˆuÚkˆ/ÏÚhv·Ñìnûf7/Èîq d Òèì›ÝqÄqÇA¯ˆm f½\¦Å:JWC|0³Ž§yve¹Ñ/–ˆ’å !UDG^²ä 8ZÃ¥+á¯×íP”Ž¼yH€}'!Îcïd˜ðZJ»ê¬X*@7·÷›ž½þéäãæýâ$ëÏC endstream endobj 1448 0 obj << /Length 3643 /Filter /FlateDecode >> stream xÚ­ZësÛ6ÿž¿B©‹@$Ûé͸iÓK/qsŽï:×ÇJ¢mN(R%©¤î_»Ø_¢ìØñðÆb±ß.!7 ±øñ…˜üwõâ«W¡ZÄ~bŒ^\]/d(}#ÔÂÄ¡/¹¸Ú.~óär¥Bá}½üãê§nîW¯L2œ¨}™$ÐcgœãÐéÒÒWq7"o–«À/mšÃ.ÛR¥­ð?òÖÕ›»Ý.kë|CÕ}Õäm¾T¡÷q)Cm³ß…PeÞºI/v›¶´Üžç(áU­Û·æámúa)…—•T½®«›ï6ÈÓ›ªL <ÓbÅÇXIá'aB‡ù”··ÕwÓWÂy€do«£Íóò[µ·=Ô\x#(\#!馭êüï´Í«Ò_®Â8ñ~YjáÁ4µ½µ¼ƒñÕ•eU®f„{1ƒ–Òá!Ęü]Š<κfâ–¶ý—7ÔÙŸ‡‡•ãƒaë&-© O_ó„¶ÎÒ¯+9Ûdu›v•´qTü.BÑd™Ûw—ÖÜjE…‚Ò‰$œŠ¤p%•Ÿ(>zé¾ÒñPzqÑ›¬Ìj¼i¬ôÒjEÅ~Å–¦8‰iÞÏp×5þˆ‡H‹ƒ;pZϱ)å^áw78ÚE…B¯”v—KZi¦nj¯®©ùýÿÞRC"[l©q̓òmV¶$»Ø\•ÔœÜ°¯+“¦ª›o !¼üÚíjYCè?d¡±¤ñâx»gXLú¶‘vÃùìv…A:ñýÙàÿÐXfAi}Gÿ´:öéæCz“ Y¯P'Ü"ݘMµÛvýE ¤:uCª5;¤ªÀÊo嘘͡®……£„ïræPîfqÅþ²Œ…—P¾ÛUÍ)¶'IÁÔp]±Œý3«w`œJŽõÜ)_U³"ƒ;¢ È iA0ÐK?B§oÿóöÝûeQD¾S'ŸG„ƒ« ¾„I+‰cÙÑ\²žë$c¨è¶°2pXí¢“Äš {E˜ên,üXwTÿr›•l €ø…‹­‚«\¢y;´ªÌóQƒÆ¶d¼›ñ¥vcQ>â¼áÿr êeÕ«(±x+aØÂ\£µÉ ÜpIÇ+ G«n‹7ß¿¡A‘X„~EÆ’ G†RàÇ‚îj†3à9_šÀZ©È°•:òC ‰´|ι\íÉ×PŸ°žÛ_ÞVEÖ|@‰¼£–‹}ºÍ7·Td¯ÒÐJÇ> Çt>ØÖƯ©º¦+Í°n¢ƒ'`J ½;·ÏjÐ* T°š—mV9¨çX_ó?Ýc œåkÔQ×ÈóØÀ®zäBíâ¼g°bs붬¬B\ƒ¥ˆÃØ»?’En«ÄŸ ý£s6YËZï^HUh¨JÆBEÞ¦,–q+y 34X«¬“‚Á½ãSi•Tš¹<5FhÃEѼ˜¹)[¦/r½€Vj@t5gAKkµo–`’'{†áDDоÂJÿ$äõƒ²©0ê !p¬öü1R¿ÏÊ-÷‰epˆ ‡† –cÞ÷›ôÍù»e¢@Ì`“—ÿ¢þ"_×i}GcÊy”5 Tà'„¾~yqõבU„{,“Ž}-»‰n4HùA2‘‹Å…é/Já+ôÄ´Ô¸¡áÆuQm>P+Z lê&Ìç|ÍØÌ%‰éèPõñ­69W»k5!·®*&·¬¶Ü†×6”ù./‰8Âq°‹6á„;uæ`ÅÛªCÄu¶É› Œ‚ A¨FÐT~”L»»ßGý¶ ADrKI¨ÁDˆ°ÇFÂ3é-5XmÆŸ'ìî(ìï(ìïˆDp›ÑÅ JZ”‚’YqöHi Hš|ªˆvÈá[ã1À‘ÖG–ýÙHp…˜‚ŬÉÊ…h‚´þOÛ -ŽâCl³ŽN ‡ý²¢¯Ùu͹8œA°•Ð© 3fKs–AsÈsX×Iæe6ƒ¾&öïeäW/þ|¬ á{à ˆN5à4°/‹ÍîÅoˆÅ:Á|Z%ÿd‡îÊ7ÈçbñþÅ¿9Œ¡E´’€•hÇŸ¯._=ˆ÷؇xä‚c£:Í°th4«k‡S­$,ʃ6VA±´Ò‚ñjŸf¥Ã«`¥ËiDùúâÕÏ?ZiCB¾™Dˆ:ðŠÆQÙ}z¨Ìü}&È8„n¤‹D ]åãTF °vágZucNZõÌ\O¯ ÐÛ™€! µô…AŸuæà ¡vlœ_èÇK¶'8’í ÙžPk›m\̳’aäC`wìZl`£Nøo+nhv`mXå•Rç´þÊðX¡Âi91‘¶¡ä æôWj'½0ÀA&nYäV;^¡ÇN2dov„Vfó3 °ÛA}€¹¢€rVsÇ=bu&q$Šƒ­TÂe†V!‡õJ+/óo|.B+;í£ïIQjbbh&îÊ:¡8uØ ׇ‚ês8 " …ÿ)þYÒÀýuÀÈ8`o9Xø·Ø8Œ£GÄqA2 äpWëy#ž—,£‘¸”OÁ1^w*NDFÇ¥´ô%„gÇü´‡Sè;ïó­õì‘$Lê&F¡o&ïƒz¹¤b`û×%uTõ³P8Ób$hb4œ_ßQÝÑ,é.Ô€8ÉódË`ÈØTe“7Ö?AÍ¢øw¡ù£ˆ3‰ʧå£TÏ“>†ê(y€Oä¼Á<{+CäVgÅQ8ŽÝ E·U±d(Dèq—…~,”;\wG]QøÝÁ0‰œpýˆç*`K¹u³ikˆ/­É¹fìh”ͼ!ð#  ft¦]B_ùÀz)ŒlJ-#(Ë œÁm¨‘/äЛª FîÁ„†*Vø—¤0ŸÇOQXtFË{``îfnAë|¼?0êÁõJË(ñŠÉ ëÏKÕ¼ˆt[W n©¾¾{d&Ž˜òHÉÂu,÷Ù%tñhÚ̧òu0±˜½ŽÇ³àgNò›=@ßìS&`6ÿÍ+`úÛ¨øÔù§Û~tºÌÜo& ¸ˆ—“R9–²£ÏÀ°K<¤MI ÍŒSóïÐoÌ…~ÌdàHúšR"é¦ |ñ‹ÝÝ„ÂÛªi'_U<Ê}ÍHË´¸k\¸w´|ÎI:Šöº°9†ýš†|‹6~Ò:O¡Ö|•Ö5^\z×PXip$«îÓ£˜fj]DWR Ú»À´,K¿ÒBx«öc”]Û55Hon>¼«·Ôå¼_^äíD!öú’VVÞO//Î8Äb F²Œg BÚp¡Àp&zdv`ìSb?V´’„•ìžbª:ê &aŽ̨…Ñ3¡döã׎„ {¡kŽ½:ÖÈÞcjƒPµÁ3`0l‚#zyw¸Ò™Ý|o Ÿc÷$¼ªOí~~¼7(?dþ~ÙÞQIsjï‹Þ j»ZF)^·¼»ºd1W‘ö…ž¤ayÔ— ÖÞùåÙĪ̜I Жî@ _‹øK„O$~ÑJJÄ#‚>Ë8²0a˜Š'ûu—Þ[&Ñûί'y®¨Ÿ>1÷‚S]˜¾Ø­­#”dgatŠâÕ ÄòÁ¦•aìš{Ù×P‘þ[7€ÆaCŸT°ŠúW•Yiƒ2¨£QÃ¥¬¹ÄgAl篤¡(ÝûŽ¡Û¶61Іl"”8ǃMçT·uíÞôèA"AsHm ðpþ·å‚æHf8‹v}^LÌÅiïë[Ï‚A_NîÁ‚š>{ã@ËGÝç &1Ò€«qŒ¸ªÔYWí³¾@E‰Í×È81¾Db8KH+iXi`…eÒû$h†ü˜Æòè€XÒW‘<¢ÃÙwpšóöôíû3P`Bkߧô.{ξ'¾ˆÕ3ì®…ô£HÚ}ξǤz–½ñ±“T'dµŽË¤Ó>ÛÉß­q6ÔIø(Dqxò³uÏ>¯èÖI÷ÔœîÝû˜,¾ç)$ÛÐ¬È Vl)=ô64“N±´vè\ÙPl]s¯ÃëÐi˜Ä†¶cûPÛ±ŽÚŽÃ&¾»¦¾tΊ>Á“â«×øÍ)ÖæK,HO(h%££±'}®+N^ùbe_5©±·!aî'ñ1ÝÁá"œN—ÓÇÚÉé͈îp²ÏPºœÁðaæðU%?ªDÎ L°åëÞÓgêÇÝP`l¨ÂÔ¬V±÷Ý ¸áñcÉñÀAj J‚OQTbyÑûf3š6úÿ¨Ýè endstream endobj 1463 0 obj << /Length 2838 /Filter /FlateDecode >> stream xÚÕZYܸ~Ÿ_¡<Ðn…·Hàx7 »cÇž}±×ênGXµÔ‘Զǿ>UûùòìßgèID#&t"˜Šóh³;ûð‘D[èz‘„}±„»ˆ%Ê@¡ŒÞýËË<‚IšÐ™Èe½ñ"4¹+(±Z–i\T]~Neü)oZ×û‘äX꡹扤úÇ¥æZ%Œè»Äæì6±ÿ<§$Î÷«]Õ ­7 ái´¢$1Ò8Þëlóç¤ÏX“$ÞÔ»}Öë¢,º×d׎…/EYºÒ:wßzÝÖeÞùZQ¹ïÕ¡;4¾­ÉËc–ÞŠ„©«òÆ yÎHüùœA©(³u™»fT·¥Üe]SlòÖ¯ü¨¶Íw@¼uD@ taÕÛ'XÒqw}h}1«ÜæQÊ­©ß<íÌ›Æζ¸3MV´¹ß·«@{±Ë«.ó´#¥ƒ{¯,‰kFOîÚÏ·qÚdÕT˜¢Ú:§A¤‚ñ°íÅ· fíGu×~ØuÝvƒlc4QÃfö £w¢-5= H¯ “#º3* p¬‰:9ÑœšhšþÛüBXTׯ½Ýø“}3ÛÅžf[U±F$º"¨¯¾š‘´o÷éë Óa7zîcˆö#z¹‹™¯€1‰6À¢ýNÞ\ƒXÐl‘¡bä)8Z¢ ਇîúæ$&¶‡¦¨>ͺG¶j{œøžr;YVT$Fˆ`šÀ€Öm[¸ã ?gå!_rz2Mˆ¢ÃRÆSF+ áSÞÄ1œQ~XI©îܹâœÆí÷¢6Ïï8G ¿;¬Û|3 J& ~t&n| ŒÞRx÷Eï\(7ñ¡Í~¶¬©ôŸ‹­³Æ {$ïY„Çù¸¿W4Z±fðj€¦,|=TžøíœX)! é­Ço¿ÿöæÝ€Á¥Šþ(79Wµž»›v—í÷ˆRç‚S’°TM]°‹,(w¢bÁ)Kíu}(‡îÊ•F*š À2£@beb)rÏNZÝlí²\ê#nNv[©«Þ Œ„ÇI ­gÀ«»œBpW6ÌØtuS|Ë\Ù#úhød÷À'CjMÔÈŸ±»P*z”biŠRPˆ…J±Š(ô‡=¥“N‡R,eáÛ£t%´rh™ ™o-îR¿ÂÑVõóªtÀ†PÊ †ØЖ>¸æ®Ö‹V¹nZOÛ9Ò£MMÎWF‘øy…ƒoñ±›Â¡EÛO[cõa‰ Ö׃» d=2$ø-ðG” ú˜½(Ö¦¸ÀwšˆY:‚ÁdÁÞr&bˆ»»¼©¹3 Pð{åi¼GÀŽuÝ];.Öw»AÁû§Ðpâ4þW H üàkP<\4m¬óå!‡èš<낃Ë|/¹—_'ÓÙ~ʯ²CÙœùR€¦9öåVÇdPÐ ¯|?W|}ž H¼ñßæå ˆ}ÖØÔiùWƒÛ¹— Ç‘GqÉ=chØДEÐòäN-%•WñùRî `™/Ñl¹º ,YË*6öK ¦Å5ÂI­w;gB‘Á±Ûº ómhà…Ž92’ÆÏw5z@ì‚mÜ -ž½¨““5š„Kê'qeŽ¹.6×®ÅUøBŠ\X‹eë‡á{ÀÐu¥¨ˆ_xÐéÀQ²œ!€æi^-³¼Þ9•õ Çþ]‡ìdë¾þ*ÀCz_†\/øÿö°‡1­?¥E7½ÈNÞ )–(05Då¾"! h+SˆDAPBâ“S§Ø$jB¡²ÈÌ)Mäi Ï?Á‡kâçuÖvHê$â–,tÎ{–|.(Å$ÒôÇÉ)›ÜÙ%i:Ì[9%R”àu!À{À,Íbú›45_³Ý>dB!Ë ‡ª½Ù)‚ˆÏ5ð¯ü–„2\[  ³¾ÃÇŒuõ-oêÿýT ¨.©üj•¯–+pq)¬ÀÖH'úsO8V/,M*Õ«×QБr)O”–d¯)OƒŠ…ß9bÅ­šíOKæȸËiÒÔ2‰Ö,ZJçGé·4I,ÀJònŒâËÈîÉŒ/0[Ið©yˆl>ïçK+.£Ù=™ñ…ÝbIª2e¼dY8 `FT¢¥°N•zÂ×Í6G7&=Fakã <2—>ó¸^ʃ.¦¸­Nð£œsw%8Ê%Ë›5Mv3¯q'6̱ nLÅ/ß^,¡ÌfªzWúSqÈ!ž.!>d²h\uø¼_`Íx"ÓÞ~\¶@’ÊᨹÅcžÅÀ™rûÕ¾®í-~¹S@0™yÖ•lêr® Š}õâÿDÜ«ƒ>Ž:Æ´P<ÿ_Wâí"´—î~¶aÑnQ“¤ «‡úˆÌ–Íów2£)Y°§SKÉ $‹“E  Ö-¼ðt×Y7³mþM¡½Ë”Þñ.ЈáæÀr³6Zʸƒ`ø0æźtW z͸& wëÊÉ…uk!ðÃEšßÞýôâýÇþ®oöÆGñ| ¥Q±>òñI~ƒ|Ž — ï.ßþþb)‚ДõqÜu]nÝzº°öá:I[ÚÅcbÁÓQæî!!¬NÓtêpÜ[ÔÓÅÄàcìë^êûXawØíÛc=Q‰Å:¢_áÔ<†Ril„…œ€«›’Þ¿.„ÍŠCØ|± H“ˆt5“Ñé{çãþ=³»µ‡@W¼šõyÕ/„£ fãýlÏÄÑ !}Šw;R±çØ ©Éß—,*Dgª_:”Q*¿ì¼Œ‡¶sb¯½Ômî»ðie²©M6Ù„–¾ËÞK:ìˆÉ,KX瀞٠LâîM^vÓX¾ª}CVvy3zæY8žL%RÐ;/á•}qòTË·BèB|ó£Kˆ»0 _!ùc`81)‚á‹÷Ë/f’ÝcbóJÿnm¼Öux#1öR~mÃ^í.Pl› ^]¥¿FŠuî^ØŒ7Õø*mÌ Ûª m•LoÃ*¸*%ÆPÌ8„À ªnZׂPu 3FÒèÐI˜ðˆdÒðˆdÜ•6¶ø.^ ©‡ªQc¨ ·ç]e›ù!'PÂaoS8 *FþÈŸ>rˈùˆ,!\¥ìVC‡k²À@”míK hÂáÿ#„ö÷žÛ×4¨kÁÇ  “˜Ð>Ä0’HÃÃ0Æ°Ï}r7å§Í{ãè.æÔI°â¿Бüø:˜`ÀA~Ç:ú¬lºP S'ëÖ´¯±ÉWlÚcÿ“²x[@ìÙºèÃä!•M]uYá{üÍW:J¢•î_H Ö‹N""H.»*üÇæ—þo9MÞîñåc¸–*-ØŸ¸G_ÿ' ^ŸåèiZ ‹þ‘HÄú€ÿ5äl zg?ÒºkìZßÌxzs‡‘IåHú.oî,kî®,f~z$Çøéå!gv’ê9¢–tt»y*þ%Cà;„O§ÒÉ€øcgæ endstream endobj 1499 0 obj << /Length 4280 /Filter /FlateDecode >> stream xÚ½ÙŽãÆñ}¿B/4ÀN»o²“lq`#ž8Þ1‚øx $j†¶$Ê:¼»þúTuu“MŠÒ5ƒ@¤ú¬®®»Š|ò0ᓼâgžŸÝ¿úäK#'9sÖêÉýr"gRé‰Í JLëãz»¿ùùþëW¿õÛ+sùDL„ɘÈr?V©É|ýêÇŸùd}_O8S.Ÿ¼ó#×ɬƒ—Õäí«mjËmÞÝt[ìþ„{ÂX“Ž…W‹ùAŸ†éj93<‹~↬"™Ëm³»ù´,VŸÌëõvU¾XÓÒ0a[W›C¹»¹•2›»]ñáÆšékø¯ÄtQ­Ë;ª7Ô}w÷À èÏú¸?à›ÎJjÙ—z™} çá1ô÷´ƒVa©ýqþö¤Ç»Á§E3±8 ä“[§™Ì³É­àÌ…ˆø5@¢Ô´ÚÓ“¶ƒ—ßo¤™«£ÿ+§õ²×_n»a»ç¼£?_}w×ÙBN‹Í‚ºæõê¸s¾þü®ÉÉNëâ°«Þ³›[Åõô«Ch$ÌÁÛ,@H˜ó ËzWú£óî¡iI˧K¨ù¡ÞUºhÞ>û0"Ò °g@àÌLvÈ#ñÏwÿ@¢U)™Yf2Iâë}¦gõ)Ü2¡ãØ72œö­wô ‡ðïŦX}Øû2îÈ4ãNŒ€L5üôF´ UË=6Çu¹«æÅ*ànWnwõ¼ÜïoPÄC8ζÅnµ'r”¸M›îÕìÊߎåþP"‰8°©MÙT9àÓ›l2 aÐðú_Ç¡ dWqîWŸßÝÿ¡°]„u¶Ô†ÙLwöìA çÔYU6 N4³]‘–*ÃÈé¸*Â03ô†0ã„0S40ã;^Fµ™¯Ž /ë’Pã5Èl"\\"xŽ˜·[eHY%€!Z 0à%Q/!d Ý ›šq]Àp‰y±¡®Y’âZ€GÆi” ðö“•àëq»h ÆF¼¤±?UAëé ÇZíðé¥íÀøÍS‘ »}CºÜã·œWûr,DOØJ–Ã]¹‰ä‘7WFÿ6õænh@ñi¦M_A#´`\–YÂXžÃ°… "±ª¸Ü¤™ÑŽ"K wŸ•ôìÒˆrnZ쩧µ*ß À(¸HPó ]²#r»2]ò&UCÐXð t#ð†¶QL´( [x#Ö9ࢨvôFâÂ?A¾,o››#½˜If¤èÞq¸Îýt PÁÅH\ý2`|8¦s—âjøfÀB·Ù/7·&D¼¡‘Ö§ ™ ’2™ “ˆHÁÉh/Á,ð^ŒEšÂçGh øÒfö:D]›ü€ CV0h î®CI2˦£OR«õ'† ¶,ͪu@Ûï`ÜþŽüYîözM™ž~úp¤[m‚À‘„YÖ#Æžq…ê´µüd´üD´´B«Çê¼Ôh”éT§Ê`4¢m«À“ÛP#êµjîõœæˆÅ%¨¬*L^—Å&€à=Z‚aI-³ÌÈSÔñ¾(}Qäü„(¨Ð0‘¿ õ7Vn*y_S*whúíêhnÏ”ˆóóÊJHÌXäþa&i+Ã$þnœO¿¨öp³ɧGï›it>öûr=[Å¿Ñøз­«;3Ë´4'¾•‰¾U/£èÚFQ¼áa߈úÎÚJ‚ s궉üÜÚàˆvmñZ¾VÈcžkÝuÉNoJh–µ<úŸÇrC â¥jW e\ÏfmÌ5xUrÞÿ rñï²Þ­‹ <ÇÛÿBHpIÜy¼Ÿ3aü´ÎÖ=ˆ­wA„5¥5¸Mð7ÈÀ1ÞûßÓŸCM#š }áÅ£4Â{¿˜?åOœËM¼KaPõç]tÎ>´œà_æ5HŸ:ðˆ—8²±G «%Á²:‹º}±¾Ë•%CoøßRbdN3Ôh›K8fÚ+ F>¾4^ WSÀôq~8îB>{GŸ&4«<ÖÞꃷ¥w^ÒÚxN A3êXœÆàfI-øÑÃAºžW¸Œæ†ÓØ“çÙ¸è‹/2˜ƒÅµï-BWõnéÂ@kjÑ¿-‘=ù¶óƃ1¯wÁGCHêÐà ÛmÓ·qUEøOÈ= ^¸”œûpÉ•´Þ‹¾¾HñÒÀЈ@úpãâ ÖOÂ_–# ﯫMD_³WˆTã˜öÙ‚b¾¹Œ,eXfÔ3ÄC…ªÃf¤e¬«}M-[à ô µBë‰l¶1a“ N/€ÖMXÕíÐ,1ÿlHW@c±‰†Šß dA²YˆgÍèUBË#!ÛUyØI‹gÅ®¿?Õ†%ùäÍÑž$™á¼C Ã]9¯ÁRÛ4R¯ §; J4ŸŠiL”É-fÏ2Ù%›{/‘ÿËz"`¸vŠi®z«ìiˆ÷d¡ýç¤jÚ£R¦Î0ÊvaƒÛõºÚ“Ç7*A ilð ·B¢?)(‡[¡X?WRS.¨•GÎ( ßZIõòmGtX€\k”ìï*¯ uÔ£ZA„M1ʉ­»r›õG€Ÿü觼=ÎöåœHç‘¡Þ7 %B1GŒý © CÝ8%¦gŒt¿Ñuº'œ:pž¶´}Ú¦”¶4RõrÈ?ÿÉ4<ùãÛ/>ÿáç&eѲ+Øßen¢r@€›dîP°ÌZZ‰ÃJ$¿ÿîûχx8nk?Öx‘x¼Cq€oEÄ—õܞѰL;ý4 +IgÆÐðÝCg`œ‰ód̽: ô,=·úÒ 3ó·Ü¨\ÓNøgV­I‡u6½u‚:®‚n ÕN9Aj<”Å J´‡ïð\´¶—XÁ1çd  ÑÔŽ8µàÎ]~—?Q4¡²Ï¹úÌ1Ô°Šùà§Ýüg‚>Ò]”_Ò„¤½QÑæ6˜'M@ÆKµ*Èø6:w Šù¯T³[Ð\Ôž`'ΪUuð#èIŠÀÍ:F×MÈáÁ,ª„1:¸Š1h‚5â¯ÂZVv/¼éy– hâ©T Âd9Òâ ëóì ëËpÐ×m‚ÚïÞ+çEŽb"×£DŽtšÙ©cÕ´R#/dNûëïÙrUˆ¶äçÎ!5 L¾Ä9¤VL‰kÎ2³ýõ€<òü Ñ™|I:áZU§¤L«ê°»©ªS<óñ¿¢ =!•µÕi~¹X¯"ÀÇÎèÚ_mŠÛÖ{øb¾ ÷ý­ð6عjký\`娭ek˜ø÷ Ü}%›Iü©lSÏ* ¢q€]ž‹Ó5Cpí  iºÇúeÎUÁ=UÎòVí=—}_Ÿð¯·Tî;I *RHr‹²Xa|àp6&ÖÆ~9FV,åîLìì¬Üà èt>NnÀ3ËÄKÈ XÉÄÌÌS¥˜ËÆÕ•€™^¨ÐiÕ nbHV)‘=Í<ÂT^Õ$ùJªq‹æ6ÖË“´¢l"DNQü Ó‘!¥£¹7ÆL}º1#u }Ñ0y6js ´×&hHpš´*f³*ûÿµŠE«ð Él¨gM»¼Š¯w¿†"ÉkÇ®u½(WÝi˜¿X­ÊUµ_SÃ/­™²Í]|ûéwO/M1õÓÆù‰«":t@FôB}‚Ÿ¾îºƒ?*К—[_É/[ˆˆhò˜L»&E ‚´kSon»Ø„Þv©ˆM!š©]lBÃØæ42¿ ›M"M¸Ö¤2Ɉ‚‘"ùVfdk/-6N4«öD(›…šbdKʼ*X 2¡y¼1‚ÎØë´É)È‚^›ÀSú‚Öì’‡¡Á¤ÊP I žësÜK-¥·p%;νÙÚË‚¾¹®N¾D5Wº ב-AëØKŽ yqpRt€:ÔÖ„ºƒ·Ã‡½4XÞóvø9oçŒf¦ø×ÅŒzй—P̸Ræäxƒ¾¯˜ Ëì•puö‚´é‚uæŽ5-TäBuÖ…0 X¤zÌaâO uæbqg0ÀœäâP8쩨“çÀbó2²ë±d®ã±@÷Ý9¶×á"Ÿ‡od{ðmNμ$[ /‰xšcé‹ø\“«zF…Œ—E»L žF×åD±œ‡åÔ%ynÁ2nN†·þšÏ.è%ºfʧ £k¦œ½äša7%Eb’_Ö`¯Ä\T›³a­H³Q6~§…o³0¹W˜²Vî4œ¢rMV¾¤F£ÊÍhm Z>)‹z‚á‘~ǃõ«"ˆÌõÇ¡Km5ì'¼åMi¼V÷Æú:Ó) Z!ö¶å hÀlÂ/6ÄșV½î¥|ÓÈÙ™ôïh4 p«ÿsM*Îø¸šðŸI¾ˆÂÈ]6úKÐX9¨[箫»èÛ¼Ö­a˜2/ýõ)øÖ*;ùúT;ÞÑ:Æ 4Z»µŽÁ‚Õ©Ï¿.•å>.ÐÇ i€$)¾¡$Ågâ~S3ñ‹_Þ3‰ÙÞãÔnRZ4õhúšŠÉL³¬•š×|ĉûFPH¶jÞ•­ZŒæøÜ1Þ~îò1¹‰Qb“p9î(|‚ òÿFу‘wå¿Ž_,i‘$ …ƒ­”íOGk5p&žz2°!sÑ“_<‰öbë&öR"|H,H+™ SÅ&{†‘kACKZ‰’úc¬Uk¢é·Ö¡~Ÿí÷Ôôäç*fAt<t•Y¦2û1еքÈéCÍSÖr–+=4mAÜIw´®ÆêŠ|[i<–`27— À¬4÷_’tiMZÔ»’Ãb ±¨µjýÀ ‚ŒòŸ{hüÞÜi’%_-û5ÊÀwMb±¥'‹` –ÍCüV¶­*‹Ïô"‚m§ÉU¤{ éóÇlàƒaCÀµ­“N1‰Ÿ’`a'_æýù$Ò › endstream endobj 1425 0 obj << /Type /ObjStm /N 100 /First 994 /Length 2666 /Filter /FlateDecode >> stream xÚ½Z]T7}Ÿ_áÇä!n»Ê.ÛŠÄÇBˆ‚6Kx˜Þ,Z4†FbÿýžãnOf–žž»pç ¾·íò¹årÕ©²c ÑSÕØP'–ØH.…þSvY31:«|ÅÕÐØP×;GüŠ²…žâ Z§Úûü“9@¢‹¹V˜àUà Ҍ^„XŠ¾ÂûÊI(ºB‚¼n!ŸÀÄ–#;ažÖˆ=VtHRq"•­Tù«àW‹Äˆy¥d"<©•ð4: Â*Nc|ªS©Ä­ÉiJ&«÷3§ÆoIZœÖÝØê´Yd«¹ߥà’$Α¢CÊÈ”Å0GR—¬€"SiTtÂØye¦fÙ•ª.‡Ø{ZTU2qYrïâçAÉx—ï2F”À¯Ø\S‡~­#†Î  ʃ(“BœXudW{ª•ØÐhÅU,¸åDÕA¶åþ ¦`©Ì*…YuV¤ƒƒ­”nX`k•äêŠ&ÛÙBI»Iƒ+ºd¼+JÉï*×?•è –s! ~„VÉ\d¨Ú?öSóîWþ®ÎÜ¥u)ÕÕ¦œ£4ׂqØq“H)Þ4UÌQÖ\)êÆ*€·Ò¿?@w4ZSݨi:!vs µwÅ !ué BNœ²U°Ê¯iø)Tn•Ô0 ôM”¹Ûv»kfe jÂKŒÂÞ26ù¶k!ÓÆ¢pÁ.ÐÔ¾!ùáQ[8¹wïdõò?ï×nuÿü|³=Y~ü}ÛŸz{þï“ÕƒÍÅë‹W^ ¼^ý°zºzø*ö‡“Õ‹õ›­{óö\^˜‰×Ó¬â ö‘á=6úÝw÷î¹Õ©[=ټܸÕ#÷ÍÓgùíÑß¾ýÖ}ÿý þ~=ŽX¢Ç¾„ášç7ÖæËc‚ÇÚÂøñ—óͯš=ÜƘ_k†ZìèüO>{ùôæÔ\¶Áx´LÁÑæ„!¼`#[Èž›Hªy1.OöYÂøðñwþÅð·›sŸ}T¯3Š ö ·—ÅÓÁ ì“N!ž[¼{‰Í|¦†¡d,hô5Uøf<ç|X%{e´íá j¼!˜Á±{AØJ©z¸²6 ,ÁàtÁ|AÌ•ð0P_Cºûù"¼Ÿ :{8~„ЈG|/ 'ß=QÅ–„Ϸ蕬%Ãs!–у¥P8ýõçy5Pè#„q¨¥ÓŸË$ <‚='€à^¸Õßý‡kØ]Þdhçß½{}cGÄÆÞÓZöêŸÖ;78@ØK‰`:±7x‰gˆØ›þc2n?lò©:mõ*2±7˜®¯S€ÝxRô«½ÝêáæÝæâôýÙ›µÓݘçgÛíúâÜÉîñoŸ¶ON·gÛµ‹ýÅÉêñæ|Û­ã1÷nÛ÷{œûFp+-ì@ÕJ¹|@€´6âîZ=¿Ø¼9]Ã>âÑc·z¹þ´u¯¯›üó³?×'€}¾]Ÿo?ÜVŽ§eØ|¼x³þ°#ÁýÝÏë?Þž=Ø|r}3Wië~~vÑdú²ëØ7ÒLÜâéùÀ¾Ñö £GCFCG#F !Y‡d’Óœ†ä4$§!9í$¿ž‹­R˜kYCò‚ýõä&Ei„`#ÐLVƒç¡!! ÊNMôK‰:/[Jž¹ Ø5|2w7‚rƒñ\Ór@zæ²ÉÔ3³e÷d÷ôÕbu9 ´AþÍxÌ„\ Ž¹m<—»7 ÎG>®æ™½¤ˆü"‘&(éÓùÄ(Bf]0x†eEXÎ`ò$øI Öâ”–´QE4«—@°*^ÒQó®÷²sµà‘åA­;‚ÇØÂ^ ³j!áë#PÄê3v,òlÏÌY®#]Ža4,9”öäK ¤Ê’’ôP—4k°ÕñK€ÍD,K¯)Hµå6 ‡9°¸«Ï"ïˆ#á¨24Ïꘈé€AÿÚ$ƒñÝw5„Ïò T&æAW;^f B+rKoD_ÇDÅmV¬ÿEÉÿ—Ó_eûàó¬ÊïÇ€>åË1Hì›~Ný¿˜à›~Nð-~9ÁOƒ˜çA±ó Øy÷|Ùg÷\ædß`ðˆ¤–AòÂIÆ®DZ€8âUåh±pfwÖX¬M^ –Á•#–Éß‚~I‘U#zdcôPž-íF“ªsw̧À?gD –Ü{QÙ^Np"K³­TºëÆRar½‚î“C÷ ‹ÇVaÁ¤!7MtJÅóÈ.‘j’åá’Yd)½À*f¾ kGêí³êÿÔºÛ5™èͯvþLÔ—në=|Anu°„s­w©0F‡Š<ŽhbïŒ<*߆„I„öÃZCÖ—§ÊàorKo12öt°÷×Ƭ«QæZ»9f] m×êP`­|yË£|”GùÈFùÈÆ›2Þ”QP*#Ú•íʈveD»2¢]¥ª2æ*Cr’ë\‡ä:$×!¹ÉuH®Cr’ë܆ä6$·!y¿ÔsE_:w®?x>Yr˜©¤%N Å7ž˜î(ëÿ<1] €íU7 GÚÊHÝ tÏv”€Û¬–V}h<lžeVE6„L l$.Sj*­§ò™ùX"Žñ†‘žÝTjzñlΞµK½Öó?àLJ3Hà} •—hT8àþœ'a<†X‘´³ú ÚeÇÓâYAP^D¨ >ÕúѤt¾\0Ì"¶dzÎKÚ¤ªîE­òæžë‚8i&H2!Ì žýà5YǾNçàË'ûBA ²`Ù$"Q#çØ.¼ú*³’^>¹)¸#ûÖö.$%·£@î²æ‡ÈUŒWãvw^¤é~ü–»&3/OÍ´ì[Úö¯fσ7ƒ7)KÖdƒÏ¼\’”µq¬SÅÿHز‘íÏ￘ó¬ #ÿ@JFŽÓwB½B3pìå†Ð>+&_Τ¬äÚ«Ó<´è·]Â’®6ÙoWìhFV‚¼8È+Zz!¼ò"j­`]»º}‰‡—ä‡n6[L·ž·}¿ÔXàÜm•Ùmêye«y ã„1òË÷xÅ‹Å ㌦<«¹4N ‹ú ú^Ý¡@]¯é5æèdbܶ°‰°¿.I†KÒï‚ïÀ ½¤zÀ¼6×\y¯š$¶ \Þwõ˜d”½òÑêIJÑÕŽ£ b> stream xÚ­[[“Û6–~÷¯Ð>l•T±8¸ è)Oãʤœr:½vÏnÕ$y`«Ùn®u顤8½¿~¿ƒ^©¯Ý A88×ïBbòe"&?¾GÚï/^ýåFM\’[›N.®'R‹DétbI¤–“‹«É¯ÓÕ~u»ý~ñÓ«.^ýû•Ä»b"'Òd‰Ìœ«õd±zõëïbr…g?MD¢s7ùæG®&*±9.–“ϯþ+¶¨ÉgÝpÑÛ¢þOZcM,.%MæýüîüüÃÙa\ÎÔ&¹hÇý&Œ¨Ö»r&ÍôKYÏæ©1Ó¢®‹»™5Ó׳¹vzU­Êõ¶Ú¬ùñÙÙ¿ðšä›jKm:­Ëݾ^—WÜ{yVÖ E’jÕ’øÏŸÏ?G£óÌ6£šEw7%_Ül¶»@æõc‚É\¹<ÉÁê¹ÄË&çWùëby·õ”âîö¦Ø6|—ž¯ÖWÕ¢ØñNq¿¹ã›uy]Öµß$ÞZ··ÕúKxõÚëÄš@ 3©I“š›O?¾1CiHçšm~xvñ‘„!ç-ÏÅÊ8âQ F4/¾ååe2›g™~”ïnŠ_-°Û× — t8r)hŠW«vŠ¦¥æÃù§Y*¦¿¼çÛUY¬·|É ÐU¹ÞÕwaø§³vèN ¥úéýÙhêíÍf¿¼âëË’ÛÛzCøGuU†'$‚ðdQn·›šo¿U»¿1ÜE]¬¿Îæ0Ð>ÉJ“H¹›”áP%­K´’÷i¤Ê!ÚQ‹Íjµ_“ž€(¨!8¯ÁçO媨¿6‹shùÆ}7i µÅr¹Áë´U7–¤å÷‹²‰Ë[k~æ_‡™×›K^+x9²¬;W™f;¡‹ý¶lw”åÓ;îþV-—|u^×¥'—WûÚÛ€ÊR2êZÍøÝ&¶3ãÙóTÇ™®ÓÖ>¹?ÜÀ$ñ¯yý§_¾?eRk:[|ËÄÏUàÃźàz‹UI^Çß2ŸûÜÜzçñ(BçJ¥Išš¡pãd’öh×ZMÉÔ4¬K¾ÿ:“bZÞî¸ûÚ[º/‹Å×oô¨¨¯ø”ûð²ZV»;äYïÂÿÍYéf¿ågÕ–5ņ-¹œ)1ÝïøqXZRâ]Vy¯žäÁ~™—F4Ú†+¯mh·û[¼½Ý–a„7i´7×{Dž0´.—%ü]«¸$EðœKDL))]°BMŒFTqÙ3rJ…TÎ3YÌäi¥¥¿Ê¹#½rÐáÒĤùKÐá2ŸŒÜKÇ»C*4b«Pî¨Ð f$Ý *Bâ!y³Ì|6H² Â}ça +s+Qs\¢©En/_` i¦à£PÌFNRð;Í‚ž»€‹c2–©Dì×H4¡üàò3ê)­â™2•G‰ƒc“1K§ÀùT íE8AE±ÎYÆh n:ãæ\jÙ£g±©Lo7ë+ŸQ×z¿*kx±%ß²Ï]îÛÖ[Ø?û>Ü?ôHʉÄfM$ºÇe'}‘vÒ¶²ah…1 Œlèýàc Þ…„Ü6&‹L4ÉËåÏ… 5Ï”Å,0вfZÎÃ=[Zœ8¥]"È·<›8• ¯31âT„8ÊS$‚œ3RW±ÜnxPS=iË3ÔYí¸‡‡Ã«l¶[å~ܦ™ß#ªA·OkèÍŠï©’° ˜]B–ÙH–ò¦Õå2R ÈM H×Ù´,7Üûóùîê^Ú&2g ¹èêå~wÏÙtêTy~Ј ?ßrâÈÇÛ†Em³h3-1÷ÛMµˆzV!s;ÝÝÝ’™-ÃmgŠtÏœ£~*nÖ×>Ç]”ÜÅ6YW„ƒ¶,CêæÄ“Þ½ kôæYwë]Þ…u¢u%…ôIæ÷×8\bM›»ß"/¾” 5@ÿû¦|ƒÖ™Xy“ š/Û0|cœÇÂu›Ð\à»EѤË>Á¥ž¶¤R¸Þ»AÊ)rJ‚Ë  I[‹ò±Ê»'ÈL¥‰ÈSŠ ÿH¤@ÎøòDÒ½óy€É{˜ÕyÉÇ*F2#ãCzÓ úQ%<Õ0þ^bÅë2Ç…¨iOd 㹇©ˆl>OLžöêë2‰HÞ»“.[3A¤qa¹Üš~ƒ,©ª‡¨S„Aœ¸+XÚ-‹%'Ar._ª€*ŠRö.I×v¼`Û“DËoM¨Bû¥êŒx6çÙ«¦f`üR0Ñ\Þñ8rÆmô‚s¦ÓÃÈÕ¶Ïj `ÖÇÑo9 Éü—þþ¢©¼Šuj^Fö¤%e"•™¨ qÀ62Kƒ\„ûÿ-f‘¹f¤ÊAb¾É»à 8¾Õqjù¡lÛÈ 4ܦªÍ`3ÿÁ¹eTËÄø׈8ÁjãH¨Pƒ³zžÁ¹ 5І!_Eb¬íJ—‡"BëŒw»¹æQ¢•.ôM§Üù}ÓIšæÐÎea IëõÑ—œ\ÞË^wÜx™—"ðV<̘ðÒظud²7£'룉ËF5##jcúi0Óü ú™Ñç';Ì=Ç ëvafSD_‘*8#lÃʱïï)Ïûˆ¢œìë)OT«é³©¡ez Ù+É‘(´û~NØóÀ±ô]t-%ÍãÖR§jŸTžEÊ©½Š4¼ýM)3xiòëÜ;={k ¢ ˆà쇳\M/¨XÊÿ=“)Ù§·6PàߌÕ#ºˆ9á@ˆË¢P*ˆâ<’Ó,¤n*ImvFèÓM˜Íž~¼h$ŸAAª¡¶6í!ÉÃ=ÁÅ»\M44Ä ¶5 èPÕIq@’ê<§â‡ÐÇäø$ÚÃ; V9¿øán Eví~~e$‰1­Ë7€¿‹i*ÀFëêc\#{²œKú(L¦Üd!uì"¬Ý¨Ô±ýè{öc{Û91—–}¿ÛD§îÈ~7zЄMšØ&óž¶DJ+v¢lš¸Ô>·²büD6ÍL1Àî©Ç(GàæÇØdp#G¹©¨ê>bæ|ÈÍè°Xž†Œ&UчÃOC\L† Ušh—žöˆ|öcûflÓfˆ¦•ãùò´›Ïžòê;åõ¿å¦³wÊ[;{¥Äs.O4çÙçÀ¹QO è—úª)<4…„8FrÄ—9T±c_‰ìJ!o"3ÐwÖV=?Gœ¬I¬ÊìH3©¬R‘ƒ ©Ë)fd3 ;xƒ†,ÈßE½ÜqÖ¯ˆÈ Æ–Žø1¢SugŽ¾{•›Ê®*1D·‹1\fa†'íÉ<`OúÔž2Ž}5Ãs1.qA?å3 æcc0‡é2Â6TæM ¶%éÀ"¬ÐûÁ n)vèD>H(*:'`BÔ˜ô¸)Ð M5AŽßûõönµ*wuµ')Œ?\q°)xû aãÉ›z‚MA®v`SQú瘰’C„|`vèyS‘0åP»Û¥Ý**—ÎÌdñú¤ËÜzµº"ow›Ú†#®v;<5ÄLß„“TwMw¹_ñA&˜Wð訸œHÙ«C¦áÀJÍt±¯k>{“¦Íá*~âÉè Õë×|WpÓÖ1Ò“ˆ¾~9Ýô)ß–¤áûmXë2ÌZ­o÷¡+œ— ¼'`L«?»À@ëðƒ~£8דä‘°¹÷I¤ø,šâó#V‡ÈäóÏê.@CÈbzÑ|0¸ª¶K8©×œªU‰[±ô Àtœ”õˆÕbyìtI2 °ªò-«‡˜ãØ!z g?F_£-Ós`°K´æ™Òz=èýY,«‘‰éŽ§ÎχOÚ6Ím‹À¸:xþ¶”…ï¶i|[§5íÄŽ{ùÁ1 Å»§r@Ó×m¬ø|h§-ò—åÀ0>jf˜ÎÈ£¿¢06ŸÞnü7Ãæ ^–H5þ6Ûû…Ò®ÿ; ¥ítæØcjeê‘ZQâ…4ãje€N,Ï”:ó¢Lí§ßÇ8«­õñߧcÎú3î÷0ñT~ÔuµÈUóaíÁÇç¹ÖUøƒ"|?.:5k• âY©{.-y&£²—‘B줥¥äeŸD±TGrÌz@ñC¼ #±‡™Åpò~0®gÒMËbùâ·ü3â¤a ²KÁZ}!Ñy}iü8 †ei8ÕãZÐB×ÕšÛ&±•S>ÙãB€¤ƒˆYêC++“Üè'6ƒ¯¹í÷ÛͺÃo ª‹'Â$:;ü1ÈظD‡Ká’Ì>öHÙ}ˆ$3<“±Á$>_|úçûø5è P ù98TÚÿàÜàÔ(Úxs 6˜<±&'ù³ýööã^â§w˜Ç>ê—w1Ì@g ͉€9„Y-ã6‡–1S#Ev•"ÒŒjì#j¨ÝûÉîcy“îŸaù[ô|YÚý”P˜ùáj,–;>ùR’C=Ï ßY<ì7OÉ¡séra¤¹)’/´©j>…äƒw ?ÿr[§s endstream endobj 1553 0 obj << /Length 4119 /Filter /FlateDecode >> stream xÚå]“Û¶ñÝ¿B}èŒnjÑø"zÆI2Nljí¸Î5™6É%ñNt$R!©\.¿¾»X€_G¥;§N_D»‹ýÄf×36ûÛväùùå“g_Æbf£Dk5»¼šqÉ"!ÕLÛ8â’Ï.׳æ»Ãn__ütùÕ“——O~yÂá[6ã3›ˆëæJ9[ížüð›­aì«‹dbg7næn&"@c;ûöÉߧ“Èj;\tŸVÆ5anÜŸ MŽÀܤ·/__$b~é'ö iÉÃÄYÌò¢É.x<¿Î*xå )“y^Ó³ÙdÔ(»eVA[±yyE}Ù6ÛeEã§.³¼¸ö_ûCóÚšpѺ S‘Ö" ó× t9ðÙ0ƒE‹ØØù«fˆeQúŽtÛdU¶öÝz€²p!ŒŒ87³€Nâ„¿ùÇ›wßNsË&-[#·Ùci™-”Œ¬ÔQE‰R§ ì­æSH<…°gH‡ßw—ï'(–6’B‘ÜQ=ß—Øå^âyZUéí4p»“x¾ÎA$ê¼,h8ìþ_¸—-øÞíŒÕ‡Õ†zšMÚP«Ã —þ>ŠiÑÚO/ñÙB'Ào1ÜIXÔyCxI½þw\ÆóÏÞÓ “gl¿ý‘1QÕ þz!Ì<]nýpîzù§ÎÈ%çi±,åI¹Ãø~w¨ýÇK¹Îü¢žD6Aœ°ºGœ°€Ü•ÛhglS„£Cüq éÅ‘;“u ôLq3[6Y˜šúC²<58PoÊÃvMÓ—pöË!ÝzÌJâÑe/_£8.DÌœxàÓ)56Z¥Æ—I¥¶ L¼µ#Sf.e$”=O›94ÓŸB›’bæ|mn%zB¥ ¨trT¥…J ½¾Jƒeé«4ß/×íG!4µz$ìÀ ô8adž úÙæuS{:T<'¿‰HvM]aˆ@%­ŽÖ(ÑàÐsàxîç“Á¼NÈ wRȸÑ“æ\)s/ I”¯Êj€*õ~ GZùë¦lÑûãx#˜ˆçxzÌ ¦ÁkÑ„A}J#€¿óx:ùm.n+hïBr6ÿæÐ,Ê«E•×}2¦ ·òcùuØU9 d˜³4.6*2 ×8„¤Ó5î³ ´ D3°ëCk¸””¡u<œãI¤m_µ'°!±­G¯.¸géöÙªÜí·Ùo0cÖÊygÀˆ;ÓЙüWWQf‘ÒqŠÒ ¼‰c4Î{¤a»Ahí™@6š»Ië ´ÕÉÖ7´ï$t4>qî®èŸÓ ž°H é5ÈQ$ÉÛCcRPht /F2Þ*(Ê{AÏNï²‰Ç $¹åÓד|²LŸ¼Gøàõ·WEVÉYoÒ_Èló)qHÈõkÞo&PN"ÓņŸ㻋ATË[XKGÂ𩵆æô2î¯å‰¾Ù€¹Ø#Xß ´äzÖÿiüÉ€?°£‰y< oŒ8¿ I˜’h¡‰=Ò¡¿¤9ï&–©Ž9P @#å`=à7MD¢Cb_6 ì[Ün='í±¹0€hÈ?^ðIQ$·3ˆ«¤=É*˜žUi‰á3æ퀘Øfà| ÂâÍ’Á>c8>)ÉÚˆI×I;5’dÜ*vån-/»¡\ƒw‘ʃõ¡‡¢¾Ýí²¦ÊWÔ±Jk?\ˆ4‹ÐÚƳ e;¼¼G!„A‰ˆx}ûÏ7#ÚÈ&m[mxAk2ç@îU=e"†ì‡È€[ý©UOŸ²¡úVõâ¡Á7VôU¯  ”QlÕÇ„TO9íÁÖi ºÏ> ‰Oz€XÞZÎGh2Š¬^ô&9ïÈ(3 ‚x§.ážê¤v ÝU¥¦í‘îB(4EÊÞcŠ¤>Ñ'¹.Ö9Â^ Éùyüý0±áïÜÿÖŽOG#ŒNÝqù¨‡`¡K² †-'¬Ì¼o€¡ß`ho€­ŒXrªýûÙ ²·RÄ`uFicˆqr($yÅöväJ¶%Ç7™Ÿ Axئþò§fXÅ¡°8òá¶YTß]pÎÛh›ÙùMÞlû˜<+„ØÛ…ÞðB17Œ·17t®ÊíaW,nò:sI·ƒ60¥ª²z_kW©Æ¯\éžå0Ÿ…ÉÃ|v¢dEXH²[|¡xÃõ²x/]nqøf}ØoóUÚdý/»LºZ¦@;-è«Ž%Ø© hkÜ@&§2UeE$ÁÞ¨$vÑÅÃh9/)Nîfª hœn<*ÞPå%• tµÊêšjðÖ´Éš/Ìéö¶_í7¤9Iü͸%b²M*¾úæóÄ.ƪ~ì‹r¯JÅ¡:šPuË¿LciS®7#*üf¹b(ôïRÐœßBû–Ë”Æqdy2LJG\P×;¡]þZñóqpÞ´ YVÍ¡-Í„ZÍö4þÒÛ05€ŽBС´mË5-*l)=ÇrBYÐi¾¿}J†¯=þ1Šü`?u÷¤3ÝHWGë¬^UùÒ¯Ó„÷iÓdUA/®ìsÛÑ–Á}ð¾ ­e0ËYãy.£q•qy‹¥xNÌüP»Ch-³«²ÊFàâ›Tl>@PwiNÔ¡‘ç &E˜¶4O¸{SR:GY±Ú åó¯7®P‚­mÚšWévK|žh/«2©ÑiÚ•“¢çü÷´i Ççó!fdÇg°A¶Žñ…¥çØ `P—Û_±îQÿ‚@:‘ÚðQ$µ³ÑbþEP›0Ù×E\¾’hps¢,cL’ru Évˇ*½? GRT¶'¡ᤠ;ïn5U¦%ä®j\™Þ<"턘E+õQˆÚÊh—É-@ÏŒ…ˆ 3í--G‘¼Ì›_å ¹ë~䎷©ÙÚ/½) 42±Í&"EŒ#Àq¢ÿ m—§ZµàµìÀcw†é™^€·¯³D kêýÙ9ÿ©IÙV UUºÍœ×°ë¼@¾¼€¨øÐdëP#ÕÜÍ‹í˺ÎéàP+¢ž7ÀX=!ÞÇ6mŽ`ÆIß«Ã[+xu€Ø˜“ÀF×¾Ù”a^‘îÂÈuŽ.ô»ÀèÙ.‹dÓv&xJ%¿ÿêòå„ÆY ³žIÃAã$I ÎR $ç’wï/Dן¿~ùP„ÎUUîFضGL  šƒ•Cn¶®L‰ž¿„(Í5¨7‹áÈ ƒï»´ú•6khmœìç£ )ú<}gñ¬WxR÷é$$oMõëTeE¥„Ä2/Òê–º‚$cÿM¾ÝRïÒ“tpŽËQYR d6"œˆ~êý”1‘°ÉëlŸùp\Æbîî À“<:4ÜéoM{Ÿç\ÑóáFÀ–ƒ©$âì1W<„£Çô1{Dx: íuæÑ^f>Kó±ªæî¤Æ¥ô¨òëM³ØP€ïu¾ö»øžûªDê…5†¶ÆÙïóŠØyI»D‘dí áÒÛKÜàâ‘ã?H-÷Q¥>éðO  .>ÁáBb\žqøwlÓñ¢xû‡¡68­ã >L QƒM—~Ó§ŠMƒua’“g纃:ïÖ{73È­cÇíèæ…¹4×{üþ0Zn°ýÞxã]o¼¡ù·Ž÷”xD¤K™¦QT£D³©Òº-W”@f#§NæâY_3\ä4ƒ¼þ¤ƒï®³À¾¶O·¦ãZë¡“g†^Ýéú).|Ù¦¼y÷Š Ž˜%w@Ÿ8?Ø%Ó9:hY…]„˜‰L3{Œ6a`šp‚Ä™¸c§"Âã%’EÞÌBn­øèÒª¸èhU\úC[ìv›æ{]6‹õÆU>°M3v‘à]ðä>þÔLéâ šâ 즸;s¿Ö:é…s9Ðúâó(«'¢{œ·,b7¡‰G¿øSf!ÔÖ‰[u4±ݣ»ë]¤HÖ Q¥ÅÏ>ã—XÚÑ^¶}¼êËNwRµŠ ÝÀ ¡E¤äcDLà"HBÊ;Tze WÐœº®¶‡ »Ë²ÙŒô}Ÿ†®V×Û±.ædN †žk¶ˆµ¯„ÄhuÂ^ÇÃY?,âXûè>\H‚†¿k§ñâÏÁÇã+NdÈ£²ª¦®rü]«ÑÐ>¶‚F£þ ø%a·”X$H˜ðN°[‡ËIÚ]ø’Äo^Ö°<Á¡nÎ|dêJÈ®NÆ’ ¿[‘Æ+[[š ¯v¾Í°îSûœE‘Ñ+hjJSºH2éE’–4!Ö®Bj¦úöµ¤—°^ê¯P9¨•Ÿ³‡€p^!Äl=¥ïžàÒéCA 7¨nØÛ—¥;lóù«gß<¥^¬ëR«(éYe+pXÔ^–‡bV¹«pØ“ù—“!cp8¥Ç ËÃŽf†ÎôMÙ¤ó]tÿúЫ/Þ^¾v?íÄ)î¨>)Þ™¼`½«g¹7«²hÒ¼¨Ÿáô"¼^H14BîŠá0œ<õüTwxÊtŒ´ÌaâópèPóÙ„ûAÈŽ²ðæBŠÅ27¾Y‘/Ũañ©ˆ|û¯“ƒ*Og†QÐý„jõ0B±ÃÔ²›¯Þ¿=™P'ÃÏ5ˆ°§ZMoº½»³LLßTë.á!·§×ö‘ú£œ32’Zü!"òÕÿ?œû$2/ƒ· &™äþ‘ù‹Òø/™üŠzŠÃ.«òžákÿß+ÂùýôÜ5þé+kÏÏOĘà§ÚŒÚRV¾iUc™ÀZŸ½ *¥'ªvù ¢­By s×1á©?{¶ÞU„'×>›ÊG{7³'/=(kÿõÊ?_m6»¬ÉWu8Öþ6uOJZ‡‹‡Hé1ªžRg¨6-T¨àao‰@»D¸ñ¹…é&Ö>í0¾è´ÊöM˜rJenX*ûÇ&a+GÉŸ‰ ˜a.ð,Þž*öWS §$£üfnËÕéõù§ç‘§é¢ËÐä‰3Iký)ˆƒäJÄú?GÜBJfsTÊæy”BBReìŒsˆlò*ñö:Úa„dN'R=ÆØÕ_¦€þßññ„ HЬàg¢ÓUûÈÞ¬¿ ÃYÓ‹+›p=EBárgšçkøBµ©›, ^y¬ øñ@îì=Ññ?!Žz°€:!ìè/äxèoÑãÙœ8Å_ÛÈÄíÌ´×¥ü½³ÁåŸ%ù_wÚÔ/¶p‡ŠÊ@h•ž%xÈxïñ-7XÒwóÞ© ¸iÁôÌÚˆ‡ûmª ¬ ÌcœîÒ)kðö©å>Rü6 ×Ý ¯Ÿg¡õ5q¬û´%fí&mšfÿüÙ3ð]›¨×]—¿>{ãÜÝ›´ú9kžMÖõ,îŽ\9Øftý`æxPIÉÆÌû7X¯h endstream endobj 1594 0 obj << /Length 3574 /Filter /FlateDecode >> stream xÚÍ]oã6ò=¿Â/(@ÂI‘¢ ôaÛÛíí¡Ým7¹+m[I„Ú’+É»MýÍp†ú²¬àp/&=¤Èáp¾‡ñân/¾;‹¹ýæúìÕ[£NdÖ&‹ëÛ…´F¸X.¬3Bj¹¸^-~‰^Ÿ_ª$‰ÚM¾^S·+Î¥‰þìè߯q¬ÖöMôù¾\ÞxYW]^V-r_pÓí¶®VeuG MÞ5埗›¼ùý\ÆQÁëÞùªh¨ŸW+Æ¢ÞðVËz³9—QQuíùo×ÿ„]ÊXd&#¬WE»lÊÞÄl ¼yÀ~:BÝFeKm¾nkê}nÊ®+*q~©ã,º Tù†{õmX›>N'”±—²´]³[vÅŠña\šb»Î—p"DùÀ~UJ @Ú¾01} ­!j ƒeE-:°+ú?|wý79{s}öÇ™„½â…\h)…²pýV‹DªÅrsöËoñbƒ€ŽÐ™[|öS7 %lõâê짌¤¥Ìi%%5àÇçI}øæû7?¿y`D8¨±B¥Ð*áL^3õË¥16ú'j>—mqgÉ40Gr;$ö $*o @g‡Î:oyÎm½k¨·¼Ï›®¡ié¿¿L— õƒþ‚%±i Ç4±0ö%Kb#K+i»O0Bc'Spˆ¢¶ç5õƳ˥ҙ°ö8Ó qŒÏ<Ð!¤þ¯±‰ýÿeѤäé˼åùžTÑAÝœ«8Ú?¤p³ñ7‚‹)eùcDfÑàe†?¿C:è”r¦æxüß}ûþú{DI:ø•~˜SÐÏfáﵟOàƒ°<÷§"ª¥©ˆ³dJ¶C ĆŽ&èC ˆjä\h˜eßîdÎMÝ s&Z{NÔYåÔ¬Š i¨3K aK¸Ê&_— hÊ»ûîòž'ب-W !Ú¢x‚¢ '8ùjwÓË®¬+Z5º3‰ŠˆJ8©„í¶©Q‡}‚]º:¤<÷hzºFáÂÞMbh?œWùú¡õ«Ã¿í}î%W'@þ,Œ‘æÅ^S~˜Ûœš Tý<Ø›»¤•ÇËõöží?9¤iÌG^¦™ˆZ˜L×ȼtT® —©=ç‹ÑÀ)ÛmQÑeèÔ+}„zÉnî[”l°P&£wMAEÃHrþŒ­~$ážX۵Š¯Å8¦›¬#C@µÑÇ\‘ èDXð&$ìÿI¯•Ð‰ "ü~&í6M5B»0ñòÏá_û*odåü¡¥ð…ÀAøT¯?«ä—`«¤™Ð?ÿm‹üÑû‰ê„$µ=¿ÿëýÕˆQÇ0'Ñ÷ÚÓü¡‰.Òs\);Ô?¾ùøã¦Y‚š( Ñf·Ù¶PuVh%Ÿ‰ê$¸u™·T·yó·×'2`&Ò¬÷,¾ýðýÕ·¯;.xZIò|µ Ú~PÚ?ü<ßí)æê éRf^y{Ñ û¿ÏŒ§•sNSFQ<5Z;¦¿:”xÏÆ}Y¯w6øAûb%8A=°š\Í2ñ$ç ÙÌ=„C¬Ê9ZëU8ôA)rp׆Á Å÷þa GFþ„°¬ì0Òð0†hŒI .~ ˜1éÄÑâÍÃQ«¢2Ê,cÀnæð4ÅÔGË››¼†5/º´{iš°ê@2õ$Él67‹…ж;Lj^ðÒ|&Çÿ ú¤cáãKøךþúÅƳÇF2óç–†Óx|ql¯Ggh½Õü³Ü`pŽi@ËgRÖEÕnS4åÒ“sŒ[Kÿ=U-GSq}IÔ0í~AŽºÏ¹ÖZ˜aJŒ]èÔð˜f˜d‚+¥ Ø‘ÖBëuAHnvÞ‚7Œö$Ðç™tb¦dÚ³êP6û&¼žÚnŸøfÓ0Û¿Ï¥”6å˜ÃŒ­gð?ÈþQ_Qó‚+š4K©q áCäj‰b—dAì`öèÒqæD eÜïØ…ùÃ¥#˜Yî«=Â23à|ÐBÁ•¿ íë¢üBqæfLÀ¡à.øc7Å^Àw̉{ùuCLá¼›9\wò”nQ@Ôv·_· ÄÇÎHßa/h_Å5™;è5\”ï—m€ Š@e#ÆŠ`ƼÕ1…Ü“g¤LÆ:*K…Ôpá1Ü¢|I$¥25…+ö”ÙŒub@ӻ̙q‰äÇ?Élà˜ÕsÉx¸çz‚ "VsVüÂX:}„s¾É)]o)±²ò¾"Žõ®¡LFTñý£´ÇhzYmwuû¸ÆrÙË0]ŽˆœI7Ü{S®ËîØÚ§pÐűJå4 6+MRˆù®«á ¸a(O,ñBuDâÛú¶ûŒïG@sÏŒ’œþ=ª9S•Š5>ú™M‘SpŠÐ–€1*Þ8‰>T¯w‘Æü« e5+Ç þñ;ŒÓÒÕ:YÜÛ£wïß~øÎ×KôSõW2TÎîëõŠÑ`ìÔä:ÎA3ôè:}¤P8º#~=¢8_YÁÉy]0häÕUÀâI½æïÅm¾[w£d÷¡Z¡fœëöùŸtˆé{^êùü6Þ>ÈQÛ|ù{~W|q¹‰±˜ðÛ» KØšEë@žfgz„{fA00.Ö&¼ÿaŸ^‘˜±[†·u[Ž OÐUª²ãÿ§îdšÕ#xõŸyÈšIÆKȤŸüõ¡ªì”öÜ)9Šá==zá°M#ëøPÂ>ºêFœ ¾¤Ön?£w¢Œ‰ÌÙ½Š¤ù¢Š¸›$½Æ£€M™ 5¡6 “êkú7ö;Ò(´ –Z[~Ó—>犰Dš¸çÖV‡£¨ ãéþIêfUWjÀý@Æ:³—í'¬ñSÿÚ‰,¯æhäÄJ©…õ÷›žöáëõ\´÷Þêjy¿cXŸÐ~²™*;ðÂ2;€íD’ ÃGOH’ë—GQ³#éám)ⷲ韠ÕÍp9|ƒ@a£?h6º½RöùÀ Õç¼q*•¼üUª¼PºθŒû¸ã1˜3˜¶Xìï ›U>ŽO€L@6pQ'›õOðŠÿ ø8öÛ endstream endobj 1637 0 obj << /Length 3674 /Filter /FlateDecode >> stream xÚåZÝoÜ6Ï_±/È@–¿ôqEÒô=4q/vQr}we[È®´‘´qÝ¿þf8$%jåµ×)Š;ÜË’Ëáp8œùÍPñâf/~x?P~sùâÕ÷:[d,Oµ¸¼^p•2žòE’iÆ%_\®¢÷å¦èËõÙRè8Úí×Q±-ûjqÔývù #FdÒ˜ Ía 3ÿï841½hqu÷çýȃMÖL¤ÂÍýñͻ˟þë8ƒn ÷“5•d±Ìܼ—§­©˜ÊÔÁš\,:-'ò[rl( Åb¡œ·EûqNP’3™Ê@PŠ)ËÎÎk8%¢¢ëÊíÕÆœ‰’Ѫ¬{:•Mõ5Šh_w÷[8¥¶ZѨmõrŽ žj¦3/<ÜûiòÀer ?ý¤3Ëݼ¯ãOK¨æ‡Çö¸®dLñìOZ÷â_o'k%z¬R¦LŠT"f¹Îíšs§+ Ö1nâåÙRÂ¥«®¡”ñ°Å;¿>ã‘!l)m©°Ty¤íÿ„T¬šÍ~ º$EíÊv»ï‹¾jjêDúWE‡z„]ó]YÝÜ3€³®*0}Õ—Ô ºµº­êÜ•Ù(n$Øp±¹iÚª¿ÝvgKÅU´.»U[]!=ÅeTÕÔüÁŠ‡9¬À !1.ùá`CK¨é„ߌbЂ–b·ÛTÄ…Šú†:ûÛ’€å›ª.6ôÏÜ ßíP~CÕ›²·´¨ø£l›åu[–Dl]7 Ð`F8q(–K\Iæq´ïÀœBΰ¥X®èàr†®… ¡*„ƒ ú[75²B>Ÿ ´û’†ÜÝ–µä8p»óð­JÙÞ[G&e¼—Œö‚g(Ru}»_õû¶d0-SdµRæ¾ßí{ƒ¬šWÇÎ$tßáºØ¼»Õ™cÇØÁÚë¯:Ö_åhÔM?Y£Zƒ¡¬úû³DG–8öÍË®©jôo§A°Õ½@ÅDõä9gi’,ž0ÍÅbµ}ñá·x±†NàÉ<[Ü™¡[0©ÆÄl/þi=u`ƒrðYZJ’KZóçïÞ¿=f÷8%©ÇfÞlÓ(8Jc]ôÖ¼ºTkê؃Ü6ÔSP˪ØØ8J²e{¤™y7þö—·?_̘<‘ƒ!ö Ý}8у!×Þÿãü›c»Iñ‘·Y’w7»ÙÁ5Mÿ ÒÙm®ÀUvVI»S«,„Hè¡ÎŠ˜¤•‰Õ?h¸mºžj°’oZú‹'Ñ•å#{³†ä.öW]¹–ÑL2>µt¸5¼~IÃúí]E÷)å;NÉÍsk ¤[ËÆhV¿‡ B"@ÇÕQÙíW·Tëo‹žjZîI'àFŒŽI+Ƶ¿G Q€až¦ Áµ tk à)×Öö|µ3öSD[=Œ‚©\LáÍ„¨`YêU©š£ÂßQhÍcƬœDz'7çl÷õ¤›DéP7Ùf6ƒ—B¤1Ÿ¿>ë>yΤôZ7ç%L€çî§pðQi‚"™ÂG×-l)m©l©m™Ø’Ðàc2Ð` –γðhsOM{‚3P3HÊ5F‘Ûª¶„ *ä@nÅŒéiËUÚY¯™±À4Üc6öŠ&iëi‘º‹")‹ˆBOàÎùS)ê9Fà˜ãáäÄœdOà$Ÿy˜“]…~œ7X”-”Þ¹Àq_ë¸Lp{¦BÆ ¨xßY;=tP§DP Kyò”ˆ{j``ì÷ óqŸ ü>6L=æR 2Ó“(í4èѶiQESÜz_T›Îú×$Í¢_Ï”4Ž0;ÕË /Í2úmÐì°¤Ó±|,ɘ áaWn`CD•.&,È6Úò›{êB¡NB…MבÉc6†£Ô½¦6äúÍdƒmŒçL':”磜Ȝi™ã$g™ö¬j8Í<'û;ç 6˜‚¦uƒ7⮣BÁXöÄ®@›9w¬Yþ^lw›’F5uû°@Cswßõå–ºpw·ž1Í‚ä¢ÀžÃ…ÄâgC`m00è(mhØ`Â-ƒ “Z)¢ÃŽ€À€|Ó¬>:ÔÛ  Ú}Ðõë¶ÙÚ=4®qóóâ¸B±HŽ@ À]–*°Ò)“qö‚K£¢Äãü‰d:õšmÃnó’ÒJÊì„™‹Å ½#8D}™)“L?”µ5Ì…·nü9ë;qSx˜ï!4¨= ‚&Ú4™ýAÃ(ßEF Ø32aØîÓƶ9ßî·»îеË0=x@K–ÆüD׌4g*%J (Úí,teʇÒ›{ŠÃíeøÚWÓ³Fâ²PpH€Ilï#æ=º—6ñ¶,‹'ŠÙ¸j²r*-÷­wæK±ÙdØ°éÊN€hv·7ð£èõ¦kNÍ( è•<бäQS,M½ü¶û.`M¢ór%¨»Øm …t{U~¯$%€šOÎG^ù¼¡ÛõÌSeá–׸òuéùÀ÷ìRã i2h©BдúgüC¸OEm¹kÚÞ·Ö' =×0„¢?¾ûþüº”§ع#‘Ÿá >-l²›#+Í”¡ˆé‹4V·åê£Á`‰9¬ÓÜ{Ê„äÏØÄæYžbsÃKÓ®‰­Ä¾ú¤>*£V ß°Õ¾Ó¤£“ƒÞ;¢:ê±ÇÈè=êWû2”¸·?à¥{ˆÌŸ»­¾¶iUÔ¡†îÊd·u9XrÇýâ± Bðžl”]òãã·‘…^S p,É 1ÕANsؼ0!윤ûŸ.¥Ÿ?’JzD*Õv¿é‹ºlöÆ-çnKðW5Ñ´ú·5h„Ý·E|qˆ—Žq_jqû¥V|4 W|& Ö?2™ë&ÂG NøØãðꜴOPFöágÇ…_a¢:müO ÿ^ácúBl³ïN?ë²û¶¾I.loš²g¤U¿-¯ ¸š£<à\Â>czœ4ÚíÄŠÛ.&R‰pÃÕýô+bõ±¸)üÌxšÍ´lâú¯ø<;ù¿ø<{©-–ÆOdæ4þk§ˆ÷3‡î¥Öæágô›ž`½¹¦Ò&ðôÈÐÃÄÆ>·cǶ¸§Ê•éCÕ—îÁÂ0Æ9ö=Z(5ÜG循TÁ'˜Êâî¡[Fl„vÉ¿t$Jר0]£”ýk×n¥*(LÕôû¶vSNV'áÒ—¥jESÂ%,Ä8a\èMu;bŒOÒAüc"Nü/él: QÞO¨‚\Û6@ye»Œ|éÅ™¶HÀä”KuªYï+eî<ÌRg1`ð¾t³Ì+ºgPp´É `ó•Hê€HnUA˜½±«Ž|¢|RT{Ì—¿³}àmÞÓ¾žœš1 v,}†û—ñ/Écð,Æw/¡"ÒCÿÁð†‹„,Ÿµ°,Km`!‚ß]¾ø—ÞC endstream endobj 1521 0 obj << /Type /ObjStm /N 100 /First 1009 /Length 3022 /Filter /FlateDecode >> stream xÚ½[]s\5}÷¯Ð#¼hÔj©%Q)ªL *_‡Ý…f!Eðd •ý÷{Žîhb‡ñØ ×S‰î\ÝÖ‘ÔjÓR$KqÁIjÉÅXXÈN-±`.5u’ƒ9ÓÀBqÅ ÕµÐ_5'!ñà)|)âDEPŠ0“û[V.%˜.¬’%;©)²„­°ƒ‹• %†Ü?0% nÎÑEü-â7³„&X¯´þiu±E6†*RE ¨u¥âTÑ”¢Ó¤´§ê4¿Uö¹Ñ²šÓû·Åiëmhu)4BÖæRìm ÏI¿HâR*ü}IKêRQZNÉ¥ÚÛHÃÙÇ3™ÃÐA*.ÇœÑà¢þmsy/Œ\¶>@š\.ÆÖ2J­[Ž¥ÂzQéã’P2Z†y sDÇ C&2~ŠŸfLhì”ñ6vPøÃrŸ«³ÚçãoÍ8h&ßš¸•¡WE;(SWr`7à8Ň (JéÃ¥Ñ=2|§†Þ!«®Jak0P§‰)ÁÕ¤ü¢ˆ«|D)ºZ:fô´ÖÐ>«­°’ ÷·æÚ„ ³ÝÔº8iÇÃLÒ^ ®•ÂªâZë~‡—0=Q{©ÚQí¿Ig:WöÄà´lå¯UéZM„i&8"\¹Â‚Äԛ¢ü"W|0­\aQ,5ô¨6®¾ËËhrcz\ì~ŒÙEQ8OÆîN«ÀØ·˜8?Ýëbï‰q©Ä¢½.^ÅÊ4,]Ñ áèΣųÿ¾YºÅ“Ó_–G‹»«³õòlý–+­"<=Z<]¾]½;¹|;­¾þÛÃåϯN¿X½wÏ~0¸VÝ‹#9Ç×XæpÇ^ñøìlkϧ‚Ÿ¦²)ØT`HÙÊ(ÔQh›‚„QQˆ£ £FajâÅÑçŸ_èbs´8y÷Óº??xuöÛÑâ‹ÕùÏËóÞ‘ðbñÍâþâîséìû˵{®¥y…W[±øRl¾`†­â¹*ê»;wÜâÄ-¾^=[¹Å—î“ûw={ðã'RüôSóÉѸ¡iõŠ…©%x8³T} ¶È·¿˜€$óR9ŠWFÈfžmZ<ÂÞáF"Zò\æ¹5ÏU­’|Ã’±€ç^ì³"—>< KÛ›¦º†ÀàˆZðÜx[–ï{š™·¾ocfráŽå­äÆÄ8,>a±H‰>r“1ËìõÕ<+Ž9nqÄ„1½ Ž™×LÍ^¸­ z0ÒÒeȆ<ÀvâxôÕƒgóHñS¶°½cFt/xòì錃PÔ'¼ƒ4‹ƒPûvÈY¹ Â?Žç„€µï÷ž›=Ê>€ƒcÜÞo¿}MÅÀ9©MÁÞ±0¹„Ä—ToŸúE˾€Ã'ô·ROƒë&pÒÚôܳ$DnôXÅ×Nµ¢7! ñí †3ïÀó܈`l<rM¦;–Õ.’â¹€üÇ– 6"³$€} {Õ=ô5\°íðÍ¿W«5š[ú4çRd3önŒþNµy!¡‰•çak‰(ÏìPŽQ13¤¸•‹_˜.cÃN8ðÐ ÕÑnJw Í×IŒQüTò98ŠÅÝ âÑ£n„9ü€A²\!ÌŸÞÆ`²Þó .‰¸[†~{÷6¤Ì·€mÜ~7•œQt6,¸·­'0Ú.±®n}Öùg(ìi/dÁÞ˜¹ ó;ÚUÍ¿^½œD\eNp@ o²pVb †ùED#&ÅCôÚ3€ˆ’WÈ øà¬bÀÄKù€Acýû0Ï;àC•Î ‚$Ø+)²ö ˜ÙÕ3¹½HÔö˜5%,Bæ ”.ÏLöûÁŒÀcÏД¦íw‚+›ßÕ^€Œ”K i<:èJ>’ 3žld#›tü‹ã;wºýÅñËõ«ÕÙâdñÝÓûüÿ“_×ë7Ÿ-¿Ÿ®õg¯Þ®ý/«?O×ç¯Þ?<=ÿm¹^|ú‘î:óZÝ}±âõº{gí ÕëMk‹ø"t³Ú¹0S—¯«=2¡"ÂÝд"òàîšÚž ºPÓr —Ò — Wg.$ >J't*/0‹\N'´x³tBnö§tBŠ<EnC‘ÛÐú6´¾ ­oCëÛÐú6´¾ ­oò ËeX.Ãr–Ë°\†å2,—a¹ ËeX.Ãr–«ÌšEhLÿ9Sƒ3iÅö-Î’ù,LN+³ 4žW0r·ˆ• -l[qw¬|ûî'þ·ìÌ3Šx™S^WÏó=æéÜJ§j­ý!¤|ëZÑ;˜n›BM‘÷7ÿô›“9÷ÏõÈe=|±â²2Ñcû|Ãæ=·H>òÀÁ<ðXØ°p"SE÷ªËy]´"ð‡ØS¿KŸy†"¼ÊÀTpÛ‡#Î|´¥ž.˜i 8 uÑ0?L¿´Ý™¯ïÎÞ>Yžÿ>£sHÙHŒ Cÿ›É¨= î>~pr÷xN­Q¼Ú ”×T÷bxúøŸ³bˆàtÊ‹$-öãE…³òÊÅç2Š ÍÛ"[ …‡Ï¶ÃìãÀE¡ÙEð3ÃÉtlóóÄ"ɇAÄƾ½ÅÀL,1íÁ0û8€¬˜ðw ÇÚ4°—˜ñ|EVxùŸw§} ƒ`šón“q[ ŠèÍ ±Èì T™'ÞIɯ÷C˜{>´&ú•$ðò MÓq'Ä`¾"!uÿѽÇ_#hë¼¥Q"xójˆW¿§™,!Ýþy “åÂZŽLI1yÍÄŒD/1ìô_Á*À.·8”<‡™‘ëqÌ»‹ & À#оHî‡ÎÂ,—ØÞû!eÖñÐI¢n`heÞ¬Þ†´Y/C`äÖHô oˆB°:ìn1ü_2 ‹Ú¦7L\¬8„uÎh<ëšÚl´ëUÞ¼ºE±|éìý¢ð½|D_ûmàñ¨o¥wIFÿU}lÓ!ö%}lÓQ÷_ÓÇu(Ô:j µ…Z‡B­C¡Ö¡PëP¨m(ÔÍpõ{™›B…4 ylÊ(ÔQØ41…ayÜy´qçÑÆG“aY†e–eX–a9ËqXŽÃr–ã°‡åqSÁÆM7lsSa&™ã”<µyÃÒuºyÿÏûÃÄÌ× ¡½0h‡Bžó"èõ0$Î5 »/Þ[Eh¼€N-ˆ•†ç$ÛÍ5(\o‹£ˆï×̯Ç1oþ„¹fèŸ-¡…öù›ô‚Éç ž¡Í·*ýêm0ßà"Dóîö_¾Z/ýÏï~[}ÖÚéŒH°T® á¥p^Ô¨¹ÜJyohlNüÏE±)ÉΗ®8ž]©kE·™âÛ€H!õŒß óÞ’¨eZ | ¡XÉCÿýž-ß(³7kbO³ôû§¹40O^œ²Ë°“™î,coú ²µa‹ºŽ™cGÁø2Û?€€‹Æ"{Ì;@Å+\„w×*<Ég-ÉV°~ʾûæü³0§h†³¦HÊ,+%kñüg,ûÜÊ—Ó¾º2âù> –ŒÍ¹`8˜Œˆ-·€C!„o’¾B¯}Ãþ„Œ<ü endstream endobj 1669 0 obj << /Length 3203 /Filter /FlateDecode >> stream xÚ­ZYoÛH~÷¯ÐË2sÙÍ>È,ö!“Í 2˜{°X$y $Ú"–"5$ó맪«š—('òæA`³Y쮮㫃 w‹pñËExâúÓÍÅßÖñ"cÔâæv!” „ ë@Dbq³Y|\¾.×ÕnŸ¶ù*/òöáòóͯ𚼦U`“ÖtôÏ/¯L¢–¯o/¯¤‰—í6ÃA²ÌËý¡¥¹]ÚÖùŸ4ÎzÜ<ìvL¯iúS¨CÜ ¸ ?½¨‘móád>2/ãÀjáÙ¸þï~ŸN;áY8aâ‰ÿI› b¥ªéVâŒm„Ç(ùiY<ÐójßæUÉü’ÒH&Ʊ1ä«¿·Ï­Å•H’ÀÄ Â Ñ ñMl—i¹ÁA¼´–'êŒEQ]J½¼Ï6Ò 8¬i®çkøj[gi›1uÊOÃàòJIIÚB¢-S{mÁ°ÓVÌÚréšÙ.+Û´ ÛÛªjwÀp|²óõ)ƒ$6^A¯_¾½ù ×Ш“Ç«LFb Ø(RKÁšŒ´bMâ,iҼĢˆµGóNº8ù…‰4#=Œ(YH4Xµ{Uõzp³¼'êAzpÖ¡’ v,BÒ œÀëFë^78ÝÐ\Ú4ÙnU8Ukæ ç7yÄ«K.­ú?3&RiFÄßTM(wªÏ䳨çñ,&L‡â Ö¡ƒH½äz7‡1»9Œœq8]Da(3ÖEïb:D—vט.,ð¼'œ â ·~ÅYË}Þ0AYѵY§E^ÞÑMÎÛ¤û}‘g›`νœÿÍõz{¨iˆ¨MÞI÷·`vω_³Îþ8d [CøkÐ2ˆcul ÉùÖÀ"aþ#·€z­œLYµÇ‚Ýô"ݤÁÝ®¤ŒÀl᪃ÐÄ´)C[ˆ0 —ïÑ/²zwhST-oÌúHéò<[Ô^ݺkÆÂÜäé]U: Èp*¨Ø@xJŽe¼œ& «p¬Ï€h(C8U±Â`pÄ~Üko×` 5ˆï«Ÿ8”ƒ ‹MÖYCwO0†$ ¬²OpKwñˆd ùíy\aŒ ¤àÕ±¹}§* FKÉ׈¯Š¯š¯☕è(xYWÅa‡QžýЩð!²±Já¶bºû,¿Û¶~v•ïÓºÍÛŒnÁ2×[çøHšwU·Û]ÃÑ’xx“5kˆvÙ\öI×|v”µ“$@Šð†ŒFr™g'‰ÝZRM_ø̘…6”$2&Ѥüú¤Žq—tÀ]Ÿ÷¤wYKƒ”.€Aˆ?{`y=?DÆ.oü‡Æeƒ#ðþæKÞ ™‰"MÖž›sJšÓ˜öHÖa4ÜQ­v'„KY•xHºù‚ñ2-x,«–÷ ¬fÚA cwV÷–Ðæt7Â9GVÒjÖ1Ç’BÌ{†Š,Ũ@«ñ«-o_ù{¶Amƒ$ššàí¥€àq(Ú>4¤‡¶–óuÞº3#™uv¥ °4\•¢¥w‡ÝÞm|ñêæâ ´K´N¡±€‹‚ Xï.>~xÊ¢$^Ü;Ҥ׽¼X\_ü›KÁ é$ˆ ­¤¬¥]Á%ÿÖ…ªah ’G{=ÃXb©ímuS¢ì˜±÷¯>¼™AU Ž2ÄÐ0/Q@›w.G·b¹¯pŠoÒºN.^:Pà\>5 \bù–T†C44¼Ö˜OI %–žÐÙ&¶UÓò>uµ©êŽÒYM ”L«:´.¿,% nÅKXŒMÁÝâ \î·i“ÑðÖ¯žÒý(àãÄÈp‚|‡O{ïö(ÇKt@Ž€|<C‰¦”Qò””Rƒ=Èä»@ÅØqå§UC ÙÃ( ‡…`ðcG˜ÎC•]â"±›@À{—vâ©)6 qì‘€  ÛH.FkszÁ¥Š‚}‘skP_ƒ¦_¨·Ê„m÷£ÖA¨ ÞMªCHöªuŽ•%†-_s‰HY²rÅÇ:í ?·X’kfÙêa.iÅ:«Ã÷7¿¿y=ïf}"ÏÕB‹Ç³¡øÂt.@O)³Ö}Q;°.W™~%_Ø6‡õ–%`À³Õ´v·Ñš£¾!Õéà 3%W@eá ;ÄÕBR€ ¬m2Lð'D–‘D©”]kaIŒá©‹¤’‘ 5µƒè¦ëm8ÏB¤€,köٺ͑˜’ѧ)‘Ò.âæuÆkrWF+¾RX¦#ØhŒ’åÛªÍüSÄM¹PÓíîÇÙŒ”'Áÿ19£õ¨[4ÜSɧÀE +<ÞŸ>/vY<ÊþDf|EB@SÕw?¤©KúË"Mí1ìˆàźH–[ÚpÄ« ‘­è —±/ªàÑSÚ¦q âä4tê8T|,q<¸M×»öýÌØ…W×[´¶Ó)dwhZ>#­Ïœ Ë0 ô¤œéúšy™·¹Ï+q j¨JÔ\xBäæç*ƒŒ5uØÖ.E¶Þº©–Z·P2´è8ÿ}Z÷RÆ¡kŸ±ô~}÷ÓߌÜç¡S†ät¬…&ZL…â2üçó¯&šˆß]w÷<[ !å°O(Ëǽ=nÈìHIq~³¤d”ø.Ë?f§7ý«IƒØZfM<ŒP+þàå¾Ò¦$×Mõ9°»-Ùܤ†FM{·ï¥#ߧëÿ¥w>ç:Ô].ÔQôuZg§'aLÀ¾z¬ôwþÓÆ¡xtJ¡|ìÑG§Ä©Á)ÂùþD8½bjÇ/ºáS"Obê¸Hé1¯ìÓJzSºä ò%ƒ¬%Ä#|b©|ž"ÉžíX/ˆâ°Í°‹£Gõh3‹á8}£ÎÓõ¶Ê×n¬);V!qb¸ÌOJ^@æd”°Íwnö~¶¦„Eé×`/ˆ÷퉚sfsU½ÉPðL{[W»oøö"òÕ/~Xr¾éΤÎ"áºK¡à/Aã¼·3qf¼U%ôÔ- ºª ïu ò‚}"@ù&å È3¿ žÙ¯W`wÑѦö;z•rTÝžù} jãã¨/¿ùy lËtiì&û†²ìÀ(ãïˆÏg2³+A•†ZL“ñIOi¡Ü³ý† Ô]^fŒ^÷ÛŒÿ_ÐÇê=%fc\N{ÛÃ.æÀ°Ŭƿ ð'»¹º,L±ë–¨T|ëÏÅÿ™¦@Žþ)%r@…ˆrÓ©]ç£vÝ@÷£Cc£vîûËäX·*xù/Øžƒ5M°ÙkäàWØ;‹ãñâáó) hì®`ÜÀÐÁ¹—Æñ!Š‚’˜]‹-VsÆ ”äXã *ŽRÑ×%=¡*ÃѸÌM)î á”Ç?ºhÙV"ñ/á7 7 †Õ¹žÁÏôíwü£$é».šÒ9²s¿Ì…°’'¾Ì ôŽ=j—¥%ȯ茗îBÞlCh䧽( ¯Šã,wYW`ÜßSÉ­œ5 Z,Ãm€ýΑa(¨ø_Ф:f&¬$þ_ɈßÄ嫪p&œÌ×ÜAÅÇÃ;$![%'¾›ÿkc U2Úµs±ÛµsñVήΊ Ìá*ˉ×ú(v­ž ‰@¼M_Púuž?Á_ª.Õ k¥oRøÍ(/R@ æ$4Üÿ‹%–øulîc߶:Ø3Ђ[Ù0À="R&ÐÒø¿)ÛMN¶¸ì÷‹’þîŸB“ï…>8ç¾h^±O÷ÿõÃHÅdáwŧpÌÿ²Ûþû¥ Js¹C ¢“XÎ|óšyyö½[à"#I`£9ÚGãoô¯n.þV—: endstream endobj 1700 0 obj << /Length 3692 /Filter /FlateDecode >> stream xÚÕ[Ksã6¾Ï¯Ðe«ä* &^|¤*‡l&“uv=vÆN¥¶&9Ðdq‡">ÆãüúíFIɲeÏÖîÆ! 4úñuLî&ÁäÇ7Á#å_oÞœ½Óñ$fIªÉÍrÂUÄxÄ'a¬—|r³˜|œžór½I›ì6˳æáä÷›Ÿ`˜è ÓŠE‰š¶ÿ7'³(ˆ¦7+s2S*žnÒ*Ís“ÓWZ¤ùCÕø•L©Œ§EÙ¸ŸOD0ý|"ô4Íòô67Ôï~e êÐx²×óU[ѯ¸¾Ü¬Máˆ,MÚ´•ëSÀŠ'3·ÈX¢ZjeþhMݘÅÉLÄñô·@Ø80ÿô¤BVù?"Ãdoç2a‰ˆýÎÏ¿ó$ÂøË)böˆe*fŠ'~à·üTÐÊŠJ‰N¡žÄnóØšR±N¿dëvMM•õ箧¦ªÓœ‘¯"NÆ,ËDۯش'ÚTÙâU3©¢!¯p_3ìô8 Îîp(|’A’²Ï 8A1¶”S龕+5v¬,û°$ò½&éEZH„ âvU·{j®iDêú·EZ×f ¸èuž'X¡bA¬w™u$ŸXï²I?‹Mñ–MØŸÌbü_iÃ"q†JÑ®oMEõr ¥ ¦›ª„­Ô¦¦æ} ÍËÒ ëi3öÞj3Ê ºÔuhJ*ù)1K…,jÈ,$ âæNHz%Ǧ¬Èš iaëú„OÝ1IRlÛÇ ìi*0ùýT¯a 2â¨3¶ 5¡ðÄ¢ÞÊí<µ£Y, ž2¶mL»^›…%$`` )ZáF-;ã`¸ïî”Eü,s±=f4:°RV”T7Uem‡¦cÀ²J³Új>¶T6«´¡Ú<­ IKÞÞü}Ç0s ˜qÅ¥hLž6~ dMº6 H¦õGLh¾uGqO3‰ ‰ŽÓ#­—b ï;sŠä¸ózÁ¤7=ÿîòGœTŠIŸ:4i8­p|jë´ú´ït$g2ê»q„Ó+Ò‚¬¸#gD®#é;rü²ò•ô=~o¹Œà¸v9~¬†ÐüÄ2r¢Yîe 2kX¯ÉÜu»»-›•Ûg¶î6º Û%xÈbÁ‡J¼6ë²z8 õÌn(Âéû²Aã¥C§kRkdZáÛ 5¡‰D4e[Ñ»~®¡Z˜Ê® ›fcŠEí~*F}½QÇF"z£^V5µ·`¬¢mÐGžŠ… K*ûTð{Iè$êŸr<‹#¨rë([cìIOÆdwæhzqu>X‚óµ~ñ1-~¯aà– •‹_.®®O©nJËYª¢o²l[/|?°_…ÅQð5/‹4Önø’ÊÚÎ×ím‡åK&2G8—??ø£ šHw4W+@ {NÄöU=7$íV¬p`ãöÁ£CkÐZÛJYä®×¢uºéFДƒ¸$.L:øÝ“ô=^2a<è0LÏö!²[ê8}$¾ Yé¸>°0ì{>˜ž?ÚI`8£„«“XX×YU ø9­2´±õYZÔ{¨;l –îs™6‹= ãB2Éå×@}W?|¸°Ã¸yóÇ<„`Â'"‰X ¨8`*ˆ'óõ›¿“ü.ƒÉ$žÜÛ®ë 3TòÉõ›Ÿ]þcΰˆ€(‰ 3»‡˜J…_è]ÿsÏÖ¤ Û_ekR3ÎG[ëøùlDG #âiYÉ[³bj@wáNàÌ ÚýPiDpÔóãLƒMünèàKѸ›öÂEˆ)5ßomhxW™žN~wñÖÛè`úÑ‘ÅٳŠ5€Óplê~WhO‡}Ð]C¶Kç–na—”|ì°Éy¬Ö«²ÍT¿u#¬· T6ž,ÉËŠ#Qwu•V3‰Ç’£¢kµWÈ¢­Nˆ’ Ÿ­f:Ùêqªq€Ü€å«‡®'Ú"s­åô¼ëžº^©³3`;JŽíçjK ¤DÈ@ê_Î0žÀbRüYü,’]·Ö=‚Y<ð.Ï˹‹ÞQöÐÅ ÇIlpU8_ë±"VHÌ,ŠŒŽ³\Uò„9—q! =×d³Hðc¸62›ñôyXˆìì÷·þ‹1„øA0}ïì 0Äó%1_lùFᣔ,Œ’a³)댖 …oPRLCþ–Z2W¸Ž$ñܱHÄÚ{ {l‡AU-,‡~5*¦U‰TîÏæeÞ® ²Û)z˜ À„V&ÐÃ%j¢eEõåâ'@iØ(©D¾BþÆ)<çÎ*cÚƒbb*ùT®+>tMâ5^õeR:ú®·Ä§£ÓCy`×ß_" ¼ùþoOŸ¯¹K"@`§&¸˜H{|£Âf0 ½îà€ŒÁ›tþ)½3»ûw-K×­¢ôqV¶µK²¢n0r~,¨q†cTÝûÌÇMe¶‰×ÔÍO^#Œ¼:Àö«Ëoc¸ŒR~5†+ñ ö_ç1„Þ[åâ^èçq7ï…ièbòñ0!ÜŽ¾žx‹ÿñ†ý$ €è(1žOÃô¸>,Á©Ö`±(ÁôX®ËE†‰>¬×åÚý:‡¾åœ±i>lBGl®\ŸmZP ðfôÙ®/„ÃéÃp®íÚ˸Œóy®—´IÓ¢M]MÆùO{L±æKKúé· …™5-f”dLùi"âv‡½<‚€óp½ê™7îÃâ èEîÙÞûíÙ¾ùøëزZ×ûVN ”¶§Š¥Ý ^<&‚ºÖÎÚ+T¥,ìĆEY˜á@g›±öL°fè>ßÑñL´î€¶œÈ]}mç_ÑGæfõÐë1¾ /£.C&céØ,¦ó•™rMÄ%ÑkÐLLS“ÎWT#± _é…,ILü 7ºGÜ&«©Jµgåàƒ7õž8#´¯4 Ž˜Gc–I4SRSJ%qNc“VÙ“oå±Íé9°rñÃÍùõ8`áËVÖŸM(ññpa—W7ç—ï¯÷guEuIºecµHè^þo˜a"èÐ-ÄžÄdbmiqíÕt—^Eê.ÿ'ÞO#Å´îÖüÓå_"Å ìöyÄŒ;ÉB­·ö@ Ò-ËÊQÄB­‡Á™âppƒ_vÜ„ÊÝf‰0ñ7Ça¼öÈ™Kð†q¨-”æR¾B%×À¤„yc5!\Žôè‚ N) ¿ÊP×1ûž¹;‚ï½ã)¹H55EÙÞ­F™zw«¨;Ç€Už¸[ÊX«þÚÿèö ·atªçÍp›´îînö7êßæH7ßÞu§îq‹˜¢e;ˆÃÚ4»÷–ž^aËoBHç¡Šp"P¼Er;ŽÇV{WgðU•mƒW%»»à ¡ûÃæF‚%DCjè¬_“;CÈ•%pwañ¾\˜÷o÷] (ÀZº¶í;†þŸG–¯Â€‰8þ ëW!ÌÅ»øuïfhWy4:gë%£Èºe¼·Ÿ!Àƒº¤æßa«ux¶­Þ{~“R(ÛKîú ÷ð$ÎwŸ¡RáÞŸC#(•3„Ðîï}°NnïM©»–`¢âá¶ýÇÑ Dpˆô¦ýXÈÛ6%Œ£ûÆ_ ÔÙla ]Ä]n™¦G‡Â÷ó ÇÝíì`Â::´íš@Çð¶6›ªÛ¿p± ®ñýÈ%%õ쥋݃½x!1ªŽe¹ð †³½5Ë´Í›Þ%Ï>ì3Ý¿ã±÷·ÑVXÖ ^(ãšFoÚ²6i¢“ÿ‡‘n¾ö^€è`tìK÷¨á…ÂÏ;Ž^ÿJw'ÿ‹ýöìÚ—Ã`(G©Bp8SÑAôÉa™½½ÐmÎ…s‘ XD½¬¢íAÇ€[¿Á xOa/¢é>·{fA+û4ñµ¿Ó†·ƒ¹dzû¤`Õ4›oÎÎî>Þ–U–²euÖà_ÁŸÕ󲙯ÎvÏ¿G0ŽmÊÙQôÉóò¶I}9uZnð jú ˜‰"¸Çá³ð6ÔÝ¢ym;éA/—>ØŽä„b?<Øö°²íó@ŸRÂ9Y]wN°tºú£ÿ«@þgïø—¢÷©ªí;¼þÀ++áà=n˪è”gÌš8¬)3±½ŒÜ^4 è(k¶hæ¬]Ì,Ú³»O+ig6 âþ–ŸMõ93÷‡‚è%‚²Ï”ˆIZ,ˆ=‘f!èñL–¥´¿ Åý76Ine endstream endobj 1742 0 obj << /Length 3821 /Filter /FlateDecode >> stream xÚÍ[[sã¶~÷¯ÐKgäéŠ!n˜Î>¤›MêNöÒµÓN»Í-Q'é’ç×÷€)J¶ìmÓ'‘ pœûwÅ“›I<ùþ,>ðû竳¯¾Sfb¢4Iääj9aRGL³IbTÄ›\-&Ÿ§ŸòMVÿÜœÿtõWè΃î‚EB  eû}}>)›¾½;gjš—ç3o÷+ÿ´]åôPÕ‹üœM뢼¡†¢¡ßۺ¡wÅ"_PËõþÆÝØ]“×ç2ž¾‚¹â€fVf뇆ÅÓÍ®Ù:îûm^/«zCtch†·w4™¹MÌX¥*¥­”»M^ól ÝU<]ž³xšÍ·U]ü–m‹ªŒìÐqÄiÐw¸øªv|ê³5R ó|Êš&ß\¯íZ€ø&ÛÂTyCoÿŽU<ÏËmIJuñ›ï„íï¢h ÿõ9§»m¾€þ g<{{uöËÎOØ„%,Ò‚Oe"‹É|söù§x²€°ìH¤fro»n k)!áy=¹<û›SŠž”…ˆTl& ån¯¸L;-‰`ÖHMjT*ÿòé{¤"*À(“x\¼yõÒPíú½R&—"Š…ñã^Ƕ¿eD¶vÒ!%@Ý¢l#³ÚµfȪ»sì,Öð„7ã‚G¤B2dÊPEJj¿|o@J^AZŽH‚Gšódi)I"ÑÀ"~D‘r ´@ªIúûJ‚a4C£§U¹CI |‰íg3õÝ5gå‚´{GI •îKÊ¿/¶«¼mÅÈ@ŒÚôÍwg ò.FN·þ͒޳ݶysz¯*=_çÛûÜú+èÿÍ»oÝ\/>¼Ë·ÖÃÀ#r¬S7èS»µRøµÜü9© ´¦^´¹õ.wdHIq‘už5·n%ØLæZ÷ŽSØ‹åÀ¬‡$Åo~vC—£àcÚz%êz9G Xíyµ¹%Uý×}5ç,€‘NX9SGÕ<5‘æ昿a„b¤%"ùe•œ¥j¹‰$ë´œv Œ¿ÜýŠÀ •‹!9›qÓ„&£Túípž[DÉDù5dãÄóž5…LhëbɈH LTš€²˜c:Jó; Ô¢ˆÑI•ü~'Ý‹°ù-å±w@ØÖ%¼ â ÎV~,Ad™f 4&+„÷ù®®AÕ=­C‘2£ˆqÝ7ÓÎÊÆ!oâÎ6C£>¨=¤½,㺣x§;Ê¥[ÐÖÅ°ÝhæËãÚ##cs›cÚ Ð YTÿQ‹¶ïtÈ‹“ÎÀ/£o¤+ð®é'ÃÌÕ15TûiO] ¹”N3œæÄ "Í1´¨SÔ…~îWÅ|å ŸÙÌѯ¨sP×ÇèÅÝPw8è¿«Ø«â|z]m+z™g ÆC|Ä… ‡» [1¨*Τ ›I§i§ø¹XR»Uzl¸-Pw(˜Ï‘ZäŽZáæ¼q½hÁO;z”lP‰Í¸ÞV5.Åk˜Üù'!¦eµ^W8ß½ÍO° P “í½5«j·^ШUµ^|}¢•ÄðlZ¨ññí§wûÖ- &9Q"ŒVÇŒ›G6AM;œM¤ˆ,¡D»¸pñþ˜6ó´jù ½À—WÿæÓþ%è±Ôü ìP*A ßßâ囿üøéØ.9ð7íí²@­è4ãõi»7¢ ãïëÞQ>«¨sz³°øòâ_oG@ (ç AÜØ0ñ|þ²)% ”žÃß?¯º4×>¯!⟴io‹ã»æ¦Õâ ìš°›D¼h×>øÎSÖÏ/=Š žõ|³Xj èHÆ-º­Ï…o é.§èOyÙ¸PRŸK ߌå ã)PTŲH+ é±¼!…¼· íveˆaòûœv³*nVzÂsXø° ×*ÂsâöNa“˜âF5ÅM Æóyf#91UrôÀÞê|±›ç´µ-6ù@ù|)j®}ÀaºÛÞîªXØz[åã“°Yi=œ¦Å,–ÀªÎxÿ9âü9À¾lW"{Á³½@‹5‹ ¿È^6ƒˆsH‰eÄ[= ~Ûô4µq|©³Zþ¬*¬ë HÍa$v¬Úb ²±to@Pù½TÛ *}z7»mæË ª3œ#á6AÀ–|‰{™Ï·A¦@nòÎæUØu±£ª&Ê©KW›ÄæÛUÖäôxíh`O2É>{ÁçËÖÞßýøîãåX wËÐlþsvcë&) °é“ãL |LEï¿ûð}›àM¶U \[w‘©³x°¹•eðÍÙ'uAžsi¦÷¶ÒÚPóAÆãÇ9(C^Ú;ž^8B¾Pûj8u0Ù¼‚¹$ó¶*ír`µVIh ýý÷U}Šj±}üC{ßã_[×åªß3n A "®:o™û£uS=¼Ég*kﮌ#6À;$ŸQß•ø”z¿€ É>8CØ'—ÄÛzò0êÈ°V¥9f˜¥?ãk=ÒmV£Yû¾6>b§ªòç[U¿’{Ñÿâ’uœs½žnË6mÉyO¿äˆÔôø ,úÿ¥Â»›ËŒD1fA]p.lÃ2º_¿ôkç…)¥³+¢”Îñ¢lqÇ.àÉ8ã‚Ã_üF –¯k~ÀØ‹=Ü<éà +SóýbÚ!Ίk ¦á>žàBÓtöÎyÒæ+@ötø¡ñ± ³à»j}G64¬¹pN 8¦?‰#˜ñãˆ"åDž‰PˆÙKEª"X­¥”h~ÀÙ<ÆO¼Ä€åÉGùiÏáöù¥4#6d—ó3È1„+túiá6ë ÔÅ2†Õ l>Ìøˆ>ñD¤Ét©ô8RD•XHPÁ—„fGÄQb‚¿ HEBï¯ý›Å™Š%Ó÷*0ã¡fÀ÷4€šV K8ÈÌ°¾÷ñ'ÅKŸ0 òÉ>þl³qg4øÞäù—ƒƒŠ±« ïüQ.Xù¼.nÛäÜb’ØÊ“>&Q©¸ÍÒ4°ÿ–Йî ×÷ÐËï3öó䑲‚r/$èô¨Aù¯­]9ƒÝ# j6’^§=’ÝVû×q€­×Ú]È€Ô¹Dê¶xÖ+St6k«®ŠQú’Cÿþ)~B”Ò£Ü?ÅâH[Àð·È$éd¿ºNk¦Í¶†¨ŽÝ<ô.r[Wë5Ín\ñé!>Z·<†]ë ‡Vö\Ÿ¤Ý¶4ù/»¼Ü¶Ö¡U讵|Úb˜!ÄÉËÑ–¿Œ(ýí\Ï©ìØ\4Ñ̓eGiýöµ¨•îÇòÉÁ]¿–¡’‹g0T¨(Iž^ͽΠd ¶ê«±÷mew_ï,Â*„t75°½Ãçv¤ÛÕ+Êís€Ý ¾Ù¼kilŠ¡›*wwÆÈ(6ÃÓ›žÅ ¥¨¾­|J áqç—s{·¿twÝ·àb6~¯\¿àÚ R†ßÞ^ÿµ½Ë»Ù¤Iõ“¦‘ë#Õr´rîp¾ÿóí;RÇôê Ç L¶x Î×EÞXú ¬Î·»º³‘[¥{±s³ÛÜŽ <ã†Ôƒ m3ÙÓR@HyÄQâJû“®úã¥O{9ï L‹ÅtÈ(z³Ú„ÇÝÓBÔ‘¨é8èDó‘²gÈAÁ쯘¿]˜ ãxlþ‚53…G±DHpÖ±j$Z3¼ÅMYšöyæºTïZd,b°.Ÿ=ŽhŠ~ÒXºxé«þ-þÃ(ÙJÂÅäEÖÚ8‹;!A2•vó>ùv e«]7è(«9w:ì —fý~.݇Öä(ƒex§F ú^e\*›#`‡M°³¯Ô3u€Ùª£3ò¬.Â@ƒEXàçS¡¦nf!YQ6ƒ±½$’¾dn„‡9#î0èÑ&<;×iµ› #mÏεñQÞ/¿ÒUHlgE3¹¾nxF¯×YKŽUà »þŒìfä@3S¸# Ão³³÷Lð^?­žÆK§PU –Bµ†ç>×&Ò©DB²-y‚}…g/°¨ìÊrz•q¹ üö±“Ýœû)‡ãûØÉ©Ûƒ»=+êr{ N³ äÂ1X¨ÞàÕ)I endstream endobj 1639 0 obj << /Type /ObjStm /N 100 /First 1007 /Length 3001 /Filter /FlateDecode >> stream xÚÅZ]sT¹}÷¯Ð#¼èJ­–\®­b!°¤Ø…¤’Í.{ðñxÃæ×çyd¼^{f‚ïÞTK÷Žnë¨ÕÝê>’Ï®g|vÕø hxg$g6¼ 5±!&…ÀF0YÙÙGS\ë“Lí'<9­lAˆø¼‡VÈÔ~űP–¸uç,Þx‘-1¾hû5qM°D#>¶V2"ßf#‘ŸeQ#))Æ´µI©F }xWs0¥œã!¡•8vÆ;Éœ ©rˆ€™ªpˆ &”Ì~˜p¨•C„h¢oóÇL£4wŒ hL&¦¦ Y…-5±8*3k¤äXMr…¿Fê&'Ŧˆ1T+%C_©é+§h’&~‹?©TbNÙd'íW5Ð#¤b0—&¹`䯘z¦Š5«#‹É¥©SÈX}ÕAé>UE+C…˜Šz,+^´¨©TÑM0ÁÄ 'h¶ðMm#áUˆ òÙ+åö2jlÚ¦¡(5‘“)â¢lJˆœ¿zS.Ìj+Í"2@Ãø…FŽÃÕƒmT<ÆÐlªÏí[55´µÕl£ÁþjRJ)ÎTu­xSKlïÄ`AÛ;üqÞqà ÐÇ#2—¼àæB郹ܓ†7#çR¹Úì¸BóèLýWôò¾-qûЬ>äc›RÁP'å²—×ö¼:6i%…b}e/å‚Šƒ=ú6¨¿°é\p4Só³†?‰pÑ”3ÅtÚ#FúdQÙ;8Ø^ýúin†§§‹ÕÞpxþU{~vrú~oøv±<ž/r îõðÝðtxø“o{ÃËùÑÊü½Ú7‹šlBˆ€ÉÛ;Â:ÚTý˜ƒ3šáÉâÕ ̽§xõìç{R~¾ß|óÍþ݈h´0‡˜œe¤ ®ZØðàùFŸ?;|ø`<‘Šèb° fp;€—ÏÿzG0«(jæ%ZÁK-VSb›ÂŽNVs{|þ~±_ël<$ˆ²Vá4DO‚÷VwAâüx@0¸EXî‰!Z‡`ºǧå¾KãÙF ÅÒ#‘ XªEì0<«ßä%~T/ "ØÈØÝ ro³Øa6É£âÈÞ¤ˆ¯–á5z±‚• 7ûËÓ?òó½F "ˆ[¶ÊìAÅFìk!ãYu: ÑE[±»„¬ ¸c㶂œq$ˆNÂbJ¶eD¬»Ó&wb× C"ÕaÈà²äb6ÀG‰®ÞáðÇïG´m@Øf‹Ø‰%Âs…xðœ&QAŒX÷BÔj‹†Mîn׸f뱕 Ó¶ÙuÀÖⱕ •€·¤Û#çòüä?ûÈÙÇŒáØW[6,Åq{sÈ,Êv,³ÇËó}WÆ Þ¶ì áœù¢0HH+fh¥“EO”8-ZvÁCEa^ÆÄŠÌzVjA”IfÅnÒ’Z±È@§ žÛW„×3eYˆ¼Y}uV\šnYbª–5 úk@ƾÅõUy„eD?g^šáo?þ…Š ÈŸÂOÏ?|x}kG/ɲ"C•i#j¬«½Íðpña±<ü4;š›pñÍ‹Ùj5_ž¹xüÓçÕ“ÃÕl5§âÅÞðxqºj°'Ö®ëÏ3±­®?p<¿~À UÈú!›”z·ÈÒs=Ðc”ÌŽ×ÝP4ê¥4TÐõâà^,G‡sh`=6ëùç•yýÛ{1{;ßÃìNWóÓÕkÊ€ër¶8_ÍÏ.*ÓöîûùñÉìÛÅgÓ–’l’f¬Î‹Ù_³¼Í›œaàÆ O£Ö éÐq݈ýM¼|“z#÷†öFéºn¤>Vêc¥>Vê’S—œºäÔ%§.9uÉ©KÎ]rî’ó…ä×#íÝR­",¡´Æî +¢Ä,P[Éñß¼=’á˜(Ò„!8Ëï¬pD٘ܦQ“[„?ReXS²ø$"^3ŽìdT…â—#% Å0§E¸†fláH¶7*¤Ž»2Ø!]4©$(@r`aRÅs.ÓYˆ¢4Gœè8"<Ç“àÛŽcd ÁNY.ÀTkÝ d\—eiŽ˜•4Ú nÊ ’»Tâ­ùþ8[÷o“L¯¡YfÊØ?IY–À÷1MÉx¤Úä(ˆ$g¬j«ênHî–w_[™-©QlÓpRròѦÁv?YVÕ’Jú, dž ) ú,*5ÝÌ0ŽKY0É&½ï‚e"2ðqD´/~c0Ùe×åa%…‚ Ž¦<”@°/éæìÿÏÏ¿qAß’Ó'ER 3"M  ¥{˜.ÝVzˆ\â( ëäí8ÆåÔ౉ÔQÉ–çLd‚¹Às]¼9†Íÿu>[,Nm°iLWAŒ€I"ùiÛœÄ`KцÌmÖÈÈd< -_€ÔFßìDG]Ó@®Ýq„¤ØmÊN 5ñ ­-%EËÖæºBj#ÖÉÔ*ã¢^/ãz#ž»Q‘žžN›}áÞ–º””«Öv0k‹ø —%åK;„šÛÙîV zCɞˎ%ûÕŽÞ¹‹¤œ‹Qd[ofŽpé„Œ1"-ØM6 .£äÞMväÑUÞ†D”ûpݱwG ¼ú²­÷šÆä9Çô4Æâ:§q•¬Ø•à@­ãÝ8 uî÷œF-_ÏiäN&äN&äN&äN&h' ´SÚ¿Òþ•ö¯ôò«NAh§ ´S¥S¥K.]ré’K—\ºäÒ–.°tµ ¬]Nírj—S/åt„ëe~=VB”­w¼ ã­ dÎÈN & Ó•·P´œN€OÕ`„; ã¦ìkfM;\ò0Óž&í ±^ÒÓ;Ð#§Cës8¦Mñ˹ÊdŽy²ý¿Ÿtësƒ`Œ¼ÿ ÏüÊóxÙ d}n ãÖtHÕY\#UçíÖt<„ÍN§½½ÒM5!aDí¦šXÜÝ湄F˜òÐ1!5Míü3Àw¦"–2Ñ#3Ë܃-o2ñZ‘SÂÂóæ#®?æZ‘*B ¤ET^oRÖž7âx1_~|z:®‘Â$.! †áyè&‡¿~$Š„é©-5Dd'ƒ sp¬u&Ùx{¼_󘱆Éì UväýLZŸÛ™ŸŸdEzÅëEQyIi*ÊËà2‘U©U½Äy[€Ïb†Ë æ‰K™ÂvÉ)»8ÍJ Ì*¼m§ÉòœL Þó…sD½Y ß½Y,Vn~·xuíò+m 㦈RÛ,YRIV¿ÝA>Í?|˜ï;7„+u i—I[ú¥†UwÚ¦’<"“]uí¡Ñæȵ)6Ôv·ñìvœ½;—É®¥ÝQ屩¸`«ã±œGÄH[¢cÚˆZOÂ2Á_Pl‰çõ Ftàªåv¼Ÿ½?߯e6&•Q`{‡mÔ=QøËÈÑ· ‡ÆGdZŽ÷‡æ=så…Äéss¤â@@X(äÆé«ÜfþÊÑÌ#{Øc‚yzò辑íèm=—6•áÁÁA`xpÄlk8þòò)ÿß{·Z}Ú†·oË·s{rº<™Ù7ËáÓrñOŒs6œ-VGï†ûw [I…wF¡Þ“Ï(6åÇùa¶\œÙãÕ‘=ÿxjçÇçÃÛ÷ïçÃÇùêälýwñË|ùËÉüß÷¯QlµîH±]íØé¤ÄëÀ±lé}q04þ¾TÙ&½ÛMÑ–îØÛÃÌî7JIÿwì ×õÕ$V”ß‘XÝדXõ’ÑYSDêJo¬)"]ohøÞÞ½{#õFî.ÙwɾK–.Yºdé’¥K–.Yºdé’¥K–.Yºä~áHû…#íŽt}áh¬;;!!OQ“ŽÄ¾¸v˜•36ë4ÝŽÚ8£d±5๰#Œÿw±7P endstream endobj 1783 0 obj << /Length 4252 /Filter /FlateDecode >> stream xÚ½[YsÜF’~ׯè}Ø0¬ÆÔ](GèAã°=rدÈÙˆÙ`7H"ÔÝ ´%ͯßÌÊÂQh°Q³/l PW•Ç—E¶¸_°Å/XøýëÍ‹¿ü Å"K1jqs·àʦÜò…ÉtÊ%_ܬï“®¸Nªúj©”L |ù”o7ÅKhq<¹þç/W¿ßüôâû›¼à01[ð…,•<óI¹Xm_¼ÿ-Öðí§|qÙâ£ï¹]ˆÔ8xØ,®_üÏÌŽ„)cY¼£_¿÷ËoL3.à/%hkÛ"ß5ôØ>ä->‰äÏ+¡“¼.óÛMAßxè^áCU—÷å.ß„Ùò¶.?…® MÖwmŠUµ[#Ù‹¥Õi&íbÉYê´£ NV,i+ú½õï<)6åkŸÉššü†°ëCóXâ40Kª–šªz]ÔWZ'éÕ2ƒ1o˜UÞ„A9Mv½zØ×á[…ÒÚ»0ÇÇ+Ýz©‹?öEÓkzE®6Eá òIAž©^Ô¨/ÝË»QFr$#ÿæ»·7?{ñ8O˜‹Tn"]•¥ ´„Ñ@ì J%•&Haaí¾Þáö¤0ÉcQo÷mÞ–ÕŽòMSÑS¹[mö뢡·~|/ à3£¡Ö»ºÚFMÇ0|ö’D¶Qé×5Æ«Ú·—ñKŠ”AC zöüp§SÇà j‘*}é/Æ]–jG3 ­†tL.‚§š»‘\ØeŠÔe¦þó›ë›ÿ}ýnÆHž '¿‘ÂHXQÆD^÷·¼;J¥I3QY¢ z›òvy!Å{™¾ù×÷‡ôJ ý™þ ôJrúrz{j¿)ñ¤9Üe‡1ùÁèqW›2ÓLzØQ—reÞ ú˜±îñÔ²¾S93‹:Åt–ó¹ÞjØå<ÓÑàÄW`ºÒ&eB\Èt »·‘’ûºXJéR&c³â Úq,Þ/…fÉõþÜ™B|ÿ¨¢‹šÛµ‘9# nj Ü¡E*U.,­S•‚o䌱äÇÄŸø§ó{×Sîîé­³ SkÃ`“²—hï lç üFF<ï.{î¼â4yN¾uzÄÀI~0µÈžš;r.¯ø œ"5v?¡ÏX€K"ä 䇂‡ä5rÅÇE=Wàm•ûf“T(˜|³ùLÐíãïc]aõg¹F—æ¿|¦ÞaþOs‡5ÊÝã¾ ½*jê{?æ«ù}á€p.ùþOœ½èÇu1€¡ý5¶AP•´àið¢°ÓÏ tBµœxóÇZpÊ_à40Øv þéï=vR¸ ÄåÅá×Ýî›–ž<•Â8ìÖÖóÐ7Ã[Ø$qvû-Hf…ñ¾Þù¨gÕB”÷o@Ë$Ë’·UÛÌ[š>0 Gíw+’dÙ~¦¦îSµáRxfnæµQðQn( DÍþX¶ôDû„‡#°][úzåˆÎÙù<çàe$SGÎÉÑhÌÅH£½iYò ˆV@Ä’Fl÷ÛÇf&–јTd mt5ÏH¸vifh& 'Íëÿž9ýbú€'@˜N-Xô/ÛYä/òNÄ;{óvÆœp0²<Š9v­OªîñØ+ Ê]aSxÉë:ÿ|etÇVK–¬KˆK4ú—)OæzWüö˜@Æ…ä´:„øäSÜÚfS­rJðuÊ]‰Ú\þ»ûrÎ 2ɉÉAñç@ìž6™·{ØÒz¨pm|êN:vë?O¾'»†¾À€I××aÁÆÞìå…B²`-Í—Ülj:‘âÅ…š²”@šùœÎžÜ zôÑ^ÀÌ*®’×›ö¡ÚߣñËT0~ÙàÚ ­K¸ñ™üh >4Lüfœ|É›¦Ø‚} ͈S`sA œ7ª™r·yXè‹rÜe kž+ú2®„DW¸ì)Ĩ¬¢…K ü>?§h&ˆ×;»ŒÈà£O$8àsCmëâ7ÆÄ®¯APYWP¸ „DÀ£Kª»Iç1üÑxBm²«Zê=;%!)àÙ ‹ûeDXFvˆNÆ ª³É µË.‚‚ èÜfM­eôežï‘˼‡…ôûËù.8C3iÆÇŒ‡míW-¤•OmH¡»Oóü )8ÖNéé†ú¬×‹‰'å+ˆ »`,‡$þ ß)ÕfÝón\j­š1ï ðjM´F{Yº)<‡-eØÇŽ^‡ñ1æ'aJš¨Ä1P)Ù“"ÏDÊ3ðÜÌú€æ"ÏTšYšIÃL#@¥'q·.Ñq6´Ó SnO¥õrxŠ¦°G–Y6B0±¹7¨Øµ™t ¦oœ»Uô{z÷håzve~ KGZá¡Jl'¨gÍ©·qê‘càRBRŠDàï³Ä×˽ºÃ°Ï8Ú3ñʱƒ/e‡Zò`™pK1N !Âç€Y"A„Yâ GÖ“Ô€+¹ÑÄ4ˆ©„îc5 ¾:1— â ¦ê:_ Xr…àûñXZ‚¥’ 9ø F×Ï·0ÏV4“1fK?x±Ôšÿ4\) Œp_ƒ@ËS3¡ïÿ¬´'p3eRÃäW W)çaÞçÐëáJÔây¸r)!¼abj'gaK'O–"Uî(l f {&ly‚ýœˆd mˆl3ólœÍŽf²Ìž[ÆÐØ!óâ=„ú"&ñýi`ri!0|º…˜Q °2{È1‹ ½ Y¾}.â@£töüôJÅ¿0«’ˆibÁç-)‡8J°쒲ϩýX‚yq&«²³,)–[{|¢C¡Êû¤Ýkôä,ÜtÐU—½Áclh²7MÅNß^¨îÂ’éw]60ìÆ}Û}ü¢üLHo…>ôé¢^=æ…"ã©6Âõ®ØæõP­÷£ KAá4…ÐFdßBË}ˆ‹:Tš:Ä8ŒÍ»ÄøB¨€ÌÂq—,ÑàZH>-øE’0ƒÔ4“àç)¨ÜýzEâ!5[_xtD泊cÕR n|B]¾ÊÄ„ž¬–ÊTk{±­D~DEЬÁð9cÒ°a&¶!Ë͆ „ûbWÔ¡ä¯ëòuïÎçÂÎQ¸xi˜Ì剰O@ž«8wð× ¬ë3ü”¢åp&Ñ#,§Œ•’½jÜ«ôk¦ryTpÿå¿üz=ƒÌB¡mß«Í?øêWCÜlªmAOwuQ¬1òF¦úD ëL\Aè¾CGÍ!{ÐÐ’ð‚{gy’6côo‚•|àA&º†j„¨+>^Úq¬Êb·B‹ãqc´Ù‚'«ðóÇb0Gõ•Âdþ2³“I¢;ev€Ýº€áÄââsÌ-‡3És½—ì@(#^@žÇ+Ž› ~µôùÄe<•BŽ‰;ÃÐØ!(Ë}É EÿǾK¿Aû6>_FMé(ßXŸº,åq©Q‡µ Î. ¾Ñš¹.…ÝÌ;ŽÉÇ–ž|G!*´7mõHME ×ÔêË&¾5º="óÉbc5mz‚V5n†dåX•¹¤í5¸ |<ƒ_ò;_åÃÎ9ý`·OžŒ5uéN~ôº¿M[<"äm…K^oîᘴÛÓÑN'&‘…ŸoTZihÒ>è?§\ŽÅÜ»20ðZš®æO9ýôÌôo=ßP13ëo&b{ÙáWžØ°›» "â']{&¤4&žøKø«ß ]À]žÞlØR}ƒ£ÒÌÅðå-ÌÖå;»‰‘»ÍW¨ðRw¶³®«º™C#†¢ýæÿ‹ºH·Ð©³ÖPÅÖ‚KZÂÚÎFÐGÄÞ Â›¡SÍ&^°ìÂåÄÌrÈj>^îeðÁòwõ˜u—KÒïu‡Ïº%S™N•:™¿²0ýõ»݈BˆÕ_ò<µ"XùŸ‹à Àì}CÖö:÷©§}è‘ GqéDø¡@Ühoმ<\Ïá-¹>0}Ìâ¹!R5·g`ïíïí,‹Y‚—°^ïý. ýÎG¦ß,šr½R´XÁìC±úpϲjwá–¡‡õÀ`H»›ã>Ŭ;M7pŒ8Bw/ʼiªU9„<ÇÏuL"{FNš¢œ•‘'î¨ÔÓc=fä«£>ý©ž¬–fD~ÖbâŒÅÎOvgn,Ξރx`RDÐRàa,¥òPÏ€°AËÀ™g {J ¢+’8ŽæõLJrSÌ°V ÁÔ'Xˉµ*’c¼M&cÔç›SÚ|\ˆ*btlÀŸH3^ê7&ôÉøãrÖÔ¹/ì31½ì2MîщUgÿ‚ +xœª*à ¥©“k ñ®”IõœŸX>.”t´k M WäæŠ=°‚} Œ¯9QxwÙa]xX +ÌFd~*e‚gñQÜÌT¡Æ¸Þº:Ë` +üÛDGáºÚ„ mVeÙPy=gœ•8Ÿ™¯Š‰Ì¢ïjˆÌNøzFL ©ƒ¾‡ì'²¿„“¦¨!u<Ë,7º˜yÏ'çÓSë3™oðOñ–g@¹Žæš¹„‰ˆ™Ž7þs´Ù9žV^èi¥‚°ùX€q‰?e:ÍNZGþ5ý©½h1q–6r%Rn|t¶f½ÚÈÈêÌ r;ÑF~–g”`m„ŽcÑYþÞKžŒÀ= ¢¤ö!wÆBÖ4¤´KÅm"¾æµžÃ,GŽ³Tüo9P¢×xƒ•CªŸãý+ì„fÓrMT ?UóC<؆ƒÅÁ7ºôÊéÆ Oh&@åÀÐж#m«âÌŽ>Ÿ‘Ê/†Žc) áÿ'…u^¥OVµ%«3–ô3“—Õ,|ê=Ò0—êáÚD_Nt†a „­d\o[‚$P÷Ý£ðìQø%éG—ÿñµ ÍxE©í;D¼Â…ò¶9¯¯ÐUƒˆü!4æR¯?^LepÀ æ@/^¶8ðúcž þ6ºþê2Y,ãLLéI˜md Z>¬‚Î[ðñ?Çðc0¢èn^‚JHP)jÈ3¢ÛR†ªÉø»o¢khت+Ì ƒ’D¸S ¯™ ösÜux)šá}Ó fb,ü£(¤ô´>‡õ]˜$:,ÆmÑ ¡ÒšîÊaSР Ð@o˜æÁcdï羧¿`æ#ç0ð}à)ê”g;>x–'ÜMS®ßÃú„ƒÁS@ìàÉÿ“ }õ¶±¢Õ<—ýº»ïø&ß$ŸáÛ X8j£ÿŒ‰ ‘þVAuד My¿+}í+ßµ¾ªÙ|_§ÇôŸÃÉ·`®—Â¥Y|‘4Ñ0ÿbö« endstream endobj 1823 0 obj << /Length 3076 /Filter /FlateDecode >> stream xÚ½Ëvã¶uï¯PwÒɃ'AÎIrN’f礓vÆ»i´D[L$R!©ñ¸_ß{ñ ²%§éÂ÷ýéì~Fg?\Q÷ûíÍÕë·ŠÏR’%‰œÝÜ͘H‰¦b–¤Š0Áf7ëÙÇù»º+K!è¼ÛäŒx#7UvE“wå‚«ù§Ss7Ýÿ¦”WÅ®¨ÜŽ]Ñmêµ}»Ëí`=ÚØ,X:¿/Èb©d6¿®ìŠUÞ@}wá‰e·±ïrûƒ >›-ëů7?Í–L©à‡’Le–Øê°»T–B*{¢LæmWìÛW0N<á0iNË·ve[o]YWö•%¦aqeG·n×ÂÑyݚ̂ÜíqpÕ¼¬Ê®´p“.2%Kæ¿T=\û¾†‘C ­G ª y4¤Ìr’§©¡‹§:ÆýjåÖXæáªo¶÷uO; ºC ƒ?5kP‰üÃû®fÍFî–Y3“zŽjƒ/sûs?:¸²§8©ÖÐÀ3“2î ¥ŒÛ®Þ·zµ¶s†?8ÓËpzý6IFª.F Ø[î|¶KkÐ$¥Ü/([«3 D‚‰¼­EÇÈ`VgÈRt~ûh-F0Ø7…¡©¬­±”‚Þùvê×`˜†)ÇjA(ìq6Ç8k¢Dv!Ê°BŽV$Dö@iŒw8 Y£[tSÀ vtß¡–ÕM O Ã^Úå1¥ aÙˆÒ%×éœE´†i’¥©_ØÕ–Ç×ï Òßß\ýq…JGglÆ œpšÌʉ–z¶Ú]}ü•ÎÖðÜY:{0Kw30ñðíìÃÕ¿ú5:4eÍ”¥djÏþ€Úa8f —„êž”u}–i š:n:ÃúPo:æ' ½Ü¿‰iŽÔ|$w’1¸šˆÅ¤D&ì|ík"âÒ„ªuhËê~bç+k*kût‡‘*_uàûÿ“{a^€Å2æ’ªøçÉùcjF{ÝûPæüoY ”«Ö³¥„ŒG…ˆÿe^ =Ç ˆ Ý€” g!EÕ ³÷φ˜%Ü)¸ΉdΆdÀÀo"Š¦€Iªw0ב@®¦éθŒC™t Æ隙𹙋<6Ó?éyDš.@ pìÏ8‘qÂm ÆÆŽÇa«è±¾p ‡è©ÂÈ“ óÛ3IÖë·àšGà‰Nz+¸þîÝÍÏÀŸ+6(œG3$Hª{aBÍ‘É(Ó„('š&ÜDÄõÚÓéÑõ!1[ %‰æ„0ç#ú‘>F=~“„NBFÇúcóý~[Av†šú8WîöÍ(í{Ò—iü CNÇÄA@I3ô¡ dIÎîþ¹Áìý˜"ÖÎzN¿üßxíUѶþð£tS·Ž–õ¡9mëlŠ'Ÿ‰¸Ef‰†”ñE ÆÚ¶åíÖü”7eOíë¼ið üÑË ZHxçÛmZœr–'bŸ3%F»!¢ð»÷?~xNáÒO‰JÕó´mEÁ|"ÌçÍÄv‚Âd™€¿MyxÔ—®‚[A&Ð?štH8ßLë2¥’ùÛò »`óÞËùÙ3Ì…Xe|W{8õ~ßkÛªA}Q:ðÐÚP×€@&2´bžX³:J’?ï (‹äS’ÈHª¸;Ú9™¯ÿAü#ÿ\î;d™z06=¦}œOÅ!0=‘b’RËŸF"0Ðtö„D—Ðwuãç¦ÆlV†ÕoWx‡‹½ÿ³¶|Ü[I{]Wn&wû‹|µâz¨rC=z®«Î}²ržû‚<1¡Ùý½¸ËÛndܱ¨®alÛFíéTõÙxÅÕS¸º3dßÛ¼9ûÜúÖ]Ñ!ÿ¡±%\±ÿ…Cõ¡—Ÿ¤à%ZÅ'l¿®0~¯nËmÙ=Æü)Äÿl –:MçåÝe°ŒH¦O†Io¦—¬ßø[€<2#ë¡=‚3¿#ã‹=èÌ°ÙÙvMy»ààç@Næ³ /Æ_@MGõ‚¿œ°`Ó£Ì×#˧‰ÅÛrWV¹kÉ,È$Ž*GÄæ•]çýÃ夦àCåÉø=ñ܉¨^7¿Ž¶öØ2‹’¿k/÷>œ7åý¦³/7¹¯¥Úr]´S’ä ¤éŒtxP?z©ô¨“”}–ÜIʵF vP3ækdE'Šh_xZaèh…Q@+×®¡obÎ ¡„N¶öŬÏÆ.â_• us$×?Å-• ÍFm\ƒ@×ÆYZξÐ, u͈H¦QÚô^„`v9~p¨ÜÄ“ß(°©#´ÿb€Kexr¥²©ÏÅ‹Ø„ iò‚Ø ~[¤â©Lc³ès]ê]½âó­§)Æ^ì‹{…¦ˆ6cËSA¨ž|a¹—€ïÊW¿÷%™1ºÔFîÔuB úð¸üÍ®ãLk{7@´x³ù;kÍÎ¥0Ã"—.NŽc áÃmÌyÇñsŽÛä˜÷º’xŽ#ßÙE6föSäá¥IpÐvåvk‡MÑšªp¼+˜÷×ïÞþò*vÛ+ÿa ”¦4›]ÖԧäöN{_¬ÆÚ ~5ˆP#—sm>¡óÝÁxIάCäƽ”+ƒ$gýw>qÓáÞt k¾·aÞzø¸×‡ócëá/²Há‡ÛÑˬ‡gìë¡’Öc±|°òãÖ8ÄÀŸd|X:!ŸtÁ'×®éW”öó¡»^¯)þ8@ ó}œIf2êž5Ø,óˆkÐB”„C%|ÊDdÌ"ƒ À}0,ú"rZF8S/2ÇLB4cã³¾¼L]²q½wº15­Ë4ITvò‚ ¼¤„#٤̣‚õÿaã¿] =Ñmòf0¡œ»Úwз֡?-ñ„ûô‹|ðÿSâ“þ¸È¼®ý½œI{L³¸XÆ·Ex©åÇ[xÕ·ÇC*l#«ˆhYg¡«gJÖ¸ÿÏpÐöѧ† ÄHv8º©ã‹¡§ððú2Ó:ðeÄ›˜o#¹ÿ ÛoëÑÕPà~ô×ÚEnµ®¸ûÄ‘'q?¯Ž>ªTý=„9õbG.(IGygL]ÖòònZ¹O-™[‡±³OŸùÀò"¡Ö­ž^q\Ðo Q%ÇKG—ê p¯Dš=Vñt°åû›«ÿ9ó”y endstream endobj 1744 0 obj << /Type /ObjStm /N 100 /First 998 /Length 2739 /Filter /FlateDecode >> stream xÚ½[]o\·}ׯàcòÂ%‡CrXb»r\¸Žaù¡­íEÞ¦Bm ­ §¿¾çð.¥8‘v…æê†Ä{ÅKçãÌŽ5˜ .ÖÐ\LœTa#:ÅÑ—•}br¥ö7ê,d6²k©±OCMlU%èZ蚦ÑE+G<ÎU%â‡ò‡`6³þ×ä$ð±Š:‰YÙÊN¤õ~ʼnJWä0‡˜“Ò8¯4'ÖW°‚Ö—¢K±Ï–Ä%QBNÉ¥dü«¢•±BÃè)+¾Ïl4ö Õ¥¢3`©UñQ2í3¨S1®,e§Ê%WL­9÷wÕiéëIæÔúB!$m™ïÔ\_`Æ,R0>Ë©d5"Îzé#çärí²ÀlÓ_³+Aˆƒ–8}[]‘Öû™+šú»æJ.s”€Í |W¢+¦”>+­¯£$‡ 'Ò¢Òç¼%;¬…û]Š²Þ¯:¼çÅ\­Ö[ÍÕ¹Ž Ê/jtø°–¨µVñqÞš•À9 V•¨0‘Yíýšk!²†oÂ,·Å ËkQ Ö¤o£Q…“Bæ-UBÂ~5í“š¡Uú;|1-ûÝrߌ&®•.èP+jX§˜T šÐjW§Åb皥> F¶®Ô #·¾Í†‘¤Z Â|‰Þ –kœ*æZH´˜ÜßbàÐ- [¿cÏ1Nð# 1-2j7*v̽— ÷Þ¸‰g½"VuôèÑÑêÍ/?¯ÝêÛ‹‹Íöhuòé‡m~q~ñï£ÕãÍå‡õåÛOÞ¯¾[=_=yûÃÑêõúlëÞb}ÀŠK0É¥Ò<´ú|N ݾu¹Õ‰[=Û¼Ù¸ÕS÷Õó'/ß¼x÷Ulï¾þÚ}óÍþýq’Å+õ0Pºoð %dàªû€ä¹q¡aF¯yºyF_òr8RMžz÷ồ‰Ñ ,"+žív¯Ö—?=¿˜ƒFñ£½Æ` Ôr†çWÛÿœ^žœýëÓå|HbQOÊR°+ô/âáO€,{“v+’—3Ǹdz÷{é¾ÙOÎÿ»žYR¦»F‘bÅïåQäàá?Õ ìþºTB ÄcÕÛAüò5sÆí€þ!"gè7l^U+žs¹ÝF_ÿìÝWuV_­TøfÕŠ Qß ¤š¡-©íõ2'Žky¤À‰ Z÷Yªx¾ÃNgß”dÎ ±cA@Qi^Ä–Á%ðpRÀ| ™(ÝæÁ&oqõéþÃ÷ç› Ÿ½ú8£ °QJM_àIa·ÞÀVÁ¾|Íû4DlVM­êÁhR¦Ñî: %Ñ£„²Ðæ"h³¾)ÐX&#ì¿ñ,uAaÀ<@A5a§ R)z0K€4@°–‘†æâIP‘øÀNÀ7¤ƒ†ü©Òb>,Iö$ú’¢m§©†Â§êB‚ɰvNAâ•D`€„GÓå­6Šz!Ë(2áoø0ëÙd²×lç/Fî¯q$Dú)ÿ=ˆc^‹I ¿Y׈BYzžyǬIBÌ°\æP0A.ðó‰épÁ³•?Δ~4ý añ )'ÜA>LGŸ’S*Ç|íVûû?\úŸÈâÉŧßßÙ1Â^á¸\2äkYõ¡+Èî<êͨd½ÌãÓo¸Õ“ÍÇÍåÉϧgk—¦o^n·ëË 'ÓãŸ?oŸlO·k7y´:Þ\l» Ž3AÛ}v ØÚÂx yŒã$¦í†;FºÍº €aõêrsv²†ð1ñÓc·z³þ¼uï¿ÜÏW§?®€ôb»¾Ø^qA}NnÛÕæÓåÙújÊåû»¿®?œŸ>Þ|v}§ "Amt¼¯N/ñ5”¬•©c×’+LÜ DÄÓëC»F:6m×ÐñFǛݺz]h×ÑH£1æÊc®<æÊc® $x!T¬“R¨ÛR4‡èïÉвÊtM¦ìåæçÄ¡ [¼+¼ÃÁ»"Ê+ï‡q$™ûÏý“"ú/ ó7/ëÚzÁ<:¶Ê°wþ±³Ú‡FV–øÿ x°Ã(¼ë¦€yaAC× L—Bö WRÁx± ‹Ø‚Ù#sfhÔ^#nªW¸£Þ4? ï„RëI‘ð±„yà $-j¼7ÿg_¬ endstream endobj 1859 0 obj << /Length 3207 /Filter /FlateDecode >> stream xÚåÙ’Û¸ñ}¾By“*'AL•Sµ9ÖñÖ®ãØ“äaíJâxK¤–¤v=ùútà’ºÆvÕ¦òD\ºÝè“Î>ÌèìÅ õß?ÞÝ|óR3ƈQŠÏîîgŒ+•˜E±"L°ÙÝföÓ\‘h±d”Òùë§ó¢ª—ûrÁây±N«*Ë?Ü.–‚ÑyZºÑr±äŠÎ“<Ù>VYµx÷=œ#f11Q$ñ:[2M(óüø_¿õËxo™`„3«íª4OVÛ´Z,eÌæõCŠ >?Tié‡ ÷ݧå}QîÜôz›ˆë›'[7PþBÛ[%UºqkŠ<8…ÍË´Ê6‡d[K 9ÿ×"„ýÉv}Ø&uŠ(Ì–jXd5ö6T±œ§Uíp¥í÷îkÁFµOÊÊ·WÉú㯠kRnpD4ãäÉ>øEùèÚI¾q]Z—ÙºrMºàjþË‚©yº-ö©_“yà~Bø;P¼DÁÆ›7?3~ÎqŒ¼wÿ¼£ŠViêg)_ˆr7܆äx{XUéºÎÎÈ*‚‡'ÀÖŒX’2A¤ wxyæÈÇÅ}Nzù§Ww? äŒá!ÁÁT”DQóßs-æ¾»$óðWuRgpµHhËúeêëb·?Ôéæ6DHGG”"¢…Ûüçj@‚¥R‘»_Ü+ËßQÊó¬öýÜ29¶ðë–JKáÔH`€O·Nº"ÝCIN$ä>ú%Qo‰$ÕÍ‚o'öˆˆal°ƒ3EŒÖQ·ÃnÎDn›t¸Y*ÌÝ*`ôñi†hvÜx®d=hÜ™ 1õ\t7qˆ"±ˆ{«Žá?¯ç¯¡&Ü´`¿yù껿½@æ”çxsÉáU°ó’I`#ýåù¨a_ÏåÅö`eÖMõ8ªe•w”G÷äRÐò‹>M ´oÅôvòv¸CPÁÖ1É5p áòkðõ±û7ãûWçïŸJB5‡ûG¦½ô©@_5WŠz t#ª¶Û ,cA4œ%‰2¤E_ª@T˜ˆ0½¶5¾“` ¥Tbp'’3ÀµÝ…Ò‰]Ѫ}®W›€žÑËeö61è‡{±ºw±7¹»ùù Õ"g†ÄŒ2 qb5[ïn~zOg˜ün[€8ÿj—îfÂÀKÒ½½½ù»³¹ˆÚ½bâ:"û(8çRÌB– ¶fÔqŸc?N\¨„EüË^èU…L3¿Qa®²è¬Lh¬Î<²ƒ&&¬Åìw“¡A^Ïa'‰'j}þõå!åWÃËïÈO⥯Æ+nðš@'6<0©®7µbO1a¬Ï7ÄÀJ`n£ˆýd³ÉœÅ‹=tVì_e;½*Ð.wƹê¬J¿U»x]äýÍòÃn•–•ëÜ£l½Íò4ñƒÕcU§;ç¨h0»A&»Î ´µœÿûPÙ–?‡œ9i b'¬£èáàÀa¿G‡ ‡VÅ¡™µ–E€²snpÆ;7“‹{fôZ3ÄPúEàœn¨LëC™ÃrÄ’Žñ»À_• îîÅnÊÀ¼E?œ´îOÞî„l1`ÏX~ÕGƒÑ³¯†™Ïx /GŽiäØ—B.Ðb†«}.7‘ÞQ榦ÁMe T5ãG'ïlí+ghÄ0÷$5X 'ŒÎÁDÑ'Œ~2ø°PP«²’F°‹‘ŒŸ`© ½\EDlúÖœ*'œÆ õ“”v°È<ºÄÝ¢S¯&·SÁv í–nÑï'Î4„^:ÿ\п °NØe昚Ǩ…¦Qð¸¾*¬/+ÑÉIPcÉFyÀP£X¤êÅûpÂodãÁô:©ü?Å•†ŠRüÄègýðÎ4 ˜Uö!ÏÐc_'y½}t“»¢ô ®‹ªìCœ"T–Þ¤°*Ÿ3”dæubìÎÝ?8Ä16PWéöžx«AÈ6hÍQ$¸I÷¤ºgߪp´Q” âeØ/S Ÿn°9ÓH)kQà×_ N%૶wˆh*àgë@£µu`lXæŽë6¤Ø¸¥½Óƒ›kC"Ù:.ß~š whhŠîÞÆ»0ÖwÇVô1¤‹UµÑ®þKÁ1L…—5ÖŠ ‰˜ˆk™“q­)Ì@UG§ð‚KåúZ°ˆºþkk(LÀf]¸ e4sN˜¤°o|w4k#Èí/½_ã>©µ&Øì?*¯­TŒä .¥£rÖûS!MTeõØ£A㡨ê&)â×ùÖ¯ÚJÌþèäÖv­ˆ^†Š‡/°a^c¶¢¨ªlµõþ’”™M§|“`Ö¤í±jƒ óp~º™ò¶9XÁ,ŒÑ]~·ª8xõæ¯o'Q:†ã1QCW| ·í!­¦¢‹šÐˆ AocòœD ݼ°Q·áíT<-/Üd£_ú/GHx||Ó§¤þpNÖ0u0æVûèƒ-ãÆ>8Ž`= Ûí ’;ÌP ŽÁJφ)ö>íӼʺ,Ñy˜øe0‰6["°HOŽrWÙ¼Šê’mÏÜ"iGО[nëÖ-È}èø†üÓd;V°âŽ+=ÇÿsÁæ3 $›ìÁ¼OK ’?¦,|PŸúl{6€„rUu™&m¬?ñ[Ó‹øçô>9lëž4NÙ Ë}a´ï(½N@Ž=~益9òìµÊ¶Yý8õ<ÀjÓÙuϳkMAC$k/~Ö˜eç#>g˜[6Nƒ¶qL·êJƒW_Õeæy=ݸÀ .s9ns=ü,r:F@ð‹ˆ§èó¼K‘Ó˜p«oûB·ÍvYžxù7«¯ïíÿëº(³ÿØ%¤KÓ\*XíRUGI×,þÃÿh°ZÂ1¢¿YÈöv*³µ›|he¼´¢$Ÿp{ ¥'º9½öö¨¿)ü,yxSÖçzÎ~#‹ä€Ý+6®¸º«@gËïv5®ðDÚŒqUWâºd÷„£ÊòLˆÐZ&‡ü€ÊÕ"²OÖ~p•€Úw89?‹RBÉ[äçl†ªÉÉÖ“–CâüñkïÎ U>¥ÐÔ®HaZ7qÎ.˜òÿ׺•ã)xçP©ƒ™jK&>«l¥ÙŠÙ õº}IÝŠþ-խ蓯¤AfÊ*uàìAy ŠHŒÁo;9ˆ†H¢!¸¨)rÆf[rŒ½æ¡cTÅâc/öþ~¼`Xƒ1]éJN©ý¥SâAéj½/Àì¹@ïƒùÚs§§ë†dç>Xoį÷…¦îÑ‚³z…г٠Ý<è8=(ÜÐa9°]bKlËïÝ] Žº’þ¦MÎ#ên,bàQÄ#©ß×#ØËüwN{æFý…²y®b] vîº#šÌŠ=ÎU‘9ÌW´‡M”aŒ²ò!3ùZ[ è¬ÞãÑ0d NÛ²ÿ$GŸ ¬Ïßu H‚Þ@ô±Ž]S=‡íƵWþÿ*­]¯¿àç,¹퉫¢~¸ðl×s”Ç­;™ Ž#€üÏà”tƒ sÚ803F[$ ½ò[8$ a‘€/·Hh‡ÄÄNcIâX(«S¢„‘¸/IZwDãíB³çíB¯ùöÑÐóMg¸i%Æ5<õãéÚäPÆIR,}/ºÇ©jG}’ô\²¥Ÿ-þðç.!Q:Ê’8ö›ˆƒ_@ÿHv`q endstream endobj 1893 0 obj << /Length 3869 /Filter /FlateDecode >> stream xÚ­[Y“Û¸~÷¯Pv“Š”²8Ä n•_ö,oe׎íTRµ»”DÍ0–H™¤<žýõéFƒ§¨cFó0@£¯P8¹„“Ÿ^„¾üöË›•š0DJñɇõ„qp%&Úª€ 6ù°šü6U™ÍY†Ó7ûjž¯ç˼˜1;Mfs®Âéï¡ g|øh‰‰ "­%’ŠD C9¯¿ûõÃ?±'çðŸùþ½±¥ $‹ê:½x‡êœIX.¡b‚ù~¸Ã¹˜hºJ–i™æ=U9”6œîKÿºjú¥åÇN(Ë*/z½à»m\éjÌ×T®g,œÆKè]RCêËežUE¾Ù$+úxñ€Óf‡ƒ?5)ëõûŸ^ øŵ B}ŠaÍÆ xÒg\0›‹ÈNßd›‡Á¢?ϸšÆ›}‚Ä&sÁt -r2„=ˆèkÇ:ØTú*wyYQ-ËW¾Í-Ê2½ÍÒßÃ/㬠š=mgqhnO Ao)&°ÌÔKñ,-SJ3”Àä&o¤±#‰oÞ|çh»†v³Ò?ã*­g+¿€|óyÆÔ4 züíðÙve”ÃF‘[S$ Íñí]\&#+á ØLÔ+ù6ÅMe™”eâG_<åõj_¤Ùíàõ‘Õìp.€&JDRúÌ@Xó²L?Îç¸Hcx*oâ¢@öÄeÍù™„÷À5XÃášè.úQ –Çðú[ØF÷õ^|zÁð» ›ðˆR€u m`›,·/~û#œ¬àåÏ@Ä~rïºn'<Ш›Éûÿò†®§lØ7N”4šgE~yûýëw§4MÈ@qVÏÅèQ+d0¨N.QhÀÊ®_¡Ð2àýõ½}÷ïÿ;*(Ǭ,ÎK X•rD"|®ÙP h¬É\ÁŠ¬í~›+¥§¯³Žš{=˜±é)ÅÞ4¤lmÄ*!ûW·²‚/ãÂL&¡@?‚¦¤¯ZΦq0˜Þõ°Ñù¾é™&ËGu× ?a¨4–ˆiÆ`Êeh½wƒÖe¾Ým’Ê?5Þ êÎ;AÙ÷NÐàL5Œ_¤U•øQÉ/ ò‚è œ6}O€Œ*“䌄Ãz‘eï÷‹2Y¶“¾LyyLêíÀJ}Ÿ¬Ûíú\;±CG¨ºÒælnØî{:"E편ÙcÓóÃôæ÷.ÙÄUmØw1™Í-ìUÃŒ©† i±ç°•[êTÓºþ®L³å3ZKïÊMŽ á~^ÄÙGß5/¶^ÛjVf¹ß˜VÊÐoåÞ—y);¿í\ƒ}CÆnãâã „ézX«"ÒÜv;Þ‘=Ž¹`‚­0§=6ÐÃùUžHE‘D pÑÅžHÁøúOd¸:퉸 xhža‰‚G€›L‰#Îèô ¿±{‡Ÿ°†&B@àÙ*]Æ•_Õ°J‹%úÁc/ðÄ&rkÆò¾Ák>Ü ‚Ú//á‘ëi‘”;´m(Pd£7@êa¦åÔõõ¸KêÙ¹9¡ÆS8!kév” -{Äœ´A?ÃíáÖþ‹2©ˆF¼FKÒ__š¥Uoâ¦^£Qç¦Öü‘ñHÙ†û?¿ùöÔV1¬Êºó+œ‹šÎq¬;?‡•E²öŒÑõJÔ˜sÄfZŒ«>~ú LáâÒ€åiçÏ_Ê—ŠÎ *5y/€,àÜaâÅ}Z&/ÇÂ^€¨móË¿yû~,:¥çÍ€÷éfCÃìë#o‰ãÞb¶›j»CFÛzŒŽ6€Ûi‘R\,Òªˆëv|Bu -àÀPRãÓ_ójlBLÊÔÑËe²aŠ‚J…ÜkÃœ+,·)OZ5 b!ÁuJc!ÕVM*9š(1 ô˜Â<ÙpÏ…„Ìö%`t©L‹ÀJ;‘ZÌÖW,•%ˆJ—phÖ8™œºÜêz×õxp ï}p ËfÓ÷Ik‚‹xCH`K"²ÏVh&{„Kbjꪀ®ƒh¿O«;ò °¥Ñ¨[àÖÖ„¬iµ ‚æe‘x ­„±M“W¦;ßqà¸@GôÒi}€ùØ!1†^ï³ôÓÞÞÜQ«—£¡ã»†öí!®{¥¥OIH«<3|§†…˻إo½Îºøʸ²$ٵɋ"^ú¶Aã£0”âÝ,^d:{ ž Dž«ºW³B™Q¬-|—U‚áÒŠÒ5•1™“¦û!­|{#€î_\T~tn »$ëÑç¼M3újÄùzGÆ#ù?¬ƒPDðcmçWsîsa0²‹¡\Ƙ£Däb¸ Êôe™ì*ßÉñÜpø¬@îg¼Šo y†Þk÷}ýk¤Ê"!îHÕ°Fº¿{²»Ç²»ÇNö$˜±cz8«4qH\–ù2mã°:‰}”ßYȪs0ô_: Tß'žÒ{Ì>)øUfV†¿Ã ‚s­s©P´ãê%b ë ›–Nr°†êƒe¼È Có'•îI^¿›Žw» ¢ã¦î¿gô¤ùc笅€=‰d'M®Q/4ISŒI ¿ŒØãí"ºp[zSœ –FÍT]ë®È6Ѓ3Ù®S×Ò}»M@ZŠMšÅ]8–¡CíÂN·ˆF`Å2t(àŸ´ªßzºc“Ñp/Öa;eð¾™2¾Á)çûŠbꀽ©Du]Aˆk,»À~«·`’¼Ù# ² ”Ô×XgMêLuÔuÊÈ’žïôðZ‘#J(8Áa‘‚‘–À[u—“Ó×e¸(ÓåF-Þß2´CÅßg L½Àˆ.ÏÊt‘b$—V¾N݉~Ccû«Ñ4ö_—w”ɨwêËE¾Yù™dÍL¨¡£¾oâó*$p#åCJ®jØ0Te|ãÄg0¦Í,ا.Fßï#ÕxŸ-ïÈNÚéºÈ·T‹i. ‚ÐP.‹Ô¹eê¨ÂN:(H‹÷Ó_éª~X€ggÞp¯G¨ª@„‡ö¨ôÃN¸= Í#÷®7¦œ~p 24'õ䄳çS€L0Ö³MÁ Y&Ð!6,»=Dz›Q¾Ãܾ–í˜[ǘúz€ãZÚ Ø. üÐŒ?ǘ ÌR8`{›:`»èžÓœeû?Žõ®qÍÁS(礎ø)¦Œ '¹+¹ðöUQ`Q[J»¸øÛÈš0%ÎNŸõ³( ŒzÚ´zjrL{öfÕÕ‚~øBÚnøVV˜Žó¹z!À®a¨#$B@„1`?§+wò‚oè EjÂEú5!ÅÜHâå]C#¡¼¨‡‘tR‚ÃÑ%ßxçñ`„¹Ã¿ï¥°Ã"w€àÈ• :Á/(A¤è€…þ¡çêDXÎ0a9ÕÒº,©Œ7eŽ5=Ý5÷!Ü9•ÎÕ¤|¥³j/òýí=€glìçÃ$>}½~\ JØ3B)µ 4ʸ@ÏpM~\[gn‘Þ¹0?A6 ˜l½ L÷'ÍP©LdqÊd#`_GÝ7Gƒ 41Ïò£Í%6°Bò•Ã¸»[ã©ÛÞ­(¨‹s.Aæ C=áœ;ãú8ÆwÇ“xç'"J,ä§öf†GÏ0&¸!«xÌã6ˆÖ°Î…Eäâëµßâ$ÅóµÇ‹€À{¤—‹pÆÀòg8AJ¬:]~‰,Ë‹1™‰sàM‚ã€þO[Iw8.Á±)Ù_É8x`BžaLÃAà£cÜ;¼ ÀÚ›…MÆ·gTX'º.¡µ´c9’ÈeÂ󩬟#Œ_UÉvWyïqX謖‡ƒëmg ¸ÇÃë1 R€ñLåió)½iu1ãp·u{7jR¸’R°Bž\@Š{ó@¥—åA 6Õ ëR<‰.Hqßæõ«æį¥(ÜðxÌÎÀúŒáÑs/BÚei`-­K :-óH[Z¤¡}ÎÒµv‘†®“ŸXiu«×A}<êÀ\ö Žn]ßé~$ah}OŸÑ3c@–ØW–2ºÆB[¼aJ”„¸ôÜZÂìÛ|8î€5– Vº6‡…BÃa%;{ø ÞÀ´Wòjôã8ô·•X9Ø"l<ƒ>æ¨xJdóˆGÁ$Kh¹»<£ÌÆYC„D“Œ;À¤œèÕCò¢QnûC·0ØÉv3a"A°|‘æ†çî¯Ë€[õ´µ³s‘QÇÖzâF6ê òPÝøðXþä$ß}õ¦ ÂEȉ1ÆŸÇ\=¤ A㔺TNÀ÷Ù¿„è~gÔÚÉØ1€Ç\.W¾±[R¬5yÞÜZoÐL{?+lnŠ ÙWù6®Òe}ŠŒýÂj®˜»µ:ç¦ ÉT`ý¯»þ33xáíc¹£; p [Ì%=ù­Âöð§KLö~ëÕ»†Œ&© ê]Ã>›ÃŸC‰“¿³½ß¹9Ó¡T¼ÿ‡Ú=ž<âئ~±#?4ãÚ€ï0#?4“BL·ÉÖïX/’O{™+|"ÈàZ11-ë$ V²ý6)p‹è±þU~äŽÑo@a77}¬4? ¥aSZR™”Uº¥{Hmµ/ü± ÍènôJhœÅ›‡2Åd‚‘éæ´•Ó2ýÓÕèWØBihð|«%ßÁ„÷Nè\‡–ø/zá­Û[zì¬_ô~«ÐÞúÄ’]’­J?ƒ¬Áa¤¹&wÃ{˜`´¿‹'¢Þ'`MþøAÁH endstream endobj 1930 0 obj << /Length 3071 /Filter /FlateDecode >> stream xÚíZKsÜ6¾ëWÌ‘ªÒÐ@ S{ˆw×.§ì$ikÞ(Fb‰CNHŽeå×o7 AÎŒì‘ãu¶Öi€&~|ÝxD‹›E´xuÙßWgÏ^&|¡Â,MãÅÕzÁxòD,R•„L°ÅÕjñ.¨wÝ–E^/…Aq›·yÑ©ëË¢#b³¦ßþVSa“÷mùá*Iäõ ©±ùÌ‚V¯›V¥©gg³mËsžïÏy4}Y߸Öyïæy B¥s7IC˜* >ôm~þëÕ°à%‹Â,ÉhQ]ß´ùc΂k‡Cª4È«GP’˜ƒß¼ºiÚ²¿Ý”5Ù‚6dÐQƒnWÜÚΖBëBY/ Xí³f×/›µ)SË8ë 7¥¶½þ%r *ŠBÉ¢E]¹Ê/¯PcÂÓ˜à,”BA³¬×ýñê ŽÂ9ügv,R÷L×± c6tÄÖFPK!aº$ÊkT¬Þ4­•y««üCÞ—N‰ƒX¨zúj—a,ã½Õ°øôÕÖô<[Ÿ³(¶dk,«²+òöXÛ¦õ¬ºÐÖèW»Ö³HMÒc2 UƧÒÇ)·òâ {‚€’(ŒÓ}ùvº|B`œÅÁëžx!«ÇÒJou½ê¨âX5"Á½YÊV¸·.×|M¿UÞž3ÜØN붩{ti¬ŒB4ó¶¶ z¤^Ѹ¸¦õ®ª–$ÓL…JÍDÚæõ6\hé·j*î—øå‚HÖ§ÉWªGä›|L¾ ˜4Š—Ì% øxÊûÕ¹ŠH ò8“ ’²Æ’²Ôö.oÛü¡£¯FD¦PUM ±¢¶e ®VñáùùRE ËKÛ®¶-l—€ Ø wz$xq^=+šÍ¶"Ä<ÀÈyš˜ãd¦ ÝmuÑ[¤†!tõ@x²ŒEjÁ:Ž¢à¶©Ðò,0Ê%šêhG¦“ÄŠ7žmå¬+Ίì$f5è´iK è„L@½ÁÝu`ò2QÁßê¡üxX€N07Å(؈¥kûiסƒû[]P ]ù»-™°¿—ôC¾ÓÙ!ê•Éõå†4Šƒ<ŽÃHˆ' &˜¨Üuì»Âneñ!Iðº&ÖŠ¼e,gI(Rg ŠÆñ|Pd£H±bð~ ND6C¡ž4X  ˜=Ái§ øn–Ç‚ÖF “Öï·¡^vôKV`ÖÓŒ‹Õ´ˆôèM½2A¿:áXOJ9Àš<k2 VyŸ‡'&ØBº/õ è¥ÔÐÝ´#&òš~RÍhQ¦V‹@@ô€Åv$! ´³¶ÉØvªqo´¾ù…ÊÆÕÝwÇ8ö‰NeaÆgÁ¨0ßF*˜ ñ¡3º‚ÚöÖ0}XQÁ}»¶¬>q;ضm€Þ—+ÛÄ jûRÄ‹†¼ˆÆƒ§p.GÅ`U«Ui*& 2¿·Ú8Z¬‚Þ…¤{«ó8a4¹Ž7Ö`Äæ«gÄ8úÚ$5q6sY¤@jº+ú]kÐUHÈÒ«ö(þ»8ä%g^' ?ÇăÓüø‘¢NŽñç‚(ÓÁ¸6»º,¼Ä‰à}|¯uk5QÎSLG«J»a@ÿv|7³ƒqºÈ}5µ…á»®ÊMYŒÃ—V7Œï1LÆvï€mB4pàɗѶ±fla–ŽMÖMe5kø6ãùÆ{p\gÅXnõo»Ò¤d¦Ic©»zìsÌ"¼M‡ÔÁð×Q™L‰£k­ˆ‚XU7½ýNi•ŒK`qê~@“ÕÔ"Eê° ƒSBÙ߬˜ù‡ÍÊI;³‘S.v“d „” ³UvÓŠ´X2ö¤bÏC"M|âWqž~Gq@ŦôÃ@Þ9:åVã S‚Eq“Aév1Gv9݉IL ©ˆxZÜŠÁölGÜÑDÜà+ç©“#” ÷øëïÁ‘àíÁmŽ qü¸®¨Á®vB1F ”iø%×öã˜ÖšjÓ‚±ÒfëhûFz2 ¥TÓÌé¾-û^×ÓøÛÒ»Yв~¥·Äù98Õ‹‡^[¤óŽn:Ö¦¬ª1n¹<ëÙKHáÃw§±µ´ãæ’sò‰ÌM‘kÆ "—=nð綂y›(7»Í E:G¡ L‘À¶©ª™bº§iÆ[ü+³úô£«O`ÃüyÒ¼à0Ëà’ü—º€y©_8ÃÝ?Ö°ò‡Û ‹X˜H¶gцþ•äÆ¿˜Ü5çï?ˆ™‰À̃…1ü~úíáÃÑ"æ‡b>èÑ¡˜!]þ!¨¥>&i‘@'ùå@ËŽ´xôE@ë^™]ÀŽ¦Ç€8Êûss$·ÓÇóŠõÊc1S&™°,©K Ɔ\†éœ¶<(]¬¬µ^¹猨¿u' ÃŽ‡eK–ˆP$1å@‘8=zÓà„nOŸÊì‘4’Q%ÔWσñ‰Æ“ª( û+CÂáÜTG¤aŸƒMq»‚Ä릿=ñè0pt«S6s1@fv"âz`ù SG6“ßùìßç<ž3 JcPßrÆ}ôÑŸ8gûa I7Ôp‡"í€[ÞÔz垶@’¥(æ„înÔ˜çßH¾/û[¢Û̆*4„×kŠYðe«[¼52Ö ßÀ‚²Ã© Â!º7dãXÖ¦”5ueLýÇï=›dùó°5^Û°Lß™Ð=»¾Aû—Áî!ÆüÒÇœ]<~Ú1±Z9«•Î=¤C«mUeo„Œ> stream xÚÅZ]o\·}ׯà£óÂå 9²0ÄIå¤Hm#öCÛØŠ½-Œº’!¯÷ßç®([µ»q®¶€!óî%‡s‡óqIi’C Ò¤ÉΆõÂF E„ V*-Ô¦hh M:Zåð$¡'öÑºÉ z¿´ ©Œa’[ÆÉ™-Ì NY]T93_hí¡eŒÏP?áO®Ô†¿•ä˜ê£Å‹Ò)Ä Ý [ÐOSoSP) -T•*9hQ*UJPã°Vøåc¾V[xÐîã·²¤1¢‡¬yÌ–BÎNy&!Û0€iÈu|.TË>>ÍJÈ}|‡Y(ɨ ÌV¤§­9Íã'A˹UCÁl´*…T -CHÅÊ”aŒê¡X#ZÃè\¬ÓzxY‹á+Œ­F!‚ûèf5˜*Åy –+5vÁJEs V‡Røxs­l»Èn¡¦aQ||¯˜zל¸|7)yÈë¡Z¥z-…êÃzMàDC2\©öñ¹-—!¹•à:$7 ¾µ-ÌMèSo+ 2½¢G‡7¹iPÛ}HëxÙ`<…ÖÞ†í:Zc:|°¥­XXTšB`ñ„ `#|Ü’Bã|h5¸övŠºÀøX¶z¦«t:~)‰-…ç;çÀ‹î {túZP¶·|"ÂI>+—Ô†DFIîC$ÃÄ"]ð'UZ°S^j4aüI=_1@´3‚Ee 3†Wñ“û÷OVÏþûvVßœŸ_lNVOßÿ²Ï?¾>ÿ÷ÉêÁÅå«õåÏ ) ½X}¿úaõíÏ2NV?­_nÂϵ(ˆJÍ-*ŒZÌ£!µàÙý¾ ÷ï‡ÕÓ°zxñì"¬¾ ÷~øöѳŸßyþÕWáë¯Oðï+’«GçÄêQÒ¢0P³Ç,y§"iQEzBÏèsgPÖX±¼š4–RŽ¨ˆY4¤¸d,l(•Né5Z‘Ï*²ÕCUÃ=rVµX±È`0œ5ã¹ßbŽG§Â¶¤p†(Œ?¡"Œ˜É^ <¸þžuùÒªC ?…Õßþþ„nÌø6G¡9ÿæÍ‹[;JJ£gµD¯Üת"!U˜Š9~ÁÎÚRTðŠ°-{õ`0¤üªð$ÔÂÃá§ö}ÉP×rAo…SîÝ\še&<ú =¬ZdÕÝÓÁâÂÞˆÖ¶·7œYQ& ߈¼à¢E–ó{CoÛ{íg7z‡Õ·o..Ÿ¾={¹y;æÉÙf³¾<W"þüaóðéæl³2~8Y^œoFœ±@Úö;EY3›¨5DRÛGëóê™ÊÕ±L¿šçt /¬óÕ+ ‘žçªFŸƒ€bjâXÆ}N DÅlÆ|ÞêÉåÅ˧kÄ5¾é»Ó°z¶þ° /n¦Š'gÿZŸÀç›õùæAÍÌŒðîâýåËõøÍ·¿ýuýêõÙƒ‹a$‘Š"êõëÉÙ%FSû¶í8Ð;L<@$õrÛ(:y6ÊlØlÔÙðÙh³1Úh2S²MÉ6%ÛVò‹/M”‰«ÿ±¤×@}EHt"Ho±ÈÕrkIùz³Žg—¯^ý©õS6R³b}c%~iRIË·Öôwïá?Œ}qÑ/ê’5&&YÔöd£†€ œÄlåx`‡µŒ‰Ø¾·˜¯FB|dPäºcê‘QS‘  †ÐTPÔ‘ Q(zÖã/Ø[$áï‹Ð#gè!d7xìýˆ†AªGŽCrD)xT$§!ö•Û¥F_R õˆÕɭĤdª“â9µÏªñè§ïŸ.¨€¦Õ3 v%†¿ökm» ¡‹®GI&kEŠ!€°"(’EÊ–¸÷P5|…œ€h¨ˆã¹Õ#¬I!’þQƒÒÉu§sI¥'Ú=²–©I¬ÞC&c¬$ï]}§"¶¬"Õ€rSdtÌ  €è¾Û5–ͪ0D‡Hž Š( ¨À*’XÚ]]ú]%Vîh) fGöÄr¶[súÇ„þª4±â^ªôiÇkªÚšzÞÓ;# +ðTí7ÙÛ›uKQ¸S ¨{z3kIF•C¤ô²O6鶱"Õhª‡ö6P¬ÏÒ¶½½mÐ;u9°wk<Ù÷•MbIp`Ë÷ɾb@E±ž‹²ŽOYà jp“|J n,ÙS$T×Ïq‹Oèx wë$$ÎÍH›ƒ€ö$ý–·|1ÙŽ¿ÉA¶ßøeÄ&›ðI|RŸ”Á'eðI|’¿>ɈO2â“Œ´)¹MÉmJnSr›’Û”Üêc%ÿ»­Œ æ[A‹Á·Bævbo·}˜Jõ@UMÀt©„¬®N'Ö»¥~>¾xùì?o_½¾\pW Œ;ø×j šî»ïVãÉåúŸ¯?,‰s‘4°%ﺭ¡ˆFÔð^¨R–¯Ÿ¦¨[Ò¢‘D’„ÿw"¼eáDFFD€†Ä„ÿµ#WkIìx’:€e¾V#WR5ݧÆâRzäI!`¯ðœ¢‚m™¢Êçä/,hàn¯L#lÇ›¿Àùœ"kh¢$`¤[Gó†‰éH„•çŸ€a<Úe±-<š7 $Ux8ƒl¥ãl`¼q(PûÜÁ¼11ù`Cy-JÌO…ÃDØ° Å³V&ÚO< Aü_ À&♵ÞrJ³¬‡ Úμ40±%L̽¤r¹e»ï=A‚@±kU°ÞÂ~îBš?ë1û© óø¿6[+PÔAgˆJAŠEµRäY¼9«íáJ ØÞ=¨êú{ØWÿÌyH…Ï°èìéí Œœ­»Ø[ƹj?Pongóÿ3¹q¶!ôäÖíQ†žÓo(C×ö唡M¨ß&Ôoê÷ õû|Õ¯^ñRÃUCfCg#ÏF™ ›:>m6¦d™’eJ–)Y¦d™’eJ–)Y¦d™’ç¹LŸç2óT )Y§d’uJÖE™Ká¡\ "ÃkF­#£þ„Š ¯-‘¹˜D^†©ÈqÊ}anðåÍP«ÝÇeÑ&ßVá p˜±zÜ*†¤›ëÎó‹¼ì–ïdTÇàž˜‘4’5Wx§z<ÒQ^Æ™¹!Á˸¼â3²9ËÇ[Þâqå{‰ QA[;_5áÙH¢„8YÔZŽVó(ÞxÁŒ›S;¯嶨"WGFÀÈ‹ypÝÊ“6 À~Ĉ1Þx´…åNÑüÃà/½ÈñÌ¡ülL\˜2*/Ú!€ñÈë$zTÿ(±%^®‚> stream xÚå[YÛF~÷¯ÐK `uú&;‹,ìfƒÙµ¯ÇA°HòÀ‘(a‰THÊãɯߪ®n^âça}˜a³ÙWUWuµøâý‚/¾Áïy~ûîÅ—ÿ0é"eÎZ½x·]0‘ˆ…M J,Þm¿,ÿžo³ã®½X)®—³Ý1¿øíÝ?¡§ôÔŽqí`Xßå«‹•ny··y^ROÉ陕,˜¥2Tñ+7üö¦XßPõºªë¼9T妡ïm:¶Ô`_5a1q„/èCQ®ëÌBÒaÆ'ž3,ì³OÅþ¸Ç ü#T㑵»E9ªêD)vÌ÷U}GeÏOx¾öì~²÷í]{!–yœöЃ;#™j¦D·Ú×?½~s5C“tÌ:ÝÑ”üPV2§Ò1_³Ý®ZÃQ ¨9 „`a¼|®â‘«ê c–#:‘F°ñºB2>⿼ •5»•‹ÎU™ Þ<Ùq®€zz ’±ë1v]íaŒÃŽD2ö {“Ç©÷ãqEUvÅÉ)‘ikÙ:†DÑpú òæ{Ž÷ØT ìîÚï'SÒ‰–"äò&ht†ì?]«Š²ìv‹ZßF-·HO¶n«ºø#kpú~ð+¤aË0µ?Àð¬Ê]XÄüG’—@ʼ¾Á5?‰w| Vo.R`~Ó×»0’WÑsèeÆí âÒ$‹•‘̪1¨spÒò—•1v™g¨°Ê£ª£rÛ¡¨Óÿi((Tu5y§–‚ÎŒ,É›¶ØCç TQ4ŽÙk¿ƒ£Š»¦h&ÊÑÚä3a T2©ƒÿuN?ùfüqNtæ5¿G°ÎhЮ_Ü°""˜·ñc‹¤¢%r2Æ„ùÑÞ¸ÎÇüßÑH–šò§«ïÞ>´EÒ°„wÊã|³[§ŽI¯f t KRó'¨8g:1 4ÒŽFt–¾¥¶f¤.¢0# C0úzÓÁ(Å'@‹7CŠM¾kÓHXVžÇÁ`T>ÉRŸ (°‹ÛØ1® ”kUš¡Yk˜ãv¬PÉÒ)Xu1$ 0ÊqÒ³”lr¶GçØÅOÈõ•H òò=Xgi¾ìÓ’J|Ìéé‰3ŽÜcö*,ÊØ®Uvl+P£èJ ‘‚“UÚtsQ5)/,UÛh²8@V3c³%v¨QªÓMY]gw µhŽh%àWoûºÐL%°°²÷a¬-ª0¬…UÎYêÎÙã–:Pn“N ×'—›¬ÍhŠM•‡õ•UKUdò®ó([R¶¥Û~²Ÿèüs»|ç¼r`nï²Od0ž£xòyú døPñú謭Ï-`|ɇ]á¼xó@E› =‡â[çI`ÅhK©êò*Œ[öczŽ XŒ³“p ÚþX‚è‘-ÁÇ£ŽP¸üòG,€±‚Níq‹þí<¿@­ . ¶«áðd®ûþØú#6Ί]FV/ºŽÁ¦! #¢7”» ThB}p ªBÎ㇎N ¦Ú¶¾#¨J BIm–ëºðg‹N8~C·ëË‘#…µVC¯!gÁ\¾£Ú+jzSí6D/ÔÑ¡¶wKš—£ONR¶þ@­ÈìDG®lë‚XErê¸]ƒqø=˜$:PØÜ•Ù¾XãËé™Æt’}Ÿ:§Bˆ^@‡t¬÷C“¸ƒ'qpq€œ_Åa¼ta±štm€7@p˜fWá¶ß®ê¬ü0·?ÝÒ½%ÞÖÇu{¬s kMÛ¾¢±¢a}]}ŒËÛhMÏ©«‘öñR•J°ÅCÚ_€g'ÀØX› ´»J ôLæ¼4¢I˜K¸ðÆÔú2\GúW)í)fôü„Ö 8£Bð®- =ÉÔl»1ÚW„¾#[žsƒ‰–:qjóšy”ë;jÅÀ2îìN ð›+ó[ƒBZÀ_µì­ {ȨB݉jƯø^lÏ£J( &ØÓÁû>²7ÞVµ f"+‡ƒæÊ1‚â®0á0¾ñÑ<øÞ% ý1ÃBôŠ‰P¬A„ÄçûTÄOðúîLú5ªÞ•ùá?~ïé·ÒŒë£jÀ÷ñªg¢0Ã¥åjí_ÎF§À.=uÀ¤|Ò®õ±uNÒG;ÖxÂíT0à» û¹|•Êo÷”­òq¶X ²u"™aë0sQÛUµ ¬ÅŠóY+@`“ÏåmÐÅ©¹>@)ãNxhO̳PèƒmãkÆ (ôs@0Ë>Ç9¡ê¥ì@PêÂk‚:€ f@P?…ÏA7AAPAÐØ9”N@P:A?‘ÜC]ôÕÁÀ;ƒBÉ™MÓ§DlNÏ£JÆ6:.€Võ¾ª6¡âþö'ŒwÒ™t”Р¢éëòÞqÂVhh‚‘ÓDo%¬eÜŒa¨¦Œ@¥vGœÅ Ò@¨Câ4 ¬:Uê9 ‚Ä©‚P#™e¢gy1^ø¬‚ð±°ôNA¨g)Áƒ¿?MC¬´ ¾.ò\&ÂNfµ€ž•éÿ£R˜˜Ï†I7‰%c(Fi{ uJ)‡»|ÛRÉûø¥ Ÿ69ñ†.@@yž˜â8æTÃCWJCgJ`Ý :¯·…Ïài3ÌBý66 ÙÖs²=ãÂÄ„”LNð1I°`UH°`ÑŸxÒ,P$XðµO°à[L°Œzô(ŠoÅ™ñb™ÐÒú9 TvgÊë\@¯$8bb’â&¡”)¥Œw+IGà[$ SêÆ v˜yHCZšK­0ŠIõLjµèŒ¿©žb¥»;.v±2V-¨¼©Î-‡…æc̆o>òíKÞ­ !.®™„öÈÖQ"9•À—48ˆ‚:h2`E >$C±j½>Õõ”¥ObN?]6ùïǼl Ÿ¥†ƒ\35 0äTŠœf2uOHÚ'º‹m‡@H¿˜é.ÊŽ„™äe1É¿’6dÒ,&èzbèŸ1‚d}¢ Nu¾£74'Ñš±ØtÈ×_±™_–÷]ÇøjùdÔƒŒu=iP¦ïg}9·®ëãpytEb’ðØäóqŽñu¡A | Ù@BÂc¨R.Ù4¡;Ì(ŒR¼@gˆÒ¬ÀÙµáf€ d|Çü&{ð¹î.­5‰Ç¨<0µ2e<•Åc,HŠ3…c€“B'àˆ ŸçëÍ·$F³©”S¸YSi@f3i4œFÙ¨ª(›6Ï6ôâ Af£¨àpÄ.¬HÜÓ,uzzÓ‡„evv{:;ˆì£O„.X w’§¢Ã­Çn‘ ë…g'ôº­«²õPx]¯‹µg ‘Õ¡ æ¼p fz,ìdzïJ<Ù.ì²dúŒ Ô}Ù߯;Œ ’àÞdPú¸::oŠ<4LŽäxzÛPÙ/á¥K`»`,ã˜aÓ^ÚH8°}9‰Þ‹.XŸû¸Gƒ ´â…-ìÛ2n¼ÇÍzI¯'±e¨M»h2¶ ð€Ê±løë^àSÓúUátƒX#öA9 Íýó‰Pu·]|úÅ-¿‰µþ$ÌÉG¤Ÿ@©8RÐ$@ì¿ÎÜTÙ›v|¹bgñ"hyÑvŽŠ`ˆƒä¬Î5£R †Å³’ªàÄŽrªÞʧœ*‹IUð0´ì®ÿQj/…Õ¨­aóãý<œÎ ‰-q°»ÃA÷7š˜m*ЈÝžÿqMÛc¹FÉÊç¿šÍØ’ªpcU±?îÍŒ^0§O˜£#æÌ,ý(cnK-$âu  ï‹™”Š}rþÕ8ë³W0ý'Õ3gFIRå­àÑââ‚©z³0Vgù OŸý .RÈ¥áÍLD UÑNÝ!Fnö9×PVxÚ­åÍ7oϹ܌v)'ïZ A^ŽðWŸ¨Ð­.S½‡6¦zƒk}’ãVBÇ»„â|û_¤¨ä ªt3@ëž+º ‹ ]Ý{áB¼ˆù4ø<½Ü‚™£6ÃkÅPï}Ȧk;cmƒ)å”yÔÚ†-tÝ®0ð² ëzÑeKÅ„çCX6¤q“%2C:ú–êCÎÖNÉŶ»íÚŒnQc=‘ëÃŒŠÂ ÃÆÁ„ƒª&oÃì¯.Àðš;¶š§€ÂpØð–H>S42AÒH2B®?¶´¼ŠV’ÑkY•äu¨ëYF¢l8ØòD”Q+¥ö~ZDj|¬Pˆ„i°>Ó” C#ɸ‚@K# Xò $Å :æþ iÌh§6Þ£„’ßÒÔöŸ¢¦÷/¤ÛÏü-g\š‡®­©”`’<“#]÷HOùñе5mp–ÐËÀ†²¿ Ú‚³(ÒÎ,W÷‹kb€j÷'l10†%ÂÍ“G[Ûõä挿¿Eq*-“ankCn¿xçXÇÖÄâ`%ÊÖåhæaLtð¹ÙBG’šPÓÁ8Øøuœ/6$;í¯zÍòX'L&Ü‚Wá>Cl4hp ØâHêÉwU/5MÈ¿ÀtJøíÃø´òp3‹ìº™¹D(0[ª‡ÆÂÜÝ+Ó³³vî… Â-Xmú³€4Žñã Ë'¦Îhõàã¹ÞUë·2ºI 6@oR#$Í ä€_nˆÀ°E sIbc œH¹_ÉNeáøûûF¿r©gvȱDvË@ÄÂ2ŸÛ7~ÖöÌÚ¡ `åçî ¼Gþ;3vZX*;§¥÷Âð’TðY¸³œëñþ·1轌NW6Ïs»:OÉ÷ ^ “N}ÎmgpX$÷qwÌ^EJQw<﯇ú(üý;È}Š|8;J•ÃÝM÷k‹Ä«ëþÇíMüµÆ&?÷dâmÂÀàÕÊ=h0§L¥]ãî×liQ¾:íì ³´tqÊ1q2 6zF‹)wÿ Ht¿ endstream endobj 2026 0 obj << /Length 3822 /Filter /FlateDecode >> stream xÚÕZY“Û6~÷¯ÐËViª,®Êƒ7W9qoÆÙ­Ú8‰ãaY"’òdòë·Ip¨Qã½fD£ÑèãëèâÂ.¾{FGÏ¿¾{öÅ·’/RbRÊï®LjBÅBiI˜€žÍâ×å{ÎåÅoï¾ï†-~]).—¯Ê‹gl¹ÎšÜµªk÷¼>l·«:+?úŸŒ.³u[ÕëxO%õ)að'5’?~þù¾Œ$‚søÄrôê«7ï^#!á?‹˜-(°~IŸ ñù0Ë[Ïw¯«Ý./7îg{ãûM^û®Ê=›¼Ç8c’¤gàõ?~°ã¿y÷ì÷gØKl‘ð”°DZ© ±Xïžýú]làÝ÷@U½¸µ_î~á¨íâòÙßüö gK¸!R¨xÿ~¹üæç‡DÄ)уa¡™{|º€Î¶/mV_0½üb‚‹× ‘ÀùÊDIOá&CÅÔµfIK0’ˆ¤Ûæ7ßþ„»¬Ûd!aú4 Ã!E¹ZWuîøèõ¯ø3k‹ª´ô쫪žÇ ¦D5fÓGÕ.‡ V‡vU]?Æ$‰ínÅÀÓÐ``é öid°OhYû„ç¶Âm½ &jÔÈDá“3LԡεPÓY(ó¬Öîɽ¹ š:s…¾¡¹ÂOg®ÐðæŠ]•{Î7WA ¥ÉÃæšHØÌt¡(?ø–§Øk’•KJ€N³W0Ù+¬4sÞ^­} *@OtdŸ>×Ja’ß3sŠ$æ?f¦éyfs8ÃN--M l&Ò‡ ®?MÁXÙÑüU w þÁ$t‰ê Ѩ¸F5WNŸ•÷§rÝEãŸNx8šÓ~ÔÀeãÏÊS}}‘&Ë)uŠÎ@añB?¢ÎÊŒ´y¸bZl¨£ÄôP›-'»CÓ:^ʪu]WžÉ]µ)ÞSÊóûà*ooó¼ôA†¥$ײb”éÉNÈw'³NÍáªÉ?äeëWÛCÿÙþ|bcw Ö³bœh@NY@^‰Lœ<)–åa—×Å:Ûº~7Ôµ³Úi ¾9Õ}öÂc‚¿b÷(çÓJÛL4IXq˜÷˜äzëùxLäî¨.$ ÊðÁB1EìäùºTÓ8J ÕC]°Ò­cW£R`+"Þ㡧Lì©\0¢å©n`0,e™Úp기- ¬h}‚{ëc!¹·~@okÿÚ§"+…Ÿ×•u|k¸†h ‘J2ž°5€²2XJI›)ëm¯ã·Cz4ã#´&2²G¤!:×7ø6†9¸J!FtwØí›ûâa0tªRc—O“†h”RxR?ë>«ÿâ}¼~ MÖÅ‹©mCÄÆ›žÇW4—8°#â+`…Ѹ"©êÀ˜ÓWužm¿°ß游Þ}U”­Ó]Ž­Îî\?]ëZ^¡ý§þmå´léT²*ÔŠªþØì3§ö0¢v1¯ØX=WwN¯Ò”H`=R+g$Ü“”ÖZœ”+·x]•Û;×ÊÖë¼i,møåhý+DÕËäÇ_~|{9%9.ëðßíM>Óãp€|= žÄBàD.¤2„&j¦J 'ƒ™ˆHI ”€“aŽæç…ælž;ÐähŸ~?TpnÜl+x÷(«rõg›ì¶ðYÊ`S;‡GPœ;åœ~qɽ;½¿s &¥Ì ÇTJo‹íÖQÍ.}ÂU± SæîÕø2Ûºîl»­ÖàÆ@•+ÏœM˜$#Är—¥ëºoEØtß¹tB1°E‘;™øxØyÇCð—Ó.„@× ÉãOhÌ$$eH +ànï_º:Ðôj8èlj€)UOX ÕhG‰Ñ4Z LÞÜT‡íƵ¯«­Ïy=«7žÓ¬.Ú›]Þë˜@Á¨¢ü°õ/÷›ŠÆ…5K¤žÐNN©Mݼâ]ÓO(;í>{îHnªÃÕ6@ 0L3†¹Cä1`§4íàÊקs ë…öH›M— Pˆnº¯fM×i¼_ùœyÑ úÔüŸ§Íë•Y€P›‹ >7Á@c ϘÄÆ|Ýg«ðã „OÁ‘Iót„O»šˆMSJÇÐd¨‘Šp ˜–/ùSP‘Ú&³H BAdl0yglжÙÊíÊ‹j˜ÝáïQvÎÍî&²9_)¸žŠý%Ï !ŠhkŽÅ`À¡A‚I=`L’€¤Vð±‘^ç_ÿ”.ß\ܦ \Ã'|j³™ {n½äm¾î×Tê^f)”¹_üæIЛ1—±¾ ¾ŠëF¤”PLYÕÌ©<<÷UÓÎPµ¯‚ÃÓñmé±]1~[ ‡u¡Ö“©ÓõÄ6‡¼'uãiNm5t#öÀ'€‘Ía Hú€À†¦äqC›(’îT„–I¨X¾t¢@`fx$€àáI­`€¢ N°l×¹WñÌ÷—F×þÙ6!^£U•EëýhYÕ;ÿÆÑìÔD…>G;tÔ9îÖÏx{S2,û£âæÛ¢3°™€À>ÄùN{»ºðc>O¤CgÜx‰d,v/®&qÙ:öØÚWÿ†OVÔÕMç”°¸8$Ì Nš=ªhˆ™ÌQJ4sÊ$J7±žñÕký˜0%#2McpŒò¥k-¢cï&G½Zy¹Æ |7)L ‡E[xvn\,/íÌ.këóËÄûnl×ó-`zâ¢Áè£E'}§œ1GæN²tXï3AŠñV…Õãz,ŸWÂzKg o_ýýÍ/¯'b6S„¥Xðá$í{Bzú¢•£$¹ð)é«Ëw¦‡ *,*³ó–i ÅÏPÒ‰¨e%íÕZè«ü>XÓMh¿à¼ÚÁ9¥¨*i+eÝ%Ö…nŠuÞ¹à⾂>¦ÐEV£òU9 ðQ¸C?Ù‡;øå|äÂÉÈ,HHîÓH"¾ÂŒCù*>ó2ó8: L&QãÒ±Û3g‡©”°êÒþÈôÐtNì*[´…©¬œŽµEëÌ”L¶W˜21[ïW /ú¡ÔƒJ¬cáE]m›‘¥=•Çµï9'¹Wø0™>2nt”âH›ÑÙE¤¾BôÖnôDöùSï_`•’ ËVw£•`Ðñk ¹Íðõƒç#'ñïxr >Ù|{¡A$]Z†h=« ŒÍJP¥³».CÀóåO é°„ WÆLôkžÌOG3Tô€EŒ=Ëy šaÖa"¥T¤GÐÌce*!ÔðøLiJ¤à › ‘IH–ûSÚ£û9Ò¡GÄé‹ñå)VRo:…Ù@ø%Ná^v0ã‚-5Ÿ¸Áh¾¶m·÷ö™×õi×'â:qÂÙøà”ÍËÙ¾œ«NTvžc>ût”:¾&Å¥FT\ícÓûpÔá$&–rçµ|.Š.EÄ[ýX~=Ê ½%fáþH[çY;NòéIîŒÆ³}_gÝn —~îƒj9ÔW«d´seu:®Éáž6³9ÏCÄüÏù¶Ã>snk—ã $Öî§^¡cŸÃWYƒx>3ÛƒL>¼³Sê'L™Üƒ LÌ˼ž²Î‡pÏãÁ^ªÇz²ËêSú é¹±Kƒ³9C † ‘·?ºÛĹ"‚ÞC¨ÉuX`Tl oòµOÂú_vš!nê`Ñb•"¸œ<»3*œÝ™ÔoÛ¾ËuöúåÛ Ã!døê÷;úPËl¿ß®~ŸºÓQ£Â¹‰¶*O°¬6¾ï,Í°¥ú4 §m4U}äY‰4YÒ)È#íê È`Rtw’.ÝIT¶†V…ÎÑU 2=JŸ¢Â„LWŸ&TËŒ—¶BùÍ,›¶ÚcÉ‚öŸMV(Í9§M `Ríþçc¸Ï£Q>7ÅÖK£§9CG!Àx“n–¶(ï¦öY / LíÈØ؃abéÁßsè F\•Q^Û)|Ú)|ªú,tÊ”ìH·Jÿ‡l©Š6ÔYû¼†=Øeå:'&âG'¾äÚdmöâz‹…d´ÃnšvïÐk™|†+xHIIùß8.1BÄÕ[·yƒg¢ ðXR&OfÄûÀ­¸ Zаµ>% Æî®ì-ãÏkL8 ÅÖP`Wléi;¥uÕ<†ly|'eN©£ió½Ïl?ã%OFϳϡ`@ˆ26ãŽç±:‡½óà,ÖdZĬ…2Ç8‚­TÑÓwâ1•’áΦØ好P4ïL'*Ž½yPg‰ˆðÕ ¯JÚXO©Ò«ë¹°]qÞQ`shv‰€Tæ¹³3¹¹7CyöÇ‘Gõ,N’5 d»O9ü@@¸²„0Õù?<ûC1ûXlDwöG…Ï?­Lh„³?:¸ËÕ§J†wÇ|.VSàÒŒ Þg>û;¯ ˆ°Rü›.­$´¿´ÒŸû[b7PY  ¶Ö)æ<ðô' †€êþ ; bç endstream endobj 2061 0 obj << /Length 3138 /Filter /FlateDecode >> stream xÚÍZY“Û6~÷¯Ð#U!¸I¦Ê›Ã)§'åLž¼û@i¨ˆe‰œðˆ3ùõÛx‰3#É[[û0#g£ÑÇ× ðÕï+¾úþ÷¿_ß½úò1+!XjŒ\ÝíWB&ZÙÄ0¡Äêî~õ!‚"_oç<ú¶hvY}¿ÞHãSÖÖÅ_TÞg»¶ªúø7|ýï»`vµJXj­v“ÃTK»Yß~óîîGì©ü¾ÿ„0-Ò0`ÔKŽfÝH®Xœ¦«ˆžæ·åz£„šê”Si—5yCÅv-¢ƒ¯îš¼¦Ò){¤Â§µàQV¶¾sE¿÷aëøQ•n¸‰*?x[µ*íÝhÏ 7°«‹ò÷ycñwÖUÉÖÃãèîP4LOùÖxkÁ¶ pÀ›”vØ5nVäw{p=à`9ðgV5žpøxÿý«ÙI(Í’ø™ƒèEdÆkÙµaÜ®*Ûº: YòxiLÄúÃHа–Y™<'ãuÌÑSZ”÷Å.ks/fŸÅîàÅoÌt’ÍG* ñ×_îe7J`ßl–þtÆÌ1%™ a‰“?Ë´VDê/·… In¡Ã†¾Â#Æ%wyÓÒ¶3²UÓ>CuVfÇǦðÀ…/¤›hÙÍ´ñd¯UMSl~ö?³c ?߉m³bØÉxÅÕÆHfÕdjNóÍ:~Øci/ÚŠé9bEVû–Ø’?´ôå…Áþø¨Úq„ŠùTö¯]?MQΦØõ]«ý¬©êÚMµß쪚Ô¶&Ü©tr‰åçR2êÊæñZR;jpt‡òŒÍŸ¹@‹BÕ¾ªÉ¡áÁ–üXœŠ²Ÿ[FEC y O¹ïç´`7h”Úô6ûr#Æ@ unEä%VD†q¯qy9ÆPñÄÙn¬kQDâðX¾ÀbÕÛåT[´ÔïSqRߦ…ÃnÚbçÇìëêD%±à8ÀÖ( ¶¦Û¨kæ#wö„ù¤÷&ÙéáˆF#X½¹½½‡.ËÔœ¼›YG®¥‰Ð³’ÅC¡xÔ(…A ÿhèËÖ(»Ó–Ôeèž+¨…R‘t®¿i”í[˜â$98œìHŸÅZZ E¤Q…˜XùÅÒúµ­¤µÁ–n÷¿¯am» †Ôuª}§ÎÉ0Ô<ø>àEÛP+h¬ó?º¢ÎïÁ@X­ »[éí¿ònùò»[<þSU?R9ÃC8Vï©f¨ð&ûGˆ¦•¼ ”êüè¡Xhë1× ¸ °UÅi€¦('N“Áé°DoÐL}Ò°÷Š22î½YwùÀ"V‚1ÌÛ–Ì6|„ʉÁ·×(y&š)vqczì‚_d¶ pÈ|MYÑÀâô{óz"ú©ž2äavp„‰2ž ã•öÜÿƽ³òÛ‚õCi±ä€qVd„j„2±Ök„«›ŠÆµ‡ÌñóáÙ øŒ~¶ÙîcëœíKR&f–¯é¶ Sm7Hfñ'}1&›LcóËí»°)ÓÉö]ÏÍ»Ã2dÉ‘⎅€€= êòò+Âñ8Z@lœð,+_8ë˜ ÛLXZ*7´$±Ç’*,ñ}SÏ~ð®:=tmÀÝ8vO=2ú$K‡¥ÄÝÚf -EnµÉ¯ Ó%ˆµ´ú bKóÄv™“dž9A8(XbfêRúÂÛ¾záxø­Æiä@Å4È ÇEO‚3`z݇Æ.Æ`P}½ÜK•°x@LW8SM*Óè]Õ’3ÚÈT3süŠvDkE†Wƒ7œÐ2 ¡ÙI*ÔN<6€Ñ¾uUž( òÐ)Xº=õ'~i=ã>´L¹K€gm&ÔçoFÇáâƒó€@-ê3ø5NÅ-ñ¦ÌiF' 7ÑZTŸ;ÂÂÏÅv€Ó%Ïâ"Ú >á>µøØÌ*’ÍYÂíÚ)åböPqA³ € K”Çò&FWIz[`¯Å$²R£ÑtÈ„²¤×e*-‹ŸÍ_E §+×™Pè!ñy™23póš ©ôé½ QñØÚV8;åÁUúnEÕ 9VôŠ.Ï& ÓÜÏþ3 ÷y…>Ìðž7 pµ­sʮַò‹Ò†|’Õû6ßgÝA¬õ¹Â¥,.iä8驸; Kx„ö;Oÿa+ …˜áW¯60ËòEfúîîÕËRr¥ endstream endobj 1941 0 obj << /Type /ObjStm /N 100 /First 1013 /Length 2869 /Filter /FlateDecode >> stream xÚÅ[Q· ~¿_¡ÇäÁZQ”H 0$qpS#vѦ‰\gQ î‚ó¥Mÿ}¿O»ZÛ‰oîÎNç™ÕPßHù‘ÔH )H¢•²g6z(©£‘S¨ÅØ`MÙÈ¡ÉøIC¯|*— ©ó±ŒËœÛZxF ?t• 5¥àCÕ"ìÖÐj”Úð”×Æ{²éø/gç¯pŠpÐÒC®•Xñ_¶f¢JÈÐ{Í!÷ï4µq¯ÍDFŒªÆq«-£Ujã•1¸úxçÚƒöÄg-áíKÁx¬Hã³–CQ᳦¡”ñâx¿RÇ‹[ Å3gÅ,”fãWxïñl Ut<ÛCÍNTΉÁ.¡ÖÂ_£Úxs×P[¢t®]ǽ,ÙègÁ¤s´V‚)æÚñΦFð Ý“Ü|9a]Ì*u.y´ZðDâ}R…^£ (É ï $oI„š,Š¨ÑYy“)Ò9˜`D3å FêšM¨hb4¡& ‰Ñ¤AÐÄhc^òxß,£¶v‹U.FË%'×1Íœ¥\ùnÎeØqî|Èl<²ËZج¼k ‰C€m|I.ª–,^ìžÿç§}Ø}zyyus±{öó?nÆõ“×—?\ì>»ºþ~ým‚aH/vÜ}¹ûü[»¯÷¯n·b%R7U$ãÄטÆvKÑ2º}> »ga÷ÅÕó«°{>úò«Çþî#•ï>þ8|òÉþ­#÷+6WN=6L›&‰ÖåV_ˆ­ $gªþˆµ¨Ø:÷âg™‘¦1¹žf„À`Q´³ÌÈrœ‘ûég™Ë»ò¤ªØ5fsAWóypÔ=µ·8L" 䎴&ø·èð_âXJ?&˜ØŽÖbI·ìÝÏ¿zþ令¬ ¤¨GØ%ÁøUãçJ¢€ë¶ˆ#몚ZJÆY£Á ÂóD£Ë†{nÛ͇JŠIßQK‘¾ôn¿žGÐ6xPHÿ:ìþöÍßᣂÁ9¼ÍåÏ?þøâÖŽp5Xåtúïv»Ï¯~¼º~öÓËWû ‡Gž¾¼¹Ù__†|¸üÃ/7_<»yy³2n\ì_]Þ ÔÁÏJO‡~©v]ŽFbrÄðï_kžÝÀ¨úé¢áâ0.íž^_½z¶Ç´Å£Ça÷|ÿËMxñþJ<}ùÏý`_Þì/oÞЙŽç9áo®~¾~µs`HãÞŸöß¿~ùÙÕ/a¬‹wjáÓ—×xÛf}tëûÂJ<ƒ¯m6ú±QÓlÈläÙÐÙ(³QgÃfcJ®Sr’mJ¶)Ù¦d›’mJ¶)Ù¦d›’mJ¶)Ù§dŸ’}Jö)Ù§dŸ’ý ùÅJÛ!Ãà… v:+¨E±¨`…ÖpÝôƒûáÙ7ZÓƒÑw·ÒÉ­Eá6õõ ÔHé3 äHM¸öº…BÔ+Øùa)ïcmn‘0>< %ÉçX ÂÒØn¡ýá/oö×+Bh)" 8a@œ-axòï•A <Ûo‚@ V-8“ 5ølu¸ôLNÓ-2ð+Å£nÉ)H® q¦zŠ‘4Õa¥Õ;TÄU´®Kn ¢0ô–‰Vë>@Vf ™Ì®(h¦0"©ilƒÒ.ñpY5D*E‡²N ä{1ú"£²æU‰8‰&\‚hz‚Ž("•Á¶Z]ŒKòªó¡à½ cÂІ=“ïrŽùßÂ!ÁžiàÃyhŠ¤²ížQ} „{Fí^@V¶"­FrM€‰öT¬fRMû†ŽÎéeÚð.L©Ô(`–&·yÜsä7Š8‚C?)¦ ñ"³lÞSâ)#j~'ãŽä²]zCÑ2ˇ¬³Ç 8Î1ã1—žƒic{¨Ç×ú–{!#ËÙ Ä™d.X5Ý£ ¨ˆ³h@I˜æÀD“¢bAÝ†Ö ­´ q|©˜˜‘°ÇõòʬKÎÔj4÷ cwáhÀ™ûmÖ«êÓO¿^ÓßZ©t5rLO1&~pÝÚù(6a¦I ™ë:qÔ±2®· Š"R*£ —¦c›V^ ̆È6! æ¿Vî⨴‘‰Â”wÕT· X´1R“€¡;BúnÚE— möi³OŸ}úÌDõ™‰ê3Õg&ªÏLTŸ9®>%÷)¹$Úâ±!³‘gCg£ÌF › Ÿ6S²LÉ2%Ë”,S²LÉ2%Ë”,S²LÉ2%ç)9OÉ9¯™scø¬ÐìÇ!‹¡ $~Gr¸®»w+fÄO@ bf’é% «Â`§eJtØÕ\ÚP]uÀ©²Ý|°êW˜Ì ïâÎü,.oIûIQ}Ô0˜ö+z¬ º^|‰ʺºÁS"e‚(ôýÝQŽGѺ™Ý€~XÒ·0àþEê"Œu ‡–CžCX_c)HÜ,HK „¾ÝŠˆûðg’ñ—_^ðÐSb®œgŒ¶¤`†½€°¾e¬^l DAµx’L  ÉÁŽ@ùe8ìçùjÅ©ôïü!ê8U_£8¿Û8e=Êá”îÄA"Êepœ‡h0x„É<âàÖËÿ‡ùhù±]ñVæa¹*·D˜¼Éõ^„÷;Κ@õ>JÐwôNéJ´‹ø]½Õ æMî‹Cx€\d›Cºï—#Þ-:¼WŽøßéædòÛ ÄáÌë<¬¿ª@Œ/`¹rYx=Ý™YxYxYxYxYxYø2³ðefáË”\¦ä2%—)¹LÉeJ.Sr™’ë”\§ä:%×)¹NÉuJ®Sòñ¬ð‹µLaüLÌ`s>|JÂo[ 1XöåJúª|ô-Ã'UžS~ÉQÁ#;¿Ž‹Ú–«ï$²þ ì¡¢Ç endstream endobj 2104 0 obj << /Length 3522 /Filter /FlateDecode >> stream xÚÝ[K“Û6¾ûWè¨Ù²¼ÙòÁ‰ã¬S³vÖ3ÞÔ–“GâX*kÄ )y2ùõÛ €Oq$QÒ&©=Q@ Ñýu÷‡éèÓˆŽ¾FŸx~sýì«×ÊŽ,qZËÑõíˆIC˜a#ma‚®g£ãWém²Y®/&\Ññ—d¹I/~¹þÞä7¥%J3èÖ¿òõÅD0:¦áŸ©¢³tæw‹U²Š-Šð\e±`šÝÝoÖé Z3`KÜŽ¬“8ä„I⤠¿O— ôz¼Oò ¦ÆÉŽ}ò=‚J¸jF¦Šˆå8tùç½—A4^V„^¾ûæÛ·×—8WÁžœÃSs1Š(.ºs¹KòÏ}2 F„ e[®ÇoV tÊÆÓ¤Hñ'¡àj:ßä¡u¼LïR4V= V’"Tæ鯛´ðÚÃ:œI‘¦Ã¬&bK!Ìm)d>’ÙòElý!$Çi7Š˜ÝÙÖó8Å07èx4áZê”8åBOÍ s'ÆIžâè‘ñÛt¹™y´@ÕmžÝ…:ß;H&ëE¶ 58>VÄr܆5ÔYÙ"Ywzë´•Áʶ8Ú>[¥È~XxÞ%ë|ñ[„ÖM‚5TÄ—¡…p€OgŒÆš j s§C#IÖh$ˆV•õþÞÓ '\»²ëA&XßAõ0hþM±X}ª¼Ý«³¨&¶^£¾ÝÕæ¦H§Ñð_@”jÁ)‚†(hGŒ1 LÊŒQìår=Ï6Ÿæ€ ÀGüh ˜WÙj‚sÜ,“<4õ–š¦¢Øºñj³\†¦÷‹ ®Æ_.8L~eÈ°è¡èƒªo˜”­Þò@.‡{ ¨NP7Ä,ÐrÓPØšEʆ‹ª-1L–C–¢î•T€©ë‘Ôû6HÚñm¨Š¾]“w‰5Þs¡"z.vhÝßS°’ÇS&‚«a¦-d kã³X/JËçéz“¯|t…QJè4a€ŠÏU % ÜI»ºD¹˜h)Æ×ór˜Îø´¦[a´7ÆlV ˆúÁ«‚©áǃÍÒû´,-ïa¾˜ÎÃOÈMw~HóØUÓ¤·áŽ¯79È–ßeyú_±Þ%¹ÒM—äÊx—Äââa±Ã ¿ÛX1M–1¾˜#@È,¤\-·<ÆîuA¨èÂäY¬‚(Å&ˆ«}FF› AÇo¢Ô‘ö#±åDòÃÖ¦I2€’Á›èê˜NT£%-;Ñâ‘´š6©:X¿ÄL1Í7ñß"¢&8ü¸Í–Ëñª¬PÕM7yž– ñ&'è_ò—f"¬^¸O¦Ÿ“Oé×]C5gYË·ú™s½Ë¸0É U ]E@)L;ú‰`‹£b æâ,1ÅB¿GAH–Q@ ÀÀé€$j ü€–óEZ„·²8A¯V,¨|Ê÷•çÉc1Ы h©RÀ÷ï~ºúöåÎ iÂ\EÃ1 o"8#ÖÚ6¶¿}w¹oX ¼»6oãpùá–|F¢œ®JH‡ s:Í6ÕŠ¦‹ô6}ìƒo#n“†`ƒi=„P~8†U Ã*2Wü( þêP,Š”$üA!#÷¿G„XÎ‰è ±Ç‘”ÁÞ[0‡PÞÓ¶¨qöÒÍ®à2 ÄÐ!(uNøãP «ÇšôM3oqŸ­fÞ……v‘׺-Þ†eÛaJ¡”PZùÌoþýöÃ¥ïâ»ëg¿>c>{°‘×âTèÂbuz÷ìã/t4ƒJ °L°£ßô(«_T,GWÏþ7%š Ъu¡'=ùa/ß\]ïR —ÄrÓrlœl›bI †^IóبæRÃÀý,…xg‰Y®Þ굈!ÒðoD÷oí!½0ðéèË·Èü¸¡û Ëÿ¶b|¡ò®àÓ2®þóÏ]:cƒ+/}Á‚¥`¼Ìô6æ ¬¬9-6iSj¨öHœ†0 õ50‹P¿.õJTwõš¶V½^Y‘‡jùÔæ°Ól¹¹;xÙŸ„;³ã½-0Z ÙŽÑ“0nQ{‚2*Ä8¼ÃªhÓN £ g° ¶æŠu³j"ÑÑ&í1HtÊù$ÖqôEÅ2kÐ}/Ôcç>͉7áOÜq¡1-,ýúÊÃîM™~m°¶Œ… 2Й‚äÙÞKòkN¸þ˜Ìɧl•ÄµÒ6%ÄÒyRbpêYŬÞˆI©«TÉðÍÛ×ï¾÷›k|ñogÑÁ„ß@1-·Y8²PãÚÌúm¶öZ’åB~-nË’Xµ)Ò˸ P¼ö¸?]H:^àéDÜHðÊhÀj[$+ˆ¥ö,"IŠ‡‰¼_¤mˆ‡ÄÏ)L£CÖ÷é« <;²Dí±Àà>z,@51<®™UDßþäÞ¯þsÈ+4gÕIòT:† î4î£åà] tŒ^«¨^Jà'÷"<èŸCgˆ‘êpyضúr%,GPÓ^Ô¢kï~M‹j­ó—õvü[Ÿ¾¡üàØù¸CÝç˜&¬ã…’Åi–™ÈÆ`Õ©½¯I¤U'òÄaP’ŽX½ïòÕeÏ-pS)ÀT`¨Hïw¤-£ûüø „ç½ñIãU/~ 8Rœ6`˜lu[œÓ‰Ä+Ü÷)œ£€zÂ+Ï9à %äKãûú+Í°‚”â„ÉÃè)}”šÜGOÎs¸ÁŽsRàTbpÒC•ºq_êé6Î.ž¢qRŸÈS$BNŸ‡§HxFÅSŽ£ÍSð Ž÷‰ñ§Û¬Âæàyö˜L„mýÃ#I¾÷ÑGW€ÅYì õ~h¯î7õÅM¸ÙÎ`Ý Î°Z4£I£U€ÄjÅÁ så9‡ªÞ¹¶ÿ¯ªª’Bõ‰ŒGÀò‹BxÃ=aÐYó$Ñßb Wri<Ÿ†¢öùtûÆ5¤ÝpäXß÷e}zÝ=øŠwv±â>Í¡ñ]yw¸ÚŒÓ=›q~´êT蚧Wà,²³Kú¡ç” ê•®ŒQ}»xÆmâ–;^O ç—A>wäwTåÔɇá4x"´õߟ ˜QãÍ«,Ûè2œP¥;aøI6bz0ß 3žhaëÑ8æ)ã€WÂt;ÞÖéÔX÷¤U6Å:Ì7YbUÀV¸& ‚â•?ãh˜¾<2 Ç”÷[ƒX4Þr-o–/$7Ë´]Sì#ŒkBÿÈ0"‡…‘.žH}fYi7H„©óçEšÛ]ÌÍ~ž†VÛ Ñ§ÁÕ°¢ø£° °ïŒ(aêWòŧùz2÷Çqø¿XÌÒØíÐs¸ò'ؤ @¥äaqzO\Zè=±ðYnÕ‰ç©5xu?dÿ÷{’hˆyR˜ÎÜöU'ÇDçóÂd ñ¾(oÔÜ«-ï&B€¶Ó9í4ú8QÊs±šU7 ±žW}C]Ë_Á[~©¯ˆ6b¶OŸ³É¶ÊˆÏþš’x£d"ý­&/Ÿ”­€ ÿW¯dK endstream endobj 2166 0 obj << /Length 3771 /Filter /FlateDecode >> stream xÚÅ[ÝsÜ6Ï_±òŒ—?%õ¦Í]{×NšæßÜÍ¥}eÙÖtWr%mR÷¯?€ õíµµñä’•HŠ@ø ÃÍí&ÜüýU8ù}}ùê«ïµØÄ,1Fm.o6\K+µ1±f\òÍåõæCÀ¿>ûõòÇî«Í‡­Ö&¸©êOg< Òúúl«Uä»b_”i[T%5üêÐ}2ÿô¦Æ)üËÎ|÷ûaò„ÿødÉÀ¶Ù!Õ üê0hïrj¨‹Û»v{—–Ž¦¸v=ϸò¬­ê†¾)ê¸Ïk Ÿ»/®uQÞâ’ÎY¢£Í–‡ð›n,Ÿ8Mñ§£Uùþ@¼r ^2Á5 ±Óþøóë—Ó½0Œ+?ö`g[òà9BMµ#‰ û»´ÉO¥-J˜áæ$ÚhÃ캟ŠÝŽhƒíqrªÊÝµå™ aWDŒ)¿J³ßzm²¬®š¶hVܸ1[n㜷f­Ž PüF=¦cÌ-3#áG1iZêgਦ€¤»CÞÐ{ZçôÐÖyÚ¢VÙVײÑB‘Æ‘†ãÕþ–ߤ‡]ëÖõp’É6¨˜iÃý>| Ú" {.›‰Zfj<“Á#¤mÝ:#/ò]Ïê}Zãn¦û¼Á2͵h¿P»îè0 ÿí}{ùÆš >ãa."ÅcÿáùºEj¾¨0 î1r&ö eÜ„eVíïa'®Š]Ñ>,HL+%r°¿Zi8ýhŤ‰ƒêž”Ÿ©-‚#æ'ÝåÔó©h隷mj\ëÐhâ;M7ÅzÛ!„`¡Œæ’ Ÿµ=IgIø¹8·Ö䜎¡°ï*ŸyÇè›uø†ðàdoè!FÝm–Í}Õ ºÚáM›ïéy=·Ü€"K3ã6Y`ÖDCf5‹M·†6Üè‘ð’XІ„%I§œ¤´•’/ •àЦs™äe[v§©ÑŠY€=oZcZæCç­6~Mú#NpÏ#=?Âáº#üMǹR©/ãDO¯ß\ÐÃÌÜ5§RÎEÄ´âsÒõZÒ½zƒ#×Rƒ@’ 8»ÌQŸoœò “0 Ó”?¯ëª^I>xö^í¶[%‘,$‹zŸR8V§œç•dJ(´j,æ üþP£ÜWu~î,¸;ºJïꥒAÿ†¢Ì÷ ‰Ôrʆ8Is{ÃWÚÂ-H)hÉ×µ¥»‡ÆÖ“¨ŒPkÔœH~2‘uND^M öÝï`¹•ü°ø€—Ñàõ¶ŠGî@Ç2ÈuMÒ“íïwv3¼±€ÐƲ¡í]ÚRsŠØ›ÀÅCÿMÞÄžLh»¯«,oÈêâ¬%5W¥£ã>m,N°Øg@ºƒã„¨î´š@Dh~Ïó"®óÒ½ñW»*û­›¬)þÌ{t´ÒÇù‚Ñ:#à°² Fìïm ”_? %naŸÁ($S,¶Oëß–0—äLFC¡’˜âÔ£Pý&Âãþдôtå•./÷ØVô{è“ÀÓÍ¡ÌàÐsØåQ[òâï×b/1“tgü-ÌpÔlq¦û33pëqénÍ7O¬‰Î—%ÊŒµ·¹«;TQÀj(;ü…“€&ð#È×ö(  žÕÅUî>(Ê'£;î=„GØRLÓa¸Îf»ß°ú-ÑÓ§¥ |K¿t’h(Œ¸-Ê’Ž“êàÃäôvgo)lÆXÁE©'ÂØ0àèôÚ{³>–óæKÛ©ñ˜° M£Fc†!øç2ÇcÍÂþ´>ƒ;™ŒƒðÎ!Hpù|â¡‘Lôm‘âÁ¡lö­ÕE† a°OñO?v7ôkÙÄîQ¶{FÙQ¸O©|õ¶ÜN2Sˆõ9Á2³$ž£q)ž²Ë ®^;IËUkéÜ¥Áê멧f`çùJýULKùÙq¬Ã@Õ>} r¬™†Àì’uºÐlM547)f]: = f9Q…6Ï£ã˜&fC"&å$+6R!aä@…ð ½½0"¨í¶ºÙf•Í‘@GNáDQW%ÂŽ]¶1Vå°›N–‘c•³UÎ.ÑЕÃæA6oÉ4I¹hš0Z¯{Nl"OS>´/$í#J({†Ío¨§'½¡v‚[ø°Ã.’ÙCC£GÚv§qY´×`WT$'QGâ±ü„®‹ÿB˜W ú:c6UŸSÛlerŠüû,­=–q^,¬A–‘= Øvh\'¡ìò™luéJxBý·Ý)½×yÚ¬±™l.û+ëFð«úu( »‡è »(/O£¼4½Ê³ÉZÐYò8±÷8ÈÒuÑ!,×Ô4UVøt¬3§·n|ÿ~(jêŠhßÜ„@û<>S[„ŠáB7Luv33Cr:!h'í9_âÆIÃbñkŸ>õ@x‡YÄ8¸uÔ&²jŸb„Ý[çL DZþl¼ÎªÖT€‘6¡®ZŽA:4 Š ì Ø Ãàb¸÷Ž[‡2º¦.gE)e8¤_u†”V–“,qÌ"îÄùÓ¿~z÷~ö Ìy28Ré!V!О»v›sË™d讲ì'úö? )+['“¼Õh›ìãà× ä‚†Ù…Väu¦“À.wFà[јfI„ùT •…¡ÙH‡N6— ³h£ŒZb Œ &kŸbI?É’ð ÃÓ…i„‚mê¸ò¤˜áX®Ü€¿,L¡Àÿ˜ !£¤#õuA#„ÞPª/q´JщÿbA¸KIƒ¯‹-Ý 9iÈ{„Š…‰4‹úm,I‰àn)p/¤1#9X±J¢l4³(JÊç+™=cþƒÍ Ô=œT˜êü&¯‡VhTÛéâ€úéß.ÎUÄT8U‚)åBESÊ’ã [°![®¡§{˜Õ‡·ƒ|®{À†yïF°±¢ß¢¼?´ÔíÆɱ¨à݉ †8Ö„q_GOlo÷yKG‡wÇH^í–sU|Fؘ¶ˆ@d˜OwÅŸùµKÀÊ„ÅÓb°FkDV@ì¢ê¸G›x2~³Ûð—$ },­õÈôë#\G¢Ý'U#élëZý(±îÝQ>@.j.‘^ðHBë ¥‚M ïQÀXÐÚJ»ÂCâK“Ê÷åzì!G6–.ÿq¿«Š–J71Å3ЕfY¾Ã³û¶›~X J|<ŽœÏG±Ø¨>Ìå4srþè`;-W«>ˆ®ü@ÎHúí7Á۪͗ƒ›Àˆ…?iÂáºq­˜.%­·0m8n ðæsð¸P°oFßʱjusØà8KÛÖBC·ºKÀÀÛŒ‚Çl - ù-§™”ôYfN6ÝåқؓU–wå8†ßž$춉x¸rãým™âú¹öÂsØYML˜’˜ÅÄ^í¾êìŒ//8bûDÛW…ÏE93îçÐáèØqÉ~Œ¾ü lš› u¸qç ÖlšŽ:{~Ôêë‚´šcM¼­+Øw*3:Mhª½{ꊌ Ú&gõÄesoÔ îÉcpt=¤qà­Æ€£ó|SX)CB„É”ðë½›ìjÆøl«ä"âqéh'ÒîND[d jf{¹ˆä€Å8-Ž¹½„E±¤…ž‘’Â2¬9J!ûM!«cwbºX5fÖÕ"§ž ½X£¯¼UVѤÒy£O®É9 õß ,9¼bfïªa(!¨[µÛån•ùØV'Ü^ÑhÙIuµa+€c6QŸ~ýÕ—[H·òæ>φ…Wªöìøfΰ¸mDü¨¦ëF6ÛâÖ½ÆK?û¢Ì§ ”T¢Ï†[ q>< î¥rGdSú„ý,í¾t€žY@ƒ0Iˆcã"‹wÖã-XAˆø¹œÜ¯BäAEM[#x˜PvGNG‡ËeÌÇë/W¶’éýÀÊ"%Z÷Ó ‰Ëº€un)2¥ãKMï0ùV5 Ý?Š” >¦u9³æ«´¦[b¶TÐ],‰3œÒ'„)b ~Ž·×—4‹øÔJâºü>Kú•Þ|±•~ð+}wùê÷WÜÞ#âÀ·€øElx¢X"7ÙþÕ‡_ÃÍ5ôî`2‰7ŸìÈý0<Ò±Û¼õOw-x,@Í´¢‰"éPþ»o/ÞwŒ=ܾèEØ[æÎà5óÜ8Ü|Iî¶\‡_º¼‹Ü$04P$ÕðÏ`”GhÏh¦(rIËw—Ï®¡®=wLõi´·ÿ³&B€]ò%X¡±g|ÄÚÇïåXÛUÙs ö-|æ@YâäÿÄÜ›E¥pVtô"ÌúfÂœè³<× Ü©ã†SB”¨—àSŠF®ä.f²Ïd­F•\òËü%ÂÖF^€¿/2,òQ¹d±P8LGØ ³b<‰'Éi—๶7¸mzâÐV`ÌŠÌ_5Ÿ ÇM38"[;ÂÛåíÊÌÏøÉÛŸ1­p9“æ´†[ì}6~Y›«ÀC# %)° œ *¦Ë )=ú4ùrT endstream endobj 2064 0 obj << /Type /ObjStm /N 100 /First 1012 /Length 2937 /Filter /FlateDecode >> stream xÚ½[ÛŽG}Ÿ¯ÈGûÁÙ—¼YÈ’ Æö Ä ízmƸµB‹f¼C³Â¿çdw`CÓkŠ’l&ª++òTddÜ2J“YHA“yk$rÐZH”à)“¨!ã6ˆJ=´ÄÁžBwÞr ’¹Q)g  ,³ò70÷VIå EÇ%H-㉤õq·í‘€êAeÌ•1ÄÆd—îDD¦¹%Ì‘ h…Ïf<Öò‡!½q%˜äL ï æ‰uDÖ?uÌÓ,XÆ{KRM9†Å“‚‡¬áÕñ[ ®:¸²BÄ¥ωˆk ^œo†ð:„Y5x—q×Bæ˃òeÌQ3$<Þƒ³óåS…ÔsO´÷ïȹ»uîã.þ)"ÄÒ4@´‡÷(Öˆ ÿ”,†9Z¥P˜©,ãX üSúXÖBÂL­‡*œ!‘jÊÙpY½s×€EãÝB­C¶ÝCm…ï¡×ÞÇo%4œ±°M!~È/ˆË„ŸzV®9ßB’†–•£ FÕ<æo¡[Ü:Õ ë- —ËX ½ôÁwµFw;ÄŠú(©„B&…2‚„FB©[‚…‡F§ “©pJ®}¥f Î28´ÖT:‘Ú RH“Ab6Ë&ŠÙ$SûD1›TåÄžS(f“Nñ‹nŭWÇ£e ÀljãÍ |Œ7r0̦¥³)¤K’›­¾ÆÝ–²±—•û¤Õ1¶p;¦~vëÖÙæÑï¿mÃæËËË«ÝÙæüÅ/»q}ïéå¿Ï6_]]ÿº½þ)Á.¤Ç›o7ßmnÿ$ãâlópûd~‚ˆÙr¬ª6-Aa×E0îËpëVØœ‡Í7W®ÂæNødûŸ»§W—Q¢}¾øâ ÿ}8K)vlщÄRŽ÷?‰/‡ÄK‹‹0‘x+±A™!ùÛý¯…y„„ªQaaz£C‹½ÔhÉ>>÷•^ÃKTï-Ø#ÏÐ÷·øîöîýü‰æŸ?]ˆ¤HÓàêÑ`=½H„w‚¥öèZ1]¶fÌ”DÂRÀA0 ÛÄEcö²"Ž–£ÀòZ—HeÐÑsì ×y=0DÔ„p¢±æ“pÈ¢ ’%*,õÄÿcÁÞ]¢†×`’£"PlX Ó )•aö |i£Ón±öQë+ê)-¼þÄá½G,ÑI8lQÀ–ï#•Î ²Á¿°2vYÓ’u™Šz e-–À¦"‰°ëA –¤‹¹ÙŠ¦L¦ 6”ÁxÉ11ƒ·ËmEÛN¥tFÛ F‰0ÿ8È¢»×hÆ} n5Êúò@ç#©‹¡°T,"u¼ÚÛz›W:‚QÄA%!ÅŽyþâ—çx˜A¡EÉ ªk†å@ÎÚ¡BK¡ì̈ìé­X~÷ÃÝûßüü‰,«®) á˜@Z…©§Yty\‘ 1>ñ M9à0_Ö0<-a½iÇ»¦Ê¤ü_â¸3ü8gz6ÿøñŸ^ Ñ^EVxùâÙ³ÇïˆlvŒ,™O¿g4˜ßP‰¬n¼>:ln_=»º>ÿíâÉ6Øþ™»Ýöú2èþòë—»oÎw»mñÃÙæîÕånHð.û~wSx—yÁšHšÏûûÝÒC‘y§ÔPëÍ«}^À!æykYê~àÞ<¸¾zr¾Å:ì»aóhûr¿©:.þµ=ÃÛ]»ç¬$8Ÿ§†<¿zqýdû|_™¿}¿ýõéÅWW/ÃPª‚ô»v…¢<¸¸ÆÓ,Ù~àPÈç˜xÔ‰ˆg”‰D?‡75¢¡“°Iø$ò$Ê$ê$&ç:9·É¹MÎmrn“s›œÛäÜ&ç69·É¹MÎ}rî“sŸœûäÜ'ç>9÷ɹï9?^hÿÂŽD"…é-äLòJŵ®è~±eâ€7cÌ©„~¸p]­Ò—Nò[ó0ìH³b•6¬Âê¼^]Ð{‡Ë éCS1WÖ)KÌzT$º¬/¬DØ ¬Od½ú=_Ö÷J¨(d0bW¨—(#Í*ùhˆÖ–M&(ÂœM3™X‡rmûʳª §ÃÒvÆuöµVÅ3ü(Åq€áÍ…ñðþßÏo¹àF)>Ël˜›'"Ø)‡3Īo¯DܾoQ ŠPPà—2 *æ †üö+Ci›Ûz›•ëaÙopp=Šæ£@>Úz°â`¯­‡2Ý]g=Xý08Ö‰ÁrG *G1ß-¨5ÅÎr%§ŽÔEýyÇu}û9ÿñû%í&âbC`Xa¶Z÷È“<J²¦$˜% Út†ÇÂ:²…N`¸.kHB1!ÏdŒSÍÚbÉt*õXÖ´l©0– Ô.Œç…Ð6¸áoZ1ì­‘‡zH%ã8tCØW2Ohq]e½Ê˜«!• î‚Ìú8E]„ÛÑ P£hi‘gö†ß‘ä®xÇcAϯD“åd$¾¤š"êåFM "PSV”™ ;¢á¾âICòØG1Š¦ û&ûˆ¹„'2ï¨ñœÅa=ZBç<ƒf•Œ½øYÔW8ž„[gñ,D1Ì€r°D&¬¼]?<üö|I#ZàÜål 8‚àÞ¢x(­Ü  ÕtÖL xøõe1X‡ú+ µcããRXTÆ1³ç!²ÙDàFòŒÌQë]þ\~ckÎIå·7Î3vv;½gô,‘ÁÑôª‹–È^¯}½Y{½^öF¹‹édÖ?×¾ŽÕËÞ(ŽVcûËõ²Rþ\/+þ×ëe}–œú¡äÄ~Ÿ!“˜·dÞ’yKt6 ŸDžD™DD›Ä䬓³NÎ:9ë䬓³NÎ:9ë䬓³NÎ69Ûäl“³MÎ69Ûäl“³MÎ69Ûä쓳OÎ>9ûä쓳OÎ>9ûä쓳OÎyrΓsžœ³-ZуQ¨jK£QØÇ–2,pUê«2o­lvŒÊÆ2ã¡®­Ó 4<[dßàÀ𿳶¹)5r%ÈfPXÈ?UÈÙ;‚…ÈÍ*¯°‡èU‘®ÜTVl‘`ç %°Çal\)'áø£¿úðl#%uvªÔ<2Pg©U §ã=#š­i²¤Êª"kÁÖ&§¤¡ºÇ€ôeO{±ósÈÈÐÙZ¥È¾X¯i=Öt¼cdYqŒ&»~ƒÃHúI@í‘‚ÝØ1œ"j(ŸÚbõ· >ûÌM¡¡P–Qóbh¬ÃQdëGˉ²ìŠ°tÇRÞÒ¾±SNÀ±ìùC3„eL‹1uh†îK¼IŽVL´.j: ¬³çœ?kIP‰ÌÚ&5¤¯€9”1ÕDpsqÁ² ͸Ž>ªÙÚnÖ¢"¦ËÒØ)úÎS²WeHÛ ,y¢Ñ{Ý &°_yoN3û˜¥¯Ð´ µ½²ûùÙpÖ ˜Õæ?Òåî7G…ÞËmÝY^O ¬=çq*ô~ ËFðäZö+Q*4¢ðﾉ¹êŠÍºì—*ÈXÐX©ð#xØ5»Sñâi|‹;?Ð|œ‚H,ÙGµŸ‰¹úK ×ÎfPEí, °9T™¦¼}až<Ýmã_¿ø\tA,´å{(£ÅŸ÷4gï‡òìúsMÖáö(ØÀföJ,Ìð÷½X®¯^lwËJ¥X´^^A©¿’ßåÙöå“DòG?ãÑù™7o_œ ¥Uv»•zªŸñe½¿ðû"n_åç)°oü.¨0^—õ‡Ù'ª†È¸øMŸ¨Bš?o^60'Fü ®Œµ²žcßOöѾÏõýÄ[Å5 endstream endobj 2217 0 obj << /Length 3614 /Filter /FlateDecode >> stream xÚÍZÝs㶿¿BòŒà›@fÒ™¤MÒË\.לÛ<$y %úÄ9ŠrIê.Î_ß],@‘mY²§íƒ†‚»‹Åo¿Àgf|öý+¾÷üæúÕß9sÌ[«g×·3a3ÊϬ3L(1»^Î~«‹+iøüˋ߯èßýzeŒ¿¿Ë›öBÌËîžfmnéÙ­ j4å‡UwµÊë%õÛrÿ)[zÂÌÿ¸«6eWÄIËmSÖâ ›jÛ•›šzw«¼-ؘ”+¥™³~v%$óÀO ZðKzCˆé7ó_V,¬µ˜ß5¤ã·¤‘›âvÓÔì`¨ù„ób7ÒÎÏ?]H3Ï«mÑÒ‚Ó3°=Wù…äóá2»åóul­‹¼°‹+çÔü&ù3%þ\ œzât(ak’„±…Æç˜7Y–m×”7HǶKƒeMÏ@MX©k¶‹nÛÄîb³¾ÛÔEݵQ”œ ø™Yƒ2MŸ¿G­R­’ڰ̘è}[mao¯_ýû•ÀWgb¦•bV¨™µ‚i9[¬_ýú;Ÿ-á¿`YåÝìs˜¹žI{ÍgÕìý«D~M+˧…dT†Ÿÿþ~´ûjÏ„Nä]žÆœaÜö¬½I³–yf¬}ÖœdÒØkI˜°¦ü™¼])Ð7ãuÔ7G‹¼ždR¸Œ9˜b gÚŠgp)¦ÀèÙLÍ_'I¬‚!ƒÖ"Z[Þ‹E Ä$ ÎHæ@[£˜IÇ(¹8íÎç ÎKó1ošüþ4é*hêÇ…+¥e™¿JdÌ8ý‘àŠV½2€È^kh=/rÔ|lýøî55@b‹¢m©<9x¶åŸµòŽžU‘·Ý‰ÚÅõNJo¿û L*ÄžÇh׊qåvÈ8µESœèƒ c+Ïø¾KkÓ{eK*¤`9ÍØ ‡7¹°ùm‡z9ò…oQÉòE·iÊ?ó#>­`™6û.í#žøoœKÐýª:Qyè›<¢½ kŽ›™ñà¢eÏÓ^0 žVÒÙ¡Á3Ñ+@Eåçë².×A1±WÖ ë:¯¨nêz[#Èoê–†P—ñ9r•¡]eh-ó.­{`»‹n÷•±ènì B‡wÑ1ëÄÞ6>à6ž±‡‚Ûã{(…ŸëYfŸï° óœV2V?Ì#qe¦çë¼ POGƬp X4œ6 ¡‡G¹„ؤ ‡æÝÜOZo ¬ûcÖ Úy?p·Ä%}¥¬iq4B=YA;df˜Vz !Öa0‹tŸ¶Õ™ã¼Û꿾½~pLÅ1Çôî}%>Ÿ0ˆðÔ`Çâ~þëBѳÁ;ºE뀷îhè¶Ù¬©…¡¶ù">e|ªð”‹‡ ‚^ÈC\ ®)ò œ0¾åæì?¸Oóïðtmšø'=ZL8Ä—‡§9ü§9~(\¾ÑE½Lûѻ㔄ŸãLÝ@¦|,³¿·ù¶êâÂaÑCí‚}0¶÷z¿ÄÀšÏùN–EÝ>’9iöùÚ®â‡F¾®1„ËsSV˜±9$ÏhðSÔ<؇œfm=“®÷8Þ†ßà~ ƒ¢a$ð— ²<*hüÑÓª ¬5ˆ»¼«P^Vå3P^éøÚ,bÌ»ÝÖ!$Ê« fW¢Š‡÷‹Št_ƒ%XªI{:3§Úï'b DïºX‡#rÞÃíÎiÀ?퀇Ùä‡$õ)šfÓ¤±¼ºo“²Ÿ…B¢gÙD_l˜*fCó›ªXF¤’&¸äÅìä/Îm‡vÄíàA:7ÖGðÐR©ÝgíWâR^ª¤/ÞE}Éá†è o–´pQïQ'Îí\lÇ×Ü„³7H§Ë#¹CÑ+yŽƒ^½é&7!f+(Ë ·ãIà0Ì4×cú¹XçÍÇv℃£²ð8±3ÒÙù²èàû-uHòf¾Ú ]Ÿi0œYl‹.Ð^X0ÝwÛŽþÉלê¸ÒÓr)01äR0R:†B:Eì§S.Ÿ°ž7ãÜ “û™mËHgP¡Ûñ¸} ûÃ.9ï0ª+h"hBlu«ôAk¹½«bâ»  !'·äñ$ohôÇÚaÿpGg_ gtâ Bà)Þ‚@¸ÒÒÏ¿>1Wëwò„”“fœðë˜qByÁ!ÉãáßÔá ÀÐM$q¹© IA  þ Ž´Û†Ø·Û*‚ËDHèc0_LøUv-ýÙ-¾Šf Ê=׳¸'kCGÅè…ð¹òºEg9þ—Àé„póü†ü“Ây? ç!tI8$2%É°ˆG†ä ®7Ë-l±LãÝ碨©sböQɸ8[ðƒGáA6]B4èÍ8Š<-ñ‰µ8K‰O8ÊšP c‡çËîÙ@èÇê´nÁñ•ì5âzKè(ù˜Y CzŽRj8ÇeÓyÇv*-£«DŒÂÞ÷(YÁ.“© þïÏdØCà´Ž.B±¾KÅƆп탞J\ æ1-!¦u}(hÚWÒ |°Þ{]¢±{_´{Ùœ‰P5r´@t÷òÏf$Çkov6ø l:ÉõD”hŸf|¥ A, Ñ‘wS&^’Þ IòS‰þ›û=òV›¶;,Õ©?’yp"†¼ ¿p ¡¶-oª"EWM4ö‹¼iðCù}Ü0Eà~‚ï“þí'ˆ5”P{Ì‚¾X3’xÀ}ÙïõûŸÞLdÔ…g™²3 çŸSöS ¾ZÒB™gNÆ*¾‚ëagš½ Èßäùì SVÆÞKÕûÞLòž2ãúxÓ’ƒáíè™ÈÄòrìJOŠ®™ê3Ƈ9‡±‹ †ÐîeË3ÇËv€PJd„¢>]=Èæ9€ÈC¸Ø¥K ð6ÌLƒe\#.ïd»{Ô Ö×@¨ýp‡^ŒŸ HCAêží‰.-ð·Þ&ßȈ @ ö+ï3xEÞTeÊìàb4™Ñ<¯Nk¬Ó̉Ãa‚ùèöÙÑöAo´}ÐÛg³ùGtO‹»ŽFoX ÅðIõ$|©­FâÄ?ce©_¾¦™;j;ÝsošLí÷48§ë 2óL<+ž®+È ÇÔSÑÙ+ûtδz¥C á÷óù“Z‡äýIü á™ÆœeÖéÇ-+DCLgæ%˜óV0ÿg›‡ÖÂ@P÷|þ”¶L y:½oC ©„ÄÃZSk —Jˆ—øß.±‹_Žá€÷ ¨A6U4Øˆà ­þ)K>2ôcA'Çç¤ÑÃy‘r4?³=ÈÆTŽ¶Ï`¬°bB" Ö Zƒ"4ŽOÕÁ2*g]bI¦³7xEJ/D0»_ÊDÚG®2aéõ±ªÅc£ªV ;Tµ°Å÷èGrÕ})+LŠàÿ³BÒÀñ Ä·›fwÿírfM_£¦ðTÌårëÂpHGÃèÎõÀÑ=×O JªiÀôAM¦Ç„¢œ¨ß„ÿ÷J501ÄíÒ¦ªRê"’?:7÷§ “üœ‚ŽáÌÚ à^²DÓ— ò»;ð„—»Ä‹‡E LEu:3¥B"‚Û(º˜.qrJþh¡s\š:¸MGß UòAFÇ<\üà$ûá …C`¼x'ð„ˆJˆt È Ð-5lÅ[jR˨ãxa%õýƒÖyìÖtŠR§3Yü´¾?èt+‹“¤ÕF¥Tp.vézbµ &¤ÿÿ˜XÜ/ÕË¡ÆÃåç«v:m”nFºR¥%4陓()®táÔµ¡'„;w¡y„=è®tO?¼1_H°OÓ(ØIƒw™‚̨Áàš,ûüXÏy\ˆ°N0=ଙæüêžîâ×›$¬lèû§¸+þÆ¥™àßWî1}1̘qÂ~”M Mûj½à†9Ý‹óë‰;Æw†TÆ4Ê^Õà-¸ž!!Lç~G†)@Þßë:€j†>z½|·,ëE2ˆ\ñ }¾rdž¾§á.½_î©V3ü+æYÃbtÓ:,˜2ëãe{Yc… ¶ÛLð(!²â ,n†,üiÖ' ™Ï³îvñê’X5ñIfžÏ-=‚µî9-ëEµÇŒ'éñA:š1œzKÏqQŸ‹ä1ÀYʇñ½z?O¶çnH2³+gÏö.¢öÅRŒË—Ò]h åÎq@pÁ÷Ï¿Àû«±dëv·û‘ÒœQèÈÔz9ÍL&ª—·?ÏW/pFwš“Õ ˆ—Ól®©;P'— Ô‰@oýˇþ Ì\¬8‰FJgö5kpc :ÕXˆ¯Î¸QâSR½ÐvøÂÐ/ļ —CD rzÅ}{ýê?Gסs endstream endobj 2242 0 obj << /Length 3794 /Filter /FlateDecode >> stream xÚÝ[Ksã6¾ûWè²Ur…à 0USµ™T“šLfÇÞËNæ@K‹ItD:ŽóëÓEP”,ÉÚÃîEhô _7@:ºÑÑtÇÿ››‹¯¾W|dI¦µÝ|1A r¤­"L°ÑÍlôi¼|XÞ×—Ÿo~ºøîæâ÷ ïÒ1e3Öõb4]^|úLG3hûiD‰ÈìèÑõ\Ž8Ñ£ë‹ Mª2bµM'½Ï×ÿÀ9¡¯êö…"ÃÁ\§?^‡>Ýñ8#V˜ØçWªèÀ@œdVÅ>ëKfÇE¾øjZ-ïÅŸƒ*N”´ñ…ûª\5Åúr"L6Î×ëüéR«ñÕåD2>ž•ËbU—ÕÊñ X@€eDÖÈõøðñdƒèÌ `c»´wam­°¾ú^›t‘jÈ_)åÇͲÓírÞoOÖçh2™b~åe ÿ–Žó! ÂÔ‡8 "eöiéØg·„"Ü´c•+O]3/°ïh"M%™Êºƒ]25þórÂÿåbòó ÅÊVÄÄDa N¸ cüq#ÆŪY?ù"0—R¾Âßß&Ì åN¤hA@æR̈fzÊ<+E¤uùP7¾4¯3_Bž¹B9iæX’ŽSÕ X5^5¾¦ú²éìצ_bˆ–,Î÷ÛQªÛ~ó,–£Ý\a]ÞÍ›É<_ͼH¹’„ ™Öå¬ðr[æͺ ‚ݨ–ïÅe$bHH‰©üJ¹XlF 7½¥öÑœõ9FÐ’f/1Wä€ã¦¢›P(~ÈPôÚ?ÞåêÎëjá aæ5øK‰68Åïê}ví̧lÀÿ FÇ%N“eah‡ÁpÿÔÊÊó¼ö…¦òÿ·á•)ÚR¾(ÿ*f~°(½ÃYÆ2ØX+Ù·ß¾¿y‡£ðÖwñOZ"7.é5Åþam°¦°ŒC-d¡Ù™üô DÚÔHËÅÂË:X}W1‚ÕC)X½3ùž ˜<7„ksœÉ»I‚É)iG{Z‹¾0dÆuPöœ%›,Ù>gÉ/2dvšCÔjDon­˺@5U™ ìvž‰XØ0Ÿ¢ bÙ™ ë[ùÿÛðʬ¬¡×í%§ã‡Í+7CN×l6åÓÍE3„õÅ…DÏ“® ]õ}>ý-¿+®â^ÁˆÉz{ŠÀ)ÖÆVUÕrÕäeP¼|…s=,ïV%ó4–1˛ܗ¾Tëž ?Ô€%E€èÜî%Wg„ÁË ôeµA#Êñê1mªuMü6ÕõÉÀ ê勇ð€A@^×ËÃÔ‰e‡é“ÖD‚?=ƒ>ÁH<"ƒôéÝ}Ò0žØ«PøÖþ?P´U(|ê(”ǧy€ÐQ¡°|@«S(WñÔƒ³]Ç`¬‹X’öi^‡Ò#´8ÎóN8Pˆ.õ{vÏ‘¤ (\x'¥§_HO?Vx G¿Â°hžcüvÛã«°° ·-iëÜŽã#l÷Ø#s/ä3EñyN»G4‡Nb3Wçœ96ñ.' ¢€ÂVÇ…ß­‹ÜËÒíNäPªB Âä…ï –z…=œ©„¾ßÇzCdª—^ :û5R€ìÀ,¨hñT¥/ÀÆ}ïظ(&-À‚Áú!«™ÙBõ|CÜ Cá]»Æ~íî™OÑÏoâ 5ƒ¥ríTØ’ÁÞŽòQ"lM˜ý!üC :¾ «‹ç<_']p]€§ÊÔ6æ ”ž8Ž>Ô¸âWb€l.•²¯{bœp@hR!C Ħ!ŸõÖE²<š6ó¦ãª/r´©CÊw@ä À+y­ ä°Ïcé£f¨ü‚Ú„_Øüª‹1›ÒN,2Õt´ _õÖ“ q0ÑðY@¥/:$‰ÿþ/’„åqº7üTJ,f‚. Ë†3/û²yòMÎàm \XÛRŽV0óUžx7h¾j»‡R¤ÔƒÅûEU"œX’ÃàÍPsÅ:Gæ ] 4tP4TßÏwÆT®ºŸ‚‘ã^èÜÀ5À ’&j®vvvsÑásH¿ÁD›{jòÆW¶ÄN«:49:ò—aEžaû†ûu`‰÷ºn˜<¼í9ŠÓCL«A§óè`*±Ü> á`oÂEÓà\Ç9S&‰àÙ³ÞåZ!þÕí¶Ñ© p¢JôöÉ·«í_ªÅ¢ÂÅ=ÝWmL=²3w™Ä³…ˆ@þÉ“|”*³îÒ4'Š¶ëÍ€_ÀÔ¶¡c0|RE·»ú«XWuêŒAªHÚ`Ñ'Ó‚]Ë8üsE&™< ®T‚{ôí¬ãZ5✦|/Ú*‹îÊÎÐX©!&Ծ¹C…v¯j!|·c9)’㦕ÄBh0±ea0ƆF3ÄÀâ&ŽÞƒF œà|`4ð‹° vÂpbqnv^Ú$Û–ªP¾È‘Ù«NR¥/Ôo„úÍðƨÇ\À> Ûm°Æ&_ êðj@aÁLpKÝc&0¶Ý¤Þÿg;6á ¦;bÝŒ¿ 6áJ#q$ˆu3ÑÉ(ˆŒf`(ÁB½›a0î¹™¡@Ïï‹õÀê  &#ö­J†ép…ù¾ à‡XÕÒH÷ôd ” s]M¶«B¶aç¼ÞŠ2ÛÌbo/ÇbõŽ¨6. H€¦oc$’ G3‡@2j÷áh £ …n>H§¯Ÿ0´züõµ‚åH³ó°|;þ°eüãåX|=0º` -j|ƒs;fŸ‡SBl`h`’Ãe6–îߎumÀwëþ¶‚¡$oàw­hT³öyxЙ|N®ô9D#Q<Íõ‡ËŒ¿ùxýÝù%1`í·8mO[M2£ÀeÓÕ<#{—ÂmýÕ Ì)µKä"ˆ<Šž‡qœ ´YL’ˆ†å®,QR×à¦Í‹äÎ~$šÙCä,¥ò¿"÷SV3,÷îjÎ-÷A`@Y›ø| üä¨G^‡%vŠvô`òœƒ ²S‹8*…*B+B‚‚q;¼ëzã62mÓX«Ú0[ÛÜ`íŸÛŒ“ç›Ð}V`æ~U„jÏÃgp9d׳Z-žâ»%‡öÜ7Nswh¡mHLõÏ^2ë™âéÿùß?̈fDl.ML³šÁòQ÷iÏÃtæºG! î&fî0ÍkZ»þé—7ûâ9¦ ÛÜ•y-B<¦Â<€ÑT¾Þ‘Í0E…Âðh&Êfs \€ ìåÙl ù#NG|qo§Ñ•Ì•I"u–Òµózòk_þÜ%‚Öc !dy7Ù a?ÖE ÜMU@(0 ±>–!åâÔ=§›ÆrÓb&Ⱦ ûXÐÜ൓“’s™ÁNG$åçÐ ‰Sq–3³N 0|hÌs‡fÊŸqàsçÐL%gÒeÁÜ¡™Úœq`­;4SáŒÃU<Åî¡Å'}Üð+_šdzR¦löyRv Athù9®QâHšËã¯Qö} &&N¤+B” [hB€A#;`0 á3‡C¸xÈN /lÝßÔŠ%÷7 <Ÿx“Q½²‡üµõÆ,ßiLíN&A³X¦R¦>s´—nšÞ àú9_ºý£wÖXj/NrË Ób+uQ¬Ë©÷â:‰1ðÙ{r=µn]ºÂû]¥ïkÚ¾E>ûRêÖuLð»y¢ ‡ƒG Ñô?p„æe‘¯Â¨1…­wÜVðüF`oq`蓬¼{«°wîjF ²=ì¤ÀCêã|þ‚Ø*¬>ƒ¿À‘¨ÕGø‹i§ÿæDÊTïʲ#¡l¿Ç„¯äŽý.€ÓhòÉ}Þàõ½Éƒ oõw(Å÷Y½0€©ä‰|éÎ%Œ R¤l9ÀæåöMЮÖö¯ÿɬ“%Ú¾ò‡g¶¨ÎúÈ Í]æ·‹¡c~7x€ÖJz]½8t÷àl…×ÃÎrõÉ(Q{>‹:‰²A‹êRÖæBûð^0µÓ”„1ݯlúõÍNÞ=¹<ùfä+?I0þÎ U?¸­Ä´Û@<ûÆF½«¶î“sL@Þ…¼«zðîA}7š‡Gçô±¹ íŇêMBš¢©Ç,cÀìWܹDîL¢÷±/q;Ê™IÅ\Èõ‡èŠwÉHðîǨHÄJ<âúDB“ £Ô¸Ó„PÐr§Äî® !;hÀø‚Ú3Р„p|˜¯¨“ZEEOׂ&s&Âï~0ü2b½.êûjå/GaU„a×;N¡,K±½Ò«ÀNñ:{‰:ÁŽ ¶‹©³+“0 ܈9‘ÌdFc £&¡ó0] CTž)tƒ$Ubá ~‘ð¾jZ¼®Ý¹K/k—P:L7³‚0lMöE(Ì®˜HÇïùÝŽÞ׬w‹l÷9øž—„ÇPTØA‚Žý¦Ø 6©×Ç:z¢¬Ø .ñ¼[›Ó˜”˜¥©)“2étùŠíÂb Šîjã1` 7…s$Zq öÞK>*Å$;wN/‡²­¤€4Bá'Ã* Ejþg>*Å•‡Ï¹Ï-r.0ë[Ms÷ Š«~òÿ~_äárM€žÞ]Vw_Åœ1 iGW従Ù4©qõÐøëŒÐ­sÛuòÙLù…ðŸ|¥†¯œòy &Ø©ŸÇdéWjx›J÷ažpç2íç1Pø²®–žÌ<ïÓé¸þ¡Ó#÷qe?÷±ç ‰m–¿cÙû‘YúßÖ—^'xgé5q/“û‘•[ý;÷—eæÎwaß%Ö†xJšäðk•E endstream endobj 2169 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2792 /Filter /FlateDecode >> stream xÚÅ[]o\·}ׯàcòÂåÌð³0Äv•¸pmÁòC[ÇŠ²hÚ@Zn}Ïá.Wvc]­ã›kÀ°æêò’‡ÃáÌ™!¥bŧbÕ‰u¡9ÍbpÖ2qÉ„‚ºœ#s¥% Ñ5­’“{£ìDZ Ž¤´º”ÿÅò­“”=Œ ›„1»ÿiñÊl`ÂD°F2 â7þû1ú‘œÐñ ·úÛßÿḰHJ ØÙÕ»·o_ßÙ|±·D àŒôžÖ ×Â4à éÃÖnõhóvsEº\;Û}sv±Ý®¯¯œîÿü~ûÃùöb»vÒq²:Ý\mûôNAlb »v§‰1]Æ ußá)’¢RF3@˹fÉ‘Ùîß0iÍÀ*s9¼A²‘ÆòcÕÑYJ£‚…¦´ûó[]o.Ï×X/Lêñ©[½\¿ßº×›ÀÙÅ?×'ÐÂÕv}µ½!gšù‚+}³yw}¹¾Ùqþþ»¿®ysñpóÞuãÈ óÈ°Úg×øT&Û®a7¬ ÜÓ<âéYÞ^ÈC(C¨Ch{!‡!Èt¶Êø¼ŒÏËø¼ŽÏëø¼ŽÏëø¼`u«X=×Ñs=·Ñs=·Ñs=·Ñs=·Ñs=·ÑsÛ÷Ì,n/Èt6„8„4„<„]ϯgòºŸ‘¦V¯$«É3ø ÓÉ©0,-ÃŽ?vÒ~±ÿ9bv PD> 0ð‚ ³œBð ^`3âI\èIJ78Uƒd^—‘àDù4SùËó‡3RVXB¡% ¾DlCEb“ Ï)-dÁ|‰Ð3‡ˆ¬³ÏJPxny)ò¢ ·<@D•N['A<;}þÓ7j?};'U%7:à?ˆŒ· ã@5U—¼$VAU³Áq·¤ºÐ¢„8dZÄD€¥$,V.K™'\¸²@ŠŸ©• ŽÐ—rBzw‡&={ùK"s. óíl«!¯6Ð xY Í·XÈíXóhà ±Vß  e-.0ªá9—)UH˜S,2d°…γ¯Í1@f]‰ ê"ÇgŠ‰¥IH""yH“¶a:«B°CˆY„pàÑ°2Êㄬô5R^D¸‹'ñ<$øL@:' BÒ‰ôÐ .J%ž¨pSüÑ?0©c¨©ž'Y¬ Zm½º ÚýÇGæݹ²PU<ó  V£Å«MZo›5æ#©0bÅÓ0fÕè'ƒù~üšÈó©(x.e…h)Èî¬W¬Œç‡È\´Ó±z‡m>9þt^Ä#Ì Á} «›0ûøör!"Ö×< áéü:ÀŠó`~¼üº*,õh¯•æOÝ{"°T¶OÝ´²”–± ÷ä©ãDî×) ³C@|Ãb pE,Ȳz0dI•Èü§1aYR¥õãP%ãù3¬ -•©£Èrù%AÊ*·8àÂŒÜKã RÑ„T Ì 6ÏƱq$•c·lžq˲œPyöTÁ€Jß²¥a» º‚¦-G’É'ú ¤`žQ"sç’, N¿·£Þg ¹­,^Y5ϼ*ÄteçDxÏAàÝc’åXz Ì_oD8V~§€Ìª R¬TšÐñIÇ c®`ŦŸ£Qð"ÔQ'5g<.ÍáÞÖûsÕ¯qîñá±ÅÝGüîS‹¨¿=µˆáwŸZðFÓ¾¬>Êó2Êó2Êó2Êó2Êó2Êó:^éx¥‡W£r¯£r¯ecPƒÚÔÆ 6z¶Ñ³žmôl£g=ÛèÙÚœ§«OìÛóðƒw{´“A€-¤Eîö0ëÉÏòÒ‚y«:Pºo¥Q´f‘š•·/{¢¼€ ”Õg|#¼ïkbI,ˆ$–%®xGn½Àè¬"DÂ1f^xŠi¹ Gbé„-¨eȼ‹ÁÊQÁ.fÁ¹`Ïñ‹kcHDZ]èºO€3ƒdDÈ\Œ•yÉV–[‹QžÕ9Á†È¼3›ñ\e‰‰ðlp¤)J¿?¢k‚™x·Fï8Âü’áåGõ¡,¡ú‚pÇáapX!|zðË7Ûµ¿Þ¼[oÿ$:#R=ÊHmûJÑ=PÞ®ß_~!’ÿ÷••ÇØ𙼮Ë4뮬¿F›4ÎYɽTpj„M’ú~Û=¨W^F®æSX xhðLý 1²‰Ìµ0µ~s¿æKsP^_ʼÚï¥{ ø“+"ñÉ‹ @¤Ê™WÍ`¥³^éD,qÛΘãñ (çxñ,Û€ð¼ÜÅ2…1Tí÷Ã=/‹\&O-a k±‹e˜=ÿTB¤ïFþ„°n=å(q™õ‚Ý"HȹÛ=æ¶I ð¯ @eyÍ!#h`ƒ2锺¥ÍŒØz‹€gØ4Ê 3/ìidÏ?aA®ÝÏ™öÊ]÷åÿ A¬Ò\…cê×+À¥ÌÁMiø,RÙÓâ(GfÛ6„N®>Ïñk(ǶιÜ{Zïsó¤HYb;²oÍ?Å­¬ï×ZX™Ex>´þ°ú(L endstream endobj 2304 0 obj << /Length 4832 /Filter /FlateDecode >> stream xÚ½\[së6’~?¿B/[+WÙÜNU’ÝÍ왚œd“³5S5™Z¢-V$Ñ©ãñüúíF¼™òeÕ¾X ‚@£ûë æ‹Ç_üé¿ß}þð‡ïYd,³Ò.>?,„4Lµ°Þ0¡Äâózñ÷%™º¹œóå–us(ïo$_›b}s' _ÊÇMs·É÷ñ¹.ו~å†ßüãóŸá;jáá;V‡ïËœ0‹ð…ÿñéó_°«äðWÄLïí™>õÿFð[ÑuëæÓ÷&uë%{cÝIÅ™–zq'ã"®òãfœÉe³Á©gb¹ªöMq#ÌòŸ µTô».öuAÅÝqÛ”OÛøÆ€ Њd¨ooîo‡…WŠ]ux¡òCU5O‡rßÐûÕp r¹©êøí§Cµ*êº:Ĺå±ë}ì Ï°PX8ìËLFk*ëúX0˜€TËÏaP£—9 ³*ó¸yÖ¹Û÷å*oÊj_S;o늺ÝÇ×EýýÊûm¬x“¾Ôq_íïöpÛò±ë÷”*BBÏ&MiEë5M,¨®¶_pd|ÏùåÓ&¯Ãú€ßðÒˆ[É –‡j‡ý\˜t?ÖÅáßo`ôšªŸ*"=4…ïBÕ—²¸‘fùLµeCµ»ü…*îã‡á+7"ÍbŸ7ÇC¾¯ìã'÷ôüÃO©¢Øßhãªý®HŸmª©UÂfã"¿)R"2„CÆ:v°Q‡"_¿Põz,¤Ø¹k0X˜Ö´ÌU-u¦‰WN”8;<¸øɽ‚½! ¸/Š=•Ö¸´ƒÛê)ÁGSÑo¾^wÅ·`šu‘ÀÆ07ü@‘6ÃýuÆW"2^Í+â©ñ°%­"<”uì^ü_mßNHèÉ 3‹ÂhzøùOF '¹cBë7@®EâB´ËzhGS¦›7ìò—~¿‡¶_@©RdÞ)­·Ùp/ªí¶ TîùÊ}¾+šâPÓs½©ŽÛ5•Qžð7‡·VI¡ú…~‰U¡€’›Þ¼)FÍ=XP<µ\°k^2ëZâÿùÇïÞ¢”°°Å-¡T løp6ZY$C+dD>™yæň|åžD¬•Ñ­Å÷a$¾Ï7‚KüF„† ÒAB«u±í¿&Â.l·Å¶¬wT1Ÿ2"C~viµ?}ûó×(£z<YHI»lá«Ú'ðŠ³í)<“þ]O͈.ÝZË}¤' ƒôvHOí#¥Î顦mB}5 %öŠšWûDK,Ò«Ù–Øp -=sÚÏ eÇeA|Qëñlù©j⺚MÞŒVÖ×–8íM$BXÉ„Q&²¾Øÿð¿?üôË„ù$3&ÀÚâÊX@f%‡ô§ýËWͨâB×€ Tu_lrê/eu“¤`Õñnbï€;N³¸n¥º܆ÍUËM_#ƒdC\ª¢âŒê*e½‰Â`$Ó>éIOßÍ3©b‚ñÀ J/â~ªÿ‚àoAóÑsµ§­ÓdÙ¨dµAÅq_¿ìÙåŠZ¢Aé9ªd4¡Ô~œ6˜_O [zøù¿¡žMQh?Û &, ²žF»1)Ü9<¬[÷#Ðu¦îÐg9çÈ'w3TF³Ûè3ÑÚAty<äO›8)Õ/-ÁЈš ú`˜0ûdRpï™5â«Ä±Ìgíáû:ÙqQµþô—˜~¸`Â)Ø(Ë2åhŒÝq÷`âÃ}þðûœ_ðA¡8¿0 ¹^éÅj÷áïÿà‹54Â^3•ùÅsèº[€NÆm¿|øŸè·hj2æ-d•‰ft~ø· WR@±3®>!ÿMД³ìù‘¼ŒÎàcq %¯• ‚©ûø\=á†àFamkøP#46$ kÑ uE+^¨¢cƒùÞ°Šö*¨Íq— °‚ì[pn•}åQD÷‘Fé[ÝÑ ãËýqw_¨L~Ø[ž=i–UC^ƒù1û¹¬‹ÛÑÀ-¦Ð£HV}´úÁºßëS ùèNh–1}?qè ªè ü#9i?!;1³Ì2o]6³Á×2PÒÚ gv‚‡èñ&+Mû Tm+Ýñ–ƒù¿hžo©8ðAá½èƒb ÁòƒqYP_X½;Ö±t;®‹_9—¬Bõ q®SH¯-8edrL´M²Zð\>Ì´¸eÜù [4jƒÃ¿îOOžšÞȨ5²[b4j/Y_ΙËÌIØ. 3"S’&”G,Q\ÂbGFÝ ·&Њqñ.0·ÀG’à!é–Å¿áè>bØ€(€Q%kÜVÊ:„²‚S$MD]%u$3T%^†b/¬†ëª¨©ó¾j¨ £€]$!ŽY¥± êÝ 2¿@ Õ5°¾PL®ˆq…¸Æi_s0î/o†3“xP_813ˆ›XÐ`ÃyE–/A×ë7fEš¦ÁBŶÈ×dÂúÜûº ÁW.£k4CôÀ–ô¼u;&I£@6¬¿tÓ†–¦g€6“Ä9KÜÆ‹5¹°xÂf,…Ð&¬¿>®6T“`à|Z8äRo³ ¨$ —»-´×Lg_¥…uýØ¿RŽ)92~åÒÌ[)(aþ5ïÀÚ©Öèoä;*€dJâH欆ŒvÞ¦Oã-î×,ÜQ‚Iî¯;0çÙ Ü™ä'ŒJ9{ἆ°†³Î†ó:;†qÕ‡‰©K–ù7Â/‹|û‡Uµ{ÚÿœÓ(p\[$MÏV‡üåÆ´Ü ·ˆXxú@ 5m 3w<- Êƒ mÜ…€U&€¯Ü$EO èкB3q&1aýع;%$`!›Ž½n‰ÚÏàÅ3ýÉd¦Îþ*lBûÑ2…Ï´ëElRø¬ a°;©å²øý"Z´qk†ü£DkN{‚ âZŽ¬â°«ê@'zëº<4Ä(¢xoZö§Öôz¬ƒ7ÈTÇRˆiÑ5ÕÍḊg-áë;ø4‡Í‹´9Ð!ÆœKp}dÄè…oUœ›ÕÁüŽFƒm5£š~{‡Ø=,»{_ѲA«À¯ýØÔÔ1X °Áà°ºgpÌ[´ÒÌ|Ev5Ú`   œ€#ߣ[Ñó4ÏÄyv†g†·þf rtJä{Òå)zïÀæ~´C1‘XŸ‚³ˆ¦yOÖ¦õ´„%âA P‡£¼ƒhìQˆ‰#‰‘o~–ž¾}WD&¹ß1Œ8”S}øÍAÎ6ä˜ßSßÒy+º—a¤ZÏ2øƒÊ»+ 8’ð~†Áðñ„£Š ÔÒe3š *8nƒ™0à[ÊœpUPL§óñ¡¯ó¥‹Û‚z)Y—3- Êf Cô…„(D'Aãë!aæHBÂaÓâpÌ@±vˆÃ†/4mT‰ d? ‘èè+cRpF‚3fväÅ8wQà%DŽ¼H‘#=žœMN"G)…9ÒDŽ4ãB^û ¡#™òE`)H§SГmŠ&aPË4ã)™3—.§?5Å5x­¯—ƒlj7¾Ñ.N)n:ÍËÐOõ0ü¦‡ŠAÒyP‚n±{µ²àæê+ì£VPæzÞ>‚ùÂ[Ñê»>äƒGã±ðølG=|ÐŽ~)_'e"AE,×/uSìð0„û]}CDß~ ß<N‹“~3fÌ{N³xZÐHÊÈLÁ¨4Ýj„ߨ ¾AMÒlup2î€J™= tš ?ŽûeÛã›|bm$¹UzÀõÇmÜ¥ ½\§Ú^t«“î-ÂùÀ‡iÞ3;…'ÙNx ΃½c™uæ=§)Ö2£h$íì¹²£ºTŠ”9sŸòÓ÷ '3XŒf6DvÏšÈ t¿ºÆé.Ždfe°œH&ÁÃqí3AJctæ!åðÌCÊìÒ¸‡G#ñuÐôÄáÃð<àÿõð!ºq2yÎX ü%‡gÏ)¡ ÁëŽ1ÃÃ'b"E „n“§MTÊm84ÇæéØP·ºÚ†CjiÓöEbðw…Š ß–ÿ¢«!ú¢K–q=qL̼$‘²¢ ×ËãœÉ€(ãbé>N3Óyçf:“&6>583£´!dˆþ4”6Õv=Šî¨B¹-Á/KCÅ hÃÕ´œ·vLÊ×ò}'Eòý{Ùge§0hŽÜ‘¯d©‚MÃÊR5'³TÙÔ=?û—™Qô_o<Eœ\î[ŸÎáµ¾z3M›~Sðز÷MNJS¶IÌóvHg  ÔÛñitC5ø$R ÀåwÀ‚á#äDvžªË‚VŒ3œØN\|¥×[6°³f^~ñm$q´%Ý=ÄÂã‘2 ê9 \1>Š=爉`ñâK:zÄ ožkð ð‚&= KT<Ö Ð;ß3/T–ñ]š1¾ó¡çÃqKuå>uª‹©C)&žA Ï&/Ó…+é6‡Ä¨¢Vô¼‚Í8Š"ç)o @™ö^¼"ÞúÔì"Zá­œ¦×[,1È#Ì öZ¾> ôD£0_4m×4Õç²ÙÌÔ´xfç.º¤•Ñ÷ó²5°˜ŽàQ¸FàÝ ¶!ëïJä˜ö\þ+ܘ½MHßlFø>º —rûé.Ü cË‹YÉó"“LpsSQ`º7W;_»lfSçkƒ™8_ÓL}ò|M¹¬³/ñ¡o_êtOÎõíLêÖÐï¶ÈëfîÉ f u´úôýA«¯6qݵÍ8¿K²R`Ôüχ0¨–##2Ü 7zúТ÷jái}<ƒû?†BONgIT¨%\C‹æ®oó,|ÌðCs«_FCÇôì™dXN~8~µ§éô8^7Ž“±¨\ßX„§h,ªpy¢±ˆ9ªÉËs‚éìœËs=ù™{(V^~ÓH™ ¤vdÒð °àcã¡™xב½²’)àaañØÙâ3âs=„ä\(F1¦ƒYíÑŠ«é‰”1ì궬ãÖSÏ+ñ¦£ÊA{2hN ˜t^DS7Ùï­ˆùæX¤ÿ@Ù«öªû(9y9'ÝQ›RÉËbÞ·W†ÝÉ ]‚`lNøBhͤ¿Æ….‰û‘Nš'.=Þyß•P)éT/Å‘±"bTåõo5ÕÑ?Ä€BN-¯íSlŒ‡®ø&™vð§*×q b-)‡ÿ#ŽGx;á°z[¥ÏvXmwŠ<¸Aooé 3#¡Nú 1<5Ž·Ï°œîç›H,=¤sú™0Óy{?ƒÇky_ƒ_\Ò /[ð¢89N+´´¬‰[à@¹žƒ ¤ENh›¦6‰¬Ú¬ÉÂŨ-wOUMá1íÔâÿ‚ÐÝ8Û5 ß,f*~ ¯wJbnHe™á&r¼ÚGkî]ŽX f”ÕN~…ú:Ýô‹ù/Âd˜O¡®50´úÊH“}•äüY×ÝD·—‚3¨‰šJW—”šâ}¨ù®PÓëðå”tÙP[;XÝ€/œb·>¨h¥ÅkyÀNZoL´-Ù©ð·›JÁã 5>̆’Ýyäw“çFã¦Y©¤2¡¢ÿﲬû¯ <"t–u}ÁsÞ×Qˆ±ÝSÛ‰µ 'ûgßRÇ{'§žqnŠù”üþyb`;ð”ïz½&é&ú© §èf³¯N„$7ý‰,kÁ˜ÏN#3x÷KŸÁþ1èþq×]ˆŒ!p+piío‚ôÿ;õiØ endstream endobj 2321 0 obj << /Length 3378 /Filter /FlateDecode >> stream xÚí[[“Û¶~÷¯à£4µ\ 3é4ÉÄi3Žz·ÓiÝdΦŠ‚sý_¯\äëp1Ë‹"-ïóõ<[òNçyZΊì>¨oß T×B…¹€ºÌ àc.~ËfAÈßÆLÒ¢Lˆ·‹X.Á"àk‡/ƒ’Ç^5Éõ¨ü¸Z¥àà™oŸ%eê¯P¼aJøžiD½ù×ùæ…—Š£Y ¥ªâÃlíÙãÑfýˆôúé™Ä0ušøÞN†‡Eä¼ÏÆ\[`æä• .|Žêxÿ€½ Q+bWÉïÙj³O„µ£‡4û°p“ ïVI5[¸að.wÑXú›¤@µ)•0g‹ú ˆRàÎß ·ÁmŠ1û”I8#Š5&ÁÏ1´ÊW4Èèõgøõ}„ˆΘÖTó®ÁP`{„´Ó}^–Ùt™ì`’è8n{â7´]²Ü¸ôÀ†Oy!`öÅ{âÛƒâKx¯ ÃÁVUŒ'¢DÐæ»Ë4™{½2ÀÊd®º©@³Õ£ÛEZ¤wy‘b*aß,S?È,_WE¾ô¯ß' Udy70ðœ5¶í†uê’ 7£u^ù ‡åÜŽÊ448T†¿) þÑ_:©¹ RÃEH¯ð<‚ÏuÍ&8Qœ×êÿøº ÝZ1—²1Ò iOïBä@žæT8÷•A·$´´ðîÆ`ædVåEöG²·'## rÉñà(;Øè'Z̉Q¦íáy†628بÑÆ)f¤W þ¶ƒ÷i±ÚTµJÐf§ûëý =VÉb¶È~÷·¨r™¦CP®ô¹äsƒ×gîÅ©pŠø¶‡æjû‡¶'ó,ù¯“eHÊ8ŽÙ²]+Å`20§¤>Q©·HûæÕÛï|óä¤ZàB˜8À ¶Ï$ñ¹çhø|Þ(ÒjS¬]ƒÖ;äØœÔýv‘ï‡"3çŠÄÛ¹>šc¢¨Ü…æFÂALN±Ž/ÏâÀž•þ/c$`—j®;“ïæ>eI ÉQ<¿õÄw×ei œ²’É¢¡ e6O;¬´÷½2_†4±¬´c ,H$ waË4ÌuW{ßÀÆw½ñýOÀ8  m—(I^2æ'=Šâ„÷ \Åß"5x•ö$|6Tj?yrLIÌjæd‚ èç»Û¿¾@\¡s8°]¥,‰…Šf«ï¦Ñžý£ k¢×sqcÖ[F7/þ*ùv.¢n t«ä³'³|PÙÓ ULd¼åq7o_ïëÆ)”Þ†_@9äÜFó3\%‘psà¸ÙºÂKáØ6yP††ÊÐô€!/~IŠ"ùXÅЃËJÿ¸\ä›åÜ_çëåGÿú4¼®GIé;/s·œ ’r(*p(Ÿš¨xý4*œmºž20€C˜ðçaZB~§ÍÔzÝ ÂC3AÑAŒ<‹2ù¯á@±dGÏ}Ùšú®ž°ÐÇÎ ŠBA ܨÜwÄÍ"Ç`JG_'±rë<¼7ˤð÷>Ç¡ÌÀ¿%t©Ûv«‹8T_€ŒÑ°ëàÖ@ñQ“{âfIþ‹W`¨­Œ,H·«p_û.LD0ï€è¸UkÈ@<@cU]®Sêûén1áÛqXŸ9„†``Š>6« =«M˜ðþf€h NåÖeê=_ÇÙ/[ û5Ö$fiÂ4Ú>|çºä£¬ôû:ͨku°Ýíñž9as™.ÓYØâ;L¹RòzIàâ½ÜîQ„¡V‰[¡q¢BïÀ™DKÝñ›‘‡èØûÒ,i¨íú RÖ¶ÀƒÚsÜ®Yb"å'­‘ŽY,ŠÞ;Ån6ÓrÌF`ˆfsL·¦Öv”Þ”~£ :6\™Çðy!ÛuÔv±Tí,–ܘTnn>jÇU‡¤¦ô”t2ÿk· nÊz?mS¶èl¡¥èùß“Õ}ÛҥçüãX^ú¶,l¯½š-z‚96$ÜRUòÓG¬ZÁ¡kÇWCv&@^ °Ã9t B›ò¨¦ßÔr:¤š¿„Æ­Åh€s‹‹ÅZ%“%!)D.[SÙ£•ìvm ¯a¬O Õ(dQÇä3ÈÁ¯Dq%rÈ9&h3$¦‰!š²cD±…?"úÙäàW"‡¸9."—ˆVq%("®EÄ• ˆ¸‘W‚"òJPD^ ŠHÙÃlð&’ ˜Íîë5± ìäÛ]b£[´¬]à‚‡Ž‘mCÅj-š§ë¼JËaÜ/vö¥š^V ,HE·‚hIãIb‡á÷R‹$¨˜cáŸýslè(|Я—»5q¼]f¿`CÚ>8¶­—veæËyØ‘¯Iñ2]ájø—½\ÊksYª«QÝ£˜®z‚éʦ«ÛL×gºŠ0½7Ð5}RGèÚº~‚érê ΣAù¬§Ÿ º ?¯ âZéMS†’XK—¦ž+_òGb$†tù¬‰›_"F̧"»ŸEÙ$¸+AÕa*sY$iØ®mÛD@æ8`Ä)Èáy#‰óçÀâZD\ ’ÈkAy-HÒ^;´&ÚNsΤyŠð*" Fx㧯”À#—`D¦Ÿ|»®).°Ä—–x—/ÃÂhó{„ƒ²þ ÕbK@ë6$K·WŸµjNbeë¬Ê’eöG:w,Ó[Éñ[àº^ž*¯ê#`õ"þ¾ƒ@Áí¥VäõyË[T´&ÖÓ´E°AG&„½ùwÏÞª1ÄXઆclàîYëЯeD?«7NüA3K-Ðd'’¬1û-Ýö!æÍjZ¯ˆ×%Ì,_nVë>Kk†»Nϲ÷!¡¯mYúSL¨x‚boÆ“ØÓÕSÀáÝ㨸yÜ„éÞÏhj•'JúÈin5d- %Äb§»M@E•‰Ù0qº}×Sú@lÓífÇ{æÏá~ÙW—ãNl¼op£ÓŒÞ'zô×1d—ÑMÏè`)³Ýœû“?šÍ~î?^.v~º€‡jŒÇa”Ë‘Ñ.[åH…=$ P£;¿bpǺÚW„m—ólæ¶Pc˹·vŸnëu ŒÄë]‘›ŸÆ–¾~wóÝå=Óƒ ̤a‚ž¤Më‹PÙBwÕÖæ@,¸ÉÔBö†&dv(¶¡~JD‰T¸jaÜaPo‚|»‘T»3Ð_‹° ±÷¹z¯É%a>§«ûêãÎnÝ4%›zef·—4üÝ"ÁÓQ͸Pè"9é;ow{LR<"'¾Ü=ªUÕW3¤¬3dÏ4Ú=…î|Ñ?w¸&1D ‹%þ8óŒ$$ »Â€þÄÇÎ{Ñ™Cäq’.í‰CÁ(V´t9wÞ€»p½¦ê]ó¬|SF´¶sc‘×ÁÕ¼_¤¿‚óƘÓ5‘¬CÇpó2$ ÏÎ#9>ŸdáH¢Óÿ“¬OJ²îøþùG’LÿO“,.ˬî¯lýåÏF²,|ð9ß>À@²®¥?Å:E—^†µ«Ë'#X-÷oàãv¿Ìx )0ZËGH˜7"“ԃ®¶ASªÝ@òOCïíï×.ééS4éõôV“Kû¹gíK½Ý!üL'¬@3d‘ö“Òp‚ˆ+8¥ñ9,â—Ûg!wŽör&Šç½œ²œ´­w`^üÁÃJÊ endstream endobj 2372 0 obj << /Length 4323 /Filter /FlateDecode >> stream xÚÍ\KÛF¾ûWè²€1ý&{âl²ëÀ°³öY¬“GâxKℤìL~ýVuu“MŠšÑÃHr‘M²YU]¯ª‹Ãfflö¯gÌÿ¾¸~öõ÷ZϲÄ£f×·3.t"´œ™L'\òÙõjö~þòÛ×ׯ~fšIùÕ/×?Àc"zL¥IÆS˜ÓÝ¿¬6÷»¶h®B³yN?»¦¨¯›/šûbYþ̘(Vt¥)Z:¨né·Ø¶u/·ôÛÞÝ€bóOW\Ï‹º)ˆcc&¬rx çºEÉ™Nlš¼%K33™dÌÒM@£û¤îÓIªM˜hŠs“H+g‹h¦ÀEGpU—Êm¾¦³MÌý–àTÝ:„_˜;‹æ^™%™Ñ³7‰•)Íÿã]¸P"xb¹ ´þãj!9¹,š&Hzµ«Ëí‡yMµÞµeåÅ|³I½pÁUb•òÄ]eÀpÓ”7k?ý§¼.s8k¾Îë-h Y­?}ûüp!ÉeÏÑÄXØDÏj$*œ¼uÔÉèiPãT„g_ÿÏ=üÝõ³_Ÿ¡Z°Ÿ‰,M˜V3£e¢ôl¹yöþ6[Áµ`Ji³Ùgwçf&Ð.6[ÏÞ=û7™øM"³Iªh"¡é…oÿýn Â1kŒËê¾:3•¨¬“Êë'Þk¤ù%oê*¼h D <3e.¢Ô`iÒ „øîÇoÞ¾ûî1Uþ"r|9ÉžÕÖà/fOñ4JÿÕØKMÂÌ—`/ÍÀOÙûñúí¤9äM¤UÍŽp'넆}w¡Áœ { z×l¡Ÿ,NÎF7½_hmæÛ*BW|Þ{«ýH£³D‹ìO 4yíeâãí*1 «b@\$VûXÎ'™Ž"¶²{ñwŸïL&VØ?„o•p =æÛ± \1>×Ã5}a­öšr% Ø8m!ÄÕÖEÞ†˜û«ì¨˜Ç†oûgq›ïÖm¤™S ™±b.   FÏ ¨*ÜcR7*‘RþU´-@Á'-›K v(º—[œ'oË›r]¶S­’ÔFá‘ezþ]]W°¾Z¦ó ÕCS6x–ÁÙŠ†Ë¶¨aZ\|ˆ4\9·ÅÄLO|.×kº¶­üпù¾¨o«zS¬¾‚Õb`ýl[º³¼¥;E9môÔ‚V‚­Ù€ƒëºhî«íÊ¡.ÉÓyuß‚K´Õй“*8,¹q*qš§çξ;WÀ:g{+4–0oÝ¡v”àiï-ÊÌþ{ùSï‹P¼óšxwÒ´ú¢Xæ' @EÑt†£€®÷ ÃRÔúKFú¸aØÌî†S©8¤l¨uÑîê-znƒYŸÄY"Œ~‚ `¸V@ø™ €,3ÀÍd ?¥@,È:1@NÝêqËçwUÓ‚ &` ­¯Þî¶KÌ9rgûî¾p©ìú ‘Ïe{G÷øI!‘)ЉÌ'wmn—ȸÕ0ãÅë£DGˆ3ìL@’;agâ<}—ŒÏ¿ßÕ¯6U] ˆDê+%i@d„œV} 1•ú \ ƒBÙ΃âÁ}Öà¬ô²¦\–˜ºfè¼nKÈÝš /Ó#/z{åòØÒèßóÖ»NÁ½ZàQŽ?bþny·«iŸö¾ÏÏpªèS¹ïÝìyÞM¨ù¯}HP[õ„‚N)<ÐÀ®AM˜Zt ïã¯aŠÉ’,ë<ÄÌýYÀaÁâÛÔ‹;jLƒ®'Þ7¥CÏx†‰Å®¤“ùÓ"€ÑçÓînBQMmŠ| ’\MÀ‚ÛU¨‚ìâú°3\Wú0"ál„hÞëV‚Z»ZǦ8‚ <•²¤àÝ5ÿŽÞ¥aÙ!^R 9Œó²ÉëS4C–&Ó•qaÄü§;FŠ»jþ88£8wvŽ'óƒJ ZÈþ˜\ ¹ä{Ž ɬ‹_!ahòSÚGÇWÓTË’Y𠲎Á%ïfë$l‰Ã7pC•’@$(®0óÞPèºZ~lè˜Ü¤7åïÅiúaÓ¤7‰ÇôãQ÷å•œ¿BuÎæŠú4"$sUÓ©€|]™®ö4HåD€îx´tAGëò#ÚY±~ óU±„<Âíq:YТ.È7Õn;*B÷aÇ» ª¤6_…l-ïj¿;³Ï×ëb]6›ƒŽœÌnYWj”Éw¢ý›Ý\Šø—ã~¡Ü›ùš‚ðѹÐÎ]ßmv¸.xäÊý·t‚ âo¹½ÇCí"!åô³Ì]VFHßý¶avQ—ÑÁ©«T‡éF·æueæÓbÕN3/™A.@£•2 ¨Ò%53©„ ™À ¦‹fãj.˜“‘g'lðÙ~†2Í(7Ì ´B 1ÙŒò÷ h&f²£Ó IH`ÈP ,qðDh®¦KÑOiKšˆ·98ñ1‘¨2M×»Äe¿€T$@]%íeRiîªÝzEß$°ŸjéSŽD'Óá¦r["ê.lþî1îç@•z_WˆN!5„%Èñi–B0Ú.ý`S¬‹%½ Îút…‘ýâÝ´tÌìmÜMßEûctL5'8ˆÂòi6­m¢úí“»%2‘¦ šäÃðõN¶Ìiœ,ªÁ ½.š½~4ð%2¾ø²7>£•Cs:Jiw­s¥B†4 Îqi!•}Üû @ÕŸcÁå’R $MÄCiú 燛fêìÍH§žà-5‰­¿œ·Ô¡Ù·£,<Ø%Å8Ö+ú´ó‚tOpy9‡R¥‰eò2=†m½«œ‹¸³w:œ•«¢ƒkÅ6ì™& @ÍOá¹ÐŒ|„ƒwTð›DJ?uә̇ÀuAêûgWûã•ð'º>‘¤é~N/Ù)€é¨~N¯w¥6À7»Í}3¡åhÇFÏd®_¨åuE;Ö4‘ðy1àû¿yù ºfà°/ÇxãÛÇn&íøÙÅÊ/>åHƒºžt¯²00Ôuae¢°h#"à€Í:‰†d`þ-ê÷ß»›Ar–pì@„qm ‡Ë›#¦‡‰âs6A,h°Uƒ²Ì¾\ŸþÓa·)äC£Òg%X©j cÊ%² _h¼/üçx£èˆ+—è» ðœŸïÁÁîý¡×Ú7¸X)’Ž•!™rˆ íg,QUX§u×ü†\[W¸ÞŸiøôs¹jï°¤É8•¤ðBáJ3 )þyR‰Ôy8·/zŒ„cð– ?þÞ® ]¤+i좛¯:×<ƒ[u›\Š‹Pc•Ñºà0ýÊpYxw‹C€×°‡v‹6H ]¹ñ÷ætº„G=Â&?óíhæøÅ2´@.R›"Öô·z×À†é±«ƒP—5$ÔKìñÄ3¬i¹_÷8p…1H~q ¤õ¡Š‰~#2qÚ ÅQ´^·‚ÍhžˆÐè57þ꺸mého ãRúMïéæíÚL-Ùyû8æâÒç<ì•‚ž_O—J»È´(U ·¿Ý¯«²3þÐO\¶­¦\z?ÕèTKENÔî)5b| œ˜Õ£°á+(nÙ]¥S<궤eæ ÞøvÔ¹‹·m]]Žœ•Ÿ˜b±*õ‡7/ŽoM}.é¥TƆƒNÜpLÀµ#7‹È=ƒHtÚýîúTª87€wj/©š~ ¦ ƒzJh}¸JL6Z ò©¡|ïvì4”iDP„°­Ø­ËFšŒïÚÚi×+…±î±®|3¥i{;ߤeÜukX ÈP\‡o9Ò]°…«1xÞ!î‘ŒÅȇh¸ o õ§'n«º\ÖóY_§Ç_§Ç»Nw$Rð¸õDå¥`|sè ‘àOX*FÛ?T‰°±tç¥7L_—°¡Õì6X²Á˜ÖòÙ\ÚT«b=|l¸QgøXÅã¼þÇoÞž š.‘V¼7îÊ»ŸH¸š‘G]÷­/ÂhꊴÓ`/ƒ©Ï8¼(£·îÒ¶Ú.†âLÄ=º·ïv†8±ºÚ7!ÎÞ1ŠSS»î3ì¨MŒRþ#jËÓiH“§LŸ&©5—¤ Ú&™¡™´MO(_¼{ój*ŸI!†˜3 ¼ÌÖfH¸œ©ÜA%Y#"œ®µŒ¸b_‘¯¿¦ ß¦ÚJ%8€Î¡ÜWå¶up{H]n ™´L2Ø@fë;ÊNØy‡d¤O^MÊSfX¼ÓgÊsà!-ssJž‘öšô 3ÀÆØSƒu¬9zW©®úðÙå'îâ$™”'½ÎD)§oÎLyüTQR»8&ÿů»|í‹•Ouc=¥{™Mw•hn¢Ž+7mßÜt“ûbCA]skÑ®ó0ª¡ø,ôÉý¤”EgöhQªD‰4níPŽ.Ù‡XWÎiZ=/"Åž0¾l»ýÉ,%Г…ý?8ðð/A†[8D_ßE4LA ¢.wÚ÷X(Sï_:ȃë"§–l<9ÓÊ%‰î¿Î™6s•ñ$c)x2Páô’ýb•)WöÅ™Lj™ù°”€E)FMGqÆ°êºïïñ¡8Õxóp«S½E–ðhûíõ÷o\6(jëËú-¿@Z;ìî‹Ê¶G¡èñ‡Ž™yÂÍp«+."•ð”øÎòõºÚÐ8ÍŸŠÂ¥¾z€´¦Ùt(…›”ã÷“'÷ Ì3?nh¦4”¿@'PºåßñïÇET­„i!Ó6ç‡À)}§ ~3y&£ã Geå£Ç^ß ëãwì`á–Õ¶ÍËíh9#wŒãÃo8|Ÿ„ñº¨ÔVñWGôÉëɽþœ÷eÓºÃl"#0³—ìRƒ®3)]×eÆ–h\½deÔiÁ{R63üD€÷½':Œµûx/Ú€¤úÁˆ@Ž"ìS‹AÑîƒÖóC€œcÇÕø{¤'¹¥/%/ÇãXÍ7æ8þê€"ÈD¨:‹®|fÚ}ZÓuGÞØ­?@g”8„Ðænù!‚! f.¤È`ù|Ž „×aE…`¡ïªàÀá.å :€'=p7цü !ÎÈ$íÿÂ4ÀÖA{žö³©;h¸ØÊÇã•kŠPƒ8ÀF».ùMT)ö&.B++j€Â1Ü!<€®;÷Bœ!À…<CØCˆ®• è¤XBx ÁCqGLc¸>ñÏÜë£ízŒ³)ú,ˆ\a RqAKþz¯/› endstream endobj 2244 0 obj << /Type /ObjStm /N 100 /First 1015 /Length 3009 /Filter /FlateDecode >> stream xÚ½[[o[7~÷¯àcû°‡Ã+Èef‘:AÛM‚Eê Û`«° Ý_¿ßGid;‘£8>/6Ä3ü8Î]QjtÁŘ‚KÅE êb®ü »ª…ƒâZUª“ crs"Ú9êNbáü>ʉ“¬ñ£è¤ÎËê¤öÆQrÒãx“Cæü#m|‹/4 GxL˜ŒäÆ7 ¯2F˜ÒRÅ%ºØëøLÊÀW’Ó˜ˆ¹d§Z‰ª§9ŒÏªÓ¢\£4§µŒÏºÓÖ¹Z#B$ª*.a#XP)ν—Êyàa¯}|]ï±sF„@¡QI”bÆ0c¨ƒ!R0ÈT(æ¹ ÂQJ¨cõQ¢ø}cjçBª‘(\ Â#RÃdÌ•6FÞ™N¾iä¥ A[bÔ‚ÅÀ Áˆt‹áBg9r)à˜1(`5 i¼†Õ€™p«é¸HŠ{*:n’&ÞQ\¥£ŽOÜ›H© î•[üó—á‚6_!’ÅgìïüÓÇïŽ~ø³Ýâñêãêâô÷gK§›w^¾_¯—ç.nÿþyýôtý~½tšG‹ãÕùÚ=xàÇP 4æãÞ§íªoAƒ½µÚ4°*çÝwtûÐ!ùöŒ“Ý>`¯9oH÷âåÅêìt¹voöɱ[¼^~^;ÛÒâõŸ,¹‹ÿ,°»óõò|}I™J|ÿhñjy¹útq¶ŸÅÍg?-ûðþÑê³{Ãå  bÿ ½¿ÀÛPgE7žŸ¯@íÍF‘ÏP¤ÛAµA³A߶Jt;ˆ6P$ål”³QÎF9åb”‹Q.F¹åb”‹Q.F¹åb”‹Q®F¹åj”«Q®F¹åj”«Q®F¹åf”›QnF¹åf”Û†òÇ;âhqúé×õx~þáü¿G‹G«‹ß–ãûŋg‹Çod<ðÜÏ 1š’o8šW(D˜6OŽ•|Ò‚y‡hŸºÅÓÕë•ÃuúîÙã“×Ïß~ÃÛ￧üM$IóÔ6$•î©xæŠïÐ6¹wŸ Â`I|€4”€çZ÷ùÇ‹GÓ€:ó V& ®wŸ¡so>KÛ»þˇ¯¦\_}€RεbAqšÄ t.ªÏåþ×ÇÅ÷Ã9(ÅSËASù#™kñ%È|’[æá_]¡áàIÌ Dpô–9㲘Ç(—ÀÀ©ÒôþEÚÙÇa‚oô§*/)8ðÜòýËDÒè¥Ô€”ƒ§G5MÍ¡/¬¾CËc÷¸àHIþÒ^¯~<ý¸:› b¯0ä ‡ÃžO B26c”’ú ÷†²™`YD¤öý N€8&< ÜȉhÅÆ/ÐÍ63iórË…˜œI §à‰ì@hõÞÂ!'“²áLS¿BÐáÑ6™T"||Õ#.¸Ɉç"3 Ð|…ïI³Íx1Áz!J"ŠHœéR´‚£ÏÃ{ÚÆ‚¾$€ð¦’Ît)v ¯—¡_@ßCc)T¦–8†oMh*á½1nŽDº®̽¦ìì3¶>½Ê“=×úÒ¢º5U¯•–Οs…3©ó˜ 왉“-„”‹ç…°ñ™¾3ÖÆ!3© 0!Ï‚A±ï†M¡¦Sg. ê:Œ™/y¿}2¡$à62Oi„ûÞô±/tÏ­ÎÃxîŒD#"‰ š,`æ#ÒŸ ·; Sêî;S—† +bštÁÄö®«Ðe­°L´ö<@4SZ:èÄˤÑlAcâ¬TÏÄ+å3*pÁtÄ<nœ9me VBa-˜»†ƒ{‹ËðlrõÊnºŽðæFê/"ò–8C„ -=2ŽÊ5Eow¾,ÜÈÚ÷3áäøŽB'M5d’q‡Ã¼§¹qh`€‹u)šy£!Ý ®Lè}žó`6y³cJ¡#“öp"3P¸.…üWk›OUG ´u”²¢o£@€çzPeõû¸&¼µ×nI‡=¿E[ìGÁJÃ]% Ó),ŽU™ëE€¯' ÝJÌ,ðïéÞ}cö¶ÀÌ­Æ;Îæ.¡ýî:[ŇÐï8[á|°ð8e©ãÖêÆ"ÈÍRÇêÆõºÇµ‚Æu¼\¶Éô¿\êˆòu©CúÝJL~Yêh–Óo–Óo–Óo–Óï–Óï–Óï–Óï–Óï–ÓïV-èF¹ån”û–2ˇÛؠؠڠÙÀÞ{Kì-‰6P$de1ÊÒ¦,?@Í1Ç]pµ7µJ7½t„4ƒ'2g³Ыïàël˜4‚¹ßHtK¯O¹îNmŠ»†A7{{Zš0?ë5ëJÎ^âhŽ€Ñˆ<ßR~9ýå§)­/¤¶ÀX¶¶××3¤ä¥lâöVÁ–En©ÿð ¦ä@ö½¥‚‡(@B°•…2©û‘G“ ž%þÀ„…ÿ¹Ïæ~DNH²ƒQšGPy_Qì¿òŠFc¢c°%v½À/šASÕàûh¼Ù,Ÿ˜^„Á¹}ù‰¯EGÌˆÝ 3j-yö%pA“Ì(”Ø~d9.!kqÌ'hßÖ­ã­ÑÊÓ·ßIœÔ+ŽL÷^IÔÜý@îázHÜ”A2óÌlCðH/}”Ïç4>®²l } ¹‰¶”6eì0gŸàÔ˜æÈw"÷r2ˆ,üHÆ×ÂÎÖ³S'×#f´ï@0ªpO‚8}ñ|R¬_çÈ0­ì}ÃMaµp”Óã ù +Ün×·öÐúÓŸBA…‘G}ŒMŠ²ºÜ3Ëd¼Y 3™†€2xÉ0)Ud–œx„As…ùW>À05vò°Å°ˆ¦¯Yòà„‡Mn@j5ÃÀBwî19'˜"A¼Å{Ž”8“ )#üØ áòÓ¯—xõÃêÜw™R8;¼Þ>Êø=â ö¬Óûeò`¶KÞDS wL4]Ÿh‰&Vònʽõ¦ÞHØ\OåÜHˌۨւ:zt-SÙéö¥l$9ËÞÌÎõÐŽÖ)Ò<5~æÙäžþRš‡ ΛœG´äG´´J´´ŠZZE-­¢–VQK«¨¥UÔÒ*j”Õ(«QV£œŒr2ÊÉ('£œŒ²5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ߪ5ßê¶ùvªÜÆ® endstream endobj 2420 0 obj << /Length 3734 /Filter /FlateDecode >> stream xÚ½[Ksã6¾ûWè²URí!^$1UsH&Äã™;IÕfs $Êf…’Çûë· ð%ʲlO.‚@w£_7à`r= &?œ~¿¹:ûê{-&13a¨&Wë —RMÂX3.ùäj5ùmºÙmn«ÙïW?ž}wuöç‡oƒ Ÿp1Åv¬”“åæì·ßƒÉ Þý8 ˜4ñäÎŽÜL 4òÉåÙ¿ÇÕ†ÅaÜ_ô6)ÿkÂXÝ MŽ“ÙAï.?œï&‚€EZ=°îb"L©4òbéèê ŽI{ºþè ÛÖéŒëéuZÎæ"”Óۻ샚&e™ÜÏB=}…Ïá´XSÿ*Û¤Û*+¶ôMRÓož&Um9Â0Êô¤ÄMôŸ~@âeOªÓ¢!éÝÅ÷,!á/wS‘ XQ’²±¥/šÖ7ž”¬¢ß2­wå6]Ý‹{ê­oRœ{2¦ãÉœÌhC“­g<˜&˺(³ÿ%5q©ƒéíMR¥–,û¸ÙU5µ)ý&9H=©íbØ}O¿¸˜mì*+WûE}—¦ÛÁûë&[7aUäŸq¯ÜðªNo+fù€ bà~)ÅÔîì_’)åt]ꧡÑ-‡(JRÚH1‰Ir¦Ä3¬ID!´i"!µ*éd -‹mdÛŠhÈζ+b­VâûŸÒ9ý<Ô7KyZÑ°uQRãî&[Þ ¦Iì¬È­ZpaXd¸S‹¸k.'ª·``ž^KGEÊAÀð$ÔS!?Q¦½Å¢˜EŠf¡è9‚CfÄCÆUÇ!8å¶æƒº7“e–£,©»ª.*~î̤,–iU°µž’zÎUÄ"Þ×Ñw¸iBM«Ý‡g¸F£‹ÐóåH„€M*¨‹VÃo:j Vm©‰{tâIÅ‚ˆ{üøá›G‹ëtè)=1i Š¶±Nh'¥ÃôsÝatK]›¤.³¿Ðì„9`vJ †+ÁYæf§4Ä;O7PX2î²<§ÖÛu+a»2ˆ˜¦ï&›Í¯’k¡½¦ÛÚ)ñ4±ö†Š³n§òßàF;=‰ÁЃo!­rQÔ802Þ¹C+ÃY¢ØQõÒëŠ~ÿ@šÞºVYr^ k;ðÑ(ï8Ä)ÜWëÝv‰s$yVg©›¢Lsp*Χ# ý¦ei™ƒf_ÜW~MrÖHQpâµ&ϱZ÷åXBP Ä6…êÊéZ ÑPGaEß^\ã$<8FÁU„ÍwHü‰Ñ›ñØì/ËFoØéq~‡ÌµbW– ÜÅÐmQpH¬_œƒLѽ¬A¾+b%1À³ tªĪˆ>¦—Ë›ìŸÖ!èìæ6wÂ×à²î²ú†Þ”3OÓÕn‰»¯Šæ@ÛŠºa\v}SÏoìÖã°*[¥MX–̨NqÔv…#b¾/Cãe8€{c;6Ü–¼€Þ›R„½);ò²ÛazÛ±?ëœsˆŠµ„ÊPßÿüþãåÔ„*£ÈOÙu{ÖRBo¼ Npÿ‹,ÏÀÒê{ê#; ½7~‘”ufã ôŽ¡¦ÈAUœ‰>òû\»'rºÔv6Û®J ±]” "1Ô3]§FØêxqá]t[¿¿D4vjY ¹j_54A»ªÉã§ý.Ü°.ÃéŠA§‰§W~’=’¨}×Lç§é cxJ‰[cý wn¹[xT‡¶þå·|–[»³„ßW­“«ÒôˆÃ™üf_îUºl11š2ë{›<}29˜¬ÞOŸR éCÃb#&ØŠø!ÐsŸàÝxc\¨Ù°Õ“yM°q¹õq6w±ÛÈzôu~úðë]J´K½uÙÁçêý7çÞþôÐZô?zêZs©1ïWýèrñeULÅm.þE5äÀR} Wà”€œÌ0¡ŸaBi¦M„•Ú@åƒìq¦Å—äÎÄ,Ž_€;t_:pwñîx¯:ø¨h>Äц…­õ`ÙK° з>—ççߎ†ºƒ!buÄÍC1åð9Éwi5Ó4%KƒæàË\ƒxЄ¯‡Ø©Í«ê½Ú& |Ô჋â(^ñáßcÖ>–?ùTY\¡¤ñ«)åV²Ü‚Øå¡3Ž$茽 ÷m íçðU™äÆé5B|Qˆ€ï*êEhˆ½ |°+YÛŠ;vútá­1GëÒÜ(‰ à¶ò‹àÅ.‚/iìZ¤I¹Þæu‹®pHSÿ t;„ªÖøš*ÞØW¥õ`Þ9vø,–OPóN2¼ _yGH< C¤däs §ÈP4“€™ !ÔM ƒrGŸÍA£…À–Kôº¯¼¦GÝâ_ìA/|Ñ?•aí©LäOeN(ži~•©³PóóeªBÈ©ù\™RùQÀN‡}hKÏ™Ï|q1Û®²¥O‡:Ç=73–a±üœê»á&sÊcFÍ.c³Wc Tã^¶:÷‚½ ÷aë^ði/ËÆÐÅÐÄùn³­ ÓŠyì—ÖÝ¥íô(ņ­ŽG±ME~E°Õu³rÕ¥Âi•w‹Âö]Sè¯hH6ü†*7vº5õ$ô(¾¥ÇE^,ÿ ®%N|¿Ì³%½ÚãØ€D”ÜHiæËerþõǙӯ1y,9—¡˜Võ}îNîðѹ[Ê}— ~4„•~µA³ü£ºM–©›ä¦Øå+j/\_çÄgÃ]Án+lï´¯P¸ÖîBÂh- »Ý‡’š„ ]E¹¢aÅ\$“1¤Ð5I‰O?gcÈ¡#šIÇæñp%’=Ø‘Fè vaì Š¼),€9**´Ça{Î9À…¦‹ ÍSp!ç‘5£Õ:kHÂ8ažmH4Sx,TïCmÓŠÅA@hÔ6ØélÆ7øÛt! l@Cò=8ž¥“ „ßCú;&§ÕÁý]%DÀß\ÿ=%ÄÞRï¿t5O´W1Q9„ñmÁk“ÜÓ&yUPká¶yåŽãWôˆØf•0Ûåuwç}L8G àÚ¹aÚšWÞeþƃ¿/õés¶JWÍÑjá^å—çÜ-Ø?OÿÜù‹7µ«£pWîÏYšöºLÛ»j‰›7xÔÙJЧîÛtíDã‹KcGV1ÓÝÚ’-ýíQà¡r‘Â{ ÕÀÜ:=ßmqv˜O™ëû±Ê—b‘é\)¼U’m-ø—.u—- ƾ. Æg>¥=BÅÇæF€=µa¡;ýu^,ü7>IÄ6JÈ^L°â¨íi[³œŠb›ØL ÓlÇš~ ÍGÑð~¾ëª# ²…¬îWp'@ôÔmÿº€DÈ»Úo‘ÍŠÞÃò#÷8g²½Ây0CጷN")ý•$€žpLÖl4Ö:%¬L·9¤¿ 2¿…H—%¶›s±à¯l³Û¸áe²­(Ý-«$ŽU*±Lr`Ñ=íßñ±Ÿv/ô¸‘t_h$õëo6W=a7!·LóþèSŒóSš·fÓÚ3ÎMŠ Tr¬ ŒõlÍŸx°©íõÐáÍ“è ù2ã`˜CV6 ¤äã:"£®ùr.…½b(}Ü—Î,È&ðÉÚ+ü®äa×®€eøοú>Ôï1¿ÃM;óçxÞ¿2%É8·M‹s”dÜ·i‰×kP"M-ÞÜùêÄMžs2ÊÓ¿ûô~$™ lr¬êðY×[ñDŸf⊹ ãf`kož©‚™XÅÆBH¬N>ŸA¹¥îówbY¤¹?Ý^©{sr^ÝN÷ p5kSŸùé‚ ¤v˜i„âÄŠ—WñžÛsäúÏìÕàNkö†Ÿz¾nXKh ø=þ"\›˜‰€ŸÎuÃ3óÿ"1 6:åpº” noºhbili»\iÒ¾-è·w£Øö$ôÓžQíû\|¶¯; Ÿ=$Â6‚cKàôðÈKeƒ Ü-¹@¿6uÀGõjH!Dº+Œ„9¤%ÂFr|(S`8°€låÝ6]jÇß]å¾JÜTˆã–»<)éy™ø,F¾$a|^4pUàª~‚;Äÿýh‹‹#·ÔwÛ÷pà×&`¥¸‰’ƒÂû{Ÿ‚Ü!¤/UvmS6ûeáØâõajùê—³¯Ò‡ÎÍ,<ñö5X¶nýÙXŠFýjWHˆÓ–Ãbˆy|í ·Ú—#vóM,žÙKé~ïÖ§Ò¶ùÓ ª¡Å€:>‚¿¯$5)Å€Õ±åÁ ¶¯{à[ñN®ðâíövWSÓw5s¹“w{–J¤½×-&Ç'øâFX‘:ñ Ý€.â-Ô®^ïËÀàÿ?…T',â³ÊÈB%º¬ÞD‰ÿí+¹^ endstream endobj 2463 0 obj << /Length 4209 /Filter /FlateDecode >> stream xÚµ[Ysã6~÷¯ÐËVɵc,NL•’ɱ“ÍÌdgœÝªMò@K´ÍZ‰tH)Žóë·ð´d[²÷AEÄÑÝhtÝ€äìz&gßÈ=ϯ.Nþö­Ó³ Ò$±³‹«™2RhcgIpB5»XÎ~ž¯·ëÛæô׋ïO¾¹8ùíDA_9S3å¼P>P[cf‹õÉÏ¿ÊÙ¾}?“¤avG-×3-’ «Ùç“îšÔ¥"$a<émVÿ然nØŠ £FŸßý盄¥©ð.=Ž°ádZjam:&ìóÛ¿ÿô)R6äÂáµi)ûE:Y”›üT¹ùu^ë:=Ó‰a6.]æü,ÊbSd«âÏ|É› Ÿz¾¹‰-Êíú2¯¹\]ñó÷SíæY]d—«¼áªeþ‹”º,Êë8NÛÿóâf[#ɳ³ )ÕìLI‘‚ˆˆÖEµ¾]åë¼ÜˆÓ3#ýüRhõ¼À-ÌY®î¹&[,ò¦!Bám¹­y2ÛN†MÊlußpW=¿½Éšœ[dåri=¤•™h|g8¦bOÐÙÒØÜTÛU”ÚeÎuƒ(kYÅÉV¼:‘B=^±œK~°þ@¡ÙÔÅbà okXZÂjdåaVÒŠŽôq 2½j ¶O 40U V¤Ö>Ï~/œL_ÀÂHÙÏÞ}¾øש2nþ姇jåEê¤odGµ ä}{ͨ6Õ{Ì(˜' Û«¢ÍÈ/Y]g÷§‰›¿wF°CÖÕ¡j Aáz|ŸY)…|.‘átV¡ì‰ìÝf#ëÆ.EÀ.K¸ÝH(«UŶ‹wWÐ"x?Þ]´Œ×cÿc¼A LÈ´aŶ!iCUSq ì³ ×<®BFÁÌÚÍ Tâx7Ê §, dÜPb¤"( Pë¼8oK`ÿØ„ñ#~Û³À Ü ªüKɵ È ~¹,µ¸d É›jµìÅMû!I#i몒ñâÜÒ*°J©÷ ‰H(Ð1#‚líçÍŽý£èTaÐn%ÀŒ†À #øèÜ ‚{´Àïë Ìñ ]« #¨$ ðÔvxʘo¸ˆ:ÆÄ"è ò÷¿zlëÀr(Ómsñщ+6LrK¢Þ=©ÚNwOY@§vBØÙzˆXhFÎׄàLLŸÞÁ’˜¼ ?® \´ßÑ.æ%WUõ2gùâÛ3$Š*¹½lòÅÍ%õr =$4zs )µ¸‰:žÞ½ýpñRãIè,’…MgÜt‘,\|6ù† d¢RMÈDYÞÞ ®éü6¯×ÛMÖsÑ ¯¬DTi§+‹FÎ)4Œ‹Õv™ó ˆ…ÑnQó†kqÇŒšÅƒÅ~ÇuÎûy;ZÑ/T{î@“üæÓûV7•·8ŸoüKð`ÊÓáHà¯è£0 dé“¡ÿ>A‘†d„OvùkàEõ Zë…÷jÌáᮘ]þÎ?œÆ1xì`ûÄÀì m-áÆÏt<žmp…4ŠóéQ,ÿµxö着£×!> Áp×XÅ~аozj»Ã÷A¯; Z줠ÌtçK~DÃnk!Uò×|S/’ºè} -4¹ý3Œ#<€j…ôš[:€—¬§’RÎß‚é©» ,ZëΡ8rç\Á‚ª0ø6zReuªäü®ášvoOù$p옕¶öØÚ?õÍ=%8eÀ:RELõ¡Ú D1i„¤Ú¢S uÕ-~¬më.s`9¦-Ài^6Õ ÌxNÃØ6Ê„vœ¥1K5vA-9SMÑýÞ¯«:ï†Î¶MGOqC‹{®¼¢Ø×Êì×ã]ÓBmV§Ú‚§‰©!¦.у©°iÌ(ÅCì˜ñcQÝâªÝÇôQÍý×˲ëØ”£l®¦¦Iú(¶¾ÝrN$Ñãœf´vá  ‡{P*¤éâ>ƒZAà@Rˆª;ñœÜÅ`ÞŒÔüzÛ%Ã^HHÆÅh/™› 46JB}›ûyÃy¨»¼­f™›hC‡ZÄø³0; ^€vMTiíp»’E0lÇYks¨‰˜š‡EµÚ®Ë†²\Q”Í&Ï–{%¼¼Ü'²$Ö[‚~…, Ž”}Hšy_®@ˆï®¶T—íܶël"XÎ}M‰cèí>Mó)CŒÄ«óÇnòœ7ý–bòHÕ ÐÑ„ýÁ_8š¨1yÂÐ+ÕY—Q‚©c—!n)ÿGÎbȤ¬xÖë0Î ðH4AÏÚß &õOxmp›‰vQpæ%^ìƒQ<’×v¿QáèäèPêÃX=uO¤|5@ü Õkpß)õ4‡S³Ù“HÉ&P†W5 ŸÑñ%s/¢(;@8û%JXÁ³OXqõ}Ôè%Áåƒï7c³RÎÎ)¶ƒ'G}P¸©hçbq™ß¢ß.)iL=®&=gñûa1¯÷”Viò/?=•°“<Lz™_”v…Î;[€É-þlÃX¨¦#k¢Íüc¬«¶pÎQ`°ªVNbŠ«ºZcXìÛø8ì>Ä Š¥uLbV¨œtŽb†ª²Z¶Í»¯h9Y ŒÖöÉÛÐ&o’4&mŸíß l†ÞòºbÈú”NijÊËkΙ€6`œðÔq¤Z¦3kÀ(Úä%A[ê)°Àæ–žgŒ ±MôñÖzcž0G‰¢àæåÙ¤Oç¥Tj…‡VB¢Ã ÷ºu8ÔéôùnyÌP°èe·z²Kï¡Ø¯A ’}ñwY<ÑÝ,îIv`•B&fp.o VCšvr!7ž÷vm˘»5àDÃäØ>^TH“8(Vzö;Ò¬¯‹¬¼Þ®²øøÃ%RâaÏVDPì(ƒ2Q†=Ǻ5ûкÂ9;´~Zdº‡¹ñ¼ºñ¢éÜÞÞæ¸i©ìO1X7¹ùÑ×ea‘Q¼k­›_pö$us¨ä§Ä±Dçù)r³X—±Eì‰r=Qn"r‡D,ØðKKâà÷q^Ž%ù¥ˆ4ÜÝ‹›–®fgò$^Å£5‡×(µÊµ9(Ä+3ñZÆ4³¦DaGbMÇÄÚ×ÞE¸<Õr³"GÎ{Rf ìxbÝ)³vœk½Š³šA¯Q¢ÏáqŽ2hû2 €‰ïÜÄð¼©=«@º¦).‹U±¹_*~F@JbëÎúcq(lÓn3ü¶œŠ–,yèÁp° ñˆ±ªÛÛ ‹(&|þ‰EÿD,cþ´œžóýÚKyJ|áü@†ëÔó¿¦}|æ093A°ÉºäWx^×År\3X¿ñ- e˜X,´b¡Ý;KÍäã9*F< â#7&ø[žX³fèxŒµ¬š@(Þ2IÀ¼JÑé‘e{?p®‰=Ê «‡³ÕÃhû–¶¾P×_(Ó)+|¾Î˼Æ`üMŒ%ñìÃN¢oºîvWP”H¦õ@‰X0A‰=F °Á;Až›7íů|hr7ù[Üùðè8(8€i÷vVø æÛr XÑêÅ.«Ž÷ Í“wÂq@½ˆ(*¿oxŽÒˆ5Ä-zn}@Ó Ž•Æ7fä“*KGÎÜ“stOb¶ZáàõÚí«p›xßC¤^¡/“ã%Ãóßdh5ØŸM4¨ÉÖ±”_ᎺÊ›„‘`@"fzsôc´x˜Ov§½ÇØÍ0¸û‚ð&â™I(a‚ðÒÌ´sଋ$„"ô}©omSὟ!ÔοŠW|êÆM¦¿°{άªxOk$«jMŸÊ1bƒEØä­S诔Êx¥tÝ¢?)'Ãbrê‹}×4-¬X{þàŸuþ ­N½Æ-MÉrüðáÇO§FÎ?žWÿÞmA’þê":ö±£­.ñ¯ÀŽ Žºt;o?þ°‹ 'èç±a ÐÅÛ_/gÃ-Œ?‚÷_ýðñí?vðº,'Quº! ½Tò Y«aþcÔlCgBžDN® ftêì|p?·ášEU×ys[•ËxÝϲ ¶½Qmn`/`‹†+±#ß;´tÖ ‚€ðl! v‹¡@¨Š˜rнǔ‚O¦Þµãò‰}×zwÉ'øÉü·-DÅŦ DVwœ› nœ›„oœÓç*ÖðµvþXñ§?ñ†A]ÛÝdq¼xïïæ%W ¼‚퉓áu7ºç‘‹+þŒâÅ0®µã”°M„NÃ4'ü`Ýc³qR¶ï™•0ßÃâ*žœÓ± ôQ,\ÂHM&Ý¿X°W ŸÍj䇱Ù0 À&±Ï+¾¢ŠÕè½6Õ†Î$÷ >épÐ.ǘç‡:Ã+¦¸ñ1ûÁ4"foiÄ‚0y2æÛ¬‹rÛð'ud¨A‰{ÌQÔ¹ŒþÙp*§dš2&„÷–š›ì6çowÅjÅ•t”ÏþŠ~ç+!x¥@8¿«‹Í†vpB‡e̸LD2 )8¨¦[;xÂG§róZìbGÑug}F 9ÈyluYh&Ì=7ƒè`ÑpüÑY,ÅQÝ|gñÏañt4çUÅ‘Ì~9à*’0d6fϧ¶3;:r5Iç÷mÓ†&mü7NiNèã ;Ö}Þ™Tžð%Ÿ¹üñ„·0]$[½î<›+ñÐ_õ9yå¤ÐÁà%ñê˜ÿe€õÿ0Öß endstream endobj 2374 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2870 /Filter /FlateDecode >> stream xÚÅ[]o›·¾÷¯àe{C‘‡_‡CP q榛cv†}´¹pa –Y…,Ù~ýž‡e{³$§£U @_½ïáCò|ZBôÆ QŒJ")…D4ÑUÉ$ @d“K{§uPSC"Qw™’3^\<åÁ2CóX2©`|öB*_"§NÉx]~›¯µ½^È9áIœ>‘•ZÆgÉÌ‘½‘Û3!n~‘±‚êÚ³h‚ã‚BN&øå¯Ù„°üµ¬–T 3®óø‚ø‚÷ ’/‹Ãü" ?–JnÏ”«ˆ¾b»ÚÆa)1"ÎxV<׈©£F®Û+æULòN± lj’ØøU“Bå¯êLJ z“²r*&©çNa˜jÛ&;mT2Y<¹(Š§Õ¶ ÛÃR59·ukÅ1FÎQÉÚvS׎´Š)¾íY ¦ˆ}¦,e‹.iùk6%·õÖbŠz‡9ªšRc{¯RB°ÞèœQÁæ€òF) ÄhÔF£M"¶X Å,ºdT—¿fSϤŠ©>b¯"@VÑö¬š}àÞ;ƒÍPRÞÔ¶WL«J{ „ª=ƒÌ9W ¡s"$…ß$Ž8AV;©ù€¬íd¢ÄGÈ›w…ùè6W) T€"øÐd#`(? øÌgÊS Ш@Å¢æñªí…DýñäÀÚž‚¯ˆr¡¥ Û)‘j—+?ÃÑzÑÀM¥VKÍí)f ®æƒ/&ïþõóÔL^^_Ï“‹Ûm|üñú“W³ù‡éü{³àÞOÞL¾›b+ñþ`r>½Z˜ïcVKý‡”[žÅR-dÁÄœ­«xí¥yñÂL.ÌäÛÙ»™™¼6_]}\Lí|v;]üÎË×æ›oðo+é’¬à8v!¹ßùíÿ Å·ÁJôÖCò°Ñ˜šÚnd$¦`}xÊwóŸnÎóq|Ì–VR†I¡á.Y_‰ c݈áâçËùÍtŒàÔ:Ú¹ XT[ p[`œG;b3ì ô›‚“j=Qo¡éÂ89s1ô^ìf›t‚qÓ ŽÁÃLÃ<Úf’’DZ`zÁ8Ë~DR ÿ´èDðbi¼v.“R,<ëå™èVÏ ”RÔf…á J‡8NÔjÝ ¢‡'ïŽø*¸¾h*°² ,ÝH)67G’mÜd®–8ÄÄ!UlsP’,ý$/˜Ï4Úøø~üáôÕ@/óëùáHm aó'X%,×› ˆÕl¸nñ±: §„>xœCB¨xÒz†¢Nh=pöò|$±…q 2ÁZ!ðµÈÛã>D[™«àÿœZo•[‰¶”Ç­ôñÅéñ§ÙÕ@1ðbï@@ #"øm ;+uâï!ÀþÙ'$ VwÃe ”“`!cë>v ©-LK#%I—ƒ2HO×ýÈ’Y+ˆâ6Ù‚h;ì"~D—ÊÇíòÉÑ)Ìri–BæºÈJš2PI2qƺŸ½ðð‘Â4 ‚I“Èø-³üøV ×KøÃŒ„‚^ ËgTï[>ˆ ÿqÛ4¢Ëôæ±bõ!ªe @nSHÿ¨<¼†p…BÞçfò—¿þ 9±e  ý½¾ýôéýÆ‘b"É &kjáüŽ·k|ìNð‰o Ð *Üñ2‚§¢PŽŒXJò´·k²šâ0“ÃÙ§ÙÁÝÕÔ„å'g—‹Åt~md9üýçÅ·‹ËÅÔ,YLŽf׋¶×Gp“±®Þ;Jˆë«[ p@Ù÷¢«”V€Žc¥´þF™©öA ­íßx“K aQ)kÖÉd°_ 2¸-ÁŠ&góÙÕÅ‚e¼>2“wÓÏ óþ¡ü]þ}z€u_/¦×‹–=Ú÷³›Ùíüjz³¬o´go§>^¾š}6M2Y )•ÁÈÙå_#8’¸|±Iõ &ne/âiU¯%\cEäN”Nô—KY]'|'¤¡±³vÎÚ9kç¬síœkç\;çÚ9×ιvεs®síœëŠ3k[+ÂwB::;‘:‘;Q:¡èœ}çì;gß9ûÎÙwÎ~Éùý ƒSÌn„ºË²x¢d˜œàÒÞ\‡;¦œäȘ!”Æ%ìÅø ‚Q‰­šÊ9a¦:¦ˆ,Ö?xNS§¡{‘(ò8ÃÈ’/ƹlËÓüÐ|QB°™õç„õ-HÇS€ŒM !¼Pò˜¶"„Ò"ç/•åñ0íæöGþÃ÷g×^ ®i ‡f¬鈠àë—" #“Zß|Þ‘BŠ`–¿‘Œ<5¤™0…òì³´ºG†ƒd¾ëãeþøïéÅÕO·«QH(°²†ÃmãVÇo¿\Îã€{°t}kA¬”­@NÎÎOÿ<,šÄ{f!ÉØáðôxdÆ )»w Hëvo_Ÿþñ æ)#Å3^—Y7Û~Cõåd4¸ÙJ‡ ªËLc „‹Ã7X¶/Wp5í@@ux;ÖÕî½vðøÖiÙâdl¶…<»µ²V(ª³NònÇŸ>ŒtúѪcQØ[öÄéôckÇ{ÖÒ÷e,Y²F”ñ`݊♬%D»‹•ØQ_Ù‰€,oHkÈú@$Øzw1Qª{Óxu©w(`³R½ÅX ‘ʺ\ì(¨0©>ÅP ‰å±ŽI’åý‹mþ+¶ ¥ÚRkle¤ûÈÏàÚ¹?b˾TUàDR®²d‰ì6$äj©5SJô{TU¡8ð¦ ga…VmÆ*ûˆl¤à ê·¤å [ lX²Sî m×mFG6LJXH^c(Kë¹uc ÁÊUV•ÖxÑŠn-¬,lËËД‘!–ò¾™´žoœ/ñöH¬{ÃÑ£MŸ}; ¯°Wlu!¥•ü¸';›ÎÿùÝõÈp^3—5I¾,mÅðL¦¢Ûn%u$lüùíHFÞŽPß.1õé¾±lþ92RÈdLw0¢ðæÒÞa¬E3xÓ^¬µ0Lå7(aˆ¸æÓ=öƒ÷íàG”7Øx[aë5 _‡ª¬&ä¼¾—ZÐÉ\)ó:+¯ Ä}8fg÷$œŒÛ`¨C¥DSó²9Ê‹*„ãÔ&¾ä$^·ð >­õàÅÞÊÙØzøöª§””³o¯º[ìöjÚ&ºßzØ3ºßòyÐ zØå¹ëÿüê.OÿÛåÉþWwyx×uÕtèÍ‹Ð[¡·*BoU„Þª½Uz$t>aͧ7ABo‚ÄÎ9vαsŽsìœcç;çØ9ÇÎ9vΩsNsêœSçœ:çÔ9§<´ÏÂÝEÞʶÂÛ’.ÙŠue˜:ìüÞR‡„€–?Gh#¯'…)g›ãœžÛ ‡RÚýÀÞaáÝHÇ;,÷Wë€P¡X8oñ²Á–i}7„ˆC=t,Ìàâ³Ä¿tàE0Cªp8NŸäÇVì•ež¼„7·zŽ 9dl’ü„p1;vW"ìtjÖ=o8™ÑA3USUï0”Ô‚èmž'höGI˜9ó¢ûòÞ¦¶ÝaÒ»7›œ!vî(Z30îÓ·˜c+â?VÎY§LC­{© ®N#ª¶æ¨¯¼L @WÂo4ó)/šg&ù¶œ‰7å•ÑóÞ Çì ,ÿd ƒ—ÉhJö ƒÕAF pûV¥,K•H·yåVK~þ›¥‘÷ÀŠyPË?pC4õàcµÕ—Ýúvlˆ[ endstream endobj 2527 0 obj << /Length 4140 /Filter /FlateDecode >> stream xÚí\Ý“Û¶÷_¡—ÎH­Á7ˆÌäÁqÒÖ‰ïìÚΤm’žŽçS#‰’Š}ù뻋?E}Pºz2<AXìÇo ²Éû ›üí ×/ß=ùì¯ZLâÈ£&ïn'\Ùˆ[>1±Ž¸ä“w7“¦ÏŠÙ…bfºXÓõí¥ú)]7E($x±Ó<› =ýp±Jf|úŸ,§Úû<›§Eèú}¾¸¡RvK×ð8Ë ì]éiy—”aUU§‹ø¦« <Ž¬Dµ·œ¼}òó 4ŒÕÉjÕ½ÂÕ°Äô6[~Y¬ß‡gP^3ºuxŸ­ÓuYнW„X(Ò’ ×:™k)Ç)eá" lÕ*[÷÷#c"/Ê‘ÂÅ"£ksÚóÕ÷=®0¶½´…*Ö]áÀ/û¬‹,7ÍWA7ïãE˜¸Rµ¤ËY¨2'"V-‹J÷(ãD—XOï²¢¤êExœâ«çË7•þÉHÙå`Fe½¯Ÿ½¡}’,êögñaQÞQi™ä3OߧÕL¼ÆB€ø:ØTÒ_ŒGôv_‘,µ-v®pðb88t§š9ïcRU³ò*y .×YÙÕ÷I^Öz³+ü„˜ÚÊ žŽ:Ä®®0_ÔY ô¤vlÁfu_ èh0žh@ƒ”ýÝ!"ãö(®ÁLêICOÆ’üO8ºcR#×X¤·ÏÿþÝ›í¡ ´eöÄ¡µ?'¸„æ¶;´KÐüÈOéZ$IRæ®éºX—^hÞ§91Û{‚t¤¡A`b3]oV×Ôˆ/^¼ |ZÕÖ¯,³y²¤âÛùÝ&¼Œºt™®@™[;³ÍÕî‘ŠPJô!Vøœ§ù™okši= ee<}QÒ3œ.¾ëMU!.Ãëå³z´ñôê»K‚–ÏÇC)a8@Õšºo_üûëíuW°Úk«"«ôÈuï(u)a1©' =õ¸m—–5Qìjæ|:n†Àª-¯â0º‘°ÝoõA„A¢‚aqXð †4Ø&›>½æ`#磔Ûg÷Ð •IÿíwižvÞž\hÅ "EN'ôG!t·ÙZ›iÃq3¤q)\Q(%üŽPâƒ[pLÈcÀÇ7)Úeâ|;T¯¼9Äš-g74¬äÎ{½åýÎe‘Q“ ºB(•qÄ{"‰ƒÊ½-ƒâ¿~h´û¶Q¹`GÙ”ûdþsò>­{‹ºp§50 ÚEÝ£yÁOn¯ÈòØF1ð¦,Î9"ËŒAQO¶‚Ìÿ[‘UäÎÙqßRÇK®wÕú®‹ö<„¨|±‹{×"É— `槕qÓcZðöé)£6'ìUA&JuŒèö(“PÝ8Åç¹Ñëyz™–Ú‘+h©›!-nFÃe‹z… xUfl BGª"˜U?Û ò<œV( Ÿ,Ö½^úxÒLŸ¿º¼¤RYêad),‡ÚƒZ Ãì!$-µS}„ th°à±9L3c뵞'ë.jÍÓr“×+ÙÖm¾@°Ûe›r±Òx\X°îÜÁ'ƒ¬©ØE̘3ÔŠ”€ü öH Ø/ÐöGa㣚sÓýè›gWß-*£GC!6¢ç&† Uâ+jñ5ûô ¸Mi¬«Ë%Žuôbp k;õ±_&Ôé%àÔŽ¯Öî_‚eb«6V¡[©ŽwàíÔð sƒSÞÒÏ¿ßfŸfÞ¹À;ôŒt¬¶™ Ð&P6n:blàkÎGóB^ÉhŸ6g°“>‘‚%€!úÅ!hzÊJÔÌR…-!%¹´P³¹¿OóëlãÃ0pï  ÛX±Z¬«ÍŠjë`o»±š.Óä† %´¹Yj.<þÆg'¸‰àò`àb|@ÁôÑ«SÊ‚ƒ$Ïñh I=!»àxùÕä·¡ L¹Nš±Hø LÛIdsEª§œÒ³r?X ”„FI9£Î ›À“ã¾'fFø×5Ïþe¬wÍšØÌX¨~á%v¤@¢öUñ©ŸŠù8Š÷løÞÐ[ ž˜áÿg±·O¾Ö§Øꎆ‚k*2Ì~*Žéá¾Á?ZŽñn®Mâ·.ó‡.k}}ÛMm="½O2pîöçÁp¡%Ù}é}3,tf"­»6k„£欆߼úr/¿ÚÈ5ö‹V,‚$ΚìÝM‘†4Ù:Í’±Êñ Ì'Ó†TàÅú~SR£&k¸›™ˆU­dDo·¹áÞ‹é$Tl%_e¾™ƒÅM?=Äù¨+ac@ë‘b…=™jõ#ðpÚІ"¡…ê¶ÆLµcö­`åGk)jÀ2b -%¥bŠ“¿Þ¥T¨ÐxÓ @ã[¸¶ÝÆ€Àb+;´F;ãJðˆf±>˜ À7¨Š p x­sºÏÂ5èU,âüõ®z‡F…Å*¦â_½¥k“<†­jщzl#ub/ ›p‹zøNSó~¦µ> Ž=ÙJnªL¼ªXGª±/áäÇ…’ª…‰¬ó`N1 BgøçŠÞÆãDò¤ÔØS Îì{ê]N§×Gi2֚ΎåVOÊÕЉ”âÇ¡QlnÒ÷Áæ^Ԛا“j7½Ï|bÞÄÓ$Ï“Òøø¬R¤27ºd‰j±¤ä=çÝ^Y. HˆÐ£Ó=!ò’áT•u7f 2âÎ}@€çÚlÜžr frL€ª÷µÜ'ÄÃDû‡\ïP€k €›p(À…˜¸Û:àü¡¥É7>qßU‰û®ŠÀw¿D!}ð@Œë-Jæ— ìd~̦ô! |’ù›lMV-8ï}äVÞ>¶õpPMñ†€õÒöe¥±°kâË*mkPévFHiû²> NhÅXð­sŠ\~  L«À`¿!Q™naaM± xê÷ðáPOŠ•ÇÆT˜þˆ€¸ex*¢ÀCÜÅhÆs‚4JD"ÆžlÃÛ»í]ïšZÕ—¯-¼•÷|šScQÁ¹ÈÄAÅD$m W‡€l]“á‚VžQüÊÜo˜u|0ÍÀÂ<”-ØhkºS>þ:qºp4qpÓ¨½!s,`jêКãÄ-Pw[ |N¾ÏSaO˜7áN&À‰»œ@­¢8~”ùbÒ¶7¿«‘óëmœ«Ã:Áó]Ò‹IfL<ÂL¥‡Ù‰îLg µw#ö•’k2p¾íp ƒÓvGê˜s¦ã£Q˜žs³?å@ïFÙµ©«[m`?­Õph¢…=b}¼X éõ]ìÅ& gž­Ëd™ øõ<=ÊŠcõ -ÉZQ‚§”W-ÃÁ¸G¥×ÕT„bM•&oÉX¨c* a¦·Y¾J<ÊÀŒŠšnœ´úhŒèɉÓa°O‰Gãàîç:¿“@‚z¨Iös!ûì<‹ŸC°ÐV1R³¤“¿ßSë½ÝòZ©úBuЋuâ&êÊ[I КÙCvF‚ÖÅí=®@ªsò¥c~zØWGækšÖ¦~•* êÏ_wÊ•ÕF†Ø–ÆnçàzŸú«†¸ý«ü¼_8QÚÛ9ª"T@~x][¿ºÀÛ~uIaÍ.Ö¿ºPí?]àG³0¦*Âo?hM@ø?¢”9¨Ö²Z X‚žšÜ—`½-˜ããøçÄeùPOBØn\fÌBÚ!›‘ª là혫_I›ø抪\èøqçzÎï3î²eõŒ9×û™É¡b®Šqs†ñÿµÕX3»Ï¨ôm˜6î,ËãOÎv?÷Í“ÓÄ?,–K*Íq+1Yú €ªöÌðA€!X×Ù¬`®½!Ðߎ޵§Œhe&íԇљ AXüÅøvF&evDN$¸‡º»­S”`^À:íŽW}Œjmg`m®=>^‡eMjâé*—‡áÞ#‘£Õô2Øࣛ á2 Ø26WÕTªv÷Ø`1Ò›zjûg„vܱ»{2›ë"7¸€Šdïœt/àí§kŒY5~½ع ¬nc.u· Ð:ÿè>¿˜ endstream endobj 2567 0 obj << /Length 4122 /Filter /FlateDecode >> stream xÚ­]sÛ6ò=¿B/7#ÏD,>€h'mÚksç&¹Ø½Î]ÛJ¢mÞI¢KJI|¿þv± вlÉy° €K|ì7vWlr=a“_0ÿüîòÅWUjb3«…ž\^M¸P™Pr¢ •qÉ'—ËÉoShæ™<›qÆØôuµÙ¶åªþ_µ<› Ŧ‹›]KÍE³¾]Uk€ ~·mÚ3^Lèü.À­vëMGß™bg\þ v"'ìD縡DfrئÛ›×o/Ï’[øÏ=¼Šàó"Ëyà_ š¼ñ;“ÑW"új&ϸ*&3n2ÆýßlÎfRåðõ²j©¹mèySž 6ýxÆÕ´¢‘jºˆñ‚ã/ØŒñ‚ýu¹mëÏÔFœŒÃÉKèlZ{Ⱥ£çmÓuõ|UÅ›QÓ]ï Êv[/v«²Å£.€d™U–Nµ(\äjÚ\áæ¹ñ˺ƒÍñh»­£ ÂæéðU pË8ü©I‹,:~|1"'W2Ë¥<@Ïž+G$r„µ añ~gò%>õ´«ªG64ùNµ›wÕb[7šÀ1·H6Ëà¦üÌŸnªÖ£©Ç¡q<À@l8EuLpa‰Œðl6«;j•@Ïëãè9‚J`×ME·m³¨ºO‰ÝðmTÆT¶·ï_¿;aY›XÜlVä=ø#׃WÅË­¾8ÂTÓÐ6HšOñ‚#*—@T>"ê¥E ˜SŽæ„WAÍâ»OõjE£sÿ¡Wä°P·tºU8¤×$ë0pÓt~¾M³ôcõÕqÈÒfyn’ÞûáF¹Û;h<§ˆ$(ùÍ’öqo‹~c((õö†Æ~~ÿÆË„¶“:E_½,Õ(æ•'HD7n;O˜OgÍèë:£¾JL õÚÊñŠ:C\³L lô õ¾Á+E‹Ì²"=éyµ%ÝêdžÝn½.[`Jê–~´FÞ¡6J)9ɶû¶BÃŒè k€ƒ$ðô¶¥–CV¹ÙvÉÜ©k {9ÀKŸ‘=×g¹JBkÇx9 JŸ„Õˆ!îñ€— E¬ɪÐY1æµwNqÐH·Ø`ˆÕ£!Mf »xóïÜ÷?\¾øó³ Ÿp[dFŠ‰n×…,Ö/~ûƒM–ð4g&m1ùä@בi®ÕäâÅ?¼ œ  z.h¦¼ðg¸xýÓ/1hÊöÈóT<Æ=ÊtÞ{Gço..ÿéi•œR  •þ§,L¦rý¬S’)œ“eäÓªlW5HBΦ(,\“ȣʧ-uº›f·òßtN:@¯šÕŠlr‰‚«  Åc+ë<ý·{7UÄ£äñÑ ™ñ™ÂW(¡w½áL'*7åꮫý:·7¨îS†ùD)¸@ù!ÊpB’‹qb4K`¡8ªÈT¸…}fx>‘Ãf®tL¢£šgŠ©§;jB›ÁS;Š«  DrA.Ê$Ÿ:㧋i½¡¾¿’aÓ ž¨€˜@Ï{¥Œo4äìã'7å–ZÀ‘ŸÑùäÔòsDÞ7vQ7@ÙÊï |øݺçÒ̬)“ºõŽV–Ÿè( "þæ™lîœÑÆq ÓžK~þîüÝë¿Ú ¸hƒPÏ%EOö·Ç.5†O9`&¿°q·\,]ìáz‡Æµ£¡õÎÙ-h9/Ð$5:2kr£ñ³Í2Œ´Ø:&ÜÄëmíîÁBXb4ê¯Ô­Ÿl±Ý•+beÁŒ¥¦‘ÜÏÕÎkï¤:³êíëâ¦Ü\W#´‡¹Ñ1«7 bjøÝ™TÓ__9É{E&ú9 DgVÎÈ¿Ä=>Ðd{tõ Üf«¼ÆÊoâ1}hoÀÅ+ä< ¶¹vgr—¯LȃZ#cÆÐÚBK °…¹À¤MÛ}9ÚùŠŽ\Þ z:pá#Öì0½Àk-ʃ.&2+˜g·â \91œEàû-:yVE~`Êèz·¾íö W¤)&9 Fócý•DÕ): ζ3¸Ù äÐmðiR{ bh˜9qgñrE`2éH or£¢€Ü(l‘Oß\Ñ Z!¬œÊÏáØnÓÝ­×Þhà„Œ5 ûàÊÅ¿~>"êóUJºÛÇ&ÙqŽQ–-XÌî¸ ÀÃÖ„@¥}®\rḪΪ ãk‚‚"8L0³uù—j‚‘«¦6õ µÜjÇÅCH ú4´k?}tŽ°Ú‘áfÅÀ_”Gðp¾ UÃYmlÍ:È8B|Ö}I„‘èQ³Q’— A!„ä™>†I±*ok¸Ç»Ì¼ëc¦Þ{å!€ïÂÇ°ÜUMüƒÏÀ?è¤é -œÅÒ†,–.¢‚„ ¨F¼ÃÝímµ·N Þ«äÚï[}ädÇE(pp^ѳ\`̬Zb—ӷͶ"H²·Ⳟ\OÃÜnKqJƒ dãWD_l<‰_@cû¶¼çh} ƒøaÏa \¿{¤Q˜ÕÁÅÔ Mm´(…¶qÈ“Õê~% äØ=ynœ<&“÷ÉJØHø8æè/RÚL§Ë#®ÚøܺT*3㧮µ=^HÁW2~EˆtÙ†`ø0™0o\Ô†)4ÚÙ@\˜ÈÁÆ2 }$fGb(ÑÕû@;ðR™éwÕ¢tu8ÉrQˆÉ³Õ!ñ´'w4 oå&õR»ª #tVô\=p™dÒƒU LÆr/hj?BåVy]eýum(‘àÉq‡å¾8ì—®OºZ¤p¥ÞãÕ.wíR†õÇþîÁÚ°3 ÷8Gè§Õ†ÑÜìe’ø'UŠ`f…UŠ}ëËèÛãÅóv'Å‘çÇ ’.)H2 åf\Žä”¸Âhˆ*é,ƒ?@ÿ¦ìB;|„ ¾¼ËD0áú+—ÀŽ‰µG‹:9o\¨¾u®³ þfÑ{žžáwÐÑ‹ò>´™†¯úÉÜ¥ÃÝÕñõmÛ€ó¿¦W'(DÌÂ`'*FŠw1(Hžq¦ï9 €(ðøˆ>[ßëá^¡t+N¥)ø}²¤ÚA|ö%4Õ<Õ&,ÑÖ×7ÛÙ“r%0!Z #ÊØi6#hÏ;Ø$ë êö´·ÖèO0ê‹æ"Mi¡¦-0µCúÝ„dqcÇcàëÎÅÓñ •U`eÃÈž %P±X–0¡¸†|Wàb_ËU WKØiÎF¡H &¬ND|.™ŠÁDXKôu!ðšÜ<9¸t¡,L<<Ý¢iÛª»| Ó6÷fM íÞ:æó»ðsÍ«}<àU\9œ…@©—êĤ\¯šyÐþ©z?áfœË¬àüùÜ$úJ•‘˜q+2!¬ ÜhQ2,£ùÕ`ˆ–m”t.\Ь–ÇH°ƒƒõ •Ô½XàEÀiu›–!Ðà%r¯á- Þƒïð&A®-?EpM_á»eI ®¤:£¢%MhÓ1ºY’á4‰'#ý´ò^5²¦j¯5%$Ø{ªîìî.â¨8ÄÇE¦˜M|ïC€nTÃp¬Œ"’Ùþ€…Ä–®yp¡á+« ÕÛçøuÄEÐs\”Ѽoüg>‡œûBÇ|¼b¹êšñÅvæOÞ¡ÆÙ@%Õ½µ^/T«z]o"_¯¯©Z Lý»€÷7p¢²˜eS÷8 Å)¦ç),·iF¤™ñ÷gÝPµgùïWeÛ¢Ž(ï<^ÀUÌá}³úX-÷eQÀß–1#™8¦WQ~øþÃOî ’@ÇÅ]²|¸mžïYì1Tr­2™›ÇQ¹Ú‘§2Ú½ß\ó1¦BžNó'Ó¹MøõXG(×ï-;ÇÕaЋö¼79y¬8äÕA’«÷ÍÙÌÚœ*؉íMhòí¦Ù:öïhüªmÖ)>8·£(i¬ñ—!\*ð§&þ7 !ˆŽî®ÛVk¯¸m‰ÀM»ß€´QÑA‘1ô€a'!#éÍfÎ#(é’$~šoöL<¨{ô3h0Wˆ~™Ï{f½‚!Û³™ÄT~4½Ú³žËxöJe¾g1™ÙÜî[,áO“‘Œ ?ðî"¿Áÿzˆ|ؘ(XðRWÜ&Ço#×—òâÆfFbÉ]__2r÷VÑDYò²­B‹î¹õ¢¦Š(g›·é ,­aiv[pJÒÜyšÉb „^Ãè~8=È Ë˜Ñ÷2YQÙ JÂm]Õ½88¬$f<*wàYÊá./ÁÛîÊzI­rNe9Ž0(.ÖÐOQðÿ…6=’2i c.5Ü;šeµ¢Á§š´a«\›LÛÿˆ s§A3æö®§ ÞÕ?Õ®ºÝ…‚kä9þ–¤òø·GÐå~ÛBhÿ~U•aŠðƒMªÌ=o> stream xÚ½[]o\·}ׯàcòÂåÌð³0ÄN¤õ,mšøAQ„Öˆ!²\¤ýõ=‡»³VRy¥&W0’¹wÉÃsÉá|#Í9‡4çÄ …´Í7-ä4ßôP²R¡¶¡¤Ð•oŠ„Qæ ’F¥dAÔìRä„*Ï£SªAª6H¿66iQÚ(”ðŸž%˜¤wÂ)~¦xÕ 4bpä¤# ™¦Êñ5É”@Y&§*A5á]Q"¥I¸KÆv¥“j”ÐÇì‘‚eJ5X©üŠŠu°GENøŒ!mâáóršD›„¬Â/k²e2m0{£å>ìÛJÈüdH5äÞ Æh-”4çXdòÃDƒ7ßõŠM~]B)ó×®¡ÔJÀ—6ç¶çP†Îv%Ô4çÔª Á½…js"z• Z:ûŽ„¥K:$Ô^Èyh¨c²šÈü5‡¦S°`m»ºXöúc´ÐªN¼Zãdo Š&¡'ŽQ’„.P H M Hú\Ђ%늩„^·¿ÖСrGZèsîKêa¤>{Œ0”«_$…aœÝ"PMN'$ £’=f6Œ–‰‡Æ£o…Î¥„~¡kI2GÁBJÒ6;uˆS{Š ˆX ªßÖ9;ÔÌÔt*߶9+ʶ]HE9D¯DÀ’‰L,š b1š ÄJÅ+˜‘…€ˆM øBŠØ'š¶zF\KÜjÔ›‚¾¢yâb³âhƽXÁŒÝÊуG›Wÿþé,l>??¿¸:Ú¿ÿþj>?ysþãÑæáÅåg—ß&X…ôzóÕæëÍ£oe>m^ž^…o¥iäêáÃãÀÔ«–Ø Ùð\:Ú}<›ã°ùòâÕEØ|>9~óŸ³ãÓ¾¿ü4|öÙþý~j=&|ÛžÆج®M–36짅}_™$Ú TâÀÎå¢T=K)ßÈâÉ›wWÿ:¹\šæš“*1ÁB™cÅü˜I„âÞÈäëGÏ^=ùîß}ú{ˆ`;\_ÌD…Õ3ÕØaä8°{‰œ¾¹:‹ïNOÞžütrúãF[V]iäàiæîÑÞ〲4"¶ö}Î˯·¯D,Î$ tÙÊ} WV$¢9*ýP…ÆÐTµ+œ¬¶ ‚mE"X’J§±#‡‰­M&¶:M{ÌtuÄNß^±™Ç<þôüá‚‘kDP†@+Ç‚øOjŽ‡‹(*–Qo$ðâó—ˠѨ€0ƒ1ý†ÿ“˜áûRx6ûæïÖKÛ ðçïß¾}ýцÒzl ’z‰bwn +{ã”&‰‚åETqGèÌíÐõŽØVì~¿#¶fÚ€[k¥6Ô»56|›Ž;6F(gŒó¿ÃæÑÅÛ‹ËcØß³`Û./N®®Î.ÏÃá?_}y|uruFsG›ÇçWS3#0d,;Û=fŒ2Ôࢇì*Û!á@ìë¿ tFx¿{@<Ûöhp!cËT7/./NÏ ³à÷Åã°yuöóUxýËmðâägGø ó«³ó«w ÞûSÛß]¼¿<={·继g?¼9yxñs˜„k qr‰ÞAMó¶áÜ\ï0ðLgÈgf3;aì„š\¨.xãê«7nÞ¸‰ ꂹ](.8rsäæÈÍ‘»#wGîŽÜ¹;rwäîÈÝ‘»#wGŽ<y8òpäáÈч#GŽp€~ò>뇅͓a Ìé¸LåʬÇñ#â7ÝSÈ ðe]eȈžÒ¼LlPDÞƒ) ¦EðÜlåøeÏÂé°x¶xü"1A!˜å€13ƒ«’ðlmw±‹_ Tïwñ ¦"ÚêáËžÅ.|9ÀâÙ=E/{ »èå…ûñ܆½É“÷܆½Yš®á¹‘ÐXß …´Ããß×0•*fĪ®Y…4||kTC98þÂ3À+‡†èÉh¨y'Sæ]• 2ž×;ñçÝ‘èÂ=(b¸žûǧ§o/N¾‘B¤"VQ|ŠÊûkÅs_%‘PäöwÈNÁ²\¹…²A¬ðêƒw/%&݆+¬)Hx¬c¥Q3B”ì$@ öa·“x¶¨>ø•º³Ø¹ê[Y,­•iÞ“JϱQ'Ôâ¨ójê#§>÷@‚ ¸­ŠÚrè θ•Ä²ë¡FªŽ= šÍ¤ýV˪¦idUÂ8UìŠX ®ƒåò‘»ÁãG_ýeIoQaX]S`3Y †´séÔUÊ*ñ¼¤™á:¸ï8Z»…ÂÂ$6A2e›ÖÚh·Õ•òK›L×8ð¾åƒ– i …åŒ;L,²ž‡{8tè¬a¡ež‡Óq‘EÆóX±t›#õ¶'byëåYôêˆUi=±8Îâ¬(Äz¤èÖ¬¯teƒ´šc:ÎY{€Ãâ‰MBø.ÐQFó ³ÉcQþ˜K>fã–AC0IB,Î1ª6ÖbÊ<4d¹’¡ˆ±rÖõKœÏàè0ÙΚ ¤=7Òx÷þ{þCï7ç±€v´_¸°žùN.¿hèµ9¯¯ïÖ:묖»ckÅÿ+2©{«è¸^Äq­ ã×¥× ?®UtüæºzCÝFýíu¬ýÝÞ߫ררררW˜÷2ïeÞ˼—y/óêóêóêóêsäìÈÙ³f̘0;`vÀì€Å‹S-Ž\¹8rqäâÈ^×R¼®¥x]Kñº–R¹î9Ë’ÅÊÂUÈçy~n ÂëøŠç¶¢ á)rj}Odžáb™¹ÁŠè’ùË3°­2Ü\ÍsjÕ7'¶J¶Œ8G{þ@¡öY«v˜Â²N¶]†„…´LÛ—#KuXa£¬© H°™X `ó(ÿðCy¾·BÕ&"²*¬ žYŒ`Ic¥>$<·vÿd–ÄðaK2f:Tf‰žW˜i,Íéü“œHC§º­_*­òi½«?Ш¶§=ŠpGÒ¸¯?Àö4þݘlÏ+ ¶§m `í…ÿø_ p endstream endobj 2621 0 obj << /Length 3505 /Filter /FlateDecode >> stream xÚÅ[ësÛ6ÿž¿B_nF¾Z^ÉÌäõM¯î´¹4vïCÓÌcÑ6'’è’Rß_»Ø_¢cQÎôÆ3"ÞX,¿}–³ë™œýó™|ä«àWÎÔL%‘0I4sZ ™ÙåúÙŸÏ„K´J}‹NÒW…~\ðülmfß—Ï~…¿áЋ0ö¢3ø·ÏžÿéY*R§Ýìâj¦œ©5³(ÕBEñìb9{7ÿ¡¸ÞUùÉBGrn^œàóórõ©Ø\Sáö†k/Ëõí*ßr®¾¯·ùšÒ»z¿õùåÍ®êv\ç›-å×Ù¶*>Ÿ¼¿øéA¦yÊ ÜY¤|¡¤0j´ÖåŠF{ÑhönE¦Ü,óM?¯òåîIJ#¦ Uq}³]Üd›%åëbékÜ¼Ü šÒ2¢h.NÖºù¿6«{ªÉèsUVw'JγjICä«b]l²mÆ*júÞæ4^çKÏ”*MýÒÒ(¥%]à´Fëy]®v4æ.˪Êë[X“ç3mKþ†ÿ)6Û¼Úd«?´¶Tô‡Œä¦Ü,ü £¨øÓ‰ê«"û°Êk**ø[åÛ]µÉ—aŽëƯ(wWlOÔüÆÓ.ûd·œ™·—Ïû—\Üð{¬Vظ‹A¯a[ÊóÞ@Êó¾ë,”d' ¬´œb…Ë¡bÏxø"Y#ÔÞ”5¢‘°3ú!q[z.R&«ªìž…K 8k"šU(e!óÖË©éÈi b;hâ'zûêû·?ž÷Äs × Î:NCûÓ@MÆô­wÒL`¶Z•—ÙÖïßã×µ ØÕy#­q4?ÛÖT¾Ê3–È, 8‹5JפÅ-”ÖÂEQŸ›?°J€ °FZžÛ ·Uy¢¢ù'ØçSƲýC½ˆ¬þ°h˜YÑPú ç?Ç!?ßz)2F1ƒŒ°„Iä䊪;Ç *—;©òaq¿qï4‰iÕ.i2E^"¡¡€ÛûSk6xJàyq_è$Ò  …#!IÒqŽ¤5ñ>Ô$ܳÓ#ð’ƒÕÃ>i:ªcéíÌÙ•^,¾ 쥗ZÖc'÷._­pÓ-ÖÃ0a[SA#à˜¨:FÆ•t"R&pø@á6f(Þ–ÅÛtÅ{‰À§¶É.?v”´®wêm±å Á6/˜´¡íUÖ PE}Ö4Êåd¡RÖ7˜"ôE×îÕ'$FòE]¬Å6©61{“ý çä 2´rpUÇ8eØÂ݃¥Ót~KÃ,ßÝÅ]^"Žmèî¸EÔÃ"®|92{*´jzK4,᳉ó87&¦ê›r·BQÐiWiS¥×Ò%,ô6»ä¢¢?TÚ:Xz„ó µqb÷<&˜H íw© ä ”‰›’Œ>­ùuGú fLŒf;Åq÷(Ë:Ï™ |$ø %Ф*€f@;p<6ryØŠ0.XÐAK6%åƒi`\7bA*±NifjÂÖ¨·Üê6ƆҒ]˜=Å…/{깬zÚ,Ф¦Ú°Þ¨•Äè]£øÞq׳A¢Æ”ø–êÁï8Ž}è(]²òÓ8DÿöG±B¡wÜ6:l(=B3¥ºC½§FVu†òT‘ȾQDhÌwZ~2€©!<‹i3pÌ{òµ‰~;â„Y²à[l¦¸èŠ¾Û°µ PÖ[ßè…¥Îo?!¡J…•Qb%Š0è˦ažž#Ô íAíµa_5cOãˆTÓ´bÇa¢z³%‰÷ !-±s£¸56È]:%š@ÃM&“¸%­–ü²Š›  øaù…®¯˜GdK&ºmL„*pý†öÞYB“¤¦öeÁäªêœÒA°zº(—)Ý1" ÀòM;"€Ä¨‰ÛHÚzš¯÷½_]t®zL‰G;Ð]:Â[œwïål •?Á &Mfw¾é Ç!=«Ùù³_ùª§'d)8à ¤5cø#"p¯Lz¤¬õ“GÛ‘3…‰zl´ž}î+°Ñ:à‰r}6ž¿ùÇÛóW ó †Ëè©;]©ràçèd‹Ð=a¥*V"U4’vñ_²Ò¾g:º@m¤ˆÁÄ}úÁÿaˆû |sñö±a;·3>Bu‡‚ ]òþô¸2j…y]kÌ d±Þ­oëIˆb¯VÀ‘…¡'2ª·è(‰£‘Œ6^Ϊ¿±qÓ³ì ÙäŽÇ7´¦{‘eÅHˆ¾å-rɇ^Êmýí͵·) јΔeÆ,kÅw_XÑú°ª{ÇES\Ñ·i‹H’MÓ¿‡”ÞX9¥{EZ¦Ï¨àOB 6é_mA]‡‚ûÐ8§¶˜ uÇqý)q$3>lÁô„MëòÞõnÝ–D[³Rj¢æ×>LÌdÂ2Ù—Ðì¨Æfn¡Ÿm]:?ó±OðZ𪘮1 …un^pQ¸Ù4|³iæ+Œ¾%´ë˜/ù›ÿ¹ó·tÒ_JLÔ÷pÔÓFߟŸýþjDç´°,è¤H8iŸ¢sõA'Éʈ'ýîÇß¾ˆ1d/í_›pŸ‹·ßÿåTÉ!é¦*xãÈà&\¶áj¢ÎÑ€M©lê’·ý‚íöM¹Ý»Ø]¶F{{„漿tïËò®'ŸR7-º•ÞäùrHþÈýôò!¤ÖRî—Aj•¤"–_©q$°b' õƒ@ LIZOÜïQœ€%>2 ®´ПÝ6rHŒ»ÇÝßÈ`½+’æÏcÔYa\3§’Å! êèoþ©€¼Ù ÕGá °Üä‹F;xÑ‹}ì‹Ã·§ð-Ÿ…( UB/^›°±sŒû½{n_|OÅŒþ®Aÿz\•—æ8=)0Ô4é\‰AqpÊ `²Ý…„¾1R+Y†á©©¨U$é(Çç®{™4¦½yЋ¿|îz}?Qáe]xßÕ^$©KsŽkbuû2‹ Ü€÷m÷¯° â¶n» QÛT†¨m¯ŀ04P0Ç·éÌ2|<ÜtdçõŒ²Ä ÔáF2Æ"¡Å7øû‘$ëï%KƒYbã)z-E˜vïGO‰¸â%)Õaèmó¤sO® }4Ýoñ<²£CR0W{ö0Èb4+(0\cóƒ ìzÑH.¶GdÀ»ð,¾ÄLäzï±€ª4 Þxï‡ ¹)Wìôĸ±—œþ:*¼Én#٠ܢ`ó°Fó¬ÛÛÌû‘H¼‘I(ïz‘øÞJl¹™uµïfø"íê0‡üh¼Ö÷7ïfAº.9Â"/*ê¿;ôø¨lëK6 ƒ¿iL„dƒ‰ŠnÛ|u!{D(°(6êé˜ØÜdi0èüJØ%µ°f*t%}è"YªµxèàÈúsÍ™´Â¦ú½/Qv#˜'òI¦–€c Ž”ˆäxSGêA<3@bôÿàÝA¾f<|f©/B-Pà}Ì ¥› RÕø– pª÷ÒLu^š=Òšððõ@ÃÑgXhŸªý§†|æÇ‘3EnNÁçàM ÍÀ)cõ p '´ë'®ìÃÀ æUâã@>Þ†q ï»l0Ñ#‹ÈÅT'?Âò¯ƒyg¶þÉíÁOsð¯PI<@¬aŒ![mý³m 8„ç‰=¥8ߺ¼¿üöË›1·}ĶïSÖþPlØ”@ b [üQÔëðõ?B¼ž{ endstream endobj 2582 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (./figs/SchurSolution.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 2625 0 R /BBox [0 0 374 110] /Resources << /ProcSet [ /PDF /Text ] /ExtGState << /R7 2626 0 R >>/Font << /R8 2627 0 R>> >> /Length 920 /Filter /FlateDecode >> stream xœ­VM7 ½Ï¯Ðq7€‘ú uÈ%E¤( tÇAŠE)ºAaH{èß/53ÑöØõ¡X`gü†ï‘")Jßœt¾þ-Ï/Çáå»ç¿‡oƒwˆÞ»ãP?†ÀѼLŸÃ×ÐGÀà eH¤Ö„¥€pÈÎȹ‰pFWb‚ˆÑÚ4ᯖ ï]ú8 Db…V¤ÑVÒu@²‡"Æ÷¹£êüã ÷ç)RrÿLYòîé­²“êì)%"½qøi“º±ž«¡´hÇ­\MÞº€ñþsÊàÙÈKB2%n@/_ãÜB$ äl£<õ49O"õ½§„b!`±B Yãi¤”`}Ÿ9ZKLÉÙzJ$|VÏH¯;1Å»ÌîÕ´˜âqŒ >9Ê P»è8HÐf_‘ʈ:ebE«#ã€^"”Ž‡ÂI#èV éÚÕUb¯«³1¡Ö Þ‚tíÆ:‰IÈkù€v- b´ÖIL¥‘AaLÖý‚™J±”1AF#Óz¢Ë4¤óË*Ý»å0kPš] kÏ!s„\VäÐö#V¤±n!œ"¤àPw,G²6«²úÀwžú¬Ðôxç&âb¶ÞÏ<­ÛCÉÀi5­)ÐLR4äºí6B½îd dÜLñÕÔ¬ÁÕýêëÓä$ÁŸ”~AL{,,ÛäwÏßR7º@ºžЂi ô¨Qý³VãhœM@uQõ!3çÔÑì|¢%ÔDp˜|O@Ö2úDi™½§¢9ÏÔì&mþ.–Ùkõ§Í×׃™Ûø½ ôÒÃyãfr/ór–:¥yfð']°ò¦ ÄtÁ²]0þ=k;àü¾<¾Ýë½^ÇÄibKÑKÀþ÷a¾¦éÉ®7Œ¤CSç²d=6öÇáá‡Çý“}©æ:­«=BzûÙi“‡¨ÉÚÿ6< 6K£¼[MõøÑûÃlz·&mib:£ÓB‰žÑ“ᇻ£¤­(SÑS2iâåUI.w,\tn×Ýkì~¾;Æ›‰$u Ü'dNä*‰“å$I™µ‡³Þ;R™ yøñéÝø¸#Îz9Èó¯_÷ß_†<ÑLœß?î²×k“2géÑk»}`LS,¯ÿÿ<ü·äß½ûðT ;âÓðÞ…YBÞ°A=XïÂ)€¤<‡õª~x³×9âݳþÿxÿÀ endstream endobj 2629 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1809 >> stream xœmS}TSç¿—$÷½[)r2¾4¤³³Z… ­3ÔÒò:qÈ¡€ ¨“"¢„pIßèKå3@$ˆÈ‡X¿fëÇÊ6ÝÚ]°c·n§uâN÷¾97;g7xz¶sÖÞóÞ÷¹Ïóüžßï÷ß‹ IÒ;MY¬( M)-–—x¾·á`¯÷Âxõue¸¤‚ DâïEè̓ÞüÁõ`Î9}Q÷Pý:‚G’LÇp\©ZwLYP¨‘lÞ—’±eëÖmÿ} ŒŒ”äè¾HdŠ2eA‰dwÑ*T¥êbE‰f—$Žû[¥RæJ T:ua™Dž—§Èó¤¥ËUŠ"É»J•R­.ÕJ6Çm‘DlßÊ;’”Å9åe’5ä’¤ÒHI¢$EQP®’ûÿAëöÇÆeÅïNHLJIÝu8œ "‰ÄËÄ.b±…x•%^#^'Þ ~B 1Mø¾CŸ cH§éÕÂóâEñ:ø$ ¶ úϨuÔK” 7û¸ò¡Ýåe']‰®WEl-C}t¼¯j Þ¤+)`¬8@þË¤å² ðT ´[;ϵŒ¶ØØë ¸Ý< ÿš A$ûFÎî‹x©±iS ƒ 6ð^«®A«uØq½€6ü•œËPB} ÔUÕ(O4AÓ‰ê4ƒ®Ú@z»Þœ}‹MC#hÚsû¾½ç7­>®× qàecóC‚UÔ¸ú&þÂ#ýN¡•{L0†v'c4J›iáý܇‹ƒŽ¦&ìóð2têfTcÅ#êž=}×zͧi¡jø”Õ1„ø·Øq$ûXô¼Ø8¥çÒo–ä&Á}Ú¼\M‘.§.ÒY†®‰4ËG:0ØÑe;)¡ …Qé‡CC8Œ'~6CŽ"šç"pº¨iZªA[U]k¡þ¤¾=«/³ó Œ„RÕÞ´ø½Š0ÈzÁ°ñ¿HùxÏ_O À'>§u1²„b) L„©öìé´+ª/ âÑ(áKô=ôã›×´¹3â‰"k©m태ƚ&ñ"’‰*Sk´åeÇR Íš),Ã߬î!PÁ¾#8Cu]é´÷Í[î@¥Ü îoz¼N#™ÀS‰ã]˜E]ÓÍOVý…ü7%*¥2Y"»ŒÝi5•åmõ'wÃ~AB«±WJ!½†ªÏiÒ› ÆÊÒºƒ€0tŒmo£`Š›í”¾?œ¦šÑF{”¶0à“†^Œ_“-Þ m¤…2;€Ç‡6tʼn6ò_«èÆ*)+BéÞíî^ê mìY,Õw›`íŽpgMuT#g ³6Ýnì…‹4ÊA7ØŒïŠàäïªÂ¦´m.¾D€k)‚ÑÆêÍÏy²Êï­eß³ô>j岯2`ù¹ïžsw?}N›ÿÅŠ*¾²0/M'…ôn*ÖØ>‚‹\´X´qé“ÿ;¿°í[’< .£XÇ‚É^ëAä‡H'~Ýé/œÇØ$ÂC~lvØz-fKë´H5¦›-MÖZ»¡«î¥Ù/€[„ûC]€–º™ƒ´{/î‡/i7Oµ ¼ÝZ9ŸÒx=öâ$÷%ÁÚŽágž []EFDú —\¯ØDŠ“æ’ØÔðÛÞñžs#glsð¼`tSÌJÏ„rJQÂy|Zg6AÙš"ÒšêhO§q®SÇû]e‚ï£ZvA€vPÂýîxE4ÚÝ9ƒ|oe‡fjåŒøÐц­Ç96?4L•Û1;«´û-® ÃSázœê’Š´T“Ædª„5°²µ²“ž³äçwgÃÕGJ U:9Ì€»œ©ˆŸ|Wq-gXÑelÓÂ2zwæ¡ØˆÄëÈ'S¬¡ÆÙBÁ)J˜hké±Xƒ97Ùê¹Jú険™`?xö0í6°ò£[r'üˆ¾>7ý«ù9¦`R|¶Èr´/™s0§ ·ê.ùÏUôo'#Ü#‚«=}ÍœzÜoè+‡¯Ð,'ÔOëUÅê?SECÌ:­¾¤›¨wÀ_ÓèÞš ÿèqá4p.Œ¥ÙÛ€ù<½ÈO'w^|z®ë"\âi†Ÿá¡OHô—.EDƶücíÏa [G¡·ìñ—ç?ƒ÷ÿñæÒÆ´ŒòÜ|q‘R_T)l ˜ùzjâ÷~t3egÔ¡°!ì»ì{‚j|ðò¾ƒ‚îø,þ¡ÈÝ’€[(6ˆÿüÂõd}¯’žStÕÝœ < ¬øCË¢DÊrrz°»·  §­»µõýŽþV3¤»ôE!îLÔiªjõµ†fù ZƬୖ*3¼L㯀O…§ÛQšÿþò ãÞÞËÞ/ÄE›@ endstream endobj 2639 0 obj << /Length 3893 /Filter /FlateDecode >> stream xÚÍËrÜ6òÚËŽª< ¹{R²v¢DŽ[©Ú*Çj†’X™!'$ÇŠöë·_àk¨GV>ìE6  Ño@Áâf,¾Èï·—¯¾y™E¢RçÂÅåõBÛDÅ]¸$RÚêÅåfñiùsÕæ'+ãÂe{›µÜªJþÍOt´ü³h_ãg ‚ÙTÛC[x¬]ÖÖÅŸ'Ÿ/üæ­‹FóEÊÄ°šè“`¸†Q‘óýÿæ~›."•Æ±ÃþX9m«@¥©c,=C%T:Ò‹ÒóH™™%‘úÌH¡¢U[•)ã\2Έ׉2A´X °ŠÑàx…3D‹ÏÉ|øþÕâ±ómqs¨…ÑV†ð‰ BÑÈ)´Uo¸]”þ eä‡>rcŸÕÙ.oóú$ –r|®ë|ßv£ažÅJƒ`D±†p ’u¯³hZm—Õ5ÿnŠNüêÄËC‹+°Ú dQînóZF­€Ší–Q¯¤Ço€°žâð×e+uÊèÄ ÏÙÇ÷çDàÍå«?^iºÐ Z™dáâPYØ×z÷êÓç`±Î®M“Å¡îàL] íâã«_Du†ÓÙ§CJ:6<é¶ZÎgªnÐ C¿Â¬ÜüÅF*z2|~i¬¢Ô|…ý…A Lb^°¿ß‚(hòü/î1V¦£pöÝÏ—çHÆhø«›:ÒÊû|Ö‚":£BëÆ¢ýñpÕäk±dQ°D³8Ñ8Ü—V¢àÑBk K5‹•‰UàÄŽÂØè¨Áò[`ÜïLñ¼:ÑÁònõ!+‚üöüí×yÖê,óC&òʸéäˆ[6bZfFNPÃwÆž“ÓÕkmÀž¹Áéé+ª‚! m°U-[½$#ëåúP×yÙòÇ4*yÝ07æâx‰QqÒMûî×wgæ5©²&õXÅn¿Íw0QÄ[?¿g44Ñ&ê l¿¯«l}Ë_›¼YƒÍ"{ ŸÏ2Æ€7’ø¶J'S Qb<£ZGc ;C{hÑu¢ÕÆVs¢—LŒ±Òå]ο©4–ÖuËå®[Þœªø7/³«mÎè=y-n\Jš%Ûí=ƒ ˜ZÖ“ñÏî°m‹ö¶Î³ b"‹ŽâKQW%²œöŒ7åôQöY—ZR¥çÔ DÄD„ã•!=Lê}€O÷ûm±Î<épyQW7àå¸÷¬gwj—­e.øôâLtIUܱ®Ê¶®¶öÜÊ\‡F†¢Ïó“Ï°‚Ømb·” Á£ÿñ+‹£ÿ…U@ŒXe`˜iÖsÄD¡#ÞÞótëj·…tKOMÔ% +kÚbÝøŽLP³ZP@eP¿›|3¦RÚýák‰ÛÚH=amS0Æyc±Mzc ²Äæö *BQÞ0]Þ-4øhÐÀŽ5A´oø-JàÉvËvl†‚±Ý;ÃQÆpf4ð”ä†xÐló¥hˆkðA†¨a„Qló¨÷t[‘.¬’Ѫz“×¼+èßgëß³›¼á/äø»¼-äó“pÃâ<6˜ëöHŠ>{ò<öãwïQß/¿ûáiZG–ï³wS‘ í½š?˜:ß×yòšõbAú†‡¬m‰ð!“©üà­¦úÓêŽ-`|Á¶ᲓG6º£Í±]×V…£þ& ±ž 1ë¼iŸ+« žR$rºÌø§¹Í(ÞÅÎ]¾«ê{†c„L¿àur…˜\aîÉ>uk` NÛ¤Á¢×âª(q0œúÄü#èÛóÓÜ’å‡zù~Ÿ—ï.º)jÔbôGìðÑŸ­®2^! ¤NVI,ß"*±(A@Ôïþ•!×UÝÖY9'I°Þ}±…ìå8”°˜¬téå꺂eîö3j ±{jØÜV‡-.V£«94ÜB'ƒ¿Ù†Y¡I‡'M!2]Tþþâòí\øÖÛL¢Óiäë” Óó§èå™@¹¸‹ ße¿ç×À-U”ër.TQÔ!ÃÑÄi:8âGÎ{G'ºe!²ç'.zþ±@¡ûcùãácÝ%ÓSA5½CAg¡f¦pVoy”™$TÎèE'ÊÙdF&‰•e:aW3ùõÝL2X•&ÉËg´£CMyùÇ7§ÿš‹•-xÉ9.J5àg“·c÷W£-v¹„±&ˆUÏ„±:ÕR ÀÖ}uÀ†aK„Œ&6QŠØ áÅÔ#M=Ž ¡ÃÛlÕm€•j‘ㄬÄ(‘oÁo¶Uˆ+¶ê!óGYê’4”è@ƒT\ªR“8 W÷ŒËšA *ºÀo7üÝO猴-®ê¬¾÷›vÜâ”Û¦b°£­ }vöSC‚Õ~™ŒdÄe BòZö/tªG"‚¤À‚0 ¨ÍKê Î2¥H[17s…/àvŸVŠLÙò¦ÐŒâ’rŒ±¹2„-ˆÅ|ªƒŸ×¥1ovUQÌ­‰¤!ˆ%ˆ(•jò? wÅ@ªG)$Ë Dq_Y+1ÿÜ°½fö¡ ` EÏI¤¦™twâì°V2 «qÛm¾-šw °˜ÇòÐ;ÜnèÏ6²5ÅŠ7¼@Ħ­bÏ‘ê¹n 1¯a.T“J]À…ELÄʪe@^V‡›[nVŽ^.âór»L.uÄVÆ$7eéÊ:+[†B^#Rá§p¹ªwY¹ƒ´ cË)túÆ¡z=Ú‹¤U AÓŒ“LU?î.´Ó*ì|X¿øš¢Á9¹”)¡ØaèÇ_cÊÄBj4žña‚‚&GÆ)×eá—ü6H²°AÉ‚£(»+ðú¤r0u¢Ä5üA*Û‹ ÑÌÅ2æ'¥ªW`þ¤ˆR‚×4QQêŽÍw®nÊYâ;B¶¼6Š–›Š™>ôàfæâ&;Œ qøqŠ‹ÁŠZ¥:yI &Ê:¦ëô™0²\›~9]¬b“Žç|T*ÛEcè‘‹¢sÀFJ­äø c GÞæ‚TUŒZ‹xïÇz±€;¬=ñaE`_›†|·\:X°ÂñA7û<߬6ì ʦ+ Ì¥cgh Ÿ`&½šD³õ¦NY ~°é„1‚(~`]¹Ñ§¥£E…í/¸¨ “7— ”3xàõ¡ˆ‘·Ø#ÁQƒ‡BŠÖªM5-ÙJü"g•‡ä†_/ ¬Á0ƒc)A¼2Ã0#á"WÅͼ@ÛÏXÅÍ”œ-†´ö‰(Ã&¯Ú…u`gÃݲ$)è R‚”#4E˜tI†ÔQ=üãÝð˜Q•¸hùZ‚Ý8VE€,hè»ôQ’Œ=bÒ Ó“$°Üˆq®©:ÌÚç”N§¸ŠiWB–›¨ yIìfV‘CJÙ'OÅnQ:Hq#§ ï„….±ÉÖ€û9F$Éœ~ ¶ 6‡+ÄÝeÛ>Ó˜ò~àþ_sjr—ûzO/ǃ2j1§ñÅ%:íhp4ø1Lˆ*K ´|¬EÐ.eÊð(YÑ‹-Ö°´>—' ±Â`áæ°ÛeuñZ;XNb®åq“Ö¸å­Ì€ö‚{|]0ÀÚ=WtƒaŸÇqHP¡ÿµP/…B—ýçz¿´‡F—²ó 9µ‡¬Ðlµ!U¦ÏìŸ*685r'TÔ«||ßüc\n[9ÈgÀK­tH—Šì퉦àQä¸näOU¶ ‘äCìÜ´œÐIÏŒ^‚¿·áS¥ˆœ~¢¶~?YÛ¥ÔÒ?fÈ„*î—3,o=t+ 2¨(´ÏãâÙÏ—oÎçc˜vzöl&‚£Nôÿ-ÿx±æ?“‹×œÍS=l 1MO;¿-‰@úÚCzT<àŒxYåÉ!=Ix4x`õPÏ¥Í8aò‰ZÜ™AK&#k¹›!Ã.% u‘kþ=²–s4)þòI¢1âfù*× O·Ïž±uä¶',ˆä#iBððî)y|–=Un1X¯uÉ€Ë#÷’àÝÄtHHÉDñ#.{!‚FÂÚÕt1î¬|”×ë9E‹I‚59*èa_ï·|G%¡ôœ4ä鱊;$¤}6ñÍܱ¨°¯à>^$Ž"Ý?SlvÃkôA_øcY°®óf_•RJK‚Ñôy„±2±Üê fÅÿ:þ ažM)›•êp7´n)®nUÓ“ì¤JÓŸùˆ aµŒ„9±L*/ªÒÔ½Iˆ× dÂ/øwæîÁÄ ‡ï¶‡\íîå:Ç °Àœ¯™›]䯂3¹7Îø®Xò "ë.œ¯¹C.œÝòüôâ$5ËS¼aü÷Y PñÝ_ò<+R¡#Bøȇvøý›_.ìoKâéӡɳª€©|…u¥Àùx²°óÓ_|ôÒ-ÌWÀÿÉšº-ÊßY¦­ýÁz6dŠ„ã)ó 6ˆ‰ùºË/0ìÄãƒAÆÇׂ+—·ñr“ƒšlòr]ä2œolýlñ‹&¬ßYÐm)BûêQ¿oÚ|G†(êüÀýÝåÄÆm仿$0i"O<)Ý„J÷ˆÂŸ¨V”¤É€!i:ª.iÿÌ(å’?V`ù‹ýt:*ò31ÉÿdxqÍhEû÷“K „ÃU„4í©W3ûÊ,`Xs¼y« „uVr£A El€é#6k8±æ!ó•êî¾f=e¥^8…ÊöÏv;+À¹•å{œ¸[ÿð•×è-X¬žwéH{?`$'›<YY§•ƒ,÷ø½ˆñÏóüûƒÓ‹³g<ú ž¥]g%&¶ š\o9t{`ýÁÚTæ<цr›œïŒG%ËM]í÷¬êî_ïÎ<žŽ,„Ú]Ôò·9®©°G8ðë+EZšÕ?y²ÇÎÉ/– ¬nâCn«ªyðuÇÀ=¼žàôy`÷4£Û¨äo“ü˜2ŸœøhksX÷—ÃÑäü@XL2ÿNr&Ĉá•'aÍdÉ“³>z¯2óìHN}˜4 RŽd”rD*ISZxj%Ü»¸Íº¢Ü$VMµícUª­dk´á>3»ºŸ,ê¶jäÊws¨ŸJee¶½oŠÆmÁ{è†ç‡«mŽóª^3ñ¿’/U‰ZŽÝ€þ/EDc endstream endobj 2570 0 obj << /Type /ObjStm /N 100 /First 1015 /Length 3264 /Filter /FlateDecode >> stream xÚ½[ksEý®_ÑßHŠ¢§ß*EUbçU8ŽË |òkQ$¯$³Y~ýžÓ£ö£°Ç®ÍX„Ä=3=·ÏܾïÛ6Þz¡„ñ6mË âŸÄA6e²ðFcà”å‘3"fϹ¼åœÐ*XŽ¼Ð:ûF$iïE¡//$¡}6e¡£!}¯„NžËz-tΤâ1ERö¸4žT¼Ææ2¤¬Ã|"Á‘@RDGˆÙqŠÏªÄwƒÖ®´°–D}0ºòÔá^0¤ðÑä­Å­˜ÃsÁ|°Vø|›W ›m¡§9â+À:£,G^¸¨Ê½ \"£HÜeSF ÜTDv3 _œB¢Ã§øhGFøˆ.b^Î\7:t÷Ô Ð$bÁ©2/b{y“!zY„¤È©„Í븒´ˆ*=þ‰Fs’Ñz¾›¼ˆ®|%Xƒ.âEŒŽkàALeÿ I•ýËJ$øY‹d2Qa ˜ÆÕ°‰LÇȉy‘’+ó‚H¹|66ƒÇ%‘MùÊœ!^‚R"{…5‚Ò"Ê–c OÁöœÉ¿ (‡Ê–›D¥c™ ITV•aäNZî„E+òC£êöLCUrKiˆ£Ê‘{ª!üC‹¡qDexׂÛò®#/5éjG`š«iß½–9¤”Ë ‘’4ð¥=W^£‰ià5&•×@Á8]0ൢ7†ß¯M §U›d9׎ɱ,8V¾NR ËkXÂ:•FOžŒšwÿ=kEót±XnFÍøü÷M¹>˜-þ5Ï–«“võAÁ4¨ßšWÍëfïƒ.£æ¸nļÌ`-DAg'ŒTXj›0í©xòD4cѼ\¾[Šf_<:<Ú{{ðX|÷Ýÿ@K*ˆ·JÒ¬Ä,©%°Rã==p}“¥ÁVz¤¬„y$6úÆõß<;x»÷ý€¢–›Z!À®È™ëÃp84†-\Ö…ÿ܇!õ ’‘Í^ï¾;øõ‘ο>ˆÍF&l€‹N¸3›“¤‡1“Öß,’¯þX.7X®•i8 ÆzIéV)eé $* #x#ñìïv<==_ ¸1B?ጓž~U&˜gqåò®@•¥ƒ'ê@ÀA.w‰eU«ç~€:AaoÙ½W? h+{HÃ¥s„H f$ ÇâT$”›!üüf8促g¨¨$Œeú<ˆ–™I„%ˆ¤°ˆ4µ•QWÆut;4\¸D{Ò2Ö^Þ&/Ã-¦sرРw±>âÄb½úÖ>8è$¢?ëŒDŒà¬8ôÕz#£ÍÏí•TL5¬Æ‚ˆbŒ&܇E`Óå2Á4A1CHÅ0™üÀþ œ…»Y.×翯ñòl¹x9©­Af.KÅüš Pð­Úö ‡ Ãjk„ÝBé¢ÔÎ=ÊP’'Ü×qw@LHˆp"SA˜¨ l·cà _krÞ‡·$’*IÆÿ smBâ¶CõAZƒØ=1¿Ò0Ì`Ñ“Ù±ÀÚcj˜ÑÓÕ­ S1(SȽbbÍ b£Ž„Ž¼ p¯чb‚píoÖ›ãçûǯƲBk86s‰~öa8„Æ~$&ÀzÊòÔF•¬’úw+Hd¥eò‡¸*4Å2O‡¥w÷IÔöAÄ#¿QâX4ïþÙ¾´.°x!çóùo·Nä"œ2€|õ~³‹Üè;i[DÕÇŽ‡»&khHæW© Wg‹fo9_®Æg“i+l÷ÎÑd³iW aºËçŸ7/ǛɦºÜ5/–‹MáÛ 8—·ó^2±zÀ;«íE`§^x&l¶>ñ"À÷o/²` ¤»`éÏWÒˆ_YTÚNCâí»iøˆæhµœŽ[l6ï¿Í»öóFüv]~Ž&Û>u±i›5k&'Åd½<_MÛuW&)÷Þ´'³É³ågQ$‹õ—X’É£É oóe×M,R¹ÆÂ¥ F<¥žÖ ¢®SuN¼˜ãë ÔA¬ƒTy;Hª*åT ¦J0U‚©L•`ªS%˜+Á\ æ 5WʹRΕr®”s¥œ+弥̒Ùv ëÀÔ­W¾BÄ:HuP)ëJYWʺRÖ勇\œœOÛ•xôòè@¼<]®7ëéjv¶p—ú1ÄaÕNhsö)Ûö¿5J[å¼™Ž:~­ÌWJ}…yo–'wMy7ÛÌ1¡dãåü¼˜²?fë*K À¥9iÿ?¶«5 +€ªMOçí_í\øéãë2{¡w£æíÑ¡ëÓg“u[4°ùép|8~ÿõ»Ù§výÍñòÓdÑéæ~Û}(V-Eß"¬Q>ƤÙj½Ù;¬ ‰£æ`²½È~Ôü4;ÙœR¦=6Ñ—üçŸNÊ»?ÊÍ¿Ô”b|aÄ[Û=-÷xçr6+ç—÷ºŸõÝB]Ñ€?_L—'³ÅG|ælñt±žÕWÜ¿I_çÚõïïøq8ùÔÞέgEÕ±î7°ª‚5¬¼˜O>®üfHPõõ”º'ØÑÉÙ«vöñt{ÉÕøŒ¯š×›É|6}ºøyP€ºi?ýÈþÄh¶^~a0¿„ÀtZ®Gͳf¯y^<ØAsØ7ãæ‡æ}óKÓþû|2o–‹¶ÙügÙœ/àîÖÓåª}ÜA1›·¥ìßY®a\¦÷ÈFXLD¶ÌÒ?|§ƒ!öÖÁAÅ25†ðÚJVã•X}ƒË”vÇ8$-£§cf¹ÙbbßD#v°»áƒ‰_42ôÈ”™‡’¹dʬåÅs‰KšJjˆ‹yôm6—¢AoÒ¡¯׫|Ä/¹5(ƒ¬+³zã(C?¢‘ì»Ø„ëV³˜oÐãV¶ÄÙ÷€1lÚã° ¬]ù,³f4ˆð8³©¤Š»I{X(’á’ÌìÊf¤;¡@RjGY-–Ê\`° G)éq%ëÝðõ=HªBz~±'é ºÙlÐÑÔüK?@É– éÇeÉÕP‰wXÃI,±B4XcDœiaL<[õÈÑoN­¯Zi‡,T`;XYƒQg×!w+'€ "ÛËŒA-˜ƒEg—½âˆ]öÕ{p ëZ£¿`+Ÿ}Ž/”ds‰…4Db¢,`µ¬½½FqMa¡)CÚW¢®ŠˆU­rX¥у‡MV†r–¤ÂrZd3¿Èáßǧë!#/ØÐd.!8ÚÒ; + í¯0¡Jh°`|6Y­ÛáÛ¨ XJS»rF pnëP¬†ÇÁºnHîBaîÆq´²‚Œî’Ö\§^7è¬Ò GP„œ"-q&–È´ôm,®o‰}†•S«J^`4„^50eÉÕ ?»îö¥¥çq¦€âá6'o9ý0,Ê1êçåÁgz Ÿ(!q¦eòšsD¦ÄF„íbž[ýêб0L„ãéÇ-cÆ^ï…s2ò¼XEÀ³0w xˆ“H ʱ5Ït-Uá™AÝŠÎí0ôD”“Ø”qJFËPa›20¢1í*=ábú„SNòÌeˆØzrV’/`À¦—ƒŠ=0†¶˜ ž|Ì2Æ.?Ó'›xgn4d>Ue.¢uÀÒÌWC)öhƒëèwÙW†gõîˆCþÌh¸ÈðÖ3F™ËYgäÝu˜nV“vçÊ \zâQÕŠ"k={a íÊ¢dó©i¦'³I¦r†ØÑŽß)ŸCVXuåÑè‰óü™z‘<ŒxbO;WõÔCŽ '›¢<'¯6Œ)Lò"`=­Í³uL°dðz ½çlÍøE Û™½Ú½Þ™½Ö½Ú™½ÞŒ½ì²ö5c¯t€ÙŒ}ÿö÷q׈áõ§rÐß|Y§Öævjmü¿;µ4þÛ~aí;êÚwÔµï¨kßÑÖv£­íF[Û¶62m%h+A®w"¿´4EHˆ#rw¨ÃịWFïªxesl<ͲCªa@¸‚ʤ[êÍã·óåtÈs“,2§ NG鶬¹ ÄÐœõL¹. $–²t?¶VQ?ÄaÖÀR–ÇJVòªKwŸÁòƒ†2,8óWŒ J’¿ˆTë%„ñæg~Òð=Ä ÕÙJê& ¸µî~…?dq¯ü† ?{dMùÝ©àR<Ùèï‹È<¢A^ Ü!¬54*Üщ¢×ºrî´kuzË ?M åwjn+¹Mg›Vþ9ùóüÛœ&BIÈ`•¹„‚D> ¹ÊY;Ÿ·ßª‹ókÿù-èg endstream endobj 2664 0 obj << /Length 3310 /Filter /FlateDecode >> stream xÚíZݓ㶠¿¿ÂÓ'íÌšI}PiÓ™$M3×^s¹ÍÎôá’Ùæ®Õ“%G’sÙþõP_ÖÞ®÷2Ó—¾X’ ?€W÷«põÝ«ð‘ç×·¯þø·Ø¬ŒÈ’$ZÝÞ­d” ™ÊUbb!µ\ÝîVLÔm[lJ{µVqüš—'Û^ý|ûwè¯FýãT„‰„Á]Ç/£ŸmµŽ•Hôj-#‘E±„4àŒóý:Ž“àÇ.¯vy³#–¼Êˇ¶¸’Aë Ürw%ákÛÕMñŸ¼+êŠÈ?…qøõ›æ±ywjXü‚G¨êŽ‡ÚvÅ•Šƒ_ñ'ïìúJ1•)Á•È`¹Npù Á?1k”O6[N~êê¬cKŸÛ}]lyˆúŽžýõqX¯_ÕÑ6wusðãnèÙíy¶¾ë>:•5ö‘5òÆ«§Ö¨C=¬Q‡‘“Ÿ kDÞÝ©)ª{bÙÔÝžÞœdn¨ótƒU;ziëò4û¼µí5|È4ø¸/¶{%/˧ýȲ€2p`ÛBf¬0„f´Âƒ=Ô +èþ D-ªvª¶¥A™':$eö‚7§^7yõa¦Üu/ÀHÅúI3 Ó‘…†¶ˆKfÍ^ÅÈBâqé„@»Ó ql®Tœ:¢Ó¹*Ž4dׯdâ?–¬íŠ²|TåcóL5).UÁÝ©,Ykkšà«–ÚsjÞÖUk9Ùjë&N3–mÜ“:L·Ú§¶£¦¥çd±ÇŽÚé๪éyCvk§â¬$Ë‚mŽâg††B½é Õî`Q¯+"{¶·o¿áŽuÕÙ+¿u΂É]±„\¨ˆW šƒÿ¸ùµ;ëDzïm_óýíE)t_‹š¹éȈHf¾ã—Òñ;»}ÁKë] ¼Û*ß”¨n#ÝÃË©µ w¬¶À&B‘Èxª´M«¥p17JŠ0òbäd43Qá°„F{žéæf §…§ vEû(Þ X0Ù3Xn0'2|d/À ]¦v Q¤ÏÔ®ãg©ÝôjW$A[Tοƒ|gËs§Æn…õ¬Á‹˜hªgȲ$­µD·MCõ7 E¤ûð½^›0ü”8*&ëÙ¯I†ö´ù·ÝvôAáÂâ>¯î-Ñ0Óª¸yϲÞp×È)!òI F]ËgRfFèLM7f0ãºá܃]´-‹CQNI`—­’âù”§AhØöaèòV „ÒóS¯.:õ_Òü²×ÄËKxÉ>C¾ÆÃ>Gú“Û,á°÷Ûü<¡ÁTS}Ôyóa)xi)t:v 2ŠLðúîBeÇ"ŽÔKñÓ¶^÷~¨B¸Í O©Ó(‡FºÏ¡ñ>/rºøŽåªé9O²†®dë!œtíA˜aÖ'Äñ(ã…3Âo¼œèÆœ‰`û(Ñ2%ºÔòÓC1ù|u+Š;ëD—× hu³C„¨Ù‡àó\eȈ;C!FMãY~@{¡2V xž‘n®/vÚY½`¹pÚTÒ›%e(¦v‘2ø ,HræO´À2FEŸp¾ÝSS‡og¹Çž_¸ŒÕrO𛞥­¬# 'DÅÉ,on,`µ-Âç5X.ºAíÓt Ü7ùqO4 ´¯ÁÃ߈èü&Ð*kwÎij2y¤á<„îǽ' ˆk:³aLÜÃ$¸õÂô)ÃR]_è32›—¤\àžcÝw¤t]'ì2ðÍ%î:?ÝqSMO`EL¤ÍÄëÖµ©±ùWü±Ô6I‘°Ï€¤yûa’Ÿd‡ŽÀ¢Áxò¸çÎ6Бœ™FQ¹#‰Ø½>U}Ð,ð2‘ ¾ ª¢´ER¥kÌîM”Ï»Óàm5ã©95„WÀ ;4‚tõâHÕÈÏ÷M!KÞMWpM:C06µ¾ª|¸0«ÉDšÏÏùAPmèj“ µJW!…,Vº*Ššt1V2‘Qåk‘“70•Yð/gðÈ5ë½a¥Â¨äÌ/3Œ)º9âdX{ç1—¯(à9º0_”0qú²³=@/??×åk®[¨>±êKÀ0|ÔSÑ7¶l*^ê]Ss1e©J,Åc8%MfÁMe"ÉÔ#yúyz%=Ês öCAÙ5õñH.Èàš¹¾à‚õ|¤zPȦJ„VÙ8EÝÕ'ºÔÁ¡aO ÎEaÞƺ4 z÷ÁŒ¢òeS—e/W/î¸z@MÎw,YðuYo¹Š%añsoö†CÍ …,+MªÏB¶†3‰…Dd:å{,Wî>׊ãf5%X„ÚG/QöuÛ]ž¯ø‚;–ã8aºÀYÂAÃòù>ȧ&jzTô³2e¨úIƒþ]oÁž'Ç)ÎD¦ÔüÂðÜð#H“ÌdÈÙHJÄý¹Ï…‰²Gn-é.]-ï¡;&Qû]˜§˜¯(™hO‹4Š¦7‰Y8éàÿGKîyäpýèð. óÕÇ„‰£{^þ‰&í€îïS£Jð|Ç&÷Â…°âÚÈvWð{U†IgϪ «X¾¼2œ>+¥~j-)$çJ¿¼ cI)€6j”À§v‘ÉÓˆèši¼PÚSΔœmç·x¡Ô0Ò5)šô´´:ž»ÏÝYôIèÙ`dÂyÕp£¬­)„NûÂvBØ¿#j·oêÓ=³¢´»æTmùÞ¨ÊÜÛ¨NáÉïnè¹”TÅhÿéIä c¶€_“8¸^J­\"®¥SÁÉåßš»Öá,‘Ã&º4Â7§#xæÄê´·“°¥y¾½õ|äw²I¹Á©úhúîféNÏcÒó;½àÂà®ÒëäØÖåéÀԣǮoìªD)§u˜~ o`FFD›bÈÀàÙÖnJÌ͙›¸+òûºB¤ä±w87"Äma1ÉB&§3F7çnoC‡Ûž%]@ˆ3çš ±é»,YúåÍcs[ê^ÀÒ÷u‰Y˜Ž`µÎ¹±b°®9»Œe䢦3÷GùÃS1‡h$ÁõdišƒŒsA„×~˜µ’ý`ãéŒH"³š°žÏ˜Bì=âŸqué"®gÇ£Òç:‚œõ–®²Ù¹(8ûÅáHÎ/³QäcTï®ÜÍÑtõn_Þ|õÃU¦‚¯®"wÿ ¦÷ì_QPç¥ñåÃh Í,°?;··¯~y…lÈI-"8*Ô®˜¸=¼zÿs¸ÚA#œm¡Á>>:ÖõWY®~|õŽÿ½5¹¹´+SI꘴ñÝ·ï~ÐK¨ÒÝ+\'˪{ƒñÊ÷”f`:`ôÂ=W ã|“ù¿˜q²â>K›ï˜¥¦çÁ¹5|›^…C©¼ñYÖÐß F3å<.§Ð<Í$'‰kêo°hȼ[060ÅO¡LI¡¢Q²F±$Ja gEM e ƒB˹Qµ4jPíPÚÊ7®ö»y´4¬‡|·´àÃéï0ZÑhÿw˜·A R ‡¨NùÞ ¡¨Ž'îAEBÇ%*r»á&½g¥wâ ¹R¼TAJ> stream xÚÕË’Û6ò>_¡ËViª,/‚ä¦rH;å-WœÇµ'ŽDy¸–H…¤ì|ýö‹Oi2–“MÕÎa4@£ÑoH/Þ/ôâû+ýÀ÷Û›«§/¢d‘¨4¿¸Ù.Œ•‰Í"$‘2Î,n6‹w˯½¬š¦¸Ýå×+éåÇlwÌ›ë_nþóíh~+ ,NÿŽýn‹UdUp‹•ñ*ŠemÍ Î0ß­¢(,ß´Y¹Éê £¼}ñæ™ì~m£eV×f™•-Ã>í·vZÕYù!ÇÃ&k\êdëõqÜemQ• ùYGúÕÛk¯—ß@ÓL)Ñ@®UqL®ùrß>{ñ†Mè dê Ô™xDPOp pgdF âI7wEóÀvëªlŠ¦m±ey½­ê}Q¾Gê᪕IS8žV)ȯ½ƒ öÚÁ ûCÕ# ^ÛežÕ»"¯y´(ù[ÕÙe[1h{¬aÁ«óÍq-+ÊÒvY÷·Bµ•/ÐFnàpqH–ßìÚ»êøþŽ§-Q¬…Ø”‰Ýg÷×+ÃwÙµE©0Ñ2GˆÀVy]¬³w‹ý![·O c<ÓƒÐõ±®säN”]¾‡®°Ÿ¦5ümÚb·c4d`>àßï°%Ü-îz†èC—õ ®Z¸ EH+“œhÆkæã ð¤r,õèa[ç 8¢ ™Œj5‘Îî;Ót-»YÞí»|›wíH½Ïh·OT4Ön`¤î4…ôTEA$Yd?ƒ¢•,?áÂOùn8á!«ñ’³}Þk`ïs&(ÖÊF'&H+©hQãÖ]ç'¢Áí—²À™ûòÙ7¯ð\.:1 s»§˜™Vë²] Û$í¦w»š“Mc ñF9 ÆÁ}V8Ç)‡Ønt!rË—¨’v¢;Þš¹e$T -«–uþ뱨ñ¾ŒŒ p{wl.d : cçÉ\Dò®gå:+™’Ûœ iò–`¯ˆ!!ߢ…fÔMÖ‚ÆË« ã‰lÍ–° ³¦ôÁI‡¦ÈßÛL²΂“$[0¶lº³r-ŠÿþÔ (Eãé˜Ø¸•áÕä?‡|Ý«ÎàÉð‘Ceu¦³Fk/ö(Q>$‹•u NG$<ó·Ïøê­·²ŒwË}¾¯ê{n«ª=Ôù!Úë?+³Ý}C.˳àF±E¹úYk»fóƒ·ù:;6²¼ìc§. à1ÝÈ„¦o_ý$vÕ)My¹EÃ~ ªÉ®{±ï°J¹»gȇ’½tÉÝl‹æ†šÃäâ7rà¯|lÈúýë.//ò8{óyæf"e`)½éÅèësVP™Ð#XòyñéÑɑЉq$?´Ì‰BÞ±…ˆN2È|µÎ«$}ÂYRwÇâ[ãÐËG²]’YlÜ . Eg_…T/o(îd¬¼ÌØÛËCÜÔнÀä¶Cc)•ñNþc¿É9Éß4圷FÁrÞ“Œk9¸A0¥UñÐÍàœnƒÁÝ@ôNy8u\‰¹˜1Q¤oÿ8_,›V$á¥2Ø"¡CH]´m./*n1ƒ ±)šÒê¼úxø¬cÔNdÄ2cŽ'¼Ò^Y ÷gw¤òL²øn¨7 Í7€¹ñ'uŠ¦h²ç4q:ÔÆ<á:%@êO…hb8X·%†°F¥&f2¿‘ˆÀ¹ÙÁ!ñƒÝÐÝF~j±œe_á$¤ÁÆÈùÀ<°%‰…Ñi!!Sïã¬x\çæKÛÁ M¶íÑ™á30³ZcÖõôØt²Îœ t3%ƒf< Tw8 `-Ø&—5Þ )ÕcÁÒâÍ„< RnVpYŠ(Í< õÌÊÞ•7ú<ûXà"­MU<ä/øËil§$¶G«(QÆbé&¨`“w˜/«ÄôAE)‰øO$ºfÅ;M„ŒN!ÓéÉ|õö̆po±ïÍÏØù|N5À€oµ&Ð)#„Q)’œøéV¤œ~”ÊÚ4ÁJš¯îõöž¿|Û6,ï*õº? Gã„Å‘²ñø‰ÅcD 3FùtqF`cÈÉ£/¶õCJ`žH” qHüT”­\¬OwI½èlMØYÿ;5áD¹4W,F¤í'JOšalÍ o´åü}B9/+îOí!ÝÙ†Gf0p9™‚ý  àÀ«!ÿj'üšÔß\çFl:ª¿9©¿PuadmUâþ°¡xj4“Qwy½Æzæ{!¹Îñüa‰w}xû|ojœø_ËáµxPPŸ Iœ›k¹xë!”‚^!Æ…£tàv5é ÜMÒ?…e§r= šÎÙµ› ¯âÄLC¼ÎšÎmÝó›«_¯Ðè…Y€KVIX8É¿÷‹õþêÝ/z±1ð9 |Éâaî1Xlš³[¼¹ú§<×L*xÝRVEN*¹Çòjà¼ñXüŒÒI§ñnc5æ cR2ÇÂPÊsœr¬›ø®Gí¼M5ø%´ó1xúdVŽÆjûƒåèn*oìX³P"ÈSoVúà ¿œÚëNåý Î‡B?³rx6(jkŠß«ipîoãåõŸ²'V¡|bd†÷*\ø³«æúÿ²^>UÄ Ë# ªƒÁìöŒ/¯–[ Âúé;ÈÕrŸÆwOënV¦ð³(1ŠK«„â(Û7X ÀÛôQ&;HFÓ/drÅÌ÷tú³öLþÔ=Í_{ÎïiÓð?•`HÁwÚYX6ìÿuú3lš\VNøs6=+Äøš4Ø jƒøp~HÀ%)\al8DÕ±=[y—)â©2kr7ÚˆÕ¤òYÚ•ƒRÈꫤä’C¤ôDžhFÁõ1m]GÐAJ«¼˜<ŒÖµBjêÎf©¥ÉÐùü42ÉI2lÇ+ 妠ÜþlÝò†CÁ0®L@?âààR‚ óð0Zò7,o+.W†.®Œúv /þŒÃùÕc³ l­‹\¦ådF˜Ç9óÄB\Õ=ÎÔ?~Üå\*v ÿ¨•J­a—§u Qú¥=éc=ñä¡'Ì£)ïÒ)€‘# =ó¸túÌpzæ¡ú‘ʆÛ\2Äñ[YëØŒVêëŸ'ÙÓ$M#YÞ¦aÈ»Ó.¯†FSíº*âP>ÅDD<çlEK¦ST†3ýŽTôÁ±–Ëïi¶›ÖÄÓˆTð²ÛuÆ@>âOŒÛ…ºÓÖ¨.G?áU¢g¯Á›ü—ºY³ìJRùî¾gí…u+Øi(ì\òúÃRó¤w$‹^èàká.£(â»D@§çT!ÝÊ¡FÖáýóŽ3C‰s$(ïÞw½.³8zÇhg#d’Œq½YÄgTo’u•Gz\ïÊÏò˜COñeŽ‰TÛ'ºûÙz“WVlêœÆÚH.Eegü!ž§«Éßõ* óËßeIÜÁ.R:Ÿˆq<ŠýÕ#y«B<+Ú2r5wšó±ûš t¿f¨yl×™)8è‡ý .ü]]=W ’$ˆºë _Aw»~sWãÏɈ&¥Ÿ¯t8çIÞÌx*ž~rÐíĹŸ¨Íà˜, Š¯’¤ o¦®üùÍÕóg endstream endobj 2714 0 obj << /Length 1566 /Filter /FlateDecode >> stream xÚ½XÝoÛ6Ï_á—6Vq$Eê£À^:$Á†¡ºì©ÝƒbS±P[ò$¹]û×÷ŽG}PV§Ù y$÷ù»cøânÁ×Ü}_ß\üx¥ÃEÌÒ˜‹ÅM¾‘b\‹E”h&B mï—oŽû[S¯‚ˆóe•Ó÷õoïh×UÙ6« Q0ù‰h‰ŠWÝü w‚³T§ÄçªÎÖmQ•>§ˆUÝФ(ïa ÜSÎ’süÿh³¶hÚbíöw7µ[CƒrFS¶ua&×;™^á-`-ÎüêEfë&ï®/¦üòæêíõ®¹Lá¯p§ÉÖ‹÷–óÍÖTµ³“éö|yVYY±$—?ðˆ¦x¯àœñ£»Ÿ,y¨ï“ü2Ï ¸ï“9CnäôÂ_ŸØ‚é4õõ Q(YÜ+s®³«ƒ©³!ÊÖÕ±äüö÷Ÿ‘ãS=ûn0нž­ÚΧíÔɽP I, –&TOÿ" u†ŒÆw'ØeˆdÞwí-÷qFJ&Uj$S ÁÂÁƒ”,Šc'vBbý¹,7÷ M3ñxpî^8' K£H!Î(‰€OÊ8×$ÉͶÀ Ópõ±=[×æPÕ­[°H‚ƒ¼Úíª•ÔËÏEyG¤¢Ì«zo½üÊ·=g¡J@kÅR¥è®Rjo“ÅáA¾„ ô³á÷TCÁcÈ«¨còj„"]–•UK-³ÝŽ–Af'z â×ÅÚ4nOmh°†À-6¦6ÚŠv ûCmštfp —oËÝZk·UcÈï,^¼¶ÛÌ™8?î>p.I"¾Ìè³/ÊbÜÓ¤)¾šÎ‹ÚìoÜöÚ­ R2ßþµæwÛÿekÆ-1˜"T#·(ƒè5˜ñP•›†üÔVøM(à÷B …°ÔãnÔYù‘ÈùJ€=H.2¼»mÎð ‡àµ6‡Ñ­ñ¿žÇ)Ÿçìùþ2Tê¡þúÃq¾œ@ªf2ÔcHMcèo°<[–8 Ó¯ìMÃCE鈴ÞáHD‡#‘Оoq¥ó­CYÀ ‡‰ÃÉá"ž8œÛì#u0.J„Ü™­mÿJd‚)æiפ Ó+ƒ–>¡îÙîhè$53¼ì=N(¡%èÚLàÈiRœ4?}-²‘O–½î =üvx¯ÞS#Е3?ž›'¡J×ô³qš!×`–ð¿HG’G>0F–ëºùø1ãa‚Iy“²ƒI9“ÒÁ¤$˜”LNg³ )çASv ) 4g²b¡Ð{ÁûÖµ£]¶€¸Vè¢ünMשfîµÉa©\›ÿ {*†ÐŸ<üTœAaèdœŽßÀ {D6ᨠ±…ÝH£Ç…ˆ]…Î7UihtûÅA®»mÒØ¢}ûç|šFËÃ6kÜŽÏE»¥¡*2Y{‰%ö²Z8…sc…#…™Å®ÔQ{Ê, R ° 3›j°­k*ø‰.C†c|y­¾÷oœR™xHŠPAH$çÐH¦HB½åË?[¿P÷hqÏ!+<Ùö%¾õ°Ï‹ãzP¢p߶ØwÇD2­&Xâ^Ÿ÷ö;Ͷ:îú–§K±]Öv‰h«ë¸b-×à¼ì®ßÝË5®Y“ò4D);µV Ö’ýK•³8 ñ ŠñØ)¡SïÌåÍÅ7œ*ƒ™ endstream endobj 2760 0 obj << /Length 4429 /Filter /FlateDecode >> stream xÚ­[I“㸕¾×¯Ðeb”)6±ŽèCÙÝí(‡ËÝS•ãðDۦĬd”D¦Iª«Ó¿~Þø‰J-™…@Äú–ï-H_éâÏïÒðÿÇ»wßý¤Ô‚±Ä)Åw ÆU•Xh«&Øân³øu E}³biš.?g7\-»aé2¿Yq•.ÿ™ªô/?ÿñ{FUßÑߧ¼i«ú†ÙiSÛ7}ȳvÚüëî/0¾°‰ÓZâlÒÅŠ™$eaw76]VôaIq"Ê÷.ݲ o6Eó5ô%})•É¡KßÕÇÿýøË癹ƒeÛت(Û¼.³mè8k3*kšj]dm¾¡7qèðúK6 æVÒ›¢lÚ¬\ç·33cJ'ι³¦Öµj«ý6 v`m·qJߊö;ÃN?µ¨ñÔãç?¿›LÃØD[û‡s Ÿ­L&ÃtÂdlû½Á¦‹•Ð*±R¡¥@PŽ^â¡7y~b.‹_W\yíï›|Ý•ß6‡”—°Ñ<¨G–ܬ„p˻ǼÉç¶4µ‰°ìŒ-åÜ̶‹§ “Êêœ CšÛP«¢¤W÷E™ÕÏT÷Ï4åÛ¼ SüÐR‹¢¡·OUÓ÷ÛÐ%QŽ[î›Xñ83m/&Ñ©o/1ЀÁ.;t¯˜½àÐ{ rü}þPÅIË3<Àv†b‰ËxïÓ<†vY¸äé1kò¦_K§ñÜÍm(v²5•â?I¨oª-íÓíe‹ç_OÆ‘<»å·âVÞª[MôHGc5Ñ{Úæ¬9kqÒ©\-VqOøª§ ¬EºÀÚuU¶E¹Ïéén@U-Ê/ÔÌsyè9´Éq'~/š¶¸aKj':ñCO{ès¦‘…i4Õ.Fo»^»%&RÙÉ#äüòwÀ$&Å5äi\âR~y®x©X~(i U½ñD)±TÕ ¦²º‘"V&Ò™“B‹ÝéDüêÃ6Lņ U‚[,dß D@˜Y'×m'óò¤nZjµ®áÃ1ðÔ%“c‘%¤]–9j oøà‡¯.?&R°«¸dÅ`•ÂˆåY§7Ôø|TÐÚ²rCí`õ‡aµ@ʵDÖ‹uÃýðû…É1á7¤ðeT§‹•Ñ‰2ìpוðúKž}ÉIÐI'É $rªÜˆœ.:-0!×±ŒnÑ€ÅþVµyXí,.«ëì¹9¬ aéÕšXÝ×ûsú‡:u÷Ïñëœ*ˆâý×u¨*«–jƧáwÞ!@±‡èâB¡Ÿ¸‹PΡÂŒÃ{îÇÿظ(Ÿö-wY[¿Ç>Â{"@(ŒøBZ¶üœÇ^vOU B$´­ó]V Sð’ þ«(ƒi¸Ðt¼BB} ÍРʣÕplVSØœzƒ-S©™„ÓP ‡K ‹K˜è-=·dëýºëÓs4Êl1Ú”kfÌC†Ï0î|ŒO-; 7ßèD?, B›~«‹¶õ&<áŸ&Í6E#X|¦ú§ºÂ>+6^ #ù?O¾ðI)Ø©w§TÔÔ$.í²ðÁši}(eaA›ã4rœ¤Ø„žjÿöw„)°iwq#*§ž~<Öêßð1«‹ì~÷?Šô-àLÞüatþÀi[T_2±iØúÝ~÷äOèÝwïþýU}º``—š„»P)Àd8³õîݯÿJx ëH„³‹o¾é„ªF–Þ.>¿ûŸàVÉ-åSOF«°ô¬þ¯Ž"m¡È:ùðùý “jù÷§ÇqZâÚé ‡¤›h>™Þ>Í-ÌΘNÆyÛ„HùÁœ–@¿°›dÁmóò‹' ͈SàŸ+E…õcVƒ)“×M°¢ n·÷(JAÃÿ„fñÍ3ýwvb 4Íülª²C)Ç´–gëÇ`gÕÕ:IY÷\ta ÁQWÛ _Y  fÍn ­ÏòdÈ},Þ±ÝÜ(\¼¢ ƒ9Xaê Àà ÑÖ–Æy›JZàmSQMo]á.߶7¼Àã›Á‚©¾&åŠ91[QWå.G€Œ¸¸Ù9»üðp©1ÎÑ›;ŸßÏ‘½4,Qÿm›p!Ù‡“F&œÃŸI˜9Cª?@8šz*š ½¥I¤X"^‘Jt¤Dù<¢#¤~H;Ú&BD‚ÆèÐíú1_£ÚÅaôMŽ¤€Ô ÔÎ…¹ð†£IÆt¾§DY'òÒy‘'%K4¨7YJ¿Ý£‘ˆ<éÅlØü6iûÿ2/:» øݸW;3èí¡žRã΢w8h«ºµèOED“òÄðíˆÄ|Í:@Í d×uk±ؖƹñÚÄÔƒ]õ °ZŒ„€`&šëð&¯kÚV¹\Cu$û±t]@1©ÒcŠ©³¢ áç¬É:X""­ìYHG‚ñ­5{¤ƒ=IÍßé\7½9¤3šÞ/Ÿ~üéÃ?æ„­J4;v¼ß6‚5;³€À‚Š1Ø!k^½°±þ^{ô¬DPùbŠ‚ÿ4‰N,üãËëHu¼í0€;2ÀÑáïI§> .|¨%MXá?ïùJ :ÀŠØï ø§QÈÉ7˜ˆ÷¼¯„ VNñ†wr^ˆ7˜²ž5^Ä‚›ÄZÐv)îâXÑ)C=i'§ÄwL ÐTÒ 0‡_¿‡Þ•:,ÄÝ1x|ÉõY¾\3…8‹àâÑ9õ~'®š;+9QØìˆBàú´v!œ†ÅÅH´¡žŒP'8-™~‹‘: õxd:å„Ø·å*ì;'p‚dK¨_¹˜É:™™[Ì)’µbiÒʧTB*Î2³Ö„t@–#ü ØSX€kF½æŽ¥ž °ëIÒ@:æÞ`d¤ÃØxä°ÛcLjéÉPcz8=kùEæhovîg#Ë ÃNü&ûm.o`½bS'›\=v½Ä”Ø%0½wOÕÞ;Î]ŒK8Ûi ,{7¬YFjÂÊ^uà©hôE:GþhÐ ƒ|„vŸm·ÏôºwMùO/6p«v',V§Œï2óv„e'6†ô¤v.;rr{Ãâz=Ì„R„™B™ ÷ìé)/ €8î¦Ü1<™÷ÖÄ(ì js‰íê2S¯0Öü2I=¥,ðÅî¹ØÌ‘^šp;Hi ®3ïivÁ5ùpK5CgÎpT ­·õÏ®¡ÎIÐAß0 ÕÔYùu<®Íz_פ*ï=SÁ ‹„~÷Ø@…©:¢‚kšJ.hó²éØE3âs¿[cÒ™/P—u0q’EW7AÞ, dRlŸÇž¬MÞæë.{È'JøÐ~Voš¤ vYë&‰ÐÞ°eGOÝú¡ŒÎ»¬(Ée ÏýÕù:{Âb€æ&º¡0 NCUõOMè‹@/ŽâCСqð|»Ü…Ò=ž î˜Ñ>2‚ÕqT?Í(˜’ÂÈ?þºSUæ³Ûâ¹åCuL1t­ºÈüwºi—û¸ÐЩÏ6.¦l=OúêC‡A0e% Ÿ‰Õð«ù!ßæ}¬æ‚¸Ì(1o%¢}ör¬ægO2 \,SÖ%@aå0^ƒÏ~k°ù¡¦Ìs/P±2$íªéD0*’ÎÛh€ˆµ¯( ‰Ícº†¯÷Ž^¨|ÚfeIÆ` V·>=ÌW†Œ )œÏ¼ ÏEd& '¨cacíªî¡ 'ª}˜pŽê@êsЈ{Müß&\Šë²5D27m“.ÏI¥›b(³ÌÖÈ´1aÛ "”ý:95Áž4@s¡–™h­Ïò"JfÂkbæ5>s¦Rß ¬ã<"p1SCrÙaêáÞϯ§`Å;ý‹ã -=^àðJ'iï¹÷±Ζ_ËÿƧo:d$ç=×`}LÃ2JIü'^Ø»å’<Í1Ürøø†UÞ”ÿÉÃmèí)_Q¥p@MÖÌêtÐ(À㨾:¼O‡D*½fíˆÔ¿>âH¨ÇÀráŠùÔ±WøU‘55õÄ;/’#ã¼3Ø€WNZLœÁVˆñ¤O‡”„ÒùÎr†gÑ8XÊ k»£ì ÊÄ”‰:ùÀöŸ‡£î_ X8—°‰Â¾Êý‹'õ$„ëOíû#™JÊ·Ý9Ÿ3øw.ï)eÎìºwœEϼ$ç¢ÿ¥¸ˆê|€ bhä¨'L‚l·or$RÂöNä…ã`[ XðŒ Æ1šk£‘ChDŠ0A£ÅœCqy×*Z}ˆ¹Ö]óCÿã$säE'’Àä,ä_8tõº°öÀ©§a`óh< 4Žæo10ò½â£‡.$Úõ©_­~vÊ©#à˜ºF‡[? %Q?ºWÇÞûÚ›i*ºz°°éP<>ùlx*^žWÈ`0–^™µ+(±p&ǸòTáC§tPKÓ*<üÇB—¢;Z}'ÇñádêÛÁzáɱ ©ÉÀA-jÎ^ã‰Ò€åõ„Îϳ4KÔõ¸~…ÊUNs$_†»©€Ì_ w¡—™XáQ4¨€ñùÐ%tÌù…BôöÌ\Ð#íéѬ7o¢«ó–%zŠö ƒ6žÿϽUçgƒW¶äŽ"u!Ùß…ÔYü¦&GEQíï1Õ³iÉ0À|sN©f"®£;ài_7û|">aî[ŸpÙ ®pMu¾²Á23CJ{xéAÀLÉûˆ2d«eµoWÕÃjMyòL_!`ÐÛïºãúð§¿Ýý;á<ºŽˆŽé¯}Ïb³à„ß1Œf'¬¥”eµl³¯Þ›QR¢P½ËÊìKøl” Ü/:ž¨º©ñ¸®ê±{$¸>ŸuíX"®œ$âŽU÷®êƒmVl›sÓtEpý|ès‘½É_¦ ùÈtkŠ«å¶¢f“ šÃÛ˜376Oú…ÞGßgŒ¡»É?çDeØ«ü ÌÊëëiò6eeÜx Öù&Ÿ¸ò²é⯘3,Ú^y!m9#é |»|F` {Uc· àë|VAîêoøÈjè:þðÒ ÀÓ ë`¨Á×—m^áíƒMúùãÇSê– œö …YÒ–ø¿§rÄŒ½ÞÅ£†×ny2Ítø+dW©xiAo£@5]Âj"a¬òâj&W”ý«lý5Þ+CÜ0¹ÇëÉÜD7žQ1ñªºÛŸ&ƸŽ|€UÕì ]ŠÍŸ–ƒøâUR@²+oC­üåAkBÔÁD v»Ï/%\`ëþNÖizÒ©{ = ÔëizêMš èüÒz‹ €b퓳ñèÁr¯z›†»Ù,;Ú'x–°‘8 bu‚w('™\¾ß6•PŠ¾Û¦øO>Û¡Bô´Û—0Õ¶º0¡„KP³½ä¤T‘IjøÁ-|K¬…së§K‚ª²&¦À×Ü1õÃòæâ7UÙÁÅ,(# 6]ô(ÛéíêªwÌÆ…wm®ºBÎ⸼Niј¦»A=þj30¶Ãp’ ðV§£OÀú Ý endstream endobj 2641 0 obj << /Type /ObjStm /N 100 /First 1005 /Length 2954 /Filter /FlateDecode >> stream xÚÅ[]o·}ׯàcò`^‡ä ¶+7Eš¶ÚÚ~ÛB°!òuëþûžÃ]Jþº×Š²ÚĽ»;r>g6-.¸XRp’’SmNjvšÔEü5-;³æ4 TsZðc)êrÉ|5ºšû@]kñƒäDbãOÙ Þá¨8ÑÖ3'Yû ÕI1RMœ6DŒ2iÊç2n„ÒG¸ßÈd+qŽœ\LÖïò†Ž ™íTÀa­ýnubKÂÙJÀbZåˆKÔ>¢³ñÝR°BÑ#«¸É·ðStjdÀ~k}²R]ŠÖ_m.%á\Ê™û‰U¥RGÑ¥Ú·ÎÔ¥–ù†%—CËXö6Gå´V\ÖÒïšËY¸i ŸËD¯¹l•óÖàr‹¼ þJ(¼[£+Ò(•ª®¨r6LŽM7ÌybÉýâÀWTÍáò\«ÃªÈöË$ñn ÎbŸ­‰3,“£è,wQ6uVº([rVµ`ŽiX vH]•`®†ŠD¬d<Š{ÁÕU‹†åÕÔÅÒŠ«E¹SX@µ®Mm{iZHé(rû›`¡×T*GæZÊ].Õ5l GxÃHÙ$¸V qð‡ÐÈ JµÆ¢1¤ R–•À< Œl‘¯U*”E>Û ·êÍbWôÜŸ]QˆC¨º@¾B×¥ë*öC쇘MšfSÌEbšDé ó㳊ÙbJœ›„Éú(íÊúÀ€%Ö>V³ëS@§E…JIy‹ÆŽîÞ=Ú<ýïo[·ùáìì|w´yòîå®_ÿtzöúhsïüâ×íų‡^lþ¼ùqs‚‹£Íãí«{–¢ø+Ëø+°í¤ÑG¡ 7¯VñÜîî]·yâ6ÏŸž»Í÷Í«ÓÝÖÿg{úöåöÕëíÅw¢ßºï¿?Â?òóÀ=ƒ¨˜ò±Ûüíïÿ€ñŠÕrïÏÞ½yóbïƒh^ÄgˆÿzOç|¹æ³R"(ç¯=³§ @i|…i|ø´ÛÜ?s~ñä·“W[§Ó;Nv»íÅ™‹ÓåŸÞï>Ùì¶Ühüp´9>?Ûõ]<†æ¥¦çŽ ­¸ ¬$;pÎ3¹ã§`ã"Óãȸ€¼Úåx¯6qV7.Î_=ÙBÂàïÁ±Û<ݾ߹Ë5OJóèä_Û#,èl·=Û½¥ßK|ŸºñöüÝÅ«íÛÉSößþºýõôäÞù{×Õ©ÀÔ¬EèÇ£“ ¼ãürWÅ·˜¸òÓÉ ²ä–}†Q«™Oزp]ì‹fõãýŸŸþôü›Ÿû¡=ýAFíŒT2‚tÖhp8¹%_T1¢yIF" czŽÕ[Ïàxvd­¾¦/ò1±a‹nG…›CT\$Wp5¸»Q–äCjó“.ñA›OJ¯‹Ë\òQ•ŠTßÝàS| L Ô7˜K¸Îå#‹j‡bzþ5ógí3ŒôwîÔd¡˜G´Fj|ƒ J`)k÷×¾µƒ&«‹šl2+ds—Œ4Eª¹s'é‚ZÔ#ÙI¥À‰! ÉŠ¨‰1\[^Ïgt-@¦‡„Ð mÚ ‘\·´¢ó’æ…ê™’Sí3ø”“]qG;aŒô1v†§ð·Íi›­(ÆØ$pã”PÐÙžNÖ7ª‘'dx‘øR2Œ$/\·¶¢Šä cª„gHÊ4TD|íWWTU5¨*0 £7oB"ß11.×´Ýï‰È3"]é(ËËaË·ª!#mH½º©D˜M`ˆ©!©ìG8oNä¿þ®µå…ƒd¬ÒM²AŽXŸ7ë¥è51Ö‡l£DB@—×{Z¶Ö/‰„®àÊ'°h?Äù#}ŒžÉåsfásôtSXd!~‹xðqcXT )†Ø€!6Ž €càØ86Ž €càØ lƒr”ë \å:(×A¹ÊuP®ƒr”ë Üå6(·A¹ ÊmPnyIx5œK¶ê5_9—\q­+†ŸX‘$òbf„¸OÚaF&>dQ§k&¦ÍHß¹Õ ¾NúLrÊj\ m̼Ȥ‘Ä#ol:-±²¢T˜œ(bòňDV™$žÐ–¯f'‹Â+¦e<'Œ¤ 9…¼>#‘À’§ÕPU'Vaö L¼b¾P3gh(­™ÙG$G¶B—Jø‘;±&£j€Å¶¢íd NîHèkükðõd¬‚±¼¦Ï)µ 2Z»J©+®Óš¢.d–‹fFT’gõä·q–‡pY߃|j@ìMˆ¹½(†kÛ£ ?ÿòü›Øå#‹¯H3/ùhœ?^ƒ ‹. 0àø%)eˆãZ|,š@|~3Ä&M¾ÊÆÃÅÏXSAÚµä)ëzKæáM¨©å #‹**ŸÈÕ#1Á“Áµ^‡‘…=™øÆêè̈2MdMýŒ,j2ø²ò nÂs5ëø5J‚{Ãï{ÕK]Ö­ò„BàÍBŠ“W¢¸³°â RÒâ Ô)´8?±²×}¥šI:mÙÃNhíj*T×ðÏòtƵ­˜£I H h‰°ü]áЋîÂ#¶«53# Ž œ ~šªÊª×w<_a¿ÉµŽm>zðòئªgÌWžžËÝQ§sý?Ûì/m| suRsãÃù¼fÍ>δqôÑÆÑGGm>ú`çÊ<(c`cPÇ`<<ŸKõž•Ï@P.`7Kf¹ˆUµ×&Jîâ»X6ÿ¹d„Àê’8õl‡£J¾FÄ<;m°²¹<ŒÜ @ù9!‘èk©à+!o‘´¬ãbÝŠ×Ï?˜ˆd6f¬º¢ŠÌ©ÂêäAçT,Uä„ûª4·ÊHf±+F k«+ꪲ1Žœ™PãA Ü5‘wØÓsu»»!SYór7"ËšiE‹™a› SȲ?û7«â­h1±†"ðñ`NƒgˆQ$Aøí÷lIËòõ"ÍÈ•K®"òj ŸÔ©qêF•í—Sü‹2q t ÒŒÈGd#²ÆY㈬:(ë ¬ƒ²Ê:(ë ¬ƒ²Ê:(ë œå4(V6­l6ZÙl´²Ùhe³ÑÊf£•ÍF+›V6­l6ZÙl´²ÙÜÊöb©~‚*AB–=Ûm r¸‚46îÁùåÞ’Ö ‘˜$·öBlxKI{û³³V/K6Q¤~ö\’úX]¡ÌœÔ«èíoË ê<`÷D^qþàßaÒ¥('ĈhˆN¼î9Ð\V!*¡Ê„ΕÛÐ6¼Çà‚WX¿jï+ºœÁ¸ÉanU#ÙÆó²Ü˜B7$ù¯TBãQÄ ‰´ðl¬[òkŽ„hÇXŒº†FN%ÃyþYkëÍÏ~ÌƾÐR}ÿdƒ-ñV| r=m(KÖ‚x‚ʨ¦æL—SÍ<ïÿ"CONþ½}pzq™²ú*ü˜É)+ˆÒd&Žª²,´w›)&g1*‰GìeâÑÅöŸ§ï—¬¯³gˆ ˆ Žº&äâ?ëìuOÑmðÁ®¶À<¹˜p\‰ÍT,I!ou=>º\ø•Ï/¦¤ñŒŸÙs\Å_±âd½»ŒŸÖ°wW§¾LÈj% 9òÆ™‡˜ÔúÇh‡yX\JðY°üÅN?¸­Ö]tvÏùõ'{ñ?ä?‚w endstream endobj 2807 0 obj << /Length 4316 /Filter /FlateDecode >> stream xÚÝÛrã¶õ}¿BòÌŠ!.$NÛ™ÍvÓn'›M×îe&í-Ó6'åT6î×÷œ’ ¹²E)íL<A8÷ pàxq·ˆ|~¿¾zõÕ7I²0‘MS½¸º]™D2Q‹Ô$‘Pbqu³øaùvWµõ…0ËÝæb%“xù×ù¶h‹ºùÍÅ¿®þÜÍ“ÉÁdFEY/Ü$7ûº¬îà{‘,Ûû‚uÑ´»:oË]E»[œæQÃy²ÈXã'úð×ß_ò¨ájÒDFfÝry›¿†9¥ìWûùB&Ë|³/šáb} øK5¢á>9|†p¤i§Bïß~wõí!ôC€òêæ¸Õ„ŽL–úÏŸ]LEZ÷‹ÕŒrS´Ô¸Î×?â÷‹•"Ê2¹X‰8²‰¥Ú Ë#@"²Â°ü(šôM]çü=ˆôn·Î>%çà ßý8R`~}P²°ª‰ð¢õÆ-TG6R~¹ëÝ…sDH¥×4„— h=˜}Á¦| ¹ð €|µ“!!md”™x'†£âZ$ÚÀÆj×RÏÈì+Ï2´¾ÀUy¨p6ß3x4N9þ– »-òv_#¶:F,Zö»{^n·åYÐ9('PÅ–z¶åÝ=Cu=)+uñ8"ˆÖK’ylìk˜…¼ Ó µö© `Ã’$=Ö†¹¹¿A2ùU |ø%÷j¦½/…Wc±Ý4»uÉl$ \7¸¬ö-5A¥ëò?¿Gú“Uiþ€&Ä ôÏÖ,¯Hÿ,s[eC¿íýž[À¾°¯åõ†;7m È«IVËrî+d¶ò» °Œe…¨šlYÞvºPÀ2ÌиÛõSìè×y,X¥áe€³åÐNLpú¶ÞáºÒ“I&%×åTE²¥Æ.'£Ø3ŽbàÝ5öìù½ÿV{iÃÎkž嫬é;Škê ¤é‘çyœòˆ‰Ž2›¾ Tµ`ãƒ&Do;nK ¦cÒ¥¬Ö›ýMñ›C1}é{¯$fñ:è/“,JzÉÐ ,D×@Ã;Çà.ê†/ÐÐ× 4t£›jŠâ™ˆiñƒ|¹¿nŠ5§ 0$)‘ ðØgIo3a ‚x*ÒGAÊñÈ^æè›GŒJÈ/DŒ22âY~[à]GÆYb¦Ó#EÕ™ªße [ÚDèa×°¶ã“g%"¸ÞUkqŠrðU'Y/NYÐLvˆ¾ÿôÝË}}ÜRI(òö»‡Î§¬óæ ®D*; 6žlï®^ýô e+^ˆ…Î,¤é"A[¬·¯~øW¼¸W`,#0ö‹Ïnàv!£¡Ø,._ý…üáJÚ€æ$4OJëAXñ«± à(±šUË„ü 0™ÎÌ"ÎhqŽ7/Rš)ÕòÅXΕY«C 0“h.Ï€˜KnÅÑxÍæ^€Ø»o¯¾¿úth-`µÌæ¯e¬¬õ·7ÿ¥µ&¦€j öéS`º­U!Ë»—³ cM›ºãݪ…$M–˜[Æ{Y‹‘ζ ‘“µ‰O¼°wß´ÔÇÁôJ¤ra:½>èsnÒ¤]¤GžË‹ —Ö…ŽÃ ëº€œ{sêBÏîæ‘^@z'ÓågvÕÐq‹ûù‚òß~¾tQ5®×MšÒ¤ä ›.†^zb Asoà&˜Ì0»¯ ÌÌüÆA)?3ô[sn#'±Ãëkµä¾Û•b*$œ…ÃoQ×¾™C¬ùØ”Í\Sˆú¥zÅ\»D´Ë»žÉÄe‘ R•Ñl—MuÛKzŒ?SÄaü™ÚeÓM“ùiŽ$N%q‡ã§¿|{з+ j®çoåBlÐo+¾ýøíqËÕŒ6E³O³t|ç3µýžK¸7…¯îó†›%oꬱ‡¬…5õÓÎæ”]Þ縔2 “nºFÖßñ`:Ø>(Û«òðõ”úÃ{ÚÜ€÷݆0}Ty¾´~g­†šoüv0Ü×Z<Ù@–k°ènƒr ÖŸ0y\Ýw›I D­ŸÝv,âwPÎ-€Y çJ%Á¼øLób U-¶/w›=’ŽT{#\ŸõòÓŸ.é…Û“_ÚÄQOdìr;8*é¡$É K–‚‰m¿€r´Cöæ>|ÿž7›w`ÿÒNGAmû²æ]…î[ëÁN1>;|»=%U'Ø›óG”áá°É"ÈéS¥_ã™Xž”ã™^ŽËñ ¿oœQT~#(²Ýî«r£0ºË¬¯m9¼ýøáÃÁs(iÕ‘!TPå¶Qè—÷H‘Ð-éY‡%+Ak"£1nÒú„ë¢ih,`«Î«‰És Ïd$²½ß²˜Á RŽÛÇòfjš,J³Îü~Bš€äq¿¯à­ Bž`O¾î1p'Ò+¯ôG0¬$$ë1„Ð{{Sd/ßüíÝDZÆBÙt¡cP^ˆ€OHë Ž ͤ4Û?¼§ !¥E™¢tæREðÕ¡ +µ!Ç£9L ÎBœÓÉ#U™8ßz÷Íû¢O˜Fý~<`_fôLø†Šë@~¯C{±z¨ Ñv¿}h&xB›Èàm¯î‹îÈÄ7Röî.)7e[úó¤Ðß|J+©(•I¸•z~YÈt¡¬ˆ¤Ž‡ w|Eµ´XÁæ\aëê@}÷nß®v·«µÿ”îx”“¹³@U6&Yp6ñW¢Ò.;¥:F…Î=Õï%7Æò¶¼Þ\Ètùcuhôq~¶oÝQÏyüѬ4 0öéù±”ÏÍ&1ä_ýÆ6àNt#ª5ãoC`å pMNÔ´‰®¦-ž>ñÀ¨äù[`dS“œVÔ&ͬ ý wñeê+ëÅ°`?v5°t"D?¤?iäa\×/‚ F÷ÉŽûyºÑ™À’ƦͫuáJ뤓F:'Å—ŸK .•òƒCiÈW5 ²Fu¯ÔÆ•ð©(vŒ—Ä1¼$?5ôëk¯ìè•«êÅýÑ->ª Ÿ cÏM±)a¤£I˜’*¦Ý+¾@Rµ-«¾5ž8üÃ#e9G°_jÞÉ×Ê©Œ»×4¥Ë rIw| *4®5îÊŠ-W&ù6’rU%ðˆ…)Éò3=LJÏB ,@Eg ù³}µ)éfAòùÞ£¸oö\“ ÷ùÃCáìŽac®2W›Þ´-[Üë¯7yYu. ªsárñ©Ú\w8¼àüFEëo¸Z;ßQñ‚žC{¹Ê«yE³\ö ì†Éeïc´˜S•GqtwåË˃V˲%œ_Czµ¥»×;¼Á¥ëÐ[ÔxG( r/òZLŠü, …•‘5'ˆ<{¯TF&>ó·´¾RÞª‘Ãvüh›u¼|_ùñŽVV¹šW=— (05Q¯VñQ’uÆ7ûµ3¹8?E"пse*‡æ™(IáBõتÇÞ0ã¥M»t×<`P‹#ãþ»°úž/b?O0.{‡¾KA<÷±êçw ¬Ã¨ñšJïfqºž^rh/äÀçsùñSW:wóeöQØ3ôË1]Á9=Ždl¿lÒ¡_Ž ùe7Ìù`œ°.üì0+Ãá *5œlhãüš«K"¿RÇ LiÝá-ÍžÇ_ºŒ9t·}]ÒÜR@<½"9ÅÆeŠþj^ïØ¿ÒQ®cäg¾“•Ä1´`lx"_ž aA<ªHû;–€M$] Rxù‚€U¥beÓߦÛÊéŒ r=—²ÊÝž’ýíäÐt@=qh@¯sð2Ðý,á«Ui?Ý“;Üé Œt·k_ý‡É¶¹åm^SÌqÃÓžc¾]ªHËV*C}+9öØ9…!ªÁÖûº¦š[škˆ©bCÐdŠ4ÆE9ˆA9r&{å±ÃJ>xå4¦‰¦4òkº`§ú Àî&^oaµ·÷Ð ËŒ=“7÷(€„Ÿ1±ÑK3±÷ûØ,hFR«YÀ™ö$ÄF` ƒÌÂÔ=Ú9šúríœ✣•XhlÊ[Ž-_¦s‹H¢ü¬7@NwyêJ&è[ò¢Kt2(-mC(fÐ1pZžÇÐ 1à«€ûÆd7Â($¿’%´Œ’8à‚%¤á'7&(»ÒÊ.ßßÒû¦èëØkwÏÛª'—¬­šã4n Ì B}`ÜGDÊÇ–Ç?þ:£U}æo'<‰Ž&èðÚÛ hj¿\‘ì=º+û¥Þf½¥zcCìS¦¯5f  Ÿ±X¸˜(%QÆöë{žŸ;ÊvÏ0ºèøI•³éî‘*Jñ¹œù†þÑH(×)»(k·™ ½Ïïtöpª¶Í«ünpE×+79eî;ßv> stream xÚÍZÝ“Û¶÷_¡GÞŒ…à›d§íL’Ú§qìú.MgÒ<ð$ÊÇ %ª$eçò×w ðK¼;I¾éôACÝÅîo?¾ø¸à‹ï^ðžßܼøêµI K­Õ‹›ÍB蘉X,lb˜Pbq³^ü½¿Ëšüê×›ïa° –‚¥BÃLnÔŸ®–Š«([­ò¦É×WK©Lt{Oµw9uÜUMK]ëC]ì>R¯m£&»’<út%L”UçM[ÕþÃs.˼ñßæeÞÕŽþí}~”áH)°È™€ŸYÔÈkøóá;äX ™P–Ù8\|ÿîÿ=‰h²° –4 þËRÁ‚‚¨(vDÂÊc£jC=Õ¡]V›%λXÊX³X-–‚³Ô¤4ÏŠ¸4üú9³°…ž¢7ßþxóN"¥£ìVt´èY8ž>|8Ô‘¥M‰-…fF&^G®UMSÜ–ž•OYy€ý:V3nE¯6c­.e€i¡üR1}ÁgæÔÌòd~ÊÅ/Kc‚]~7†2çòJD¤\ð? /¶YýÛ•à‘Sfú’›ª¦F§‡ñ@´-…d±VD¡xNt:0xÛÜU‡Ò“¼«<É·ù€âÀÐm¾Ê“ÁØ»Ü36´C?¸Ø5m¶[ùÑu¾ÉëþúEáÓ-# ‚ cÇ{ö®ŸúÓ•4éÆXÜmgi™ËORI>VÆ¿å›ìP"çÖÎÉ;a6•CôR)è–û-h,dkÆzÿ³¦©V…'þ·>u”Ñß©¡ D)âaÁ¤jð‚T ÈÃ5ükT 'tÏÍVò]PÜM·IØ@0ܲØÀJÛü@ž¾ßê923gøJ0Ð7Tñ ˜°ˆÞþôöýõü4œwÀõ¹(Ë«¥6‰Wml§Qµ+ï©×ñ캆<ã›Îhðm{‡"Åî¬öt*¾¦ð4ÔO0Ùa|·ÎÚŒ6$fÓ Îë|׸.ŽWZ:ÿˆO7'6:ë ¿°sgyƒÔ°„w¼þúŸ¯Ü÷¯n^üçvó…X€Þ0®ÆÃv¬¶/~ù•/Öðî{˜U¥Éâ³¹]HÐ)h”‹ëÿðÁÂÈõÀ ±„‰,KbíMï͇GýgÊ$·¾ ô,öÀýragOIÍR`âËùS2f6IÆ ¾ÿðêõ›=Æ£’LÆ~2ÚÈW¿·uæ÷t¨ˆØÑ)"þù\´w#P gÛü<9-%z›ÔŽÕïÝ»oÅ%¬b‰& „6Í]..b2 g2Zóæíû'TB!vˆËUÕ¤“ö,‹v$•æX„hŽYaÆ,ž cèvÎÙ;eæÁΦVZ·“Bk–$$¨Ö4p ’¾‚½å<ú¶ÚÞ;Š¤‡àdœ8FÒW"‰\4í>Šw{vêaëç¿ÏØ„‡\xTŠi2ã)e4ãR¹©xãOׯ>Ì ýRÊ„¹h3vÎÂ\€be•µ±•ùžjN2+éßgd¿o´ÏV~`vt_WÜŸ“×ôÆa1<Éî ¡Qf÷c²°néW§ìƤãïiGZmtïÈ@úç©~ÊDš\–¹ÄCi(ÐÅïΓ­ Š/g¸Z*XЈIñsˆKÆNÄâÚç+§ú!óƒ$l×UQÏ`‡¨#£÷»5û3õMvxø}YekjùE ¹g×u›o|ðc¢>Ï„d` ä̼‹k~˜3Àh@ã¹bR›/€ mAøœfâzb;m¾Œô!ƒg£ìR™”Áj£­ŸcT@:m 0œ‚Lì—¸±‚¦™8Ìt£44°*P¿)¯nò§¼(äY8øúpÛ€‚º`ÿCL5IÇ3oXÐÀÖ­ƒ 5yÛ/ê‘š²¬V˜,ôŸf›–†Ìá²ðEÇLs} ²ÈøË%g ‹îK"ž¹[Œ!‹ .m¨K¬(zeò9$šuðP3€b™4•u~ŽÖ¹¯³ØÔ «²™tå’©¥ÄTPŸ ’R¤S”L£Õ]¾úš-dŒ.7‘!õÀÆ쥇†=…Ë¡“¨ÌœP?úù®:|¼óÔ$£R› ÔP#…Å›Ñâ¸;°µ¿g+O” O©Uüá[™_º#¸ÚùDUjˆºÍ÷òÙ×Wö™êèçTQs• zæY]¡ŒàöýX¢©†]²Ãàæ|³é®9dž®*¶OÙŽÒbºW<ª³¢/¡xBë:Tˆú˜ªÓØÁÛUµöªnãôAx©ãƸ¯y Kàul7FÌ•”P»²˜‰.×'G—ÖG—¯j§:Þm¶Ë>æ[ÈbgVã31šìb4haŸ^¨EŸïŠÒ¿õÙ´‹dÝèšžä»îÌOÊQ/)Y ÝÝÜŠ„ëZ´YغÍäúî\äçæ:7¸™¤¯¹þøúB½x²â ³™Ë“_€UÉ´š$u¸úw§-oÖ}²CÄm¿ÞÿÄó¾ô¿+;ËJÓBߊ }¾\9@2©“¼qU® :2ÄäXøòabˆí³]Ûø=‡EúäüˆNÁb_äb‡‰ÏKð9¨žbùŽ<¿¤ŒBv…|(£ ÈéOÀ(i{IU¡¶;Á$!ž82‚焳8™Àó11d€ö±vhW1³¦s‡žap„yX¬Õñù†„ÖkGæûÝIäiˆ¸UòyÝŽó½DÑ:g ÔÒ3‰öî°ÐÏÈÊöÎùeÕŽGS©:ê|Um€×h?ßiôµ×%¼-ŒÁËþ/ϧ^åõÙuGnDœ ˆn¿;y½<3xcF¦Ó%åIK¦Ïµä‰À;Ò›gYSžöJt–Bزo§\˜;wYyïÁÍ¢[æË:jî4×ëDMÏÞ¢<„”™”‹ŽÖŸ`ÍË)0C;·E-ŽMt]l ˆSËû+k"TÙ8îP†‚ü‹ ‹£#x3ÀÙX^\ȃJ.Ï ÎÜ^ˆ˜YÍy–s¹œÛÿÊr&Kža9—® z¥`{äñÒI&ÔŸÈúèEýŒ· t‚+ÜZ''?:ÊŠÐR… H^SÇ `\€˜á¬^¢HíäæàIkÚ|x%Ó4z ‚¦!ƒáìÕ!m¶Ý{¯#’ Æ}ÚQöd¹¥?=HOVvd>è†î bX#]¹þ¢ê°ô,¬(ðôy-]Ó¿0‘v§ìЀ¬nuGM’` œ•÷ Å3ñ'Ìh}0w8C9Tb’ñfQ*®O 7Ýô…¬±†ÏíS× QÝúRkq::! QV--KRÙeç±Ïͯó¶=žlwØÞ†I8÷·Ïwo߇TaËÖÍøÊÑQ¥£dut±HØ Ì)¥îBQ2ª½Îç¤Xd¾V๠ִ”*¬«·x€#uÈ(™69u5ÛÐí8ÔX…-[Hk ±¤ê¼Úg5b^Í–:zWRÒXxÁS³°qðÒ'Eðêíû7~6˜Àžýý.A€º q] d W!o>)Ét–ÓÔúAüüù.G× RKV§,ýÕÖ‘ô²¦ ï;yá_gŽ;5Áá®.}AMh`M*‚è”(&/„€Ñ~ ˜uç§ÚùùWt A\óÛ\•t2»ïÑgUè4^¯Á*»öW`\#°„mdI=%mu` <56ºqŽ Oòq®g^ðÊÝ!±t‹Ÿ=ÈÑâô˜Ž¿^(l Ý#7‡]8X@oµÝÏœ Äši,¤‰Ï<@a` é(„²¾4öU9Ûñ’ Äv*~†%Á¸z£%a_fÎä9€†%%O™N'Kö[mxìÊ¿Êyx§È]ŒQ”E{O¯Â @ô‚ÎÍ1v¡K¥dwYU…@Ÿï*W¼ÄHäP×.}Â~†CÑË ²ZÀÌ4}²–ƒ¨ÿ̱ï1ˆ?ä@`º¿«Õ!ƒdÐ> stream xÚ½[]oTÉ}÷¯èGö¥§«ª?%´’1!‚ÅÂN6àÁ “-ñ 3lÈ¿Ï9=Óã@˜±•\_ É}ïÜ[unwuÕ©ªFK .8-Qœhå@fáÀœµÂAtÉ"ÉåÚή†ÆAqÍú[ÕIÈýéæDZ:Ò’‚S¾˜ <&ãH¤ª™“"”–¢“j½Òrv–’Ó ¸ú›/…ÖŸÂ%ÄY4qFÅj‰²F+à×F%" k¼, ¢ƒõ{-oNδñ]*ŽÔœ+¾!WHï³›³ª”R&¦c*âb¨|·¨‹*|®˜‹û(º å•äbNjÉ.r®1*.ÖB¥º¤Ki.I¤Ls‚NŽÄ¥ø+¦-¥þ•Õ\Ê™3[±6¥ãŒÔŒ¨jv9äþnqYƒBG­.ÛæÝærì_Þ‚Ë9ð Ìa¦!`¤XâLÌÍ\nkÛ¢+ÒgÓT4SJË®Xëï‡U ЇKŽýæ ?«\és_ƒÀfˆ uU0‰UW¢ YÍú #|FÉÕH“¬°Äšj9Â=ŒZéâ¢kÂi©¢®)­¶ŠÁK¿‡_'¼b^[æ”VÉ®q^1‚Õ¶@ÉB³ ±?» R Z†LBa‘!vé Ó ©ãVØn(€€!Œ7ÔØï& [éw36„.¡`¨Ü$#b›¸KRhÐfÐ&9ò®A›l0šrÑ*01Øšaó´Á̇Ц&ý.´iŒý.´iªý5hÓÒ¿FÍåèþý£Åù¿>.Ýâøòrµ>Zœ}þuݯŸ½¿üíhñ`uõnyõŠ.!¼YüañtqòJúÅÑâåòíÚ½ÒX<×M%ùëƒ9xˆjòÉ »û÷ÝâÌ-ž¬ÎWnñÐÝûã‹?¸<¿ÿ_´â#¼ÈÐkð†y;àìâ÷åÃ÷WÓÀl{… ÁªøÄe¯æ•†'¸.q/ˆÓ«åßÞ™‡ªú¨_}Ü¡æaKp¢¸Nù»8žžütþìõ=Õ×?L8!¥ø¿ƒýã#S4\Ãêªx¸ÏïùôùWþÃûïW—>yÉ>N85XšO#Ú|¦bªúö±æˆj)p v,WO7<Cmô3X ††Ã(Ï¥‘ïê?yñüù„3°5[Ý0©žQÿ€³_¦ÔoÑ·¬×úþ¶xÀéñË W 5¬#ˆú·Ï Œ¢^Tg°Á’|$@3ÌH<`Ò%ˆ3wúÁÇ|kzPÿ¤+`-{pPPOj{12b ÜMœcdÁ¦§ >æØp ´ö6ð,8¸—nñ—_þ æâ |¦€™\~þðáÍÞ…ÛOæ–`öv˧SÊÞ@oxºÐ™òVO}»§£D½%ñ·}V8ÍßHv‹“Õ‡ÕÕÙÇ‹·Kg›wN/ÖëåÕ¥ÓÍå£/ë'gë‹õÒI¿q´x¼º\÷%yŒ¬!¶ísA8b 㠿ɸ¨¸ØH‡ÚÅéÕêíÙ ]»ÅùòËÚ½ùÚ–N/þ¾<¸Ëõòrý‰\¶ð}šÌ§Õç«·ËOöÛï=_¾{ñ`õÅu+Ë »0dÎéÅÞ&o ›»…~‚âžðOÏw¶ƒ²äñS?åÝOu ÚvPÂÈèØÄ1’Ë\†ä2$—!¹ÉuH®Cr’ë\‡ä:$×!¹ÉuHnCr’Û܆ä6$·!¹ ÉmHnCrÛJf*³Èl$¿™ÊWOýdN€µ;+fk s¶ÇYt27%¹Ž>âƒwÒ¨C¦E¯ì { ‰©gþKf‹Ä&ìs3DÌl`ô̸}Væô`‘̱Aæö‘¶oy¬zBÄì"v"‹d½ó#°ÖD)3PFð@…[ áŠDö€§/šÒ&a ,‚ ±"¢Úá8™@blùÀ¦`F}Àñ„êÚ*|ØN= œÛ ðaõvÚ]Ɉ”@`{Ù#ÐÐ*qlßLŠ| :ó5§Œé †ãiˆT,×2VBêAžŸžO™R¸êÜbÀŒøˆ q†?OJªáŒ:ÉÖÃŽ}XOi {!{²Å–dœÅÆÖL‡ê¦¬{«NRv@˜p5zÇ[‘)h‰>7–ÃÌ¢"Ñ#ƒ^ó÷SÝ—/~>;9žr.+ÓABÜ`=€àäųiT$ö=FD ÏŽLóÀñHk¬Ì,ÑZ8bH¢gfR¸ @æãs˜6ßTå´Ë˵„å‚i§ Aqĺ#D°m²¾@@¸.yžú¬"u H~} }]ƒ˜º>+E|CÎdµzaWJG‘þ[Ãuž©X­º1ˆZ{Ñø&w6ð‘)¦ëɨ¸Ö™,c"«olaˆ«µÍ´ ¹àƒ7s`ÑŒ 1`Âuš¯{@jßû˜t›•-Ê°ñͼXœ¯{ÀZý¦uɲ`ï峇¥t§s8-øö–¹"° ÉÕ+›J}EÊ igLHsóÓÐÌÞç\4„ÎYa¤Î*56¯­îM{w9o™p-à2×lR‘çh0Ïƨ8ß e¾ëµþ‚]RgSª[‰[õX/líÍõùµx¶ã4.&2Ixç`ˆãçቇCÀ# œˆdovÃK!lÌÑ7 =^JOo´ÇË~P §72ƒ3K±ìzJ{¤bVzJa‡¼²ÅIs›öœ*[ƒ3™¾ w.r¹m炧pnÕ¹øêÁëQ½éiä`Š0Æ(öM›cžkC)L؈ñ¿ûQÿç~OÍl ÖÛÂ7ÏÌlã'Ùý”Æ Aƒ:£&®£&®£&®C²É:$ë¬C²É:$ëlC² É6$ÛlC² É6$ÛlC² É1LYµ¾›6¦o” ±eåî0ŠÉ -žkÀ¬<Avyœ3)ŒÌÑc >±b¸"¡‚Mù$ mßfÏþùÛŸ>-ïàÌ {llY³AËz¾ìáØ?OžYœÙb ÛšbøŠç×)Û*¹·U–¾—Z=ˆeZÇÙxf »TË~ P±C#èž…9:ktpQQ"è™~êÄX½Œß§™Ozüâõ½I Ç;³DšÕOg“æ¸WLûa<™G͘þ¸Ã¡pÕÂfY¦Œa0FãA)nof©&o ‰mŽ 2Û«¬!zà \î€dïñÖ»°Š¶ Ÿ[Ì>ÏÂßcr«HÔ˾J`a´ú j¥gªYò‡E ¾r`A!õ €;°Î($Þñ÷Œ¨~3ŒI—#rúó5Ší9…›P<¹£€f®do4ƒ+É{ÈÞ]X§´¦ÎÀ+ ë— aUe˜Ÿ¯8ôBâ\ú{#ÿ3 ÖX躑Ÿ’n±ž×R»‰kš—Ý1ªyŸ3® endstream endobj 2891 0 obj << /Length 2140 /Filter /FlateDecode >> stream xÚÅZKs£¸ÞçW°¹UvU H ‹YLºf¦º«ûfnwîª{ È1Õ€<L:óëçèÅÃÆ©¸bj)d8ˆóüÎC ½G/ô~» íõöþêæ×8öP(ÁÞýÖC8pL¼$Dw_x_WÉÚGa®Þñ¦k”®xµöq®öTКµLÈõ÷`/ì¥A–$‘Ú*ô|˜df“»fíŒVlâÕ²U¿ÂÕVðÚÜowÌ,ʦlKZ•Ó¶\£·ïå´ªÌê[‡ê{ G ø‹=¡r?>ÿ¦Ä"#V@’m Ñ¬|¸»µï=ÜüšÄcê,Q䈚 …AGñ ãSèø#é I®ôÅ-×#]iÉ©°T’Y]´ÜÜ(Øv€ «Zsã¯5ŽW´ê˜ Ö~ŒñêýÖ¾_î<%JÓaÅVãdèB¼z*åŽI³Ö_+<5‹awó›Ã®ö½vG·²Ô#椒%óœ Áäž7EÙ<š[ 4PºK»YÝÕ{í1W¿Ü_ýy…”í<äE$ ²Mì%q¾‡½¼¾úúGèðð–d©÷¤IkI‹Êûrõ?ëÆcûD$ ’DíD‚ Ô¢ÕøÏûwÿ½ÿh˜ MatGÀý#„§º;Á"Šq€²—DŠ¼EB¦©Ú ƒÐÑÀ¢áPE—Üñ®*Ìú™+èW¹‹ZÒm«ì¤–í®”feƒÇü0!£i›~Ÿ-̽Åé”…ÔõiWæ» "öÙnä^÷)€ Tkñ1èžDpkfVI€,†¼oZöèøÎÏ´Ðį2QœeJ.a¢8S÷F^Ô‹=¢…%Ê"7;–€„ š£r6£S~«UÝ«‡ A­ÞùÖ\‹²f,¹}Â~‚džŸÄ ¢ræ$ؤQPñ„ì4pz_ý8NŒ g5®M?ñÕ0+œˆwí¾³®)·[Áhm~‚Ë™Â-k&%}drº·2ql2üfÆñE/JúØpÙ–¹õSÆ»¶¯µ«ÔSy}oO,E£q$÷¼ØèÍb“‹ŠýXñÚCÜ®ANÞ\»è­*–·ÌŠê|²ÿ¶”y£WËY1•ßþRŪQ0EYoÅY/ÂÕõ‘ Í{èK{u|Jl[j _ƒa)dàΆ½É1—â39Å瞉ºkÙ„O°D=bR(ZÉæò7Üß Æó†yíÆ™MB;Ìlvß…‚msÚõ~Ò "Ÿ•5 »‰E´2tHMÓoN%›â¾dvPK•ƒà´z–åbŽ–ž­`2åCoAÉ)[ &Ù jÓÙóRLf¯Óï æxÕ úî¤âWçi¨FÙ<Ê‚*P›¨žop”: ðÁã]²`ƒ¶ˆC¹­÷¶¸…ØrÕ…àêÖ“Âh±¸™ïéI¦Õn¾ܸsõÀÀ¾ ¸¡Ro˜Ë(öšT˜—&%Qï­ht<éoK>ûºÕ—úŠ®Môòž,‡/y'Ë”BŒú9€`ùÞêûÝP‡m'ù¿—/7gúòC¥ZØ|T 4W-uWµå¾úW’`úÚ$ø´cæ˜i< 9˜q8Ô¡€êÆí$=Žæa²©Û!§!7ØRµ+~¾L#xR}â☌ƒ_#¶×g"ÄØ©;ö-uòâhÌÕ––Üí®¾YU¾ÎðS°¢ËûíÇ£§¥FÑáYã1u µ¸‚__îY^*þû©;ôrÆîÏgÛ*¸¹¢*ș٠Ž¢ 7‡ãòÒx ÉFtq°‰û£e4“]“€drì°ÓŒË–e?Õœ'Ê“ËåQrúh§)J•îe†qÇC!&³ÏÓ#J¨Qs ¾ìFäÝ‹CÕTÎ-”¿0‰Vxpˆ°pÏÌû•3ZXUt½9ó(ûfù/„äÌ©­–VÓ¦=!î+[ß ˜ïüb¯ÒCŠÓ¦Ò°xˆ3wªÈ@È Ô÷­êM–’òÜcš+#¹z5^½äš·P»7˦œô?ÓæûÐgÝ~ü<ê³m»%=wä”ï¸FŸëÏ/ö…F+¢T.|4SÏ™±†n”¨c{¢ÿg!MSû¿ dòÊ/÷Wÿw<£ endstream endobj 2939 0 obj << /Length 1816 /Filter /FlateDecode >> stream xÚíY[s›F~÷¯àÍX›½Ãö¡3išdœI]×QûËBÈf‚@d×ýõ=Ë.ÈŠe§Í4‰örnßùÎYŒ+;¯Opï÷§ÙɳW‚:>RRrg¶tS âH_ ˆ3[8Ü”ŠÉ§Ù›Ö~ŒüN®_Ô—¯OœS!¤{öâ|öö#˜yð?él†%T`7Š(¿™áF‹Iõ&NÍo¸Éó(-á+Vp7š7/â,í„)áHq~¼šþ˜šQQÆ« j5Ãlµå+uŒ%A™Q¶ÔG<{%eÛ¥’ Cl´|û»YÓu»@Wõ’å„`7Ë,/º*M‰ç!LØãÙ­¾‰ðp<þ7¡©PS‰Ç4M³Ò(¶)¾PU€‹hÁeJò”ïL)EK£u£©å÷@Æb¬Áa\Éåu ÞM¹ÞX‹2‚•/³Ü ¢<¯‡+Àp¨ç&ó rý¶¶” N$h-‘bVÛ‹‰"!‹æ‰•$›¨Ð[æ%©õþ¡#rÍk‹’Q’DÓSn³²íB…<êÕgâ!ogýa¡6èà¹"jüáª\b^ÜÆIbFs»¤Ø¬+Úˆ¨oì„V"áyðK‘…*ñ?Žàï3@"K)ƒŒC@h pX€ ADÈŽÛŽ–Á&)[¡ò±D;²SÄ'Íä¢ ÒE/ÆÚz'=<Œ¸§FÒƒ>Qz,âà*Í \„æyÇi§Wæ ©÷e¬WYI*ef-¯Íè—‹³ú°,ðü§ó|Õ„Óùöø G¾zÂ=\ý 9‡i·vjåe´ òÏC0b1µ1âž-­¤±‚ ‡°N?Š¼mï´›ÃcQå¢-|8œ ‹ýáTœÖ tú~™âQŸî(·÷F‡\÷éNGr©I¶S„dtºÙºéÒ‚¦Öt°’¸™7*ÀØ0Z™nD"þˆ1ËÖ…Y½ÈÒ¨6ÀàS$*À?ªËžARd-6´©Ø§kà+EƺöDt}•dóšx[9­›ü$‰Â²nÓêV¿9þˆþ{óó´\LÿŸ\üÔýXBRÌ=+i®»Nï¾À±ks궺Öæ)¬<í5EýÞéûýzžµœÐlòËõ¾ H(º©CÌúÁÓM“»Á{HÚ¦r›¶»÷åV·D÷ˆy©/vPô!°Òrëëp¿IÞ¯†µ–Ý«FOd[;JÔ³e”× ·…g±Mάq TGše½ÍÚ4›ÙT ò<¸+ª 7¬:…|°±ãòÑÆ Å‹üA¼80í—«¾ÿº}D«LÆ)àót—µÖA¬"íØ=Ö’¥Û8Fcíô>t>ˆÅAlf¦,és2ø>ÿjù¼a`ýÉr[F¢èžæÕ~ z·™Ðõ4ñ„ÑHô‰ä y¹u_¸¸Š¡(U= ëE)êi°ÍÄÝ@Ö Ò6)›¼)IÍŽ ’»¢®mëZ—C,QýÏ®Ý Ã%æqOÅ3Hs](!ÕÍ êàM–ܘÉ_€©‡¡-xŒ»ç§z?qÏÏß›ƒ*âÉ͸~·4/ˆ;ÂÏÀ 3¥¿UVçq—w:ppžÅÎ.ÍÉÔ}óF¦‘·ty-X;èåìäÏDØ!‘&àŽÌÄ}'\|ø„L¾D1å;·ÕÒ•×t“8ïN~úsƒô‘OÍI’[™I]gÞÖXæ»CzPÐTx …k&•#Z,kzî…©!÷rŸk÷îjËmÙ#¨Ë cÝŽ¾V:„t@º"p!å!]1¤<>&ýù®lN€‚­“Í!)‘c²Ï_¾(êÎ&×M§š}s1»´0§G˜‹.Ìíª?&k÷ùe¿7°‰bÈbåÅ÷Õ1àÃàÏœ$»úÄM’"Ó}Üôàî×™ P¾Ç{xO›[¯@&øQb ΡÒif”6U«o4…ëµs;kë˜šß²Þ ·žMXnrû¨Ó/K¡Ï*̳æ4}TÅ–úEM Õä{“ `Qª C‰ŒKC‰0úÕsó/Í£Q)z²0ïBÝøIüwå˜ÐÕ´³ËÔ-=upuÖÛÚÕY?WÕ‘¡úlçfaåGxÖ hóq×ò–W9Q¯rŠM ‚÷ƒ¥€z qé; PìrDø` [A‡êó6ƒè¦hu´`”!á“ãµ`T"ꑾ5µC½¦vÈAMíÇË—¢böžüm­"vBéñ²9&Èóèˆì!Zgú’)p(¡Ã±×9§ã^e~Qç\5YXR— aBº¸^@žÇó lÞ4_òŽï‡éˆ+UO·9À­y”WÛÛªäàÙ£YÝ endstream endobj 2980 0 obj << /Length 3334 /Filter /FlateDecode >> stream xÚÍZYoG~÷¯˜—(@l÷Ý3ò dí Wv$m‚Ý$#rh LÎ0sØQ~ýVõ1‰6»à{ú¬®ª®úªºiô1¢Ñw¯èäÿ›»W¯ß*Å$ÑZFw«ˆ)F4å‘Ža‚EwËè—»˜sEg_]üv÷C76úe®”žeël“Mº†>FÌVeµIr11Ý=d®ªªü,ËÙ¦­W{ï[óbÛ6®1/\UãFÊYÝTí¢i+ßuQn¶eëÕîûúÒu»~óî"á³» (_º&_óáîæ鎘$,I¢9£$Q‰Û˜ïóÓjvuséö™KW¸²~s÷ê÷W öL#q®HÌD¤$°h±yõËo4ZBã%"‰£/¶ë&âD'PXG·¯~ÜÃiÎc¢¨›‰>"È-ÿ+U´Î2ÏuJ€¢¢ Ù>n¬°óm{_g‹&/ 7X?1ÎɈåÇo°Ìàü4—YU»VÔ˜]²÷P-bAhÍËɱ&œÆOÑ-ø1º?¡e̶ûZ99Š¥Ÿ¬ûtñé öO+ocÇ&jì™wýOy_—k°Æþx/¸j=v€r)­³ºwèxà|*s>X“^¥ëu†“$H‹týXÛÓ$ô‡_ "”Ø9ý<~Êl)˜w§ÿkî6ˆ) {ª‘ÈéavÕÈnÛÓÚè…õÜ8¾ð£:ëìv½D{ Ðηµ/¦…c‚Ä1 Ï™‹’©Ò¼øao`°>4z>6ñÎp¥ Ó±™i1&&`MÔ˜"ØÅŒ±ç2ˆr0 eÝô´è8@ê^˜Ç|ù.È‘¬w^´ãôS#˘0øPP D31YH‡u¦ÓKB¦ßfÕ¦m,ズ'莕¥«KÝçŸYUÎWUæ{.óôcYX9@#(Ñk+lh©©ÕÊCó>èÂÀÐ…Á‚ði\biSñÄ|sÏ€‘*ïâèÝzý”ÏÑ' =8;¡½™y+´G¶¯œ@ÚtºÜŸûǃzÙ™Æ^­—m•ƒgÿ½-ÏÃ1X¶ó”Ž g瘶‰R³gƒrs¢¤»ÿàYʺÎÝÿ9­r´‚õë´r ý±v-`ú$XÊrý9[îá?xÁÔHììu|Âãi ài4“ýóúv·úÈHcYrš·.&„ R¹™¸·‹ÞÜüã(þb:9\:mÚͶއ+4œIéW€ïglD)S»ºÏ`+ªücîدCÖÁ§þÐë0[’r0‹: X ö’d¤`¤›I16°[>¡€DúÌ&xïÉÞV%êðç|é<Ž‹}DÉãØgêÖÛ:$Þ†>¼k;ï-≣ÚæéG´í§ ÆØ ]gúB½qЕ¹ûû’7®Ó2_¡èV¦\#(Š &Š<™„ƒ½RÇž£sÈh·bú÷RÇj¯s‡t툰D#"¡%‰åKÔ€%6+€iÉ'Zàã6 ²rŒ”`?Œ{¹¼¥&±šy˧¬ ÇÄe»‚—7ÜÇÂÀäa 0÷’õí­ï%eËyêzSÀ“CS0Q ¿Ô!‰wüX5XÝÛJÁAˆ†@0¥xQ&_*¢n&#þ¯Ô‚p‰©{õ¤×Q É[¶‹Æ}Ø“ ­Mh8 ¼êœó¾¾ÏÕpUÁyÀgîG ÕCs3»…°;ÆÆÏÈ(ÊÊê°«±.YrÀëºt¥€[|}á 5Ì*óâDÈ€úÜ©‡1öé¸SC„ Ïér•™!¨·›\¹ÿ.Hs1šk«=S²Æϼ9Çg徯{\×2öÜÝJ?cd异’(úÚ ¿îå(‡r¼t9C¯$rV”¦vµKŽµ ÓW~‰]í’=.QÊ')¡²,|ÁIÛסæ`æ°m,ΉG0É$>Ý õ)¦µ°àQŒŠŽ®o> ôÔB@_u•®2k OÔ¥o*üÔv—¸è€´€’àüudßNÞ"íü€AÚ¢~Ül2̆¹Š;1Òb”Yûø|•‡#Òëà9*Ïer‚ÊÃr]rÍÉ7›¥èݪ]»ï€=ÜGx6`‹×oÁÖ"7«csu1W†Í~t IŒÑ>¬¦˜Î¡wâ>‹=ÄÓà1žŸzöt§ÉAl¨æSÓ»WJ]¦ Дêµ tS¾çꆊ‰fü¤0\$/ é:E7ÆËÙ¨ 3â¨À=¯.ný+½hÄf4b}Xi`ŽÄt‰¤«=â í½Âd^KÀ*CDÃU\Ö‚¯Ø§êÒ¡¬CD!€Z¹€¿àú%‘ë ÜL”›QBÇçv.V&lÊâ¿ í Šô0t d¢=õŽÿþ™Ù=ÞºàUÖù€ªSW±)­!² ¤¶÷¯Øˆ§´É7¾Å¹¨ÞdÐýÑU®Ê²ÙÂîÜ[×oý$ÜÝÕ•îfXv m¦óëé…`¸?Ý7÷)*t99p¤4L…M®F™Ä´mJØ.Øݽ=”uV8òu¹jü¥°G<àwrïý;%À“c[ɽÉG Ù=OÂÚÚUR´¼TÎÞ®¾lÇjh[UåÆÕz;ˆ¾¬šœšµ†$´ÖsýöýwöÖD<ãB8‘£}(×KO†§ŽÄõ>n†rLb)Æp}ŸŒ›@´W¸–ã^d™Oð,oðŠáÁa[þµO¼Ìà‰WP¦N‘Áxa‘ô^•Ú¦‹OéÇìEOÁÎx>•hj_O [ƒÔõ‡+Û@þ‡ >·e9ïj—@?åEÞøï3ÞSIxGàí¿¦WEZÒ^„É®ó×ûîΨ}Ã8|‰té|Žøwø?¸ø;pª hRˆø¿óâêy/Åâ—b\¹«`6¡°í_‰(3Bfþ+¼q­ý‹AsŽˆð¦TÆç^±î¾Qfw'eµÌ˜êiß“·–œÄÉnÚZˆéÆû^qÖSL`&»›5g>ð*öªg}€ç­¯ë²Úg›(µû¢#Ù÷ªox’ “B?u’ânê°>Ù’ððPø špú–WÙrÔSw—Z Aà°Ó š>Wœtv%ïô2¼’{¸ÀùÚL ‘\¾ü »ä—¢;œÖ²O#> stream xÚ½[m· þ~¿B“ÑŠ¢DŠ€À/µë"‰ Ÿ‹6uòáâ,R£î{·Ü߇³«õËí,ìÆ­æEÔ3ùåÜJ )äVj ÖÀŠ_møµsÜ8diþ‚¦â Üïb)Ttà ¦~§¦@Éì - ”Ù_¯‚żÅjòµôBˇSõ–2boá2³âµì-`r)>t©‚1ªyÁ+ÊŽ@†Kñ?%pJÃeuäiû€ó0šàSËð9ø8®Õ±$Kó§øn¹` ¥Àæ5Í¡$sTÊ¡döïÐ «ãô•š†§Š—ŒŠ¶¡o ÅhxjSà}f,c ¼R9ûS|j-2<åP%y_Ã=e²êSņ÷[ö/#o sÛ ×=[汕 Lì#Ô €ç÷$ºxKƒè ¥¡Ç0Á–qÏL¼Õ‚goYÐA ¬…üSÐê_a˜VóÕÀB¨Bƒ|YT]mš•  ý}}Ô§·jPË|¡ÔÄ'ãµÀ¾²-9ŽfCiøoU:ˆ™kÌŽ °°Bê-ôjÅ‘CÕšµái F- –·(ÑbLZ¬O¡`&®`Žo0L‘™ë¥¹þ¦¤þØ8eJÞ„'.>®Â©¨ËtN’|pW⤗(«†)ó›þ¦Š¨²¦ˆH|Ž ÊLÔÒð.F#Ÿ41ZÆpÞÄhy kå¦çp ”KKgwžÿïÍ:¬î^^^mÎVçoÛ ×?¼ºü÷ÙêÞÕõïëëNé×Õ_VW÷_Ðpq¶z¶~¹ / 'æÁ2%&|6i‰âjA1Þ»îÜ «ó°ztõü*¬„oßÿéù¿|Cò˷߆ï¿?Ã?ò ¼g0Ä? «üüOÌyt¼Šu¹|ûúõ¯·¾ˆIÞ¬%Çv⻥”è–~ÚÛÐ÷ËŸz;WL–§Q,¹¾÷vXÝ¿z}u}þæâå:ìú<½ØlÖ×—!o/ÿünóè|s±Ynœ­^]n†é{X*vÝBõŠ¥~ÁN"» h`uwO@>–û…ùõ>ÐZ·@·zz}õò|Õ¤ÃêùúÝ&ì?s« O/þXŸá.7ëËÍã0¦ëÁÍÕÛë—ë›-Ý ÷~\ÿþêâÞÕ»0¨Ž€`ÝÐ…§×èí •¶/jwƒoáxo±kìïäÞàÞ(½Q{CzC{£õ†íÒ%K—,]²tÉÒ%K—,]²tÉÒ%K—¬]²vÉÚ%k—¬]²vÉÚ%k—¬]²vÉ­Kn]rë’ÛVò õ¹– JŒÌ)BÑi ž3V×'Íó“–ü×'÷-ø ©¤€207U-f)µ|{m¸¶OŽƒŽ¯®.ÿó0QG ¶b0xÅ¢û£=Žj^î8Ž².Ñ-`ü‰Èâ8ŽºŽœàhÖ…Ó­ŽfCÀ‘ÀõGT#s>ŽCçÇGÿ÷8à±j9£-Ck•£àWK;ŽÂ@!)Z¥€»”'””Ò@ü—‡»*8d&‘d -„)2—=‚k0Z€N ÂÊ<ɸn4dB-‰ ›4!\Oð:-@¨Ü$zŽÑq ŸŒf6C 0*2UÈm#–#Âù P*W,£Ñ°(Bô)£Y€S‘ÊŪ£ÑpÍQ¦| -Àªœ5"U°ÆÆSF³±21ò Gæ˜x*&[€W³5x·£I ±â„Ñäx®?–¤{ Ùp]'Œ&/À«H¾Ñhš0š¼¯fO¾}¢ÑMD"yb͹EßýØá6™åˆ5ÃhêŽ@`5<Á"y^%ÍÍdØLå)›Y€V 6#6:‚Íh™Heò´JÒ&ŽŽ†bæ4A«yZ¥Zõ6CÈ9I&T„àUbC˜8Ú !ëD\0d^õýÄÊ£ÍÒÎ:¡«¼­!Íl£Ñ!ínS@ UCši#½SBÚm~†`ÕÁDF“AÖ™§¼ ׶wû®åäöîá‹}V0ÉøÔ·;Y›”­¾«‚#}g}Î-ÛÃí×·lÑê¯!Ií ‡Z{ö} üEû·ÆöÑþ­—>{ÿ¶õíÍÖ·7[ßÞl}{³í¶7½¢´kìïì6<½œ´kМۛ]ÙM-#Ó‰eßmœÐä¼² PËnYÙÏ„â¼²xrSG$’a¹q/à•É!>!„Ò%HñôoÇNYrŽê嵎ƒs,2A¹eN§lMa pÕŒ8’ŒÎ(¸¾…ûw5µü~Ií +“•=Oý@À 8Êœ8 ‘ÔãEµ¶ÀÐÐjÈ"õ¹%||û›ÿÛ®N„ ³BÀV¢Ÿ{ ß®^×çèuc"øæúi§øæâúâë‹7ÿÚ‚‰3†N9¢Ùšg^bN‘†Ê6Rt= LþÐOûi“üô{/î=/ù®…L½½+–J‚¹O“]Ÿ%ùDÙ•Zô£+§É.nø­ž(» òƒ§ÉÆÊ€ÌèDÙ¾¿¢Ÿ*7Rv¦‘[Í»†+Õ⣚êôûæ÷ Ñc¼óÙáJK‡+Ûjég…+~Zdfpo”Þ¨½± `ü È®Ñã–Òã–Òã–^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶^¶¶ÝÂÌU8'L•(!U+Puä~vˆ¼@vñœlXbQ…—芚díG™àD‹–£RÚ¬^K,zx+„iº”Á; ¾]×£cêœ0<“',Ž—áAã)yŽá˜ŽàYQ |ŽðCS Å1ß}×ÒŒ1UNørdU(ŠŸN¬X)f#ŠU‹<³Z(N¸&vÙëb-fYµ¸ÓüŠúY`¦ž™UxkÊàû&𬆼9ß²M¹þïÛ‹!¢âYKû»3d5I¬´-©û‰ÆJ‚©É'xUJîÄü$JûŠÊ‚ˆ;Ás‚¸†Ã\k4àiåÖío—7O××ÿ™QO ~¢´c(ÈSËGAÜòÃùý»3b¯ Ž*2ÃðìÉßgÅàq5c†,ÈÝœïT¶m¬f·ØËÜóà4JZF ŠÙ£Ë#fŸ‘¸UÅ”4 ÙÙpì¿·TÀfŸf•2b€N6ÇtÃìó€ø_ý±¦8K‡mŠ âòù“+˜<ï°~1: dv…_QvÅwíËqs¯ƒ ’ÊpÙ+³Ž¡4ß9/·VfÿôðÉ#6ÏJÚŠtÌ·ìÙPF"ÎÙÁvå– ¾óŸœ=âƒOþ_È àà—}Ÿï«Å\­¦©'À˜×…z‘q¨“~»jp*À墳ÎÓöÀÀƒºµSpͺ«W¡–fÃî¸I° ^zËùÅEâÏ<|x `+ÿÏ ƒ[Á¯U6ŽÁ˜²´LÖQ0Œôt°ÓúbÙ endstream endobj 3015 0 obj << /Length 4265 /Filter /FlateDecode >> stream xÚÕ[Ýsܶ÷_q/9ÍXñM¦“‡&NR§õG,e:4Ô¥cÍ#/$ϲü×w ðK¼Ó—§>XÀàX,v» G‹ëE´øéEt üîâÅÙ:^Ä,1F-.®\YÆ-_˜X3.ùâb½ømù!Û¦õÇæä÷‹Ÿa¸ —œI+–÷1$hY«0à]yr*”X¦M“m/‹l?år••m}Âõ2-ò/Ô(–û²¹Ýn³¶ÎW4j›b=›[·šé8Óü+ÒŽ‚}FŒÃ?½¨qÃáLJŸpÛr@@À*Møüõ÷o/þŽ44üáž1l2¯’,’IøîÛèåãfåªÉiy|ï¼1S<þJóžÿóÍd.£ƒO¥´L ³8åKtâçœ;˜Qtgá&^žœJ-ó+(eÔoÑ`ç·'|F_J_*,U²Ôþ·!)«ªØoA–¤H–»¬ÞîÛ´Í«’:‘þeÚ áÏÐ|“å×›ÖµÂW—ù.­Û¼Í¨dkµÉËkÜ•Û(nd´á´¸®ê¼Ýl›“SÅÕr5«:¿DzŠËe^Róož•Àz:¬À !Gl†–—;ZBM?øÝ MèבîvEN«P˶¢Îv“Q,ù:/Ó‚~¹ôÙæWT½ÎZO‹Š/Y]^ÕYFÄÖyz] æ˜Ùr3É$ZÆw+Ötý)§S€¸2ìlp.l‹ÂxPJ?˪ĥÐO'õÃ>£!7›¬ô…„Ý ×ð µJVßú5TÊÌ^ð …Õ˦­÷«v_g >‹i- ÌÜ·»}Kcp©®ÄÙ±3Ý68/6ï6 € º"KÅ1~°îä× Ê/Ž 4ʪ̑¯AQæíí‰ÑKOûf¶²«ò²…yœ]Ím¸¿¿¾=wŸÿpñâ(˜(ž<á̳0HH³Xm_üö{´XC'¬É$^ܸ¡[P©NÅ‹ó¿xC3ÒA‰bJkGI%7çû>¼9¦÷„}«‡jÞmÓ 8rc¶)Ö:qÉ×Ô±¾Ô“RË*-|%é²Ñòp3aª7¿¾y>£òDŠ¸[Ð è‡GjbPäºSä?¿ûîØÜ[›SA7w³ƒk’þ $¤ñÛ\©l¼T~§^XN…6Lr9‘™‘ »¤Òxùƒ†MÕ´Tƒù|UÓO<‰&ËîÙ;¨5$w¾¿l²U?f’ñ©¦Ã­áõ3ÑòÌ_ßätŸ,ï—„Üýp·Jº50 `Œj•§ ñ+.¡{[‚õ1 Ðp5T6ûÕ†jí&m©† å–dnÄà˜´b\w÷(¥!Š/4K¬5Î~³dëÀS¢¼îùóÎéO±ÜÒx8è~¼L%b o&D‹m'Jù†+ì‰ðÖÌ°.Ìs p¤ | fÁw_Mº‰•Ìé ›Ù ><å j aÂô@Qj³¼>áÈèÌ£Cl´Côˆcî Gl`Güçƒw>ŠH°(áÿwðQ3Ñ+Ÿÿ"|Í{|ä ¨÷Nêæ`#à<ÃXŽÑý>*MðQ˜)| Ý—җʗڗƗ„€NÍ>BƒƒXË—Å-5í Î@Í!(× Úæ¥'œRA *p+fTO­*Îr ÔH} ¦áwg㯨±ÃÓcZ$½¬Fb†ˆeÑ"#¦¸sÝ©¤åÜBà˜£þäÄ•ÄXI2!rx%»í6oÐ(-j);ã?ÄQ|­ïÀe"€ÛsRN@…ÀûÎëy衃zŒe˜åw¯<÷Ý= £n¿9ï·™°¾‘Í„ ˜©Å<ˆÌôÄK»B úr[Õ(¢·Þ¦yÑxûjl¼üÇ @ƒŒÆf§z–£á¥¯œ¼C[’=–´*ÀC` ^ï6Y"ªt1a@Þ`°Q—_ßR2uâ*ÌH*˜ŽXÓ1¹Þ‰¡õ.Я&lhƒ ”8gfñóÞ•ÈÄÁâ#+IX¬»¥j8Í$!ýã Þ™‚¦e…7⦡B£±Ûy¸mîܱâxù9ÝF¤%u¤ûkÐ@äCssÛ´Ù–ºp7›ÏfJ|Q ÏáBØÒ} ŽµÃÀ £´¡¡HÁòÆàdR+ytØ1èÕêc@}‘wº ½sº ~UW[¢B»‡¦Û5l~šÿW(樤ÜÅV-´ŠXœØg8@ .6DÉ¥‡9@’iÛ­Ðmv‹˜—„VRdg¹a 8 ï^_À˜zÆrnÀD@.ªWý`ÎàŒœç¡µ;wB``:»ž6St­¤Uõ:«óòÚû2Ú»ÖPl+~í‘¥ÛjrD†_›å¥M6kt)´îÝ ¿‹±ÊDÄ™®ÚªÎ¿ _®Ò&#Þ&ûcny@‰ÔÑ°$ßÌö!Óî(Äca· 6tþ ç Ö;24cbbUý&×O£§Ù 5 ö6vbXJŒA9ø(\ ³Ìz”iÕ‡¥È#ÉåíÄañέߜ÷y ?j½Gí¿¸ëÇp÷Ýôæ­“ŠC˜0ñ} ÆEŽž*;(:V?At•˜ÙrÓ{ùyÈáH`8W>@;Ïñ=⊪iòËÂoèSZç)üjÎÒš<¶Û¦»^ ú«âSÀÄcó zãÃ<Ã#¸Â„íœçNÃŽÔºH,‹ae3J…ƒñJOÛ³ˆ~3Õc¬Ä_v»ºúœouºQoò2G³µßÒïW„F]0<ÜÉ¿¼y¬UtÌ!1sþÈ ¨„¦éåxL4ƒð#K§È»äS{ˆMÞbµÙTûbMõKÿù§ØpKehyà µ{=“©Ù²PWÉñk&ñx‡+TÐâ9èIj¸Õ Q²`ÃxÍtÒß3âT9á™Ç×.Æ ˜ì¨ÖrùºžúQ+è«Nè¡íxÌs oK HáP?+à«QDÉšäAÌö€íÞH3‡­ L í)ù„Š IÞÚŠ¨ï"AsDî…ÓÌ÷(tIþø&ã$Œ?Šo#Isi ÍÂÐïoÃ/ÆùYo½N–N£4ëžs»Œol2Í÷4¹aïT]QII²¹Ô’ûÂ$©ä‚Dœ!ÑWà!¿Ä}Tª7ˆ•a\ƒ—‰ÛeM¾ê™¯Ý Z©Iz€Žm2 ×9Ìgâ/ïúú”†ufnÄ–UU×Y³«ÊµW¹äD3+}„üÁí当P •ë¾2‹ô3ÄOÀµ5±rbkþ ñ;2î­3wÒ3‘úYåàöÇj¤Ï1¬?æE14©?–x¿}ôø_YÁù÷ïS^|ÿ×ûW s3 \,$‹#/EÉQä Ê.ã`øD ã`—®>¦×ÙÝýûïkîêÌÝÓ¼Ú7Á5É˦E|ЯñšÝ™Hó#ê,í4©ŸÓNO^+0듃WGØþþ݇Wc¸ŒUŽΣcuÌíC9®Ä@ØÿœÉ |Z”¢¡lë#Lîæ}“µyóHù@!Æìæ÷±;~°€‹ÿ– &\û`ú4LëìjƒYCg>±Í–Ûj_ÝR½©¶¾w…Oj¶`mÀñ÷л7~Lÿ^A 0g.áÇ‚OœÞŽ?£ãuC)öi>É ڻܧ…oÇ– (´‡ª.Ò[—¯)³Óvï’WÐáÂŽˆßŽ ÎÃjvÙªõ?ЀQdŸ¡¡ßžëÞL "Ü6s+'PJ»SÅÒíxoàá¸GNк°µRÊ!OlXWe6þ|šÖ…hÜw&XËŠlKÇ¿ºT’ é@jDáë[7ÿ†~ä~Öl:¾‹ £!KÏf±\m²ÕGßD\C´KÏD±ÌRr‡Zµë{éEøX’˜„þëqʾ¸*IÔpåq€òÛ]3÷º¿Ò^0üHÐ2B ‰fJ!@Ë.­ÿ4€æ±‹?‡ÜѯgÂîBI°ðI Ó£D†4Z×»÷¯ß½=Ÿr Ó?ä¸j鉆„Çñ&úÔÞ‘'Cq4@¸9 »X3R÷!@éoýãЩUÀ!ûÄEÜËÞy§ ^¹+Lȶ–=IŠù÷8ñ0 ¿Ü.ܵ|[9hB û»Ï¹Ä¤ž²à3$üÒ(¹v© ¤$Áq:­œT/V]X´<ºOXíÒ^ÂNÃ'MþÅó á²Õ“¤*zI© Ÿ\ÃTDîs&Ã$™Vˬ¬ö×›IÚâ²j}“Wy‘6>/%,“ÆÎÉ &iï{TÔÔò/!¤·PE¸éS´"d‹±B‚ãª!‹D¿êjßbÞh&Sº?®m@HªA8Ecåsb ¹r„”õ¡Î·Õ:{ûj.+ À•Ðwy~it`ùÊDLÄñWX¿20Ÿïnà³;8Å0:·“sv6ÒZg”Û|›¹ŸÀASQÇÊ£;luæε5³ç'P)ȇ¼4èó .L‘úU Ð$ÎGéjìÖáR…¶Ký`Ý?T0½ª£ë®%èÑI"Ñë¿©Í@ÇÞ”ùšñiŸ~GÀ»o+øŽ’¯Ñò}Úä§ë¬ è؇@|~+k‡Y:¾_Faî!dgG}r{l;ýšàŽ6ªòUFuŠNÎJS]µtrµoéN"‘[ƒ=ÁÖXi‹iþ5²¾Çvʱ+¡TÆ=-GM(‡UF.;ÆŸ}Ä…sŽЊ4  5*ºFÜ™-ðMÀx —Š¦Œn÷nƒöqj£ýösÉtÿ¨`Ó¶»oÎή=^g,/ë|ïŒÇeU—ÝÝ™²¡&Æ¡†¬ábͳeœŽªaëvÅöÛ’eëýÙõÇ €´3ñ«OYý)ÏnŽI 8 ° ñI™S%b‘À-Ä«à „–,Ž}øÂŒ3ëpqÿ”èWÖ endstream endobj 3055 0 obj << /Length 3759 /Filter /FlateDecode >> stream xÚÍ[[sÛ6~ϯÐËÎȳ6‚+A¶Ó‡lšv³Ó\6v·³›í%Ñ'©’”]÷×ï98o¢å(n§û$Äõ\¿sñÙ͌ϾÆøýÛÕ³çß™x³$Šôìêz&´eŠY&”˜]­fç²mZ}ªÏ~¾út—½îJ0eÌåú}uv¡1u{&Ì<+Î.$ÔîÖ¡Ô¬3*”Õ*;ó*/n¨!¯éwW•8ô6_e+jYÜã/ïÆîë¬:Ó|~kñÞœi‘nîkšˆÏ·ûºñøﻬº.«-ÍË¡jžhváq!8KLBG)ö۬ʗéº>¿>|ž.›²ÊK›¼,˜Êad‰²4è;Ü|Yy: ÉÊL$Һζ‹Û L¾MX*«©ö_nø2+š 'K7ùo¡Lì~Wy ýg’Ï÷M¶‚þW|öêêÙ/Ïp >3 f•œE&fRØÙrûìãÏ|¶‚°m¦’xvçºn¡kÂŒÒPÞÌ.ŸýÓ Å€ËJ1ÃãY“JèéûtëÂ, –efV¡T…ʇïqÕ›(G¯_¾½úç0í‚TŽV׊q‡qßp×ßQ"Ýxö vÈOÉ´ò­)ÒêöL=óM „'î]H%™¶|. 3Ú†d›l l Ò2q‚’YÔÓ³VcEdDò'$p"‘æ¶&öÏå„Àþ¨‡±—Å4UE=`…»Ïñ-ŽÍÇ»¡àïpÐ+Ž9¨«‘r¾( ãš*Ë´F‡ˆEÜR¸ÃÈØŠ^ÕHÑG]ØL"M'ÅÏù5µ;™Ç†]ŽÌ¸E¶Àz~ªUægËýš7¾—[ðƒ™œWpθßV-n%H˜ÒÒ›'¥M„M×åfSâzw `Ä=Ÿ4÷T«×å~³¢Qër³úêD-áPŽÛ`ãý«o•[%‹ǫ̃„%VÓmÉBèkv5•`ôà&²ÖxÕ|{L€xÖ´¶ü‰Và‡×—Wÿzñáð€äXÚ~ú µÑ 0üðˆ—/ÿþã‡c§”@ßdpÊ¥¢“ŒoN;5˜ÃäÈl¥³aÑ»x‰/_ÿçÕDT$%HLæ ô€(3Å,èèDúþ5?ïp®+ä߀Ã?éÐÀ^ÎÕñSË–µêw8µŒAo"õ¤S(¼LÄ^†0öBɨ—aÀš ¦&‚Ë4oÃÛêLY°¶%ÝfäÝø|•µw%Õ™†éïê)Ø ™pÌ€ Fæ¨âYŽ!9€ rˆ¼Èc@Kßet–u~³v‘'”« bð+ª¶‘"”#rršD?ªÎo PM.—©óãDR-Ï#m«²Õ~™‚­&ßf#Ñ ©¨ÉhíîÑê¾Ùí<ôY,lÝ•yÑ wR’Véýi2,¸Õ©î¿'L¿„¨/ÍÕ@\ ÿ¶‚ºq3q®Gþæ!ÖL¶RÖKøÕþÐKÓÚÓ¥ôÄjé³.1¯§—ÃHìX¶É@$c9ê^߃< è®b`7ÊôãÝî›4dÐQ§¸F$<À–ìÝõu¶lz8òÒÅÇ{‡ª°ëjOYMš(£.]n›wë´Î¨¸ðs`ORÈ!yÁâëVÛßüøæýåTÄ¡EW»tù)½qi“DôÓÏö2ÜX˜‰^¿ýîÝ÷-¼9 µM¹.í¢¯+PpÈ‹²2XóúI]æRÇó;—i­©ùAÂãÇ%CV8€Íç¯ýD!Q{>^º·Ø²„\ÄܕŪÝìÖ axþ¼CÑ2Þ~€ .2úõ_:)€‹û v 1%ã&8–¨óÛ”<÷ÓÓÜáד2ôÅK»é‘Wñžùƒ/D*¿ß{jóÃ"Ÿ.¦¼!ŠÃ2jEÙt !P—Å& áG³Å6Éåcáë­˜ˆÁ®$‡™ù˜üA˜µÖ/Øãv[E†&#­¼;óºâñ‚‡ÚcæE a ìD˜U³ÉÐìOZb)á1¨Šé§bEÂi"nm5Ä‚yPAq´I>¹c b±ó·Ø ¬ Ij*:Êjƒ&Õ9‰6¿Ý/‰A•§NV°%÷?Å`¼‡i8%pOÌ1R3fîv ’»ù)Í‚Eg.@ðës¯½œÅñH}+Š¶ž/ËÍ~[Δô¬VÄ¢¸5[ù„VF¬»åÂ̓‰ô ” YËoòCR¬…, °Ï[43µSÒïá–NÐŽØÂvÍQ¯$~¥„(H<%úá°š¦™¤•Ÿ/Zâ0ø¡³Яʜåò¹ï  ?F.ˆ¨êýe.v6uùñf)©½_ÔèFœ€: O6´$O&oTƒ-„ó#¬Z¤8¤Ã”“rWj®;€›e•/ _kêeº!ÿƒ•¦JgÜoî»”Le_z@5>Þan§Ç¾xtf-ýF,áþÌïl™pXÂEo½+`p¦„â\ª)Jè׆ƒCÁ8l x [{W¸ðÅÃ$ü€„ðÁ¢oçͨ¥Î~ÙgE“û,æ燹:6úŸxCRŠÖßÒÂÞÊ"\.ƒC·b(Íx½ë™ì@úG.œ½Ë LxŒ…| ¾?‹akuÝyí[o—ëçf¸«æû:8>„Ô·åæ–4rœ¾‘ Û¢wçÉ3"~ìËw?\¾|qŒÎ NË óS³R·k}x÷Óx­Ç´Ý3€¶Ç)énó)e,ãÝ¥ÿWCu¼0@F«ýä>«t!G½>^Í/ƒ`-We‘ù’×,÷t‡w–Ã}úè§Ä8ŠaÁŽ¹<°çvvsI=ð3­èà©V û¢‹¾\—¥ÓgÚìêñ­™‰•p …Ùœw+ £<¤§Åx¸t¸¬Ö¶æ2ÀJªù2«šÔy$¬`<àñ s¾ñüʹ(øÒsñPk]<”×iMçÚáw‘…™AÉÃû lø‚L§|˜ˆCüyöi|_Föü˜™£ö:ž\2€>@Ïxè ½>ä¿ìï™0lïßtãgÜùv¿ÝM䌔€F&ši.O„+ƒa<4&7|Pì/¿#3ˆ2˜nQÔ_&ô€Og{^xc’yx~à­xŸ8>ä9 3¼b8ï›Ä|$˜ÉÞå¤:ˆ´ê¶Òý6»à›~@H>0zäôðЉFR éµ:±èQÓ.îÇу«nk Wõ .A‚Ÿ½¡Pᬺ=+QÉAÇQè|d¸ÇêN=qãtVʲ6øIâSÔîkú%|"u˜AkºÛmr9 â,,ô¨²]Y5më©/äy šÚüŠR§FÏK~BŸäÏÒK‚â>=lò‡#k¿R©æߌX;_®³¥{5b£ðjä÷n]üyú¹ pï%¶Ñ ã^üUnÅÉ4}*(t¢V¼ïÃVâ:ÎÁ×.—_<‘d ŸÿDÏ ü]¯®‚ÇLLiëº{È´L‹¡„ö_šÊí£ÿé7…=„Ðz²^áBGŠëÑ+Jl¡œ9Mì¦ÀZ[5îÒÎ5•I­ÝÙC“Ÿ*üÒ&dt4 ,mÿ“sšÂ€7GpàÔrmÿÇKÃâ(™Æñ‰$ùì¹Ê ‡ê ‡æå´O]e7Ãà©«œß­Kj¯eýÓh¡$CÀ¤¸šIPH7›r™âM{0±|Â÷K£æ×U–y!u‚²EM‘Ü?/ ÆÑ ±ãKÅîE‰ö 45ï£>ó%¨GàÓã.íòÝ&Ó«³þ[-E7üS<¨JýüÉŠÁtû^Nµ7ïXΊz^K.˜ŒÇ^‰Lk_¥¿àÆBP£ã¤S÷²v!i ñoƒ¯tϽ±r·Jõð{—„HÖ“”6ÔLëîÉSˆÅV&_ó¢’àbìèŠÃ2iߖɲõ˜`|>Ýàѵ8²Â·yzSn˜9,ÕÝ=è Nˆýϧwés4êÈ._Rªñ°A¼ ùÃ÷è)©ìñCëÛ¥¥Â n`ƒ´yÕß> stream xÚÝZÝ“Û¶÷_¡GÝÌ‚~€™83v['Î4Nƾ‡vì<ð$êÄZ"U’òåú×w»à—x磷ӾHˆÅîb÷· ÈÅíB.~x&Gÿ/¯Ÿ}ó*Ô +’( ×›… b¡T²ˆl(”Q‹ëõâý2Ž/®t(—ß^üvýS;xñþ* £å‹cSîÓ&_AŸ Y®¶e¾Ê¨¹¡ÿfË Ÿ.t¸LwÇÑ÷×zsý×2”~µ­Ë‚{­U^ÜR9-ÒÝ}×)YH!ø+ˆ$ J¥ªÑZ5­x¾¦ÊÒ&[s+c1ØœÿöØ{$¯ÆŒùs¶I»†tƒIF, ¬#CÝo/®Œ’-Kq×iƒÐÔç`Ç…›û/éêcz›9Ž=ò+&£Ï­·Ù®ãÄ!­.plŸ5ÀB ±žØK,…{{¡…¥€&.*\ÙWÞ:Lop(t¬ýØVæÑÉÆü3BëÇ]Î[3 NÖTúA¶=Ä>¥Œ ñoŸV§ød”0±éÉ<Ô æ îNÌ”º?÷jx }¬B1ØRШž–`³×,—úwº…z•îÜ™Áå¡ÉKžlŸÞSá†{²jSVûlíøº¸b¯”I˜ùYΧ*ºÃeRE(øSIµ²|—Ô¦tÕ”U~¡–ÿJ‘ËËdy ¾[¶Á»ÉVMŽ…O¨¼@ßn@õX;¥…ÒÆ/vÂShóUYs¬ ?$/æi2ãõ›W¿ü€ óYŵ"P­âºk§ZÇÌ(´²ÂJZUé}íËÜcUîG:§Pk%ПÄK´G½l[‹®°ò~4+XÁ5·5%ýßð'Ç_§¼…Й€-zò%áB³I–‡mZg°ëÐÊ囲Éü¨´¡o¼¦Þ+§çÐ|ÃI>H©WyV4;^µcÖ<3p†N ñËîß9‰!õUöOp ­ÕCIÖY6Ó°dñ– , m­gZ¬ç-«À%Ûä)ÆìQEÄÞOrvW*ÒBEC›÷º@ €˜oò]ÞÜOؾ0qÒ·}QÚG–56Jà‚© ¬Z•ÿÎÍ ¹5ëû=ø¢Ê¹Eè…[É/mEÜy«wÿù1&©H¨ÖS<§5Q⌠T£ñˆÅ† ´ûZ nâw²´Lþ­#ͱìJþ÷õ˜-¯J¯h«…>6vªK°ÁúSŒ…Ý®Äsrçºßµd£ m]ý¡‚Þ)•p`ÍfÊz //(¶ò‚qyí?Ó¶ËöpZÓUÑ·ÀyïŸCÛjáLqj‘ØèDûÃÏ*ðAõkL°T,IÞÕB+IÒ•<ÇŒaéQ»ã.$ב™Øg ‡AO–vêÍÚ :9¸V^åp å@†8RÅCå`(´²qže²ÿCQ×ÙþfG&)Ãöu^Cç› €&ì^àëÇ,Š„ÖêÔ.Ùyv鹺ԗ¦£q΃f©ÎÐŽPÝ?õÀé9Aª‚JN9#I)‚h(‹îˆ!Š»¤냖µGw£P¤§5<ÄiË]^s‡¢¤ÿ$@%÷Íá°Ë³µ˜rs¯9´z·Ú9 B»M§“êP»£§ÄÏ9áç:)-ìäNæk³„é7ZöRy€1EÙœrV ûÎM ×ÿE$õˆÚ–ØÓXN©§‘±H=ŠÌêrw$„µcô¹©¢¤Ï( «Ö¿˜X ªƒ–#À‡ÓY«Ñœ†"‰ã¿[!e´0ÂJVŒë§y~€I’w¤ˆæίè&ÈÔзsফUV×^N¢×mY7§á}Ÿ…-þÇØ” äS(gbúå× @ e]ç`{¡úTÜÆBF'ñ-ç; ˆ‘L­¦#cA|{+¤¿±ûʨ 6{fhRκEœ/'(‡¶Á„–k1¦0î3 qžÁÜøئˆ&È”}CiÃåÔ ÆÑ4G{ŠEó•w4K(¬ÇØë5Éa°VQôŸãðCê œ;Сó“HÿÛ‰%çy„32?ætQõ¤E“?tQ­¾úNO®™ŸãÒ&—hÏÎqp»#0«eŠ#€;—¨ÖÔíò}^ø<4¸ˆ´©(jnC{(Sªg›H5@óYQ¼Ž&âisF<ÍÀ0`8Ê–xØ8AYóOå™ÌË“>W#°ØAÍI8d †¿Óh¨;©§è¹gì mÑPV%¥ôÐÄÔNÑãM9ÙË{ ª§I|ñž@ðñ¦Æ´¢ Tn2f$E6F¡?#ÿ‡È¨ÊS¨Õߤ¹…{(Dø|‡å)98öûÀ£Ìá!Þ¼ýñÝÌÜ<¸8~ Ð !ùïÀéwpc&äÄš‘°AòΤ{µWÆ;`Á1Íq㯶ü½Äi‡š®Ý|ÓN› 5|ãC˦<Z=[U8C{R¼õÀŒ°¡áö0£|äšÐ/÷9/ÔÒÑø˜aCF«›Ùï¿Ž~NÏ÷Ç=r,nE€ewåÿ,‚~Óıy$‚PiÀ¼<‡—Özp³ñì(KNm³*WɧÎù˜æ‡2oI6e› Sìè‚óm—·Y±åºKÇ”ÇgéjÛ©Ü—»O6ôéîüw³Ý?1 mÇQ×ùˆYvÞ£(ŸLöyw¬ê¿µ[: Æà#µùÒÌŒâÍLø“ˆ@Û/ÆЈ›Ph¡¶|D¾gPŸ ‘ã$(嘰üŸM¿‰…–ñÃÊþú šSVèhtÞÈB@œ gŸä ’6Ã6«,hð ßÙm a«šßO)¾PQË8E´áö÷pØóƒ÷ãU~»mèã¶M­Öù:«§¶þdî®ÉÉD'ç P²° ¨t Gq¨õR)úÇNòðÁoŠ¼]( ¶Kw¼}™2g8ËÐ k »ðMùrj³ïEQŸî1X’É ¡øÛ⨌LìðæÈ?Ù‘ç¼Ø™ΚH󽵎#¾·ÆÒÜS$"TñÓ48/Cuún:«¥E8DsôÂ(õ»ËÁýc*„aø˜tÇóMøØ„!D©íŠÁ[ž@öN(04Zè%>}â’X€çž·;%Þ’…×Kü"+“°D.x%áGyºÊ e>ˆbw3v^qY^o êË}–\t9R&² P˜D˜ÁˆEn¦ô~êîuÝÊÛC;¢Œ×rièVéÊ?`/‡2/˜F¿î§]¸^tÌ pú¸[S«»ªëBÁ¶ÜqK•î„­®©87±¥:kFoIÙD RKW£+Å+Ó©KÆòc%©Ô¸WÀülÉÅ ü_Ó?íºæuÒêžÚqM7Gûž ß°Ñ3¨Ä?Õ ZUHé=n¥ݳ½s®au$]pü¥ùïçD€º$ôJ´óÎn2Fa¢‘½M]ÞÅEÝ à¶cÁ nïf2ôÂï#;é8á·^¬ 5Ž•]€nÎbbÒHáœÁnû(šEçܽ-ÞÔ‡zù#gbûVÎ{‚GÏ̉„˜XGœïÒB[¼»N„µlÔ#;ó—ëgÿü, endstream endobj 2982 0 obj << /Type /ObjStm /N 100 /First 1017 /Length 3176 /Filter /FlateDecode >> stream xÚÅ[]s[·}ׯÀ£ó»øÔx2ã8uâŽg,gÚÔñƒ"1¶j[ôPTšä×÷P+˪D±ñ5›q$\wq°Ø]ì@Ò[tÁIëÍ¥è¤×æZub‡™W¥±]+‰ q1„ÑY]ŒØJ.Jݲ‹)”=´Š‹Y;?«.–RÑjx£E¾ÛðFOã3 %·âD¢²…/4~šø£7ˆ*JÇ57ŒÑ#±g VJéê4ÖÑJN5Œ7²Ó4°ôâ4WJî˜g ã³æ´é÷î”ÔtO9Õ$ªüL]ÒÒÙJ.eHF+»TRa«¸TÛèev‰lu—Cæ1¸ßÀô³Jæ·âr*Â1ªËEùF,.·(œÞm™ò"¾å#ZÍåžønÄ·œ>ZêJP"ÈÉIcùÄ•Rø®Wjï€JW¾+âj³ÅêŽyHrUSb+»š*åIqµÄñYuµ&Ž†¨­)Ý5Nj®aÑ1¦Ðd¼«â R"€êZÂò4€a+»Ö„’¼õ2ZÕu[ÍuÚÀ’u-Dš‚ë9DŒ½(¥$q°-JNê  Ž†)@H_á±ñ=l† #¾âˆ©¡ ³ÙѬc®9 ÙRÁP°ÀèhÂêñ•›!,J¦Õ.š}(8Câ°ÔóZ†À²s˜A”0Ì¢à5‰™Â †é £ažQ’RX:ŒPF‡áZcˆ‚ IŠ)À€qGLHcàÀðÀ¨2t3ªC9págb~Ô’úÞýû{³¯Ý øf‡ÿ?s³üøO¨Ð+4UñôüíÛ—{_~ysGhxôÌš|Å﫽ÝìáâíbyðþðhîtýÎ÷‡«Õ|yêdýø—ßV߬WsÇ{³G‹Ó•»ßÍAÏ þ=ú=Êt$µx_…yÙ-Óßì›îJ´o*­?Û7N±ž Î¾_.Žæ+÷ø¾~äfÏç¿­Ü土ÿþ~Nà¯æ{˜Ðéj~º:£c a{³gó³Åùòh~¶vÀñÙßæÇ'‡_-~s/8|Âk——èp‰·áÑkX{³§§ H{±¯Ä3ÂëEC¬¡ÖHÖÈÖ(Ö¨f›unÖ¹YçvÙ¹Y£_4ºÁ裌n’»Iî&¹›än’»IîkÉ#Ž^4¢5ÔÉÙÅÍ&'šœx)G¬±ýÚÒ %ïÍÎ^ç''§oöf_-–ÇóåX ðröíìñìá‹8¸¦G°¸‡Ršx8›K¡ûˆØT:žKB¿ÃRÜì›Åó…ƒwÜ{üð»çO~º—úâ šÖ$8’DÛ G>#dn#¶I4õˆ¼—@ÐöA}ƒÿö)Ã%4Ï<¥ñ;~ÆX*‚Ü<þÑÉjîÏß,ö{?œINž©‘ö)Ù7„ñí „8Ý¢ Á.°ËKõ g“Xýjºñ¥ÕµK`òL]<Á©[¿qü³óŸù¯Ÿ,N}öê'\l²^°exF! ^†Ç”€g)» Y!Ìp¤ ‚¹ncâÐQ¡_í€t(ˆVºÈ´¡£«gž™«ø”Gúçkà µàKË›öýr?ä)}N„:#TÀAPHTß´nDbk"“®IB¤À¦n@,œorÅeÊ”C%`1ðM€€,3'h&ôÝ„0$ežÒL¸*²eÃPrP¯ºqYdRWA•3‚—I è}#Ž+«‚w¦\8‹´P`º"º-–ìÓ„X †ÂÂ!…võ,aö¤C»[ÁnK -HÁH%Dlÿ(çFJVoc4ÓǧÚG„üB®ˆ ›!üþîSåãhÊyçÆØ…ŒŒH장jJê)·GÓÃwÇÇû½L¨ ÁDz/6_É‚Ð2ø, QµïdE" …Fú'0’‹Cmï•ÄPÄsÛQ h°4 uyâóî  `2®-#ÅTÑHÅ:‹ìfz÷-6Øö‚ò d/¤ôà·(áÛ_‹F›û>a®¼9\´!Z¼ƒ„…b£·ìgÃ;ÞÏß¾ï‡:¡JÜ‚*ÁV•L+~swËÍ÷œîÐI S*IÎ ¹y@ü’½¶¾bÓÛurvôú|Ú‚©·±©©&OÆSBA)•  RïRIœP%ö@O9²’òö¤Q€å AôÍá›óýÞ§¤P¿aq¤ÂR#ã8ê·¬äžQWåÏ_À%¸Hɉ¤¥¡´Ò…y‚€ VË7x¬AéäjQÉ2† ^ˆ°’ÈÊ6ÉŸr›5Äv‰`›®Óc™ZdA ²ã——sS™=¸ 0{0r­ÙÁì‡gùÿ½×«ÕûýÙìÕ/‹å«¹?9]žú_–³÷ËÅ¿0ÎÙììh±:z=ûâ“ÂV$óÀ„%ëPÿßa¾=\.ÎüñêÈŸ¿;õóãóÙ«7¯ïæ³wóÕÉÙÅÏůóå¯'ó_ý56=NmÃYÜñ’³õK{Go¤[¥“ÒOÒwËÞYݲ7ŠâœÛ¤äùG|ùGLúGäù"PI¶n¨„J5&…{–;÷?ͤç˜ô¼“ŽŽõ“>Ž¼Öt°S,ÆËåWF=‹QÏbÔ³õ,ÕÆA‹qÐj’Õ$«IV“¬&YM²šd5Éj’Õ$'“œLr2ÉÉ$'“œLr2ÉÉ$'“œLr6ÉÙ$_,éTt¹¢ÞëÕ•ŒB úUTñYH‘6DÒ¶3ÎK” hq%e+ö÷F’˜¸€OãÎpŒšˆ1²ÁÂC¹B.®»"áÖBÍxž>©B² ÁAÕÞ©€qpï;ÉR¤ÇEëî8èx™•ªŽ+ž'Õ¹¡hL;\˜Š¸ßxfYñ–‰òŠCFØÚnŠøD‗aÀ&ÊX¶ Ó“³Õ¯‡Ë$ÄËé‹×Œ…tdƒÊ1ÓnI‡¿›òøB=o5\Œ.øÝxWbÃè'Ì'V‚²Ã—(É_Ê»GÁã¬=Œ]·ÏN’Þ æQÑrs ¼R>Ï}«kö€X¡¼ï ‡(¨N$Ás…€ÔBÞ‰Êx–φ!Õî[Õ>Ý®ñŠ$°óÞoÁ‚`_Áþy%X2Bêí¡sy~òÇ>€Nű»ò¸—Pš@dZ»Êá»ãåù~hW‘ >2oK¡æ(ÔÄ6ý0—ßô½Ê\Nq¹·‡ÿ¦$×weÿ%™ËÆÆc㊱qÅx¾b<_1ž¯ÏWŒç+Æó“\Lr5ÉÕ$W“\Mr5ÉÕ$W“\Mr5ÉÕ$7“ÜLr3ÉÍ$7“ÜLòÅ­ã—Ӟό«…Д”â+ü¡pËJig{¶”>öhÃA¶¿¶€ñyêÓÌ1#L"‡Ê ª´|Ûåàϱgóð}Ü—BÉ“;÷ ^åm2ì©ìnaxÅÌp(¡*Ûà˜vex3¥òsŠŽ‹Gð-˜ÂbÛçß½#oÁ"2òNŽ’ÊI£nÏÏ­í’Üee%äxS¥ñJj ØÀú¯ "‹Bf8xûqœÞcZ¼“@â}¾æÿ  «”¼sl¾Ç¸Ãc‹HÊ»ÉÕt§P|i›&LÍYäñ÷vk ÊT&n…#Në°uüyÃ%ŽZ±"² ™êÑÄ£ ¤ûoeÜ D¯„°ÿ ýá endstream endobj 3120 0 obj << /Length 3248 /Filter /FlateDecode >> stream xÚÍÛrã¶õÝ_¡¾IÓÁ‘éff›vÓÍ4i»ëéLg“J¢-v%Q!©xݯï98o¢e+Ývú`‹ Áƒs¿’Ïîg|öí ¿¿¿½ùòM"g)sÆèÙíÝLhË„3“&L(1»ÝÌ>Ì›m¾X*cç«lýña!ø<«6t'¯ª²ª?Ý~÷åcz€¬a WpŠ‡ðÚ¡Ü,aÎZƒ;f•š-9sÎÐ.A»Y¦5€é6e‡ÍÄqÂ0 Я:N¾ä¸m¶|þËB$óÈ„Ä/¸aÔ¸áM™êÁ5ÑÅ&_ƒÆ×9«` YxºƒGá2£Ÿ;¸ÖM”EyG¿É„h…Œ]lˆ‚ê…’ÍQ’Ÿà ]@éí7 Å¡—"ñ5ù15Œ2žž<Â;æÕ]Yíó ùðå„Cy‹a4µ4sôÇ9u¸ëCvI‹5p¬¦Maw2?œö+ô ®¾óóI¤‚N½Ú—+ÎÒÄ´Î<†4‘‹£Ëìíë"¼åµÁFU»âgaký²ß‡ërGjNè9#×—w*˜M[”_šð3"eªË_M@À›šÖˬ&8ë\7v3,æÀW ¤úšvBÐy¬”qnfŠ¥ô²=lÒÁ@p6#/ø×-Fƒs¦I‚Öõ¯eH£òºŽÙRŒmTÞ–mô8„=å!:ôÍ©òéìàÖ‚×Fd^FKÀoHË"…ëºXíÀ_²ªÈ`U™U”=†àQPç盩¤V*¦„êè¿J_p}mºøû?½Ÿ$é)Ò„LY’&ÏÓ¶ƒw÷Ä2nÄõ¥ÉŒÂæð«©P}iSðv$Üèí<#!N×£ ÛåVñõγ’ NâÃœA\@'øë€ÖC}dz>Ç—v.DW¯t‘6rñ’ÈÅÝ}r•6-´«%ÁXwNë•5ß«¥ È‹cÔ zˆØRkc‘kÁ±S 9fëps•Að'š<Û$çŒ;;Ôñ¦+íŸÌÆ͉QþZ¹W0I'LØs…Ϻ¤JȶDh[F¿>Lø^HªFáì],'=±%¤û¼Áæ.†Æ¡&Ÿ# ½P´<[6$àÎHÙgÕÇ)”•`Êb ¨ý-*”6iÛý§U??µÐxÑ5üq…é”6²ˆýÑ—§:>@}ñ œíè°•XŠ9U"å‹=¾«Ëç ®eÀ~ Êãú *ƒqýõÕX¹’A*@¹ìûQJsIÁ™Ö]¿«LŒžîm JeÈíU÷ޫɺ†IÙîÀ#£U0V<Ã[>^ß³*°©îo%sÌ\éayw¶ûˆ (^î3ÌÁ«â-{= ;èWæTÛŽø8ÑÕÌðÖo½ž€Ä€V½xnVIè·MÛÖ‡nK¤¹ßAOÄã;ѱ["Ÿ“²â´ðè©Ñ˜Ž ÐÝ6Hèt¯yP|â‡ãq+ïÙ9>îò:|ö„JHìaé±D‡ú î]ví²¡‘€+IgŸ&yÜ3§ØkŸg/¸ žŒØë ìX™ Xi¨$‰Œ¢à©5ã¾Ø—ŒƒÛð€êu¶óÎO¹¶FœÀÓ€€¹t•ÒCjújº$ÜH/GÓ×5·:®€3t¢F\1m Î' $Ìv}ëÕå{ÆCѤХØáÄœ‰ææ·7?ß îð™˜I™`8W\0®Äl½¿ùðŸmàÙw .åÒك߹ŸA—øf7{ó7í  $„s«íuLÂúRʆÄ(YlÚŸê}œ¨îþÏ#Ы0{!$jß mÍ5»3M$58x‡£VˆV騂›Bjé/CGVÑÑ ®YÙïžÎvs¥¶@}"0jD¿Æ.ü%…ïASëꈯ áyAÄÇÙ‡»ñAÐ]áàëçBÄW–‡¯)Ü<ÛÄŽ®hØ:>^•˜®¶c-ˇÓÜ‚ ]ØPðîKz@ãÅt3`³.=«%ûý8‚«"üvsmWLDŠù W%B¯ª¦ÅU&¢;"ÎjüqaV3}X7•íW'ü)M *1Œ¾B |÷éVª„ä"ÖHM»á†¯V8}"R@Ü@ò…8S¿§Þ–§Ý†®Wáý:oèEŽ¿Pá,¥S퉫¿IyÑÙ´"Î#èNA&˜ClªûVQ—<–Žð䜸Ù׫‚ˆ€ OüJO„%"& [’„œ»îL Ûiß’¶tD¬sá²WçÂ*þöºÐ°Z—5») P"ã¨ì@l›Ç#ò5ÎPêâþP`¶Îí¤|_vΩnïú‘íóÖP‰7u¾»k»Žcwæg-éSƒVùÔ ”˜·éÜ&ÌÀ‘NÏiž<ª4! %{Heá½ÐsØN§’ŠæóûGÒS²a|ü¸‡Ê¯*Ö´Ç•,'‡$ha~°Ù´‚ÎdÅ¡©éFÜAn”UT0ÿâî¾W¶ÝÓÃë•BH(Ý9=ö9z–JAí®G“õòÀ/ê:E;X[›ÿ‡ùî°á÷_ïþ/F Ù©)±É´^v[‚O¹8*¼4Á<Õ§,Œ-;åëFAͶ½±ü÷ü3«Ñ°ôÒTr¿<ÿˆn¬PÞà&ƒ8ï«ì¸ Ϻ\]¿’>M¦TŧËÃ\uqjÌ3žþb¬\ÙBŠÐþ+vY+ÿèpάêÈVú¯¿3åÿS¦RñŸ¹s½{¿Õuãå¹mû¼ ©N³‚IL E0iè7xŠßYËP  endstream endobj 3152 0 obj << /Length 3340 /Filter /FlateDecode >> stream xÚµZ[ë¶~?¿Â/l`ÍŠ)‰Aà$í ¶ÉI¶9[EšY¦×Bdi#ÉÙn~}g8¤nÖîÚNó$jÄË çãܨ`ñ°_¿ ÜóËûwú Ä"a:Šäâ~·à2f<æ‹(QŒ‡|q¿]ü¸ü¾Ý›zµ*Xþºj™GÓÐ{Zj´µI[³uT÷•³ÕO÷ï–óOX3¬,Ö\2-%­öW³KEëÖõp’ Ÿ2a*â0Ôù|µy° h̤Ƕ:¤mž)ÛWyfàÃy­Ýô#¾nˬ:<Âœ›¼ÈÛ禔d±L)­—·;`N«%ì!6äتóÿ1oˆv,›çÃÁÀ‡Œ>  ŽÓ€œL-jdÕ¿ü`y‡šœE‰_üÓ¿?Žª9b\ú¾ pchݪ&†&ìlaïQæ­“á±jò6G,üºâji¨—•,hÀÊ°wZ°ˆ‡Ð˜VšÖº\.Át] V¨;¹8ÊuC@Á„Ô¤$x5 1wxÍKz7…9˜²M "ïªzÓ§+#5¼ÃêíWßÝ‹³(»ë¯H#Cü>i@GiQ<y›7Ðg³Áòˆ'Õ* ca¬þ¯Jê$äÉ›"&Lò¤ñFÜ„Fs’ž$¥%lM—ôfå„çc]!Í·Öþeƒ"Ç¢xlŒ›ë ýÅ‚ !O¤‹ÏÒ_rª¿8šJ&–Ÿ²ýÑѪÇ6¯J§ž(bQýAêÑ3DñР°º‘Å‹ÔÈt{éfÌ¡f2èàëlŒÅ¥Ãgm~9æµÙ:L÷|‰Ó¾ó÷eÕî @ØVå¶>5)5¶õ?˜¢_î1­_)D@ø™fFØ8`B ÒEúQ 0p¢Ÿè2€Ý\¶¦d29ÔomÀ…<Ù¿CZÿ<·O!Ú›¡Œd€>’zŽÏÓ¢ëùñŸï>ÍÍåʶ ¢¬xHPXS µò‰ë¶ÄiŸŒ)é%«Ê¶® z…“²ÝDpJ]·¼¥'Ø“þÕX3Í'†tWE…^òÉbS ½¬…*’e[©‹UÈVã§Ú4¦¥¯ÖD`#[mð\Â{Ï%[­-?äuÓúNNÙ§[’:9æÕ(B0fþ±Î«ÚîV˜H`#-/º½ø ³1w¨nªný[á2ße*á©uJ8Óš¿f¢@Þ(èx iâ´ÜÒJ²¥÷;Höv‹¾Ù¨`æ@ øä`]Ü ï?~˜ãB3ÕKlÑf!† ÄÄúŸšIÇ„}–€‡Òù|ܵÎl¢\®“`ÝpùÉê·¾ëì¼{?&uïù¥Ðîñ!®ÂDìLŠør³·ö#i_Z»Ì¯G`·N-`r™ÕeåGËûýq ÁNãYðŒÄ[ðQÇ¢ . tÔÒ Ü FÓtŸÐó¥NH»•2Í&i€¼&wQ ‹ä•þOŸ¤1Rugè|Ö¡¯ÈÛY›Õ±bm‚âýñ • ½¢¢W‹x-°-æH&ØøÙ&ØØ°Q®„(ÜÀÖMaS¾6˜œÓk…ûSÞ€g£>k¤ªÚ¸ùŽl ñýª…9E.l¼ÔúõØ/ ùÀ® ɯPŠÃ êe@@ˆ¡6ìú1”´aHTô¸øPA`èè ëq>kkAOœ·€P| 0˜9¶€ƒ.‹ C¦>VãöXwq >á¹É›.*¶ÎÒàJ<àhÀӱũm{WWlE.’Ÿ‡ÞÁ=˜›K³a×ëô»ß ùÖÎ)Á’>rÜWÅÖ±Ñq×âºÚ]ÆZ,aÓ0¼?çqF‘ òãM&9sÁYè±Ó2;dygFVÔ†p\c¹ÅКßU­!¢ý²Ó½ïvüœ@,îOù5þ5îó¿^ÑáÛÉc=T´ÝFÂã"$~¸XÑ x]dú{6<|àÉÕ.LGwàȧÐéSgÂ!¶ Àwe¢ñ† odËÕ(CŽÁGÛà!£ š°wÓÚïã+—`¡i‹W÷€&1EaŠ¼9t OÝ÷¨+Œ5°UV[GÃuM™nœIÄaµïÓNƃTÙ“å§,ýöýÝJ‹åûäž_}㶠>ÙÈß6 È;È?’#•å­+@4N¶ÀÄY•0Új?‚óè¶ñMèÌæÙ¾rRßN³Ì4/Klž½žr÷Uã>4ýÝçÞvÛ¢.|^Äñ2JðïVI°¬š&ßfP©ŸËøUÌ‚è¤2ÒÕ›¢Ò$<“¥þüViií?žzñãZ)p]à&çjGÁXö©?|uΠ/33+Íî&ûî -`_hFn WbÎÒÆ_©Xp÷§Óõl é4%ÕsO …-ð)'»´ ^ÀŸºÕšk0ÖMe-ds¿¥¶ödë>íÓ ‚ G HÛ¤¶¿wr¾Ñow4¸›¯É3o.Aâ‘l×Åc øàZŸ–E‹”Ž€ê ªJÙp‰ úôŽu|n ={ùÍÖ›Oå*jY`õ/Y>7›Mtm‹ž}Òí¿ƒYF§eËš±+Kã }3WxyÊaX!Ž¶–™(;ðcc 4ªL1o1…4à{ÿ߸DÄV2BFl‘qöézæÞÒ`´4HNéÑÀz…û„¸»/Ù9Ø«çSÓ ÷‹7Kɯ û|È&]‰€÷õykàwTΑF [OD’øê‡sz €ð ÇÈÖÛ° L]D`ž†¯u×­÷qH¨vnž½›ßjå%\£¢(n_‡A¼¼µQ ™q™BJ¤ÞFyæ` ·¼ðËc?g¡dg¡\Ò1³™Ø‰ð‚J?nãFá¶v¼FË{ë%æÐ;îö lnç“Þ ëÑð“… ÷[Æ{Ùˆlw”;†°qlèPÀ·)n¨ËÀn§p+tGÅκu«b –ê\SìÑ ’AAnçsŒY]Y(pÉ v„¼c¢]h6a¨êŸ‰)øàQ…•hì`t¼ÉË{@š(ZM~™Fi–hïÇ \Šé¹™“É$¶Þ [è¾Ým6U tÀÂ>Õ«@\Ù_Ysg{eg3a½¡s•±ƒnÜsæ¡uÐ]R ›gj¼¹¥´:&³màèºöƒŠË-(ôÓ1“ñĨõ=/vâ ‹Â?àÿ†ÞƒÛ ꙃŽ¡Hùj(òâUÏ9C\pÃÃæ;B2݃>™ƒñ„­aˆC”tgC/“iÝáè‹ùBjÒ§À®Pˆ+dxR°±qì€Û j?ѽÏ[ºHÆVîòz!"&‚I‘Þ†¦¡¨ïù‡@Sƒ¤s!£Ôþ6uó·ûw¿¼ãö¢•/¸–,äb!`£0Yd‡w?þ,¶ð/ ažl×Ã"‘,²g«X|z÷™?}–ŸÃpµ#,óv1TcÌ¥ä,H’a¢^ÙòÙ¨¯]^_€á'Õ…3VÅ_ô Æ;yk„kÒi½×4ÜïøÑž´³ ¯ÿˆ³é55FÒu¤ËLÖkbÎëh¾múŒöí‡ Çf°ÇMƒ)¼=ß𮘞ÄBË>§õ™±çiê ˆúå·?`#¶ÁrÕO~F5Ì9a‰«Wx*û2À\p02Sãz¥ ßí¾:>€/ Åàî ÔÒy: ÷E|#×+BWÁ?š²Ü”Úügêb±ð7@˜±¬ø®á{SÝÕÐmVÝ  ¤çm{«7è;w?þÕaè¶&¹ü8…§j…µžäþ¡_‚Ž¾°ñ™ªiÇŽ¬mí«ՙ傩&þ…AF—Uö9D^ù[ì¯ c ©´žùµ‹ùá™ú;xÜë×¼J¼‹šX0à¸ÃÒ¼é&&’©kS…›žu+ƒ¼î:ÌMS›öX—Ä=G¿y¬&¬w —]êv×$'•Pˆ€TôR%T¾T YÒÿ 1¨„Ïè-ú!« Å݃‚Qׂ‹üЗµF™U¥ÒÌÜøsŽcŽ#+ïŠ%S#~fÉFÚ<ö/un*›œWôXLójäLvüúòhã‡|9Æ×,z 8Þet%áHГÎg –¡"ÂíiŸg{"gUwU¹mè»­PàÀ–:(‘ŠŸá3úàQæ³ÃÁZ[óhº ý‰Žç™4½µKi‡1íÇ»[·¥®¦„+¡†oÛ±Û뜓÷DŠŸ9€_ìbx" .¯ô1ÀT¥™—‡NªaRˆí¤c¯!ÆŽwç£!àÿ™›¶Þ endstream endobj 3189 0 obj << /Length 2690 /Filter /FlateDecode >> stream xÚÝÙrÛFò]_ÁG²Êc.û°UŽd½+[ZKYW­“„,”A€ €R”¯O÷ô € H]®Ô¾söt÷ô=ô&_'ÞäçoÏ÷‡Ë“×?ép²È÷ÕäòjÂUÀxÀ'~¨—|r¹œ|™~Jó¸I—³¹ÐÞtW3®§ñ*mRhyÓzöÛå?Œè€ <&4‡3Ìþ¿á 8Ôc0Äô¤ÂÓ]çÓψƒìlÖLÂí}ÿöãå鯞ö„„_n!“3 eh¦…œÌ¹boiYÅÕ·1œ%g2[œçZÉéç봘ͥïOëìk‘ýêy"‰‹‡‚iŠŒø½©bZ“y>Ï šÍjNâMÌÃöâŽæŠÍ*­²$ÎixÍ„žÞÌ„7-›¬øú †#šI•Æ5 в–\9^Læí9÷XääWñ]Öuš¯™¥UwY#8°$„¯`v÷YÍ}~À"ŽŽEIY4U™×tTsR£N›Æ Œòj0 ”/@nz“gë´øpîÉËú•ƒ•É³ðb³¨Ó¤ÉÊ‚6‚ô=Y|Ù¨ð …FhFðÓg‘'ˆÒóë¸NGøa¸¨:"#Aâ$IëÚ©ËânÀ€ë²n¨7ƒ©…¨¯YQìð/Îs«~ˆJ}%„]OüÏg!­ël‘ÛCoâ|“Žéƒ˜çïè°åæ\ æ;Õ¢Á,ü2×ÚŸesmhR*4ŠßeY¤¯ìÁ]ý"lLJ_>œ_Œ©+È;×nÕ™b nbÃI¶‘øu’F ¤QdÕ÷ë¦Â‹S*2׃Úš# Fë"Ÿ)?°ZñzƒN£öEíõO¾ß»Å@¿`³`‘Ô´ùïD¢ßÕRàƒ…Þ|ªhü††ù\Bî £øï‰èÀ±1!!°‚O$ŸäW4‹„äEòøÀœ?>ñ•:˜xПfžL€xPñ>uË£GÄåñ<”H8+ðƒ§Ó)$<:èÑ9 ̇¢JlÿrDé.”î¢ûJw uëá2òlQ[L‹¼6ÖÃÐF”}T#@Uø6a×;D°Ù€+è×Ö¯²pŠ« endstream endobj 3092 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 2876 /Filter /FlateDecode >> stream xÚÅ[]o\·}ׯàcòÂ%g†_ q*'¨c–6Mü ÈÛĨ!«uáö×÷®¸‘iµ‰©-ļwyçžËÏRŠ¸à4uQ æh$g±7²K&l—KïS]ÆFs-E4jp1ÔÞŠ.J,Gh L&v«0n­ÿj.f¡Õš\,¹ßË.ÖF»è"AÅI lFÃócã-Ü9ñê7´ÿ`Blµvd«©“j-<Û*_Öð;£•JÊláZû½ê4I€ËÌ_cÀ ”¦x hÓÀ{â,äÞRŒMëýÌ™ª²…ñ²ÒÍÎrè¿gÅøòPÕÒû5—BŒ\Š–ùÑ%áðaè0Ø‘Oà³’u,¯”ðr´ -« Þë)ks•†sí_Z]*JspNjUø qY3À©Ù‡9£3Z ®¥¯bÌ.×ͯŕ @r%ögqY„ã1^Åú‡Ku%å†wHs¥"Àx•j´¥ZckìŽÇªXaË\Uº‘âj¢‹¢fW7N@@ÖÒø^EÄ5ATE|i ™Ha¾ ý-º¦Ê'§Í Ÿ0O´gæZ±ÞJ®m¾Ís!ôOø8FNî^Ç5|+œØD¨ây†y‚Wq—Rls—±+-àËi¬9|­ðø´»1ám@N¬ }cJŒãľ¹Ñâ þëÃWÆVhƒÐ^2é!1 Ž‡07uŸg¼MræðâpTëM¼MšÔ£GŽ¯þó~é_Ÿ_¬'~^÷ë§oÏÿu´øúbõf¹ú1 -„׋oß-ÿûÅÑâåòlí~4«^ˆ°FŸ‘ ¬UŸéÎ=ý¾r¹Å‰[<¹xuá߸Ͼ{üìÕÓŸ>SùéóÏÝ—_á¿O‚ðŠaÔ|a.Í÷)]qË. m&mÁ+Ãic–|Ÿ/ %õV—~¾ÄÃo/Î}òi)æût«^¥'@/œ‚ëo…òìå·'¢¢õí ]rôŠÉ Šûõv§l|256Dàä} A ˆ‘J81#HwƆę@0Ù}¸‚œî u sg‹ÔäfIl ³…Ë]õÌp¦ÅÇö¬ˆ>ï0\¦ºC_™G+æ ò‡å‚I‚dÚ 1²Ó%1Ì ÒâS7E)ÅbkOñ€@TÄ[†g¬øÖ“Eò‰Õ ÿÞžÐOßýrqöO¯Ÿ‚KÝõÁЀe¥qÅòDC,"Z°l)&Æ[Qœ½]/ýéêÍ›/j›9e§HžXÏÈŒ Ô,×ÙvzejêÀšâ ‰Qð䆜Næ‚ÕSæÇ7°°0÷Ò-þþÃ?\ÃBiärÑx÷îõÁ’zÏÔWË{zKò`!˜Ø­»n?Û ÜÈ„7‘¸Åã‹w«“÷§gK§›g^œ®×ËÕ¹“Íå_>®Ÿœ¬O×KFn-Ž/Î×}HŽ¨z ›~ÇœáMÇе8.àÜveîáŸãxprÙþvœÛ¸($¹ã"“š÷ à^¼X]œ,á9€ýæØ-^-?®Ýë›Áðâô—å¾î|½<__’?÷çéóË‹«³åå†Á÷{ß/ß¼=ýúâ£ëa’AâÁ‡áù§+<>Ù;ö»Ä‹»"ž®„®6i4òhl;×ÑØ|h—@W82:6i4òh”Ѩ£1,Ça9n,¿žEÃ2¢š†´ ¢Â +n ïÀ}T˜M(]¢àðQðbÌŠ@Õ…$+íP H±˜P&"‹%(.CZ5†5²XªwŒÆ³ãçO0i*K‡bI.A.$áêŸy,D=œ["ò(”±!÷Á9ÐP¾‚þ¤Œ»z0­ _-[@9°Æì@qC)äéJ¢Ñù›R€‹|¬é JaCѹÜ2BE·Zìð}} CÑ™ÉR±-E'À,z@Š>\Qô]„¢K+¾²º‚ɬ‡±æÀ²riÞÍÁ$ÍBùʃù^•+-‰5Ìž{XXœ«6ºZSÃ,AþÊЂeóå€ l¤sUxB(°ƒg…É@Ó½µý4Åð{~ âÈ2sŸ¹ÐVõ-"•\ß®'O~ø~žb11È4éºQ3+Á ò-ö÷§VîV,o>¼_}fV}0úB’klsR!àÀñ"‚³+6òÔDšÈ¸dÀH¯×}`”©Ì~ˆˆ LÑÆ5ë¾Dn&øâ@AÅÂmƒ½dÓŽCÚdN–´woE®©¶ooÈASÙ³w*XJö5-Š³è}½¯ÔË9B÷PúíšÈZ+Â*Émbî†JÛSÙ݆7”qƒe˜ægÁè“tÞõM—ŸÖyÜѹRQCÅ¡ÆâPcq¨±8Ô˜ŒŸdü$ÛŸ†P“!Ôt5PÇKu¼TÇKuXÖaY‡e–uX¶aÙ†e–mX¶aÙ†e–mX¶:UA ˜Ì ÂY°À ¬pYdAùýÚ îͬAÎQ\d]QœS$Q~ø÷c<± Å-r îýîp•:'KÆÍ8(Ò·ÔwS!¬€Œ·³PëÜ܆k †ñ©ªû)1jÖôÕx@ª¥ºsÃ-¶‡à E] š7)Œgü"XŠÆ-Û0æº Ÿb~&ÌSžj†wë ®‹ Ç ]‰ÿ‚‡Þ•èžÝ–©3I ø½&×9FH›¹fHù¶GzùiTdî-Æ]ï8ªZVÄ·Rïë=Î0p¹ík;‚LÕÜþgnžG¸»6á¤ÂæðÆÍ V-¾‚e£”F]'ºN£4úäQ1Ê£b”GÅ(ŠQ£<*FyXÎÃr–ó°\†å2,—a¹ ËeX.Ãr–Ë°\†å2,×0³:µUßUúù)äK¸n½±{bS‰ ÷YÀ4&`„)bþu÷€îr3×—‰¹V¨ý èjð¬J2× ék½ãÔÁ\ǃñ›©/ÄÿV !Û"ëOG[V²Û[ñ¼?]þ²:}ÿë‹sÑ”^ºB:ãß#„èù7Æ||G­ä÷pdî‘íÊÊ*Bˆ* ¡ÀÃù !uÇBð€p¤Ÿtl›MÕ7’Ë’ö˜‡GsµÅË2ãµ^á˜ÉÁª¯ª<¹ÁHÉó/<7xÁì¨ Mö˜Ý6ó ÄO§@¬g„¯‚N"Íô¸IwÐÊ“·ÿ]žœýúa5wH²Èg‘íñôíåúߧ«É8,¨WúbàÀì¦òØäÙ‹—Ïÿ6S”"ÝÚ5LkïðøùÓ‰ˆñš/HÛnßýôùã¿ÿ°É3i endstream endobj 3247 0 obj << /Length 3673 /Filter /FlateDecode >> stream xÚÅ[_sÛ6ϧУ<¡Ä_7“›isIϽÄñÙn;Ó´´DÛœR”KJqÝO»X")Z-Å}Є@» ìþv± F·£`ôý«À—ß]½úæ½£ˆYcÔèêfÄfQÀG&ÒŒK>ºš>ã<ÎË´<™HŽïïâ2y u)ÇË»„WeRPm¾*—X3ã2YRSÝ+Í—É ×ã[êlÆ_N„ÇE_gÉÉoW?ÀÊÆá§G.±z¸ø*› µŠY ]Ü /OyçÞwõêWßñ‘Œ #눑r4¿úü[0šÁ?À¨ÒF£×s>ÌX¨d£ËWÿó\iN&aÚ6W.ßþçÇ ¿hbg‡—²PFÕ—‹3€=é_ž-‹›Ÿ.§w«‡M„²Lq3šð€Ymi¬y¼,Ò?A"2ô–m›»Øp¿À&ÿEü8Çœ^^ýôíEŸ‡~zdBÅdÈa´PLi‰‡bF«€7×|ÉRÜ‘XCF§fé4)Ûu⾫£‰‚G `q-Q\¹·DÐá>44÷v9Œñ¡aaXtv~ñéç­ôY[u=l.Å×ë©Þ~úð2S}üîç·ÿÝ6— dpÀ\ª&k÷\Ђê|=’ ã¬\PíÚ‹y–ü"Ofôøk ƒYrs¡ï*[6%Ÿ­Hìp†ÐJµ7ÎCšeÐ]ãì¼â!-z¼öå}±Àýô%%3˜†×» ¨?Ò õÓ çÜOè^ÍKª$¬b?‹;Pò×T ?yA¥¤".üìË"‰—ŽJlõã¬ÅÃ/£/ƒöêþÜxÖÀ_p•8H‡ÿ*bÚÔ;þŸ¨a:zy<]Ìï³déGüž.EúW¼L9ògŸ¥Mü<­žæ8:Œsféò±guZ±pml`u` @çSÔ×RyÅ-u¥:°Vy|Ÿ:Æ¡fZÈ.)ó¸ø½ìß#2l_Î¥Ÿâéªì¾ôÇ‚Î>¹ó åmC€95áš"©¤4{PþÍ{R ½(Y°>oà`ÁNä=4r©Åâ†ukêòºF•Îq”t¸ï“tŸãHy·Xe3úçn‘Í y­apm刖tþîâã&täÆ2!¢‘–€Että!g–ÓHÆúósz¶ÍèÃòBÓ`Ù@¡ f#½ ”™#({úlÑ··ðÒ˜âÞ ýgþÍ@šA¢õp[™ .WíûL†3Öìpí\G`« B`«8ˆ¯ÿH=¨º©àTú†¬Ò² ØåÐZÐ{ü(TÛˆ ð™S]Óìá¨CæÀM{‡íl@-tNŒ6.’èsQ“Ó²þß•wñ‰CÍd#±%¦b &,:Ê|<£6oŸÝß ˆ…Ï$Â:‚ê“­æ4ð÷™ìŠ4tðåêºL¦–…r¬˜Ùâ“W¹ÎœÔ[RG2!üð²¬0‡t‹p–Šˆ  ›Uj[R´ÊUéߊýPˆã¦«,.èyWX « Tfàöé5²v…&¾^ÔpUwàª~†:—](µaâ¸í±q]ì¯x­+Þ~ý¤g¬Ô×ÀQòPxroÒ@Û€ûR¦·Îeso.üyöXÕÏ’Ü…ñ¹„­_?TÂèìñµYsAæÐEz{·œÜÕº?¦ÜËeûm4z üdèÁ Æ@{èˆATǧ¸*Š©µ²»EéIž­~¶þ.Y¥Fw3·ÝëW5µç°9M½]~øôÝVÀdo QKS‚Ó“±ýX©Bf„hãöó“äUiÈP™ñ—Êóü&.È#yD®4–XB ­»> ¢‰ôeÀÇÿ¹=‚fQ«¤3`ëâ`•Ÿ¨‚Úz¦/6Ói5S `¨@°fT t¤ <­h$yQ_ž{qùî«ÅüZöÓg$Sƒ>g›¥l o©Hì—dåX)TÔBÁ±Â‘”ð*ÿüêb—¢Pώܪ¨ÆÁg¿ôxT _y ÒD`Ü9o‘¶ã´l1í!NÜ‚£›„¿…¸½›RX8à(ÄÙ Ó!®bè^ÖëÔ©íÊSгêÔaôÒÈÔE ‡j ‡Ø`X„ ¼šÈnUžÒ‚qˆô1èC?6Ôƒ¥§ZÎçn¸a`»¹{—'áF}'Ñ7Ô! ÌF¨Ó{|-Ö1’ºø ‹NÏÏ­ý5­4Q ‰Jƒ÷èú%ôà\è„Þ2>;LM8vÝrjóƒÂ Ëb5]® ß=!ðjrß}8xuÎÅ‹  fo¤X$D3 µ‡C?‘"`êi¯…†7ûŒ÷yõ¹ À°*jG<økñZî¾áaKø†Gkáã ß•9u&—‡Ú*é—FAmõ¨ éc»—>Œœ/Þ;½×ë<ô^ úkRØY¼›ŽDzRênn¶TzRj;4¤ï¼tþìˆ>ÎŽ†¯Ü"ÝRÀ¸TÀØ…4#TPcérjRÀ§‡»tzGo´Ô"rl3× Œ=³<Ü•ë5Á»z¼ƒi±q­æÅÍ’Vþš•‹4nNuºZåÕEiPå®CSšD  wÛ®¨P࢕Ž&<$j‚AkA#¤¦Àð™PŽO+NÜÑ 5w×Èîòºf o°Åq˜nàñ±±[=›«ÌTÌt餪?`Ù¢øýéçª;Bn˜Z Ö8–]cA]ÑH<°{+QïZ§ ”'1î|¬}ßãéÂ÷'U¬ëÍÓìþƒÓì'ªnÐUÑU›—G Ûa þ·}@â/RžLzé/H$ÈÁ9ì­Õn¹•øÕtŠšžÀ¿z–eqƒë࣡ôÄ9°;½w÷cFµù=_Õñ5þË ìw³ÊKgx©±L]z¾_c`(±7?Ž 3êTÙn0¦ñÅÄs8àh}N×Ù‰Á°¾Î0«·}¼Ñúã-Äí¦âüÙ‹¬Ò¦«LöXçÍa‚Õ¬JâØé¶5ýáîó­Õ¦ö~ˆ¬O¥sU\m'ð»«ö‹õ·VØ<\çÄÅŒN2Àyà¢5dÀº-ê{M…’Í¿Éz)žcÚJ¯þ¯#±DE™f(¶9@0Ù}¬`™<.¦ŒW<¡h½Èäÿ5ˆ• endstream endobj 3277 0 obj << /Length 3633 /Filter /FlateDecode >> stream xÚÍ[ÝsÛ¸Ï_¡¦•f,˜¼™<ô>Òúæî’Æn§3¹{ E*bC‘:’:Ç÷×w ~š–%[×éC"‹Åîo?{³O3oö·WÞ#¿_ß¼º|«ÌÌ°Pkv³žq?`<à3mã’ÏnâÙÇù‡d•Ÿ«Å/7ßÃpÑ.9“ZvÜW‹¥4|þvÁÕ¼(KaôÚ×ûÛ*Y-ø¼Niv=Ç•1î>'AóGÐ •£×SDL ‰-X–Üc¡ I8Q1ƒ§‡3xŽ]9f—-,;ï³$ª˜µkÕ›¨¦V¼ßeé*j^$y]¦IEiÞŒvo+rCÌîH+øäv!¼ù¾Nbê,ÓO›z¹Á%чiœXõ.íV†ój¿Ý&10í‹pþ×'J&{J¦BæÑ(Ù÷ï¾Èb¤‘\3î7cß„4û*Ê2”—­œºŠ<»§®[Çb\ä õDkP4ꌨ§Ú¯VIU­÷u¯†­ê¢LÜVÁ°Ý†6?´²FZWô²Lª}V“˜–bBˆ¡°âd—ä1ŽVŠLEùns £.£¼Ú•{,vvÚ“ÉyÀ”§é\}óÓÍ?{Ê á?~H¨¾dž ›ï.=¿Û¤« 1YmŠ}c …Ô°r…—Û"Nö<‘ÄM}—$9=D'®@ æñg«Nø¤Ž¦\Ja˜Õp¯Ž˜ºØ skcÕL@j5¿±Û }í :öÏh_ÔZ'Q½/ÝC’G·™µfx EÑá|_YåÅ®‚~weü[K%rd{Çv]îWH:&u+,úÃ߯QˆÞ•&e » Çˆ~Ú×wi½¡VUlj%Û]}O͒пB­cΩ¨¾Äg!7ð+˜ÌHYo´u¬¤Š© UîÅ6Í­x`RgGÞPàd¹nE+DÇ(K'MõÇŸ$±Ÿ¬GÄ«"ëý ¥ž JTl -=­1ƒ…K¦¡…¯=·ð÷S.× Éï»^ IS ÿ·÷#ö6EU»%íË4ÿô{b™-šÉ81³ä>ÓpbRËÓÖ×ÇäwÏg¾iuà‡ÉÅù ?Ï?Çâ|á<±¸'Í"LiáìB?nÙ>™ ¯¬BóNí‡Q&øB-‡´="8ùq©” ó$×=’<è=§ýF€#[`1vy쾆‘Mgêh8ÒAçEèqUlwUå5=Z4m?-ÀþáC7­DV«‡€¥ŽÜ‹ja}Û}ƒc›Q¹Z·.¶0Ì`¿¢ºAÃ$*³4)Fç5+8.½€Áƒ`žm°®ÆÁzëéz»×®P°À8¬çOnŸl< ¶žíöé`þ#ÔdWSïƒ(;I„q~TeqâKˆÐ¥´äsÙqÓÛqxlw¼:¸úûmá3730D =óç›8) fB},>‡R¿Ÿ_Ägáƒ/õü3¬Oø>S¡ÚúúøÌN[-Æ?ì\!!b~ Î±¸P0®ÕÿÙæIÈ”äu/_Ÿô5\œ¾¾6¼!”\ ±æÔÂ¥äÜÁ%¾ëÁ%>"Bº]F† ¸b²ƒMé68CËf€RS˜ Ï„Ön°Õ‹úÔ$V±Ö%^ýôöM äQ)¬é§°pÞûIN ! ƒ ãó׺-b€³kDd½´ÊP4OœAúôçP%ÚèîÇþøþz"hXJ/=F•˜zäð’<~$‰™*n¨®¸q©u‘À¶y×ükÁAW)Lr)Ù“È5ì_îV¶.‹-µ\5+tn•ŠQÐXíKü,kb€2预ÈMà•øxÔçÛdí³ºÕMå©bB>Êe¼N°½ÀË2;ÎJ×E¹êúöX ꦈó*G? {{›fi}?yú,û N¯PS<Ù E?Ý…î´¢Þ.ôÀÞQè–¨’”%Uwò(»¯ècé6 ºSÈßCÜå6¼ƒ÷e‚µ¤<ÙÒ¾Ã@›º ¤"Ëšê…c`dR§ žyP,ãÞS¦®<¦õ™R¸nZþ$ ©+R´jï*sгÛA$OÖ^ð@¢è¦‹/â¨â‹ÛŽqé%Í—+H.‹}½,ֶݩý»wßt£¾¢ÿøúÊiõyP”Ö³Á6N„}¬ùDKÁ ØÆKÂ>0A”´v°{óãûo¯>² ‘°8WYer‰Rs¦øV(µÏÄp}ï?|÷öêߧUxÀ<þQ•X‘1£ÒÃdÖz•÷ÌÜÙÆ0ìýÈBª#â„H´>¶ªá˨ŒûõÖ²‚ï'2no”kOòûnMFLÚ®iÜ4ú5Sx$ŽñœË3®È½èm³¤vOà½Ëô µmð¿Ý4uXóß•i]'nV:*µ>õ3•IÔ(Ò{Qp&!ý{ºzñ˜ÖMDng ‰Ò -êväE¡Ð‡$ë‚¿]D°iOšqš)Ó<&?V¶nUª“bŠ*ÍW„Ñ!½ýÍèeYFùç.n|,"è´ ýVÑ{|>nÛ…|”cÁ}iÀ¨l·ý7ä»qd' 83÷ôDl`)ÎÚ#Íx"²ÀGJŠÿhG¤`ú—• „:ìˆDqkp†J2ƒN¸¢Ã+,ݶî+*,zI/MÝÍÛÛ윖¶œyï"/ð¹‹êÑ©FŒ«ÂîÃ¥_ ÃBãqû‘­K 2 u¿ÐþÜŽP.ûïxB{¯‹ÒFZº=C\¹ÕU è8lê,t“ÀRIj¢á. Ö—æib>55ø&µž¸?àpb}‚…F{@ŽÍî„yQó%%¶íŠþxf¿v‚iÏÔ”kÄnW'Àæéìsº@Ègð‹ ÿBÑÄt˜¡æš|,àÚñ°á.­’‹‰Ò ¨ÆÝ“Ò½ÔV7»®§S[xïR[X6Ÿ_'—QFHa+"²Ïcº²Ò#\EöætõM@7©ôÛ[&Tí‘zSnAÓ2Aë ¨ß]M 櫶ügÜ•4ŽÀvmÜÀ‘#AZÒKkuôV?"‡ºj¯÷yúëÞÙl¨×éÑØïâ!vWy:`~Ъdê.–I?`¾ÝVj‚ÂÕ\3ÿ” K¿T±Kv]颌VɃòð–µ> ©&û¶ò ƒÞž†A#¢ºCl #Vè ÅÖ­'˜,Åô®é7¢ŸÃ'=мá0÷lK´«ÞÜ'èšðÇŸB {ú½ê°·F»@Ò¤M–(Ü2"o‡¾=ŠnhŸu) ð×Å…a˪íu÷è.b+¢¡•ûó{Û"ª»´ì{6j—f¾uh(–£Cÿ¤UóÖÑbrÂÂZ{ËÂû–e|ƒ,özH ºëÄ ªÑ$¸áGà·òDL’7;!T6Lùú%cѤ©S‡}§Œ"xoÔÀC©œàŽŠÌl†×9ªÛÚ˜?¿ª©¾Eu.îΨ±Çù[nÏ–ÿ²Peô3º"¯ðÐ p.µ×Iq|AÉ~Kc{á.b»¯+÷G9NÝïma/.#'yË uôìÂM\U…nB¡\J)T6ŒMßXõA¦¬™{šugøtGxaÏ÷[ÂH5Úç« á¤iD) ^n)ô€ŽjU¦Ö}¨æè^á…b{L–EîÎ×T0 ì‰ZÙÜ €l_©ðÁ€’ÇîÐnt.‚ñ¯;‹ÌûÕ„\Fèûç?]Þ¦ù¥]ÏÄ>$_vE ükPïV†£J:˜ÆA.ð’B÷my@è@í pAKÿ 3Bˆ.…?˜‘R˜7¯/ñGv¹ÝowÕÔýÈsÁ _Ì‚Äû ¾°GutùºA€€…Aðì]1’‰PžaW ^Ä‘GìÊËgt»ÒŸ‘²­7¯ÿSÜNŠðÎ1q¨Y ónïu¦jƒ>9g®„ðÖŒ¤ûú¡ÿ á¡›£c•Cf#†Õ¬þëÌKŽ endstream endobj 3191 0 obj << /Type /ObjStm /N 100 /First 1016 /Length 2857 /Filter /FlateDecode >> stream xÚ½[[o\¹ ~÷¯ÐcöE#‰¤.@°ÀÆi6i½±a§è%Ƀיvz=ÁxR¤ûëûQ3' ûØ-”ÏEÔw$Šü(j(ææ‚£X‚‹”Tˆ.eRW­ª@N¨ßa—sQA\ ýåì5Š‹aû¬º˜B8€Ô ²7¬PÎY 5H9K- EfV -2@B‹BY[ài©è"qv± ë= “Ž  U5ô§ªŠ´Š?¡÷VUUST Í()Ò@;,h–ƒ~|Ãe¡¨ZÔ\wÍZcôAà˜ú½æ8eE…fÌATŠŽ…£JÉq.ý)9®ø‰7ê÷ÄIضÍN: „1ÀÕHÕ çÞ¢9…‘bpRRQ):©9¨”œ4ý„Éå˜ú{˜–$U%q™j¿—]<€T0iÒÐG¬.—Öï5—›~QJÁ•Ð5§èŠN¤ä þªD®°èW&vEjo!®”ÔßˮԬú²´–Д֘z‹æjEOÁUêß‹!®Ò¿CRJ%rµô~‰]mÛ§âZض…õ‰JT`jÑW×tSÃ5 ªZ Zˆhj’…z[ØUˆÜðBªÚÓÞŬŠUû汄þA¬,ÚC„6½ 1ªÑ'†¨!BC¤>oèXϺ"±R r7G\GªOŸ,ÞüçãÒ-~¸¾^mgŸ~Þôë£Ëë,ž­Ö–ë·¾!¼_¼\¼Z¾ýâ`qº¼Ø¸·XÐ^ Ñë``‘{Æb…ùø ÞûÁ=}êgnñãêÍÊ-ž»'¯Ÿþé;÷ý÷ø7CM¾a Š¯0Á) g‡/ÿ|:VŸ‡c¸…‹oò„‹_>­ºZ] „Qtôë Ö8Ña¼ ƒ8ú’o'„Zð!å‡a]}h™}Å:Š\|­jƒƒµ!˜â»Q\þ¶ìHÆÁ`|´ú• nÉk™Bqty³ù÷ùz4ücô1*Œæ©©çÃuæ9ÖˆÍ<„zk›Ø¢âl+$EŸÚ-ˆÂ˜zÄØõ†âIãÜ„.iƒº:H°F«A`¸L†ÿš€póéç´¼\]{ñ‘¿Dòê"hAp§nñ׿ýÝ©q!°‰ëOWWïï}1†ÐßKñ„˜ý¸·%UOð/{±¾X¾zÛ-WW«õÙÇó‹¥£m›“óÍf¹¾vi{ù‡Ï›Ï6盥‹ýÆÁâÅêzÓ‡å<;øÜö½ùÜ‚]€óµh}¹ï.Eì5ÄåÜ)÷©ãâd½º8[bV€âù ·x³ü¼qï¿žè“ó.ûz³¼Þܨk/Ú^çófõi}±¼Ù ~ï§å‡Ëóg«Ï®›"˜Y´žœ¯ÑÄXv»ùÜ ãN¬OçÕ;L`Ä„¼š½Üìåf/7{¹í_.&T¶ƒÐ©ôNˆ&$È6ALÈ&ª ¦9šæhš£iŽ¦9šæhš£iŽ¦9šæhš“iN¦9™ædš“iN¦9™ædš“iN¦™L3™f2ÍdšÉ4“i&ÓL[ÍïG¹Šæ :ÉUC a4 D(ež+&tLÙ \¸2wI¾£Âe¥iR g•3¼eQÖw”ñ?–àÝœ÷äôø/#‰˜TÛ# DqÁúFpx|40~òšÜî!Põ‰À„Ÿ¤3æ墹è°L Ã` J(2Ü™Höyò,_°ŽEÿ§»Cé«Ã×oŽÞ=)ï¾»:ü´(÷ÖüÓg&æ[œ †åƒBÊ3Á/+ù\Vðõn'Ëõ¯¯®G¦ƒìuƒÊ ûÑ”)ßÈOBÇt ¤*€I ¯G²`ÝPÚõN$@S¦zÿN›à¨XnQpÊ>´¹Qì­2d_%nS€ŠÙ·{Éî×|×ÓHŸ:Ûæ&¾‚@i×’ ¾ñäZmèb­‚<“R·YîbäNgq]ÓaüÈSü‚`fÂC†ÆR*_]|DO‰ ³R*fG°`òÝþxül d ”– ɘn2ÖLT@¸Žõî18}y62"aÓ‰7Xµº§;…àh,‚Ž©ë; :QƒWë_nÁ­o–7I`E“8ñÛ'™Âq:†9,†§ˆº‰[›`œšÂºw8N6#½f«dÞƒ@RƒÀ: âõo‘îã ·ã2Æ€pµºj› ‡¤Ûq ¸IÓ tuŒÝSE¬ªí š”š¶ˆá ŠøÔ£øÇäK¿¾Äh LÈ>‘‹–D†“Æ°h©ë4s›ÁW2’ Òšä¶ð[–©þÇzJÛF¥‚¨ϔ੔çQ­HDÇfÈÇ‘.¢µ­,š“šÇT[)4ŸçÞ‹†íP÷ûË„ûe6Ç­Ô®õ͉Š ûˆ4…b¸ßNˆ¥Z“4 àW˜ 8…a°Ûæˆh™¦ ! ˆ‚Ô15-Õ"Šåy¼¶z‰éÄÎ.§@ ÷Úf”ÊðõE àšzF© Ò y¼vÂlô­àÒsò)Ã1` òÁgõóîpZ#S0щÀ˜ ŒX&œ•ÒMåñ§5–óÊWt¨k5tn•×¥Íd|a ¯}XgNÜ $¥¹(x¦=N±Ô) ¯_¿{’hd*̘=²‡ÑಔpÎ #"í-HÄúEŽN†y(õ¦8ÏŒ(†¨§Eª&…[ Vá@y&ÄïNÛÃ_0Ф¹ú&k¬Ó'wHRº« GÕìô“ ýäY?Ù ×%Í@75 kMOEL]£Éë)žØ÷§7‹ÂȡЬ'ëq½¥{!ÖG‰c·˜á£³«p ”ºU ÈMS:‰‚Ò×(´`¬ç UµþêE«,3ˆVÃjYY¾¿˜üeÍù‹ú1.Š+%=ˆ;†„<ÃD4ðžšœòMÿ‚F@*®ó=éãÙñÑX†ç¹€eŠDzÀðþµÔöt´æiGãÇ„4jMüOK5àƒ óÀ¤Õ‚Çú¿± ¡mï6$Ýí˜Ç2´x§'”ö rÔõ:…a8Ä7Ö™ØA üO 곎¸ƒ¯\oAÀ’–Úçå¢j™M·…û/|£Ü1®³e°z®”´¦l8àÂôg³ãÐ4é #eÔ_[h‘7ma…úèmò»öš÷2IFÐÆÉzùËÏ#ÏbDÏý§nÅGÝiàЇÀy:M¿;=æD[Â@d-aPu-#À`¥MfØ2vï®\·hõd[Hú»>tw¤šÍ>‚Ö6iC{ß,†ñµ}üœùú endstream endobj 3317 0 obj << /Length 3697 /Filter /FlateDecode >> stream xÚåkoãÆñûý í¹8íqŸ$S¤@’&›{õì´’| %Ê&Ž"’:Ÿóë;³³Kq):–t4@?Üiw¹™ÙyÏ:šÝ΢Ù÷Ï"÷ûõõ³ßi9KXjŒš]¯g\ÅŒÇ|f͸ä³ëÕì§ùf[4»êba¢h¾¨¶Ôà"¡{±yȶ۲Xf]QW¿\ÿ6_ðˆ¥:¥ þD3¯vÛm“·-õ^ýøêí5ß¼ù†ë¢ÌÝç¸ÌÚœZõš~o²5†§Ú.o6EÕƒ¸én# šÍÅBhÀhM¿¦%<®†É$¥vÉzbWÍ$¬p'˜ôìÛëg¿>ã0ÍøLpÉ„IfÆH¦¸˜-7Ï~ú%š­à#ЊÉ4™ÝÛ©›™`&…F9»zöOw?<\±Ý v¥S‘|‡gJÃRÁ?Ç™2e†óðÌëWoÿ~ùnŠdp®Ô=ÉnŸ"Ù‹Iºì±ùT²K±>Ù¥Œ˜QÉd—š±Äç8S+ÀqDö·ï¾ýîò?“d—LÆòh²ÿÅÊéB˜˜ÅÂ@ƒ3‘Æôíò›××/Žt$$üÏÝVb°•‚¦ˆý^˺±ÞÖÕ dWr1ïj÷{—Sc“},6» vø¼-~sÃ(ÑÁ¼û rÞ¼/ª[·0ßÔ͵Q#àï« >Ï/¸$õ<ûz]îO¾Ë:ïP­‰hÉÍ¿ŒÐÀèiO¢eFÊl!`©LBõ‘•e º''å±ÍjØ/M½W7*š?§±6Ï-ç0`¦g *dßy÷ý³ÙOvâÕî¦Í—¤à°¯Yâ’wÓÖµ;ˆåZå]V”- ¦û_@; ” K9¢§™‰c´;Ô»$¹=›}q±P.a‰(æ –e$æ7x_‘t· wuÛÑPÖшû$ç7p‘z~[TU÷hoF-_ §­‘ªÙ²«›â7§ïñûÖI;Wîô¢¥ßº*mq[?G‘€ íüGÇþ„Mp±öP$!‚}ýаHf¤v¤»H€Ú¶¸)ÝN²rzHM³Èð=5ƒ»]hÐ2Ü;¢ ¿sÖfžgË»1ÏO"mË’:!ßzvm·ÙÒ Ýdö&±éÙ®'IÞvÅ&³Ò†Ýe½Ùî:?{µkz®ïWdUV>´Eüâ;cTX€Ïab@TìuÐß&¨EÓ¢§)Ñ«+lÅoVaFë|òê5¶ ‡ÿ+âR«nzì‘y:¬v”ÍÃ+XÃ\ Å8bü=_g»²0×´ŽÖCÞýÕŽ:’–Ò™†6x——YÕÛ¬AŠd›\.Ä~Š¹ãˆ }ÀÜi¼‘ÆÖLįí WÞ aa­xï}s" &£…и|ñà¬\ÇíÖBÏ×yÓþF…r0¼„¯¨ÈãÁõ8ûN†¨##ÇC=çVr’0²2Dï2RоɻûÜp‡€/–n)0N$—êug‚©ÜØ@C(=_6…•-’pü‚]¾@+‰«ht@jX5¤,†•4zESïêrEø£ûȤ}|Ò IÙò=Ͳn'ü‚ìš‚HûX²ìœÃ÷ÄÄÊE5ÐX=TÙ¦XbçP¦qI²]ƒ! 6v‘Á‚l,rXÓ/Qa›û(Ö‚ÉW~Ë]جGK[ MWûcʯý~ÑdÕû)|zЭ3Þ5»e·krŠLû¹.ê|I{yÇú¦ÞÙœBãN™«Àúû¦5iÀÑøëÏAéÔŒ€ÐYŸ ¬»à3¥|*P³i–˜¥qÄ­óÎG æî܊Ÿ…0‡:c¿ÈØëdgáSŸ í‰`d½+K"´0}G²£æÇà×ðCŸWOk¹ýB%xƽö’2{5(€n°Cåàn…»[‡FíÆL3~Å~±> +.¸`Ç+ïÇÐrÜY_`AËD^N>x˜‹”)ãü‘«ÀxªA­lÂåûmQ¡Ħ3løÀ˜ÅÔø{[ ¡> |ú oNÄ_¡PíC™×ß½ùÞâožÄ—öÎ9Ð=„z"3½¨K«°s:3¦üÒÃLˆ£n-Ý3#qÝxãq”ÒM)ç|UÎ=•®à&c²Š§Éª@>$k…˜ «Í?8ÝWïºE½v¤ÅÓIËau*Î¥í^Ðù¡»>V€B¤vq«Ú“Hž«¹ê5 ³ |dmìH¨aà %˜@ÄeÎU‚{¾ãÖ†~E¯9)A(AèöJP9% %¨ÎV‚\òs•`(Aî•  • 6:-R‚"•©ðJ?ßÃXŸ´ÃÎÁ;C1“$ÇdlåQÆ¡ŽT·u½r[ˆ·?bÊ“d2¥šÅé]_ÔÖ8á,t4±Ôé}¼7†E: FcÓ°T¥Mx{=+S3djbé´¬<4òø¡Ok2ÃøžäEø¤@|<è½gqÿ>›…X(ébòT"ÂMkfÀÅ^êž”Éÿ£Q¹Ï ,X‹t”¿ÆTŒTæPÕIå¸>–ùº£–;ðKç>­r¢ÍãEž%Ä%»œF"·ÔF›¸˜ª#86ÈÎc÷¾ÀÒNÙ—Fp|í'o«)Þžw|MJ$¨NðgTcÁ!WcÁ¦•ø¥S 1¨±`w_cÁž¯±+öZ{ʼnùbkkuN¢•½LYû€ì타@l\^#!¥ „”Ú†•d#°ç‘!•ZS ‹J¬<$” Ái§b˵dBž‰­Ú—í¥ZŒ%f–MŽWÊ.ÚÈùëÚ2‘ìÃr4u6|³™oÛ²aKqEŠFÅäëHràsÚXÁ2L²Š²0îê¡8´\îœéqªªÇ¾ŸÌÛü×]^u&Eðƒ3m-ér˜P¯§R©b"I¨°ÇªÏm»DÈ8éÁóŽ £F‰+ÌÇ ã*i t{d¨¿>ƒdl¡ ¤:/©‡î$z3F™¶ù² ä+® ÷ËDû¥¡~5јdT&›VÒ¦Ò¿?õù”‚¸wêºÉ1—ûPÄ wm>çpåÔU_bôu÷ÅUIîÜèP\ȸdãšî°¢TyÏ–M¼#Yø÷ÓoFÔcoF4Óû7=6V—í˜UÞ ß;ør-²ÚùöÖù?˜opEІüê&ª£j åŒ>åу•R÷\$bB­‹?bÜ·‚§á'˜ž|yИŽm_d •lÚ¾¶ ü¡.?Pv}\„úÈáCó«·o/ÿõúÇ—O¥Ðûˆ%Õ’i©>¥JÇ í$=1^^^]ŸV´5X-aÙûó=æˆ\ébøšcòõX»žaVu•3b¸¯häŸs<% þ釈Fú'þ]CÞ4 öN¬.+¦Ö|>e=e â–eÏSØ)Ò}•iÚôwËËAõ•®Aè1ác>}*•†Tîµ%µ†™xôpç eàí$1ó|g‹ãòè9¥ÑOy ÒÇUÝ3Ü‘ÜÖÓáÑô—&}á4~þ”w&þH}Ô‘Ÿò´eÂë•ÿƒ÷4BŸüžF€´ÆQrnýÿ$ P6gðCÊÒ D®ÜȹsÁÜÈèî@9cy1œ¼Õ{w>9'ˆï7õnÑlãó ê?ŠWDj\¼æ÷T§…±«eöò«·© .Ã7?ÐJš™A-;éÅ`j|vÌXµÛ°ªWn úôØq€Ï†’ã88xkq[´÷;¿¤¢e4åòhÆE‚K“âKÖ€M³%@V;zÉ ðÈ’QÄ\†d:¥ˆ_»z?6ˆFØr¹hµ]½…–Hph*µ¦Ó£Ó>D DaaòïmÃ]nésW”Ž…B‡ŠB‚ðªþ”®¨¦^Ùq0Ϧß|ê†(h†æp!vœ€ë`Fl>v᳈{†{†½4ÀД(Ù5;€ÕÍq.[l‚ Ï="µ¦øˆ>b ;ZCÞãð`?ÝTaéT@¥ƒl€”#â7pP[êQH ’G¶˜»´ÚÇü&…éDO3Íü ›®¶Øg5é)ÌH)$,鳓Á*3Qò"âîZwy¹õc˜ÆÁQ‰‚±ôl£Á4Œ’`„¹xZN™÷ÙûL9{ðVÂ>j²ÕþOà6YµÌÙ!•# ‰Ad_›‚âbIâ"àXK ^û/£ $O endstream endobj 3359 0 obj << /Length 3322 /Filter /FlateDecode >> stream xÚ½ZYsÛF~ׯà#UeŽ1'€¤¼UÙͱJ¹œ¬­Í‹ªIÈB´¢üúížž (‘²“‰ƒÁ\ÝÓç׈Ñ⇋Èýþóúâå÷Z/–£×7 .4Z.L¢—|q½]¼_^ýëÍõë‘Ž„†ÿüò×ëaš¦©˜%<†5íø¬,ëK¡—÷íåJèhÙÝæÔØÔ»»}—uE]QG}C¿ý´u¹?úr›ˆ"±)òª£Ž]Ö5ÅnLµu²­g§Wû²t»Üew uÖ-C‚zžø_ 0 („á,IÓÅŠ–ʘýù6kóvÎR®<;¾º\IçØlò¶ÍÝ9×ÞÜÖ­£k»oŠêãäõ˜5w~ã§MGYqÅR¥Ü±/`OÛëÒ­þ)kŠ žÚ—YÓ\r½ÌÜÝÕ¥‚÷uù N~H)’I.'¤¾ý÷»îtãð§ Ï?¼µç”!ÇbÆSí—ùùê—7ÿ}mWøîúâ÷ Žs|!eÄTjFK¦ôb³»xÿk´Ø»a]™&‹{;r·̤Ð(ï.þãÄ<ÜNJÉx¢íBBÓ¦¯¯Þ]Xzx©ðìNx&yŠ©¤gÒÕ»ŸæhK8JÚ :¦­¬7‘ÆÛ÷ê[mÏ£Žƒ­HR?}–:%Œ‘ŸO’†%±x”º'u"IYñ§•¢ÜçíŒÐë˜E†2î½Xi 'IÆ‹G“AïWZ›å7 -2^Vu³ËJjjnŸºüŽZE‹¿Éò.on`x¾e—+óåÕ õ[;½QÄöý%š–nê=ÚHÜ‚yÙ—YC/¼¹±ƒìŒMW7ÅŸd¦áØ 6DÇ@Q¿)Qz3]åcƒÛÛ¬»;=iÞ°¸ß&ïöM…Ô˜ðÊ`k#ðŽàÜR1s5 ÖZ¹bú}ÑÝÒD:>0ï¤ÄÍt>ÎÄÁ°P¦wq"¡Ü˜ðœ W¢SÌ,¢Y<8¿Èéš–2õŠvõæûŸ~°n9ñnù˜‚«„)ÞSÇÈJ_û{*VÀy´ý9Þÿ‘+=îEÇ·Jž~z«p\2mÄø"W|ö¦®Ã°¡Ì;|Régá˜MÌ$ñXi¿Ío²}ÙÆ`.òI€>ñÍÁ»ñÊ}èÃQ¹îíØñÜ6£ó]UH"¨éº(‹îaÎP)§¡sŽ\^uy“0@£ë†ã$ôë*ßA|õºRxÓ4VàmVeå°Ø½¡p+ÑN0`@}ç(ƒvWÓ/ÐîÐ횬jÁ8ä´Fû¬ØYK³r'™dã™ÑKÓ«‰^Ó-)§ÒLG}bf¬Dä_¾šávÊŒìu›ÛÍV"f595Š 6„‡{2 ±ç!4ùÀ'küí¼–~÷­Ÿl9 ¿d<±mÝuÃošz7ÙÁé®nu‡xž0ûÿžÃ1¦ƒ»4æ3xÄ÷:MÝd‘Öc}z›—Yçãó»Œâàؽâ\ Gƒ'2,ðC†ñ“lyúEÑ~SuÔc $‡LDjÊÁ]Öü6Ç)-ãÐ)`é+2ê-96%Çæ(]”_n.9˜j¯ÝxˆVœ-ƒtØMêe"›ÿaÇŸyS¯îüPpmõoá‚7~‹¨·cv ?Y-qŒ´¤É‡‘öÔé3”FA·Q§ÜÇTk8›øÙjÃ1FGzC$ôÁ ´)¦„ÆaTh»­ ìƒOhÁ'®à‚O\ÓïÚÍ ÓzËh ¦mýíÑ£¡Ò(„Ù£œnr›„6oêÎÒ‰Þ/C‰Ó±Mì™l|E&›†»yd²ñ¥Wè´.ûFhžÃ&Ž‘…~Žáä§zK`’e4'‰"v>DÄšCˆ)ìr]cPŠDm@4š¬,þ$ó7ää‘ÇâçÓ¯œöˆT¹°(•ËmÑ‚&¬ÑÎìÉ¥ÀÛóO+¦¥þü#òáˆa%s×Ò» ÚVìEÝÄ 8 YPŠM|E¡D°SZ8ªœæˆÖŽ«ht¶ã|N@\(Ó/uY(aF¸ÏCʦ|zƒ-¯l*šh)töAƒ¥K_ÝBõdAà`C­bºWÖ4ÙÃ`ò‹Òܳ dåÂâ©çÚ¤´Ð!v»œ_øM EÀ^!ªˆP˜ ‚ ‚i!Ö  E;Ÿ¡\:f±úB¢‹|ÐÒ_˜£¼r„öcâ,Ü-&¼¿Ådz‹ðŽnÍp…‰»'è%6ÙqîžÎÄŒb|È$æñ>ÉåB 0fÿ,0\–¢•@’NCü`¨bHÇ$ø¥bsK4ïöFckíØÊ v?Œ¸Ô :tõ&!…„ˆ‹ñÕdñ êæ7Š6"¹¼kjÄÇéz"¹6ÏŸ`üâ½ün¿n‡(N,±xÁÌTX’¯^)ÊPÑ®ÎËÀ”MÖæ˜ÞJî/tVûÝÚÒC ±Amv•;%uJTV×Ñœ'*ј?³¢Â!²HTÑ"XÁD}†¨pcÀ£ÐJ'Š±`"9<žž ©ÁÙ9.Äx ÜŒ ¬­¡9ŽàÀнà³d<ž"ÖØãqómÞeEÙžEÙmâêÊæܺr”†ue•R]Y¹œ®®¬†Ü~ô: •¹òÀ•›v_XÌPQÊŽ¿ã]Åf‡ÌW’†rt˜&L‹ ÀFBÆåe±+ªà»ñ÷å°ÃÊù há1ùó3d¥CY)ÎCê^ñ“Ñ~a°È)ÿ¾ªýy¹ösß~÷í^V‚öÇ_¯|=³Ù“8¥ÑLªø¯ªõ‚aŸ\“«ýÌV´Ú.«¶VªceÕÃ'g¼c/}—Uì(ª.o*ŒEìȦ†sï¾¾\¥)–À€ßä I>ŽÆ(l4½ª Dm©ß‚LOØ= ˆÛ¯]ÂØ4 ²µš³‚Ë” ÔUù@ƒŽ¥‚*ñtúÉ‘gð74@¦ ei”ƒó\ÁIR3Š€FA¼?T~¿žYÄФÓÊŒdÍ"QÃ6̬gjî0#ÇŠðê0èÕÌ~œ3°"þDë™Í$ˆU:·Ù¸ Á$† à ›Êk5Ô߶ôìÛàR˜)r7Üæ2áÛ¦øxÛ­nÝ÷ ò¤0O’í¶ØöeÚ¦ÉÛ»ºÚŸ/Mˆh‡¢XëŽgüã®,6EW>x×ÜWˆüÇîwßALrP]öRDŒü}ÜÀYóªÍ_6ùvoKÉ©/–¡f äÛgGijèáP"Kë¥EËÌò'+ÿ¶RJ?c—KŒ]ZêŠ|ð|áa¿½˜QD[—b„à1å?vY45‰›Ìð<„æ„z¸'aÓ |ç¤7Ø3”^ì~˜,ì FÙÎiî}N)[~lB×RG/àøŽøý3dœ#ÎÄKg„[Ê©x+'Þ2o¬¸HÁýçO0&ÛüæC`í 늮ÿ˜H¹„HDNÎZ®hÌš _â© oá åìú  u…¶ŸÉÖÚY5õ8„€ú¥‘Á±YÛÖ›‚®5Ü»Ÿ ÜQÎ?ÁÅ‹š¹ß©4)&ª³b]ŠìbàG( V¹&a Ωý\7Ç)ÐœøAì*ܯË|¡åœõ÷¡³2ÐßÌQT“Èh—ù®ñgb\ú’Êë®Ú Yé4õøå’s¾¤L†òaH­á$ôÍ»‚ Å'_΋IXÖ5ùð9LæVŒNú¼&ú[?¤³™Ó|.Zg„¡`œ¨‹•Š ›—´K¬GS¾»¾ø?á<Á endstream endobj 3386 0 obj << /Length 2960 /Filter /FlateDecode >> stream xÚÍZK“Û¸¾ûWè’*NÕ‹à&“ªMví8e{]ö¤rØÍ’ ‹eŠTHʶöק P$Ey$­·*‡¼F£_·Ègf|öâ?SþíñÙwÏ#=Ó,ãpö¸ž‰0a"³XGL(1{\Í~ ^–Ëj»ËÚ|‘y{¸ûÏã?a™ì-‹B–¤ ö´ó¿¿›k©ƒ|}7W\/ÿþæñÕ¯<â2†ÿ;Eð@c‚Šª¦RÞC)¢ Ý˜’zL]ûÁ¬ÌŠC“7¾µ¢JÞšh»“QðéÖê®Í¯œËÒlMÙÒ‘Yí†Vy“- ³Â‹ÌæŽö¹à,RºR‹£À)ÎüE³Yæï^ ãT’¥:ö èn,„½1íD<sŽ³¸[‡wºêT¯¤ÓÓcùSdžš…Bû…'³{«úÒ1"a2Bf…L…’V¿3EÖ7ç2âÁ.«ñ²­g¹‘SÝTHÅ”P£«æ«?½«Öy«M;´…XZ‘ÁJŸl{j°>¤Æ./W{Ú^ ÁòÝ΢5käÌ¢…ÆEBŠ8x¼ £`_â´ ²O¸¦mm–Ë:,’`ºB8Ì4;³Ì³¢8ÐðgJAm`Ò±ƒ9P©Ü ëZmí/ €?ÖòøQG\K¥}…!ùùoYëBÀ¼ÄHJ[Pë£o[˜e‘õ¿¶Ý{(¾pS†Ø½²²23L¶Üô܆›·~*ê¸.RÒg"%Õ¡•f‡)X5 |là*M¨­6@Ñ€„‚t¢—È êªÜŒ]Vƒ ˜‚SÔ˜9ýÆik Ûi×­ …+Ø7n—èzìž@ŸË‚i`Ø ˜†¶brì )]ݶ_ÄÎÄæx+ÿd|\¸«+œù• ñ˜Æí‚DöM£Äb0x}ΔÖnsÀ¦Ã) £@,}$µÜTùrt k {`NLîu"ã²/Íè£4øž’FÚ I.ÌÁ—ƒšð"."Ž–¾ÝT+šâ5¦¥ÊâÚ”XªTž"ßäI³4Mû`ÁÝãJ¸2WvJÄ9ç’^•dGãAÙéTÞš ÝXÑ /nM/;4” ­e¢üØIUUœj§ îc‘  µœ” ·9‘\„Š?Ѐ‰óŒ›Ù£$%{c+=r¡Õ¶‹ª°œò ew²¼I¹ ¦¡("åN€fÄ"J†BÌIbJ Û\Û\Á’çˆU¬J({ˆ‹Và¥ìü„¸kÇ\G\èîÝ 'U”dƒiøJ~_˜ï¼' 8ÿÝ ·cv'¹xy‰$Gq¨6©w™5>Å­'•UKøy`¿J‹£büº¤l`å6ãm—¯©ìq ò1ò ±!~öÇî[À÷¿Ï_|Åœþæ"tX‘_æ.#¹óÊܨv®faì§Ü°EYÍ£µ3k*=+ä’ÞÉ`­ûTÇßz_^¢ËÆATãòÜŽúüôïR8];¹< qP?úňÔ—)ÓÚ­OâÁ’ŸŸýwñœ» endstream endobj 3280 0 obj << /Type /ObjStm /N 100 /First 1014 /Length 2925 /Filter /FlateDecode >> stream xÚ½[ÛnÇ}çWô£ýàÞî®ê °$SV H„¨ Y2µ +\ƒ\%Êß眞-ZtÈÕÆ ˜5³35§««ª«N·%•æ‚“Tº‹©A¨Á¥\(D'=RH.§qG\É™‚ºÆOÍuÁ =F×ñ„äbˆõ¿eHEœH,Ð:žoÑÅ’¨¢á¹Z”’¸Ø‡¶¦.©”²K±ð›­¸”ú¸W]RI”!v|£uÀ|®ES¡Dcêx8F¾ÛùC滟”F,0òÀÒ¡ "à‡j§øŸ.ßèÝi€ DBp:Æ!€«¢…Rrª£ â´Äñ«:­4”„ì´µq¯¸¦_«Ë1Fh0lÃ8J³ÒƃËy²Ztd¥„ h2î‰Ë3I] }HÍ•$JÛc~hvHøURä¯RÁ|HÆs¹ }Ý•Î9–\ 4®i HÉU> I\UšI’ºZ0Ѳ«µŒçŠ«=Œw+ÜA8xPôò^w Î5U¾+ѵ\©ÓØj$> «5ÏÁ©z¿f‡¢)®§BÛÃ-ºtÅ7>—í'Ýõ1oõ½rEáˆ}ØJé‰ÓÄÁ/bHcW…Hé ZÇû…¾dzbU~ °bhu¼†ð€6Î_ #´ÃÌ™"f¿g|!ÂQy³PÃÌÐid|f%ìLmÌlŽŒ NàÂçù*Kôˆ€›T S®Zf@Õ@e…ÚÐ[¨¡W á@ã.4`Ö8Ê @ÒŽ<8Z½úÏ/k·úîâb³=Z~øi;®Ÿ_ü|´z¸¹|·¾|›Õ«§«G¯ã¸8Z½\ŸmÝë¨Ýc ©ß¶±TÏpCÒðûÎ=xàV§nõdójãVÝWxñðk÷í·Gø÷å߇×{ºÀàðw¹ï#y&Š”ƒˆmÅ+|”xà=·x±9{õÏ_Þ_Î#jñ‘/ÝÄvìÝ7¤Äé‰ù.'—ë¿ŸœFM>ÁÛb¯ÈˆÈçž1×öšãîÕW¤°Ø8-Â4kJ^{ºÀÕ‡ŸøïŸo.|†;{Q*> ;F­¾2ݨúˆÄ3®[=Ä$©É4¸—nõ—¿þ ‰mX•½øðþý›;D¦O–s Íö´¦æsí7žv«G›÷›ËÓ_Þž­LÝn×—.M—ßÜ>9ݾݮ]7ŽVÇ›‹íÜ1–í»×Ž‘á´»À$õhX&û¤Ÿ]\nÎN×0"¾õøØ­^­?nÝ››óròöë#€»Ø®/¶W\Ô*ߧù¯6.ÏÖWÓâ7îýqýîüíÃÍG7fŒy¾§8y{‰·YÇôéÁ1ÛWøð(UˆgT*;ALP² Å„jB3¡ï„ÝÐG²Ls7ÍÝ4wÓÜMs7ÍÝ4÷fÖ%;!šLÔ„lB1¡šÐL0ÍÑ4GÓMs4ÍqÒüfž¸A•æiÎgÄ(ÎLE\–vg _Gq›/„SŠ¾ÀÚYÔV¤Èr‘5B¹”r+–§ž¿zöãWQüzF U}Æl,çS}i³â@VE‰“ñn™F&#ªèãí)öÏ?ÿéj=ãr—ZÀ² JUßM{<û÷Ì4tâÞ hÆ‚ wÝa7If ,üè Ðg¨WÖAõ²‡6\÷%}ñŠf-TXÿÂ+Ð(–ÓÖâ^çÌsQsr‰ÙÁ$y¦ì€ÌkdX_Ù?õæ;9”ˆŒ4‘^ãí+ÿÓçÇ/žH™Õ"*ÃU :QŸ‘õ÷Ù9kšHl€Î+òXñ° <Ü>{¤YíÞÐ72;‚š½§Ï¹{¤,¨6¤6ÏÕKº$+Zõwí÷2lÊ C†]äçqÌœCZö,¥ÀAe0-~tøµr½[p«\_ºyj§P@ztºª}®*ó†nDˆ’¯ØÑ‚>†]Ä> ÷ºE}CÉ(h(É*%,M°ôfÄP.{-2ëÔ°áW¬+D [˾È}XDQöÁ”êÔj¢*$%(Κ¦£í ’‘Š‚)Ña™FŠ—M–­NÑN&­6’ZâkEE¢¸¾£b?9ÿ›ÌgçWÛ9Ó{« I‡HOéÝ%˜'Ö|§§Â³úiëƒ2ŠÏ+«å=0¾ù&†ùÛ–HjŠ![¢ü%rIï·#Ø%ÓYÝ¢Ð-û5 !„Õ÷ó0òÜÕX綃ÁÈÅ Üb “YíÁDոױÂF‚ýþ@Rž·Ë£›ŒRüØ@A7I~˜\¢”¥ÜC*Òè`·ÃGÙŽ^n"¨Õ]pZ°Ä·ÖÈÓ“9†À:t[à -.–6à…t¡Áh‰î^ó¦ QL@æÎËø0bÄsŸ'\—ÿkBH0rÏï Þòƃ׼%ƒ4¤ŸN(IÅÍÉ[ÞÁN®Ž#Š¡ØvôÜo9ÍOÙNØ.gû%\­×Ù•Ò¿ŒíÌýÙÎ\7ÛÉ-Á‰ÍKÆø%cü’1~É¿d\b2.1—˜ŒKLÆ%&Ó,¦YL³˜f1ÍbšÅ4‹iÓ,¦YL³šf5ÍjšÕ4«iVÓ¬¦YM³šfí³Rš½ IðjTDaJ15D8ü·é‚RžúL¢ˆíP÷yzúâÙûÍÙœ­Mñeë5ˆŒ„Ú^scHHúœ13É.4 H-%àºÈ^JbÖ®f·š‘{+÷»b‚"Gò­îehú}À®Éyì"æJ‚×±-Wš$ôTZy>¥;|ƒ­çœÈáí¯‘â¼=Mõ‚4i@× Ï_þp:ï¼4zCR/è0Hà%Tׂ*D>³Òî…Ô­2 Q–C‰çí0-º eyÁínñü ZNáù6žé û÷0g/:B5Àíë ¸cíŸz!òI¬Ö›w+‰¤.÷ªÒXèxΤóÞ&\Ò}pº½úq & Ü(âiŒxûúòòûdzF -SúCŽ°´ìÅðln))çAÞ¥qò‚ç‹OwÔ÷æÛTtðÔMjÝkNÃa¥¤EfÅ Â-]²E) bçqÔÞØÍ-3+£…$•\ó®… ¾ñÈ+÷ó2†àISž9‹9³q‘åyîb,¶z¨!©•Û\Ù§^se.ÙåsO’W\i£0;P7·kš•Xû”K»›<»Á¿ÝdÒ~%Ï~K«uW¢] ÜA½»@\ê/œNøÝ$ܦs€¿pËÆYe㬲qVÙ8«lœU6Î*gUì­bo{«Ø[ÅÞ*×oÓUŒé*Æ¡UÃSMs5ÍÕ4WÓ\Ms5ÍÕ4WÓ\Ms s’i»¬ ü2žï°Ò"Oûì­æí|…Ô¯ )„#ÌK™L»}¤Ì{Kׇ V¨þÞ¾ßÇ!E²;¤xŽyKÅD ‹¢#&CÀ„ŠTR2)¶¸ÌÚëäßà4 `ø,êÝ¢Ë,‘<@Ü š½ÒMîÆp³ÿÓ9k†‰<‹u×m4´¥<ÄY½.xnƒÔYv94XxZõY” ‘åpŒc d&àÊÿA õm‘2ñ©}0ï#Œˇ!wÔªd^ÊUFËìÈ‘Ë%Ž¿‰$_bnï‡NÍ‹õ¤¶ endstream endobj 3431 0 obj << /Length 3446 /Filter /FlateDecode >> stream xÚÕ[YsÜ6~÷¯˜—­Uyœ¾¯ñÙ§Ÿýð‚»ßo/_|õ½1³ˆÅA g—×3! “FÍ‚È0¡Äìr9û0óÝùåÏ¿qÃe ÿ‹³—?Ák²÷šŽX¨4Œiû/³ß8—EVŸ-óæ&£‹Û¤JV«lEweµÌª¼øä:•¥m—süÐÝMVàg`¦œ øgfNÙß¼ÿ'®úבñSè¦ù)·RoÏ]‹Ø¿ø°ýÝœè÷ÊÍSgËþ9OËõí¦ÉFr¢ô«Õ"·"ÌR+¦T4[ÎbÓwªl¹I­ôÒðùmV­7MÒäeÁ` ÁçYöˆfì«›«:KñMJ19ÖuKŠåãã¾=žaz4Þœ zjzj•‚Å…X:¡ßÝ$u6a>¶¯òKð5i IÓ¬¶Çi\ÝÓïMY7NgU‰è¦,V®ÃrSµjµ+bû¶–GºHV÷uî^½µ“²—h0‡™T1S:8Ýì$ößK±`b1¨U«YNµgh¡®ó«•æKRå ÜÕ_%Uu&Ì<¹wƒajx^®¾dˉÕ쵿iâG(ý»ÿþžýúòÅï/¾73K¦Äð ÎÃYº~ñá#Ÿ-ááO0¨Š£ÙíºžI ŠV³‹ÿrÑj ý¢”Ä‘$‹`$ÒÄë÷¿Lêñ!} ‚_ÊÇõ¹Ú@HÛÖ— ÄX]Î[À§˜Šübêÿ»¨1Á<Ù4å:9ƒ@’§ôÉô¦ÌÓlhðßB€¸ ¶KLŽõîò,–óÅÅwoq©/¿ûÑ­<ŒîŒ`Óº3ü­2’G®“áèr4UþÇK×~íœéL‚nÎ$ØW¾B{{`º’¦+§§kí³ú%k`‚Þ1óçéCæñK ãŸÙu²Y5=»˜Î‰¦o6¨ñ.ÐÐrÖz+j<4+7ú`Zï³UÒx]AȳJ]g h >=eº!‡l/žÂÓwE¾Çd 3ReY'Õç©9+ÁTØO:0ó·­”Œæå¦#€…W:t Zo˼@-ÀMfV%÷‚ °`-wG5ÅCmf ªÅJžÕÀN/ÐH¡RDµq ÕL›ÐÏr#.þ—|iA¨€²©SLY*ZQVµª¢¬ZV7¼Kz†Ý-¢È Ék€hêû5ØZ…ö ±i¨¡¹IºBÇÆßìñÑ^|Á)g˜ÇñaZ5L¿² î}^§¡2ºè2¹ý$frœs¸ޙк–­ßœÿö´çð±D¾ðo´au&b7Uõá.4—·N1¶‹U ô¹C?Mjj~X;ðc";ЈØ™Øì6b09F,%ãBŸbĈÇшÛEÂìiÄ‚™¡ösÔ>.© èþÇ e#‚ù¹ìÍxµ¬zÁ÷ëÜëVáÚar k‰ášQn Ôäó¥L#<é–JéÒe$r¼¯𸙘‚ð×eåÝoVЂ—§U~Kô"fŸÔ-<‡UU:lÅ"u!¦…¶Žê€zµ p `òh†*aQßfiŽ¼Ý;ÔÊíhÜþfÄz=´ ÅF«P¼pÔÚxå9XÏ6 ¾rÕúç+ꂶÊâ0 °Kp2˜)€‚±· ΩŸŠ{ý ;¹¦$<ˆ)¿7’—ÂMBh•Ê!úP3á ºFî±ø i/–#Z¸m Bm°½¹Â€„E'“°InU—«M7aƒ÷Vîƒÿ4æü?,r 7z¦!Щè”P)£˜…šFž"¼ÿñbW¤]ÛHùò0Ù*D­^ÎùÒ0&ñ¥¶,ä?4Ì8H èÓÕ¨ øµ †j¼x÷êýÅë]ò) +ý$š|3) ó6ŽOP‹Imþv†ðß'0Œ 2|wùþ 2¡€˜Æ3°ù`›/W¥¼×ñnª Ž’›6©à9r,R<ÌmIåtâRürÄà°,A¤†<~ºìЩã.å?(w\IÆÏ"7€*`º}¹™#3”u°¦o!½9´E¨ÐZ ¡/¯®¦Ê:º¸§|¯ÜÇŸ¢žÈA=ahp»´hË/ÿ&Ö¶wÉ褊x¨º7Ž4ó*_åÍý”CkÆ}\EfþºªMö8¤Q‘å¶9o²*éS/j®ÜÞÆÔLoÜåÃñYQº¦+×80€öu¶Nppˆn´‚zbm {¶ÔÚÍv Ó²ª²ú¶,–Ž?†È±R™î­VñÂân%‚#jÙX刷wPŒ•]íá`æ-ÀŠ¢íº{•Ð£]–òù·YšlêŒá˜`Ø9¶9F ˆÑ˜§rŒp·cÄQ¼åÖ”–¶ö‹šMU`´±wëÒ8g20;˜ä!ò+1yõ—<©h$.öÇ) º <ä(©]= [¢BjÍ%´¡·âÓëMaÉRb}ßöóò60¬2j¹Ë›êãB“×`WHa7WnKhìj€MãÅðÕ)å1{F!‹&üLgï¸áøý¦Â|µ.+,I §\‰¬Á$»œ Õ´é €‰¡2Ï”„&[ê‡yÚŠ·Xƒ»Üéš8'\¤´eGÂÐ IÕä@Ç]u>fFQôÚ×Ò˜ûŸ¶,i+£Â™^%ø#çéͦ¢TãÊÅz¼?"¨bpìÊÕ]t‹‹nRÏßúÚ¡tÑn¢´ X¦ô@ ›-ajÑMòÕ‹æ,ŠÚH9s{X°øñ¨ê-H철ˉ/B§pp±~(iuþ¸Ê`¨~ýQ w¢ÖYR€&Wí¶³E T ÙxÄõ©7\î¹·$™àñßq'|î]!9ÿÏ},´°5Nü¡2¢T€=të'Œ¬GÏT'Œ”Ø d8Í*ûCc‘Ÿ6.ãX¹êºLsZ`Á È[SpÞuá$l‰ÍW~ë% zÉ ”ÆP¹h (tU¦Ÿkº¦0ÏëüÏì0ûˆCÖ¹Ä.ûؾl¢RóŸÑœ£ù§¬:ps†ÛÒÎá³¾®ƒ¶5 rÒCw¼ZÓ±¸ZåŸÑÏìN Þ/³x¥›¸ÃédÁŠ<.p¥Õd]n ¿àv»´ãBUTë—ž­u» ˜¿‡çUòzý` ±'ˆ²ÅØ&_»öNI%¬®ñÂîAÌõVyùåƒíXšø‚Pã>÷e¸D)pKÇn+Ø«õׯìÃõ=Ý €øë¶ü¾ÛLˆM ý¤‰ee„ôíoãGµŒNþü 7êj÷ŠësOl¬eì.š—`ÑR<攢YTBÒH\ÓE³qMÜ)PG6Hø|›¡L *‚ŒfR!9å°i3GâA¸7­€t´†%€%ö‘Ý5hÉ!Æ)“%b·c pÉt™¦«Þr‹ŽŸ@+  ®VñiZ©oÊÍjI_e¤ðŸ2u@›‰#Ñ Áô÷ñrDÝx¬èO‡yp_R¨2Cë8/5tÛÝ’‡ŒŠÔ5ÖÙ*Kéc¼·Wˆ76rwXÆ{…Ó½ü–^SÍ .ziù0Ÿ61Ó]öÑ=ÅTÐ&MŠaøy«[îŠ4Vå` Ì¥Ífç;Sýä‹{ë-òr-FpÎ@Gåi\þÒ•Ýý$ ?‰æÏ#¦à÷„ZV $Ì^Á·ÎôÑÛ!ª;ô€laÀ4‚'-Œa¦Ñ@¶½<"Ø)Å8Þútðº'…z ž¼äê$ †kÅÓ#nýn{AžëùX0GgA–›ÛUŽñÏ!©~ºÙÛ’vïØU ײÂïô@Í á¤0œb„…wTð›DJ¿¶Ã&2ɇ tõý_Wûû+qÔIk#YnszÅ÷ A;ëoèóÂ+²¨{³¾­'¬ý803ifNÑ{E?64’ U„ÿ‰£:.»‚Œs¿mô„­DE–-Ýòþ,’·¡6‡OŸ ŠÓX¶™>$:<¿û|^,­U{;¾ÉÓ›1ññÕ“ä~8½e^§IµÜyºd«j·çÙÅsÈÁ½×_´Óêþ arÖapÀ™˜ÿÚæ5ê¨@ãö'7s©fˆáJbƒõj¼ ª|ÛÐW^O¼ìšëÂË cæi;L^Œ†HÛ®¶HÒ°eQ^/ÒÒmž€l"Ž)ü«ÊIaSôN®â‹S[c‚ÇwT’Rþ£Ðt]VtR³ZÒ êë¼hÇ–T‚í Ý:ù€¾{ŽR›cÂ$l·]nVrŸ0)ûaR&m¶Œæo j£Íœ\J§m¥î<´æ õs Z(,i¡ÁèïêÅVr=àçÒŸê‚ñÒo×ÏU£Ú¾+Ël•·ÁZ,óód­9mNWj¼û¶aÊ…†¼>oÃî]•7OÌþoàíÏl[ñ1ÌAtN ²‰Áp̢ȅª0¼‰é/-4RÅ endstream endobj 3482 0 obj << /Length 3103 /Filter /FlateDecode >> stream xÚÅZK“Û6¾çWèÈ©²¼I¦Ê—lâݤ'åLNÙ=p$ÊbY"‚²wòë· ð%ÎxHoíT¯F£Ñýuló~Ã6ÿŠMþ¿½ÿêë7ZlÒ83Fmî®eœ*µ1©Ž¹ä›ûýæˆs÷¯û»^›?¶Z›(?‰èpÇY”ïÚº±DÈ› 2Ú—v—7ûbOôýµ)«÷TÕ‹iïò¯¼-ëŠÈ—cn‹øn«L݇¶W[4T*- SÕ­'TmѶ¥¹$|ÝÖ§8),`Ãyœéd³å þ3Zñ‘¨èTVEÞPÙ>Â@g,ËèŸL³ïÿ¼:Ö,U#ÉK„Å~zÓ hÂÇ;”Q$'BÃnœ¨›%©¹úÁòjO…O¥Û‘$HH;Ü$è »,»,¸ŠM¢`<'ƒŸÿù×ß|³¡2H  ¯~{``·=/^ÄdzÅŒuÿøË·£N5Ò€"f¡ñk‰ Ývn¥`13éxCïN7¸ˆê‹ç—ó(ÐÎE^:®'úþt,*ߺ:=R[ÛÂfÛ¶Üù>‡¦>S‰”šÜ(í+ ‹$²×Ý‘šæ¾3Jçàö>Š;®£ççËéŽG…ÛB\¯`5LTe[T…µnd}¼ŽÜÕ„4ªøŸ…c”A'ÐÿsYåUë{T×ó—¾yQµMYXú #’MÏo凖:f8HÑ” Fôy)ï„^xŠX«÷¯æ–ÐÍmÍmxT¹Õ¿¿ƒe´%®æ#~¾Qã]åâÛSYª%ÕMñçµlŠ=£TôCEä–öZî@=Q‹Ï£ïw.ÎuóHå7áTïr²@9.Pª3«š1UB3î°Ô¨CX unáÚnëÃvW7ž¶ª<ÃÜ–>QOÜIÆÑŽŒ§pG ~œOMÙ¶E˜®¦0¼ºƒÒ›Žmgü{ë.f­{%âmÉlÃG ŽÎ|ûÓ%/D]+ûx> p;ß'ÇráG ³…cî)UMËóÖÆõLtC=eÈÃèßÜmS©=CÚZgÛL60+‰‰UoV~Ÿ±~ £DñТß¡¹Œ> ½¸´Dõ'‹3Ê‚d[S¿ö˜û>dv§«œŠÀ|NùîÃ'7`³'Û—f1ŸX>{}j¯½f–^}.µµåÃÉkLpÃ#ýD?éÏ£ëAö=hæ2ûÎM«t}WSóÖ’yKŽ,ìòj¬ôœê¹&ü¿ÃÉ`à- cÄXF`YÙÌ^'17ÃN&JH7” µG i–†xƒ¾©e×yWŸ/×Öï¼ë{ 9}’¥Ã’u÷rKS‘[µE±LòÔZ˜Nœ?üííýO8ÐÁÙ<µ *ïDй¦­”c3¾S.ežP$¨·j¬ú#„,“Œ2IHj$“¤ÆB—$bÁ³@8MûŽOò˜ÓŸÏW¤, x$:¿”aÀÙŒÍ0üYm‡®c¦&ã&ß00”k,Í»âœ7æÎ0.92Õ2zƒgËd#Æ€Mh8Ëèä!à§ü£«Ù]›°§K£@Owì Æ°j•¤Ï¡,@ã|fY›b9œ”Œ¼ˆ:§2žZ:ž&1I“:‡Tô±{ET—Z\¤ð=[‰W>4¸8¿ðA„1Ò'ÈR§µðw¸¶×Æ3O<ƒP@”ÇÌÒ wŸöIž€¹xYÐg‘çq®IfS(8s院ã³”ÕPäI+‘ÎÉ\‡‚dIô©p™±l•¼ÁTI¹Ö@÷9iA `_§òÈÖbfTË]ák'¡#óâY X“8êËeá£$äáœ?’0NE¾'’CH@Éý§0ìÀ(~ 9ZJ¨î¯»>Ÿ5›x˜‰qHõVó8ÄøÓS«¼]œÖÝâ|ôjÉÅ:œ¯…MçÑgœ3úA/5åûc»=º4(VØr_ø‘_v-.¥ú>·¾¹»u‡ø`ˆIq…/És¯¸èJËU‰@1H¾,¶ùÃqùÛõÁÑ1s2yŽTxQ†0Ò€¢&ÄÛ¯.<¸U§bjèÁÏÙ8=1€ƒ1~z³øÔ­ßœ«Z•Ã„í\™«bœžª@¤;ÊC!¥´Š7@¦‡÷ËïÓh^‡LwT^N>j¢“ÎGW´´á=#åˆùôfb©Žˆ¡žÒ±qsx.ÿ_ LýlS‹¬_åœÑ¨ñ ž±81('y.^”ç—>üœ%œÉ-@±˜ —fÍg3…L*¿4¯ ÆJ‡·GÓvo0ε!¼ ƒž|ìý©lTga›B:ah4ñÛGØlÅ$< ë¤ØÒÀî•x%éfÆ?¾‚}W“ÈÁ/ôÍ?•ÒÃwc˜:LªÛ&¯, *w%ˆÍÃÓ;(¯yyŠ,oï]²™ÅŽn£•tÖm§ñÉ=2]ze.Ï‘e6†û+)ùœ@Æ)ÅLúÇYD¤ì9ËøÜ£E0tÁjS Ç—‹ VÏ“™{k¶æÞW®Âû`Ç‹JßþôŽ 7æή國$Öj&g¦—²Ô¹–š2f€úý‹>`sOÖ+¿0„Í“«œ¢iè¥ÃöÁ³÷j·Ý*ùlT"ã¤÷)!*lòÒâK8 çe¬\ž}ß\ôçºqOâÐ+˜>ÂS2jèáa·ÿDY³!NÒí­g+^ 8H‘ð}‚“¯§…¸x— jÍm¶‹óeFqÀ¤K§“ûÒbDö0áÀJú¸è `ñ/£1¶T<ñ:•!ÿ ÂÜfc €ÆÒRzüdzŒ ¤ß^ ü‚ÿH›@»4uÈK¸Q+"וçã’ÛÙ³YŠ DÄÐ¥-.Ý+®¢)¤{ã^§z÷¡Ì–­~o&@È|ƈdÎ o)Ë÷UÝøÍßãDšÂ±4pöt¬¤I:êòýýWÿ\Ъ/ endstream endobj 3390 0 obj << /Type /ObjStm /N 100 /First 1015 /Length 2914 /Filter /FlateDecode >> stream xÚ½[][·}ׯà£óPŠ3ü.Œþˆ®½ðA[Û(6ŽÐuV©V 8ýõ=‡µÞÀ{W©¹0¼#]Þá!9œ93¤¼OÉ8ã}ÊFBŠÑÒ„j‚$Ù™•‚˜T*5E#oj Áˆ«­u4¢^’ªƒåÑJÅHjýäj$ã÷èMªðiÉF]tF«PªbŠˆQñ™_˜ÏfÁ¨j]øàÑ6ì^E»’ ªs­þ“@ š¼ò¯ø/Qñ FB©P ¡T ªhûªjLFÍ&¸6ìZLPß´`n8*œ3!º&‰ É'JjBÆdAò&T×¾ &:_(E³)™èE1(ˆ!´v“M¤ÁU³ð Á”(‰‰•ƒ ¢&‰²_ñ&iò”‚I¡a‘hR ì+˜R èSšŠ´§Å¤÷‘]a¿tVá*&ã %59dö«Þä‚ɹi†äÒbJŠ“²ÀUH±bµ ¯† ‰«›><•JX­Ò&;h2¥ìúȦ:¡>-¦ W&xØ—ÂR S16®y4“ÅאָP3 ¤–6W˜âZ#5{˜sm½apâ`1¢O|=(Äèø>ŒD\ò„hÉ"zÂ0aÔÒÀ–Åö`Ì"…]ೈ×Öz“©ÈEb†-’[Ì7ÞJMDo²[F¬ª¨¨Co‘GÛDÅÄ=Dó¥FÁ—„Ñ›¦ÈÕÂcñ G‘Ð&žm±Å»6qèG¼Ð¦a“½¶¶èÍ÷ï/–¯ûue–ÎÏ×ÛÅòôòÇmûüüÃù¿ˇëÍO«Í×àÞ-¿_>[>z#íÃbùjõ~kÞÀYØŠEÁ~·•pj´™3\¢M± Ýsÿ¾YžšåÓõëµY>6÷..¼ÀËÖçÖ[ýÆ|ûíÿ¾‹ŠXëX0I¶r¦Ãm‡Äfx>/ÙÖ@—PmážT|.õ‹Xž=zñúùÛ{ùí7ãpÀË¢_Ø KèWá:£UÙár~ †Ö‘8lÁöÒ¬– nÃ*¬ÞØÂJç‚Me È JÃÁÖÂ…ŠÜb> é¦Zô@Ø–êÙÇb$´¿2Ë¿ýý`Nô€DÐœ_~üøîƆ V­e’Ô¼ù-­›ÏMĈ8}œnPf¸­µY>Z\oN={¿2~÷ÎÉÙv»ÚœÝ}üîÓöééöl»2Ò¾X,Ÿ¬Ï·mJž€A…ºí ¼ ¸yÿ@¢.û€˜s’@¥‘ í›E4Óþô=îšÝòd³~ºÂÒã'fùzõikÞ]_ó“³­Ãùvu¾½ Im}ri/Ö—›÷«‹MnßýuõÓ‡³‡ëO¦Yؾɕvvr¶ÁÛdû†Í’.ÐqKƒˆ§eA{Áï…ÚÕþ¨….Ä.¤.ä.”.ì&£¥>{Aº ]ð]]ˆ]H]È](]蚥k–®Yºf隥k–®Yºf隥k–®Y»fíšµkÖ®Y»fÝi~7Ê Ò&Ú5ll\$eU-Xû¼!¦eˆY¬‚ÂkÆ&æöø|C¬»3ê^½EnÝ¡ 3D¸ÇBËÜIÈ€‰3¨üOÌ`®ÜýÁ&Í3®(3íÄW[w„"2ûÊ„â‹0Nûådµùe< ‰´,K#ÍÂÒDj4mƹ(œ„j"ÒÍÌ”Ú+¥ÒñÚ’Ò<³ÑS‡¨Èå|:¤+TJœ ¹y,BŽÍÉbK.,ZÙÄÉÐb«Î4š¸U1ÈgY–?Ë­¢…uÊ7nØk{ÖÊ@6„|[c6›†9¿Tg›·`Ó&9 ø‘nd¿{CðÖ³ „tª P‡ˆÏ7äw/þûêç‹fâ@ãònÐI¯¾?ÀGËñ6±C€™B€«Û\¬ÂCŽî F€ÏˆÓóðl3ûk£ï0Ú–z+Œ“íf Q"[Vì‘;¸f•à¬UG—É4[ÜX–v¥ºÜ#Ò•DF—aXD†©:ô¯ˆ/®šánp¥w`¢gÑŠƒð‰p¦Š¿¬U–0f‡Î†VpŸ ð…,P$K^AöBœ³(Ù!ìS­:¥àÍ[5ó¤e H½‹*Œ˜%O1öü‡ó„d{raÆ–aà4bGGÔåéèrÍÄ#Œ¾óáhaž'p;>ÃN§Î€Ã1ÿÌ™"´À25"¨Ñ™§/Š‰Iáÿ‹8ÞØ®ìÉÏÿtúüÁ/xðOWâ+n‡'+iHEô¿Ïf}¹ÚþYt ’ÂúígH`*,ø߆ä z7—_ åw/ˆåI­úbyrJ2æÀÍÙøÒ pVì]aË€–€Úú½ÙÞR;n©ÇëDàV/Y#°y&¾ÉًΟ§¯aöfà½J»›JgÂôÂÉ¯~FoÆ ùÄsFXã=ÈÐÝË%i?#Ø ,…Ì?ÉSniySx&\ªÌH yÀ_ xæáÈyÂÝ~JVïž ©ò$ôþµëãtÿ×Ou,Ch@Çø« ¸‘Ä›ë® Îqt‰[xð°‘;³l7àùØB°ÀQí {´íW^}÷x,Ï«žá¥;þÜarc8To 0€§÷[ŽÄtËõõ4öü%5ï < 4LàPR’Ô«T¼½NªÑJë°¼­ ª¡^gHØ>È=;Ï;'<ø˜ ï«s!x$I·¸Zbn¡yÎÜùpC;ËS?˜jH3Rvìùû =vF—Ž2v“í9·»<ÏTÈø+»Ëó·ü¦AÇÞ.@~Â;£ÂrBÙÅòö3¯¤HTŽ<=þ $Ï- endstream endobj 3519 0 obj << /Length 3387 /Filter /FlateDecode >> stream xÚ½ZKs䶾ﯘã(Ù¡ñ Щ=¬7Yg]òÊY)q¥l(¥a™CÊ$geùק ‡Òšú‚GËÏ _Ó¤µÔÏšâ6·Õ‚?˜q×»Û6Ï:2M‡ÆpX %1°ÄèV¢% } ¡$FË´£g·Éi‘[3Í}QUEuO}õ® ëy" /"¶¼»àl™f]Ý¿¥–Zh~ؤ­ñ#‹Øi:ÒqL9}sõÕK*âqÀC7ö€Õ8­Û¤@dCïx½–M‹%oÊ24Ëþ˜¶.?ã¨üw`Žƒ[³ÁaàNö¢x#‘½À(ô.ƒ8æ z±qâ=’Y×*äË]Õ>m·y×6°å6Åw Ø]ÜÑ9Å÷»ºy4mÖԗŶ¨¬fqŽÂ~ý70x›Ûqë]cä‡CömbÆ‚N—°©c'Šï>Þ\â’Tþ‚ Abƒ€¿H¹äø †H’–¥ËKꨧf\¤ÍóM8 ")÷‰å‡ˆ urí>$kFª¶é‘c‚54¬‹6-¡ü±ÙlhnÓ Á–ÎZ±§}H³âDé凊Ú–c`Õ˜×*RùŠò¬HÄrdEø¯@NJŲÞu«ún•ÕMNyu¶ð¹hêj›W]û›ccuØMÎKßä̇c“3K´´ÄÈä°ÙšÜsÑIÊÙèý Û‹ÁiyžñIíY#ë#J€ÒŠ{š/©g ½¥ö´±Ò»HfO-ö¬õÞ8/Ò5„–â'¸üBDÖxl¼|DOUÈ`Þð Óij‘¨pyfƒ]Â!†~¬ûþB3’¥^¦ëÏ…‰ÉRWÀ¶]k; »`Wý`­ Zëª|¢7´ÓÒÿ&O[7·¥°ÚmoÍN‚_ÝÑÓb%ìc,ìBŒEo$I«Cz›g)’5c³´éh·é Kë¢+ 6#βMm[gEÚ€ÿ-ÌœÞÛñMþË®h¨K‘Þ섆{x빇wjSh)] p33crz!DV‘ã|Ž+ Ü; qâkaŸeÚ\p½¼·{hVoRK8Cí¶Ÿò0Ð:Ú³7¡N µÅÖÑþáf-ì±B1‹§&-ÝÓ™£ R½)#»Î ¡ë¼Ë tU÷ ì(*øŽ^MÌý5ðر5ÎÀЂZVàà‰´4g Ë>¥‡“>”—&X@toBnŸ&dmêÖRåÂŒ×ý"<’"jšMÂÐ2€Î^·mA^ ~NË]>—AZÁõ<ù&{ ŽD ¢ÉRlfÎ8Ða2?%àõ(Š÷ô Ž{Šj}©ênð °u0åByf¶Ùè(ˆÈ˜¸ðØeã誣YNí\/±:´T6y*ö {kìèGX®±Ïô*Öʦ«sS˜¤:êÛ.-*³½A+š$¶!LxUfš…œ02gÐA¤{Hg§ƒòÿ:3C`¯Yq;;gÒCu4f¬ÆÈlmý&fæñV²BŽŸ*8z N)`I3Ët6kÍ!ƒFÁvÑä3œ À±Ã¦<' Âáƒ]»A*qŸ‹úðñýÕר#~UÉ@%z¨ìxõæ5"™þé–éÌ5H“jÂyì­-›§<<—ò$Тÿ¶'\†Gí•É°W®BN˜MˆD!^*]N qTG¾Û¥MÑm (²9çÓA?ÐD&é°!ôx”¸š@N°1ô´µa xãÙ&cCr7v.Óªr•Y6³‰€6¢ÞßÒ Ãv D“'Šñ™=ñx¯½¿ÍÌÑ!îà ŸÝ°%V†ePý»¶ßàíFœmÏØá3ŒójÌð_\M+Ì£ŠcœJ)f¾-»M½»ß€ÝÄ`øh?1›ƒy¬©Ù§àic‘mÜØÁ>è‹1á¥gUW+äq‡ £êJOhÅ:œ´,ièƒKbùÎÒPcÓcûGExN=OÁ”™-j.£F‹–ÚΨUé@ 9#õ ¥R™&3”RAM}º¬o;eŠ©2±ÇxnÌœçâ„ô@íþ–7µ-GAÖFÆ5RÓže˜t'í §ù&ïv e°Š3±ÙpS7•C wåw;«Âl$”¸e&ë³~}[¶3\ø1F»¢iQß9¸RÈ£!šrćܵÖ}¥­È6Ò¹ócÞØ©Æ*úuGîø~×à©Ç¶nò×T«y4ŸÆc—ÄÒ !˜xÙ>-«0l€ùÝÙŽ,-m|QgsÀ–ï—õA‡‘cìåŽsbª3)íŽÈÍŽŒ:Ã"çKµ…=çP¬EŠãö³o€dðåÄt¤ßû!> Âö3»U“öÍÐ9¢+ LË.uYRÄÛ/Éd»¦ÉB¼Í7tFPÔ»æ™òÄCšýœÞçÓÚ‰_„N°ÕBÄ/)˜lOB÷0”Ê€†qV Œ…ü]b ’…~„ìUK¿ÄàtlRnŠ¼¥¯jË +6ô>eæj,ߟæU $ÈûÀ§«ï¯ß½}‘¡8à ŸdœÇ¯·’‚Zk߶ß]]Z6Ü=,ÛøvXºŠbú3ewÔPT.­J³¬ÞõÍÔÒ}ø8g¾£¸¼hÂl(]+œnÃî_’àÛ’`“…$ô‰´Ø ÿžb!«”3!öþûÒLñ›W¿¼âf÷à ®%X´šŒ9Û¾úá'¶XC'€HôâÑ Ýd5IE¹¸~õ/{Ïh¼ ©êgB¡Øs‚Ë×7/^ -”çØȬ ±… ¡ÒÆš ©¡!a¿R!Á§g¸”½ ¹Vtí7RÒ ¿ø#È59ø´…Ct²§`©Ñ¶Òã#lè<+$Ê¢×ÿýöø*œ(p„ ·Ókw„ ôÓâRC·±ÄŒÂ(ô†ÙRçäÊ¢@²ø™›;ãs‡A=xèÓ'Ãfu¹ÛgNm<’n|=kã°{kÇ"ŒËÿcãŠQH31­Ž´q¿àádÁZi‡|l‡±ú—)’ñ•ì>ÝåâKÝ&êQf’Œà¾!ê‰èyÈ°Ä[úc+.Ìn ¥Éo ª7nûÕSƒÕ.â> stream xÚÍËrÛÈñ®¯àª'óÀà±U{ð:vJ[»kÇ’“T9{É¡ˆ´hÙùútOÏ€R¢´Ùä çÕÝÓïŸÝÍøì/üÈó‡Û‹?½ÕÉ,ai…³ÛõL„1±˜E‰fB‰Ùíjö)ø³Yg»¢½œËH_²bg.½ýVÊÞÊ0aQ*a[»ä»Ë¹RiÀiÍ?¹æÕ®Wëù²ªry)‚Â4ô5MµÌ³Ö¬è»­ð}6Ù¥äÁ—K¡?#/Ø ÍÊ¥Û2ó{o³úó¥ànfÀá4°®jzY™Â´yUº3Üp»±¤Í掚¹à,Õ)ÑdJÜMó ZÓg`@¶Â½ùNÚ`‚ÀÍnatNU, úÁ 1ÍÇ•`*V{ŽÓ Õ›‘2.„ŸðóÇŸßßLoÃyêg=äEq9uB2øžUY|#¨¥Ù‚ú4ãÑÜÐh»A–"8«Ý‚Ú¬Mmà®V4—~ªÛ`tÃ8¶ÊÚŒ.$bS5¼|eÊ6Çsq¾ e°øFO»'¾|¹” (±önŽn€3à Ó³¯À|°w1` f ï8xóêooìú7·¿] ˜ÏÄ ä†q5‹Â”é4œ-·Ÿ~峌ý»ª4™=ؙۙ™‚—bvsñW§{ýÃd³XÚTªê]ÈÌèîDÊ$<~èYä‰DŸ&OÉ¥@ÄËéS2fQ’ |ÿáÍÛ뜢QI&ãN>]䛯m¹;í ":Ać¼Ý dBœmÍy|šK!YœFCñ{÷îõ!»Dº‘ ,ˆÒ/`—ˆ"¦íªˆÎ¼ýùý#"¡B¦¥x¾H€ÝO:nO’(áFR©¥Ò,zHâ$bH¢7ºeÕÒ Y®sÆN÷oR„!K…WÊBgb¯_ÿrûú(¥½‘;7ÍtÜéÙ²*Ûº*š‘È–mŽæ†lŽs.Sî⇟>ÐËÚdínï34oÌc’9ûd'ßìYîÏ€[Ó–šH {ŠÇ™KÅ"€s˜J¤»†MÖLùyà[*¾ŸHúÒ4qþ­ð€àMÕø«ÙÕyy7f\™ßš¼ñ_«s×—ö¸¶ªó÷x|Ø6O#–8Ù÷— ÜSÓä ïµm˜3åuuÌx$^wÏô¹‰Wý9m8šùi®uÜ@ð²ÊêÕ€ÓŒYq„j™iaòÌìtb$œfu(6ò ξ‰ˆŸ85L‘“íÚj t,és¹©ò¥*Kw@u¿§×Suojä¶Gå­©ÖíƒeYmŽÐè.G>F£âjO£â¡ÅŸ4â\/´8eQYßoä{p«Ã‹´›•+ziªb·“T_¡ŽÅÁÃ&_nh—¬(*<öÁá‚Q-FI ¿"M‡^jk¶Uítw ¨bÔ<`[ƒØœP47=w—àŽž×YùyÄÜy‡@OŒÔ£bÄãžñ„®€SbÃ]€)„.§4Æ-iÆ£K›œô‚'~ƒ¸ÇyÛuÀx)"Ïø>fM‹aò1–÷Å3VĸXë]Q8®ÍUœ¯Ïh¼Jc~Ûa„ŒÇ.2¬¤ëñíÎÚWZzRösßÒ8)€ËŠž[°1$H¢ß“’4 –¢Ÿ&´5ªE £è^!D×ÁuI`? CZ^Ò`0ÿµ½"/æêÜU{;ÇÛ9j)²©Ãt4]ó½°ó-‚í&w¤u¦ÞM™- äŠ#ÞÃË®1µ[XQ*"Yµ ˜öPç­w—ÉÐ]òÎ[f$4ã ^2žtyÜðrSIyp*‚UÞ|&ˆHænÉ3Þ N$ø© Ï !8 ÕÛ÷ñÑI¶'Û%aÐ䔢~äY퀾Yq|Æ83 ‡|FÅrNä îÃ;h3S–mEÛm(’çüøU;ïSÅf´[›žs£œ=#—ßR|„1]HÑýêïňƒ˜a ûåët-+ŽÄ OÝÑ„sêë…£>‡”Õ¨Ñ@µÀ68g*BŠy_g¿;Oô4“a—‘z¹‹;•BÒÕ¹‹åìþ¾®¾æ[ËŠÆÁ–Ë]-‘”o¸õÕ™êiw¬ô¡zDá©Árði<)A)’L†J@¢ZçYÙâ‰g'y¡dÉúÉSÐ`oÀnO¥:Ëj{_CjÐͨ³Ö™Û3 OÙT1-†Zv]â©€Õ"/òöÛT B6ß«œÍ¿Tˆ™¶1¯4w^AS¹N@"´#ðÅÞ'ŽtvqAä‚]]›²ÅzBòÙÂÍõæ’ BsX„,ÌÖxeÏŸµ5ÄÎÖ(©g8ØX²XËQxÜÎk¦x·î{BÆ;Y‡ &³nêšÔ3Ì€b¡êÜ÷|žp~ ±$í¦_Ínñ/È‘éƒÜ¸ÅMVÞ‚a¦UºáÃu½Ã[#£€Ð'-èuÓI‘&L«Ã{1®j—{8mŠ|›—=-9'±õ)O¡aÓ¹¡óoZJ@6Œµ^ž¥õßÓù¢ãøãHxÎ=C¾ÌõþžCuòš({¯ø¡@Tc%ž[TÇ‚Q\ŸY7–šéP>7~ê…­W²ÕòØWË£~pŸCã;%|Z[d.ÐÅ÷¼qUô'Yû¥$ë4]ƒ°.!Ö½ŒtÄe¼z:ÑÕ.Áñ^¢ `W¾±#ÏmÎÇèåì–äwæ‘Hl^ƒ¨Uõ #Dål>Y†»Þ‘„]c=Êè.dꖧǛ«³vš†Ï ´MFXRÖˆ8ajÊ$ƒŽAV<à‰BÆ(éÛgøT´`aÖÔÿ‘¾#Ó®œçV‚ÝôSšjëx$@C¤Ô!R€X +‰dH.šAåÓtÜÕÙý†`6€P¾ë ¿ÐÚM€•Æ¬¬ÑT$òÃs(ºï¯$ vè@†1qçQpë‘Ùw—&Òè³{ML'ÏI¹ÀF؉hŒ£mn©´>uv7ò¦mhbî¶qo¡§š)Vr5,%…\&«‹MŽÚ¿‰àéÂu·!,öÜv5™Fü¨Íj·t;º­ePî¶ ?Á&Oøܨfˆþ%J‚WE»©vwwþy6öm3ü 6Ýô~gBˆÀF¢ÓL/1ÒÆÏ|{Jk[$]£PK*ÑB˜âÊ>¾7(]RºV”Ö¯$áû÷¥;“Ž¬˜BúÞûKÐ(ô—ÿó‚yú;Ì'T”ê¦Ï(Š'ã¢8Ø'Å¥Ï/ŠÇò¥áà ò§Š£ÿ1c ±¦"Ÿ]‰ å¾F­”Ý ¥8[šdK0jCÀâY^ÛŸ ¥ ‚ÛÍ®9“%ø[ìÞçÉXDE¿œis4Ä„ònI™™ÅT´"žDz˜¸§QW&ãnFÔ?E<ý :ØB‚6¢$½ j…å¤C‚ŸŒÔd«Ûý‚{ð‹ÁÒÇ¡ _"´ á{ˆ¹¼öì]dÈ8—¥½õ¬›{OD£6Š‚ˆËýÃ:ÒøX0 y€è˜>ÅÔûÿŠ{:t6x„Ê&nϹˆX$Ó£•“a±ë¦x4N÷NE@ðCpϽfÍâ0î5ÿ1Á³E(„ ³¹‘µ s™²$‰ ­dXës{ñ­‹ endstream endobj 3572 0 obj << /Length 2326 /Filter /FlateDecode >> stream xÚíZKsÛ8¾ûWð2UtU„àI€3;{˜ÝM*SSÙÝÄ·d´Y¬¡H-I%q~ýt ER”m9ž$‡=Ø$@°Ñïþn"½¼ '®¿\]<¡LdHš$2ºZGLjÂ4‹£,ºZEïâÿl²Æ^þ~õ+,æƒÅœ‘”I äVýx¹à©‰³åÒ6]Áˆ«øúÖ_ÛÅ›$ÞTMë§Vû:/oFUœ•YqÛä_œ•«Éóõ%£°E[Õùç¬Í«Ò/Ü!‡_òqcKd¤¤„ÁŸŠj·¼y‰B‹¡š’A^ýãõÕoï©¢BÁhyM4 ‘Ìt/þÌžáâh!$#‰‘Ñ‚Q’ªÔ?åÀž¢qUû«ÑКƒ IR)ƒ!. hšüº}.ãY±Ám£ ©ØW_Ûö£íÀ@ÅÔÏ9ã˜Q¦PöÃÏËÊ—ÕvWƒ‰ò…³ÙÊ?™¼°ÞÅÑ+¨ÑŸ`6áqV­½Â·#}}¸DÚN¼`õÚù@·µÍZç`8ÛøIúÓy67œqlqsžÅŸ3êÙÈ™îl½´e›Ý–k‹òÃŒ÷xXá=onwù2+üº‘nñiµ2o¬×%áÒà  <‡¨ð¾µÍÚ:_:ÅÁ(/ýõ—ßÞø›u]•móãy c`¤O¢2箉åBYOüç‡fo#I´ i©S–s«×‚ ˆ‹]]üï‚¡P‹„}%Q"’h-·ï~§Ñ žý ‹ÔDÝÊm¤51#§ˆÞ^ü7äÈ!')žÂ”ò¼ìË{¸yõÐý¡Æ€4RiÞSÊg“Î’N/”sšvxïËä!y25%/@­ªËóÿ´ël_@z”ùÌ2³›LÁRfX$ã1¨Ä¿…á° uà&Ðñê\QÐÎý¤ p¼9¨òL0‰ÞŸ×þY“«òðXCü0$O‡ë1 -|èÎGI¦ÎÊ?¼½0z2yD^~c‹‘€Ð.«/d®­m!½æÒ³¦„+vÐâY¡¨×_^­ž·)¸ê!av{ê£-ïs<Æ .§úÛfõsz‚l'´z[ªãWPE¨ØÛÒ¥8!EÜ´š6_º±Œwu…6ø¯Ð*¸"?0®ˆæ=¸yõúÅ¿Q`žÞ«dA¨H©då‚q²§ ÚÓ<éžìëÊùÒmšü¥¼ÝœO`Ùawýõâç°éêgú´›Î:±‡©÷g 3F$›Iªé L™…ÚÉt·!Bžúb—;(²Ü×5 !?ð+jz<É+æ‚Aåæf‰¤€O0£ ´qó´Ìšǫ́t‘Ð1SVa»}s67 º.´‡ì€µhªxB Ó@øi5+žc1-ì§@ª-Ô$WE_¬|¡šK¾ÔÁÊáí~»›AVLqÂRI•8u´âÄÈSÀŠ)IŒñ”Xâ8üaÆ na˜kP¡™í{ <ÀálŽŠì“½Óèn…Ð=+šjŽb 8“ŸM±óß8‹¡ùÐ >¹„s5/S]g·¡¿\ûë*ßÚ240TdÎdq£ÔØŸ;wf'\Y¤“©Z{ŽkC96ožÕî1à¦*:tܵ*å~këС?†9‚ÍAHã·ÖÞ“ø¢wîý·ûëÆ.Û^lAÒóà t!¾S¡Ï<þí.MÀõíD9áøíÓ Ïo Vƒ{ÏÔÇΉNøD2Á¥ÝVÐ ¶J4‘T·úÛl £y_ºæ/U©„šÑž œ(•N(ŒëÎ…žkp ¥’ñih €è&:ýgAÓ”Ð.¢:ÇíOT8mË&ªQ+VÄ2 ¹šuMí‚5«Ð ê/Öžßœˆ¸dqaÖÖ¢Û^îr5ñÔf]W{x!Œ?æE1ôá<Œòu—uÝå³­«™HkƒvØWûŠ’]‘;=pNÍÿ^=ð<½;Á#ˆ0=Á«/0©vÙs_6·[¨ß@wîägêô7Ηë©Ó³‡9=óNï`Á)†ž‚Èè‹Aõ ŒH!ã,Õtô¹p΢†¨;Rá ¢oòX?ë+++¾x¤îô³õ±s@¦[ŽOŸoliëÎOí.‰…j­BèñoYë©÷äÝUM~ FVOÛʼµwH|ÒŸ€Ê$ØZ|û ¾:û,FCÎÅ£b0Ư\q4ÁÖÅ%ó™žCÌf+»4ê¾Ú¸©þóv¾! ™Ç ¨ luëG¡àp¨M”ø8‡2<ö¹Î‹þ¥©ü'Ïí(SùâÅô1Ì"øí*_•þyˆŽgxö.@0YdÅ߸„ã>›ù¡ÃÝp£g7•—KH`þ Ñ÷Šb‘‡Í®±ìÛ°‰ÍVaY[ùkØ~[Õa'€˜ûÜm.ÏHÖ­êëÊy¾Á“Õ¬õwDÞèfœÓ¤¾Už!ý›ªÌŠâÖ¿·ª¶y™• FD_þi®Ó¡”$RŽ2@ç`wÛ†ò¯O•‡VþúÈzðƒ€6p{ëuÛ‰nz€÷–öP$tfÐÒŽ=š¥€c6y’›¶Ç4‡óľRgÝ¢¬GÕÀ tk.ãÅOû-‡Î±_‡N˜ªqüòǵ[M[ív=WË’ZÝ7}fÄÙ™®¬ö‰ÐnñÄáAÉïÛöGMU Ùÿ_ô”}Ñ1B8kÓÓ2@VI„¼‹y¸÷^‡è$ :É"ºã/dJÆY”Evw|öÄ¡„Q`ˆ%$GgO:íÏž¡9F‡O#Y{R \[vç;LÏEd Õ¥1™üÕAmçTÈUz'A mLŸñ¤ ZÚX¯¡m¶Ü¸V g¡r.s²ƒCW*qÑÊBªÛÙÒ¿ÍânÁáÛ±Bx™ŒS_cP¥Cƒó¥£æK" îu2n¾ÞS®¾WO?N”®¢„ÂpìûÂ>bêêÎÝãéÔ¸Ÿ”0.‰–éyzG :#j’±gÞ«‡zn&¾Ã~½ï7oúo)úë}¿9ljNB}·9þ.'>H®îÛw_¯ÍøUp³?6ë0 endstream endobj 3484 0 obj << /Type /ObjStm /N 100 /First 1016 /Length 2912 /Filter /FlateDecode >> stream xÚÍ[]o\·}ׯàcò`.‡Ãá`HìÚIáĆe M?(ζšJ¼œßsx—rÜH«ML_0Ösµ¼sÏçã«)› NSÎN4Q(.–þ—ê´U ÍYÿ Îý«ª®†ìb‹ÑÕTø—àjS§&ÕI(õ£Å‰Eá}ÑI¶.©“R»”œ´È[‹¹,S‚J©F t¹·º˜Œ0JsÑ¿ÅXTðŒŠ;jîðBÿƒ%)¥æ4Vnü~Û Ô,RÂGæDà5v ¯Ù2ßJ¡ñ=Zv)*õµâ’æ>®ºd¡k.ez Áá *%qxb¢…å[u&Ë· æ$RÇ%M'²3+„Š³Uª³ª…& êÌ€@)$q9¦.E—µßñ-oü(¤Ô(%HÍð ).çÄq˜±\­ß«®ÄŽE’+ªÄ3•´<-»’ñphŽ®ÚÔ ¹ÔÚ¥'ˆDÍU±ŒgÄì`ÈŽ¥À3"õá£Zæ3`âZ¿U¸KU"Pãt»à²…Æ÷…±[·8Ý®)]ÎÔ\ƒqð ˜SD|0NëÞdÞšt- þŒK¢´.ƒjy8c —C„7†ÜAÜVûXj¨%Àx±Á 3Å,© Ï(#E#Ô”)rÁp"Eú"² bý] p$Ó}Ì8 v»5@^ j$†ÒNŒÒoƒ†?£ˆGDz?Ä1ÇîÌXq±_È=V:±eûìÿ>…æâ.º‡‘¤ø"í(6⛯ðBÑè{µuºÜóìl·Û^]¸¸\þåíîñéîl·u‹Î“ͣˋ]‡ýQƒ9­{„yfZ[._!ÆEAؾ†åÑt\ ½µ8†™c\âÐmž]]¾:݈€ôð‘ۼؾݹ—ïÏ˳³mOð»íÅî5sE¿Ÿæ}ùæêÕ¶ÿ­,ûzûãùÙ—o]Ÿ±Œ„Uų³+ÜÍÄ ËÀ>Û¯ñà^=O/ö‚! Á†‡P†P‡ÐöBƒë\Çà:×1xo[vÕa,&ìµÂ^šÛÐ܆æ64·½fV {A†‡ CHC°!ä!”!Ô! Í24ËÐ,‹æ—s–TRóy2×èV@U†µ”]nÑÇœn\Sß<ÿòtޢƬz¯ °¡ÏÈ­‡<™Š > ï\ÄGÖÄZ}d±Uq]õF¯ßüÀ¸ÿüò›õ2NŬäà# hCÆ"Dð‰7Ûä¯O¿˜8)ª>·r !õ²˜^ € Çð…5{E$ÄgV`9e¤žt°ˆ3SN¬æ‚¢X/\ÁÇ™šû¢Àú³$ŸPëÇŒe‚€ˆ~Á#F­g©ÙgT®9ˆ¢¥+‘,c v_Ñ 0;¬\±4PHÃ>Ì/†p’sý#ÅÀâ@ĬèÁ<¶©ž½#r“o·äùWß“ I¾Ó[˜Š†Z % 6dæE¿ÙOŸLÅ‘Ò]m¬Ï„[¢ø0r£€ózk•ó¡–®qp>r´ƒ@>Ö|DTáºÕ-Q–Ü@ —DÑÃÿZ¹´†%"˜ñ@Ô‘™„9÷yPchk‡Š¿¹õpL†b‡[RêU¹³…kܘÂuµ«.$­FÂNÊ Ñ1¥ê3USüøÍ4«¬Ø??YéMý¡ç¿On䉑mca™…uQÐX'd°Jl¬L³­À, Ìª¨$„ •›ŽR:&ÆÔz°£ñ÷,2÷Fb‘ß8XdÃ[gDãF ¢ªÂgrÎïñÇ·з1ËÿÃFgîxŽ ô]¹Œ{¸+öAltª¿g£SþÓl4÷I÷”ê feP³2¨Ù8xÜ8Ç18ŽÁñzðàqãàqãàquð¸:x\šuhÖ¡Y‡fšuhÖ¡Y‡æ44§¡9 ÍihNi&gÌmÁ†øÑ90¦8?’Q³[¸¹ø9=ûeûðüjfåÉ®AhFõNÏ®¶ÿ<;³yddÜ­GÖ[ª° ÏÊH>vKº}zùêÅ~þq¦9¢r›\à ÕQÛ](fƒåx‘…¤Ô~Ô$#ñX')EH46³ A– KçØxÖ¤”¦ÑZ¨ò‰óšýÛB†5!çÑ:F`¡¬·›ÝI(¶„–Ú˜øòÂ('T'X5ZÙ©|©VA]Z®a$¬Î…ÝcØ#Ï%²Ù«±á®6 fô.J@¸.‡Ëùƒ <$oPð|Š‚f$éXô©¢ÜÞÏõJ’‚qÜ»WC˜{òƒ›ŠµR[?ùÁD™¸†³>s79÷¹xúl‹ÔC8&ý@–Þ) ˆbÉÍeEˆÂu½ Ñ} }Ÿ]bDGQÄh*YVŒ^B’¶wBšHX$¤ia!²¦!®x(ÈxÚ@4¡½EعSR¤°ã]¥Í>•Ã­z Šä Œ?91´·‡É°ùǤŒ§'TØø²~êä¤æ53œaµ% <ņ) )_—½ÁPWœn›“—D®Ë=‚ÂY; qå:¨`á4f®Üe«‡' K³¶rùÁF}6é©ý˜d\¦×/)ä~®sÁÁ2QÚaû °¹»g÷7Øw®'ÜÞˆº <]Ѽ2d$i([[`aøGÝ´Ó©Ɇüvàà727[°^Mb³é±£%ƒÑ£¹½Ãcæ"ÁçúÿE´¼ãVþ4ƒ²Ð1ï3( yóç”4ˆ $„  aƒ„°AoØõ]ƒÞ°AoØ 7lÐyhÎCsšóÐœ‡ælsÏÆ5ÿÛ£qè*[ìÓ>Rä\Žß²™Wc(Üd!ß‚ëºbŸ‚Ò‹;Ò™5÷DCét$)kÙ§c5LBŸK AtÅÊ'–ä ¹uÑ~œâ ŽÑQ€ÑƒWÿ} ¢:šR¹õoÝpùþ“8õL‡ò`’w8Ð+TâºÇÜŸ$„|nB)ñ¬ÉQ8¦fW2ôÒƒùGî€ñx:ѱ§(9yv æÅ*ÒI!ó"LuÔ±C=€Dþ –£€LŽdýÈÂ5eõ…>ÿ “—Lè¿"Hšûñ–¬ë SV’Ý}ªÍª¤óc[øAí?7KÜ.<î¨Ë¼5—  endstream endobj 3593 0 obj << /Length 3155 /Filter /FlateDecode >> stream xÚíkÛ¸ñûþ ÷›ŒÆ<ñMMÞ9¤i{Ù¢(’|mmV,ù$9{{¿¾3$õ ,ïÚÛwWôÃB49$‡óž!7^¼_Ä‹ï®âß/¯¯¾øVš…!‰Rbq}³ BªéBI(§‹ëíâMôC¶KëÍòÝõ÷ÎFàœ®9¬eáþ°\I-¢—Yë@•2J“èïO’$Z+„Ds±XÅ$I”ƒ¢3[¼ ´ÜÎlGÑ:yl;lÇÎÙn-W,Q{k2Z§›wKGi½uCY]WuãÚ©ÿn³·qÌÊlë&å% …?¹¨‘#ݾ»Z¼±Ó^ÖM¶ióªtËp óS%c‰Œ^´Y¶ù’Éèã’ÊÈ#ZûwYiù²X%”Ät±¢p*™¸S½eü(F!6 $‘S\`!Šƒ"ºË‹Â5mµ÷}·™Ÿšå@ÀÚõ:RBgýxÈšÖ úÓÍæP§<˽È7RgéæÖñ÷©À)CâD^&^â”-¤ˆ€áÐïgvKˆ¤ìIâ,£‰¸ýñ®€¸ò ôRÿÕ«ë—Hf™2fÔT5Q²ŸÖA/V\ÆD˜PR*dšŒ;VB˱ {á«—ÔDï³rãA4}Ë2çU•k4E…B{ç~`'•VjŸb?&ܤH¡Ç¸É¨üï‡"< ¸¹­2ø²j]c›m@šO›õ½û¦~´€!ßLÝçÆššMÛñ¡ºq_‰l#‰ñÁ(Âb FD¬CÙà·'¨ 0צ‰pà‚YÖqA£CƒÊ‡=måz¶XŸ]^f~­±S_"AŒüZåíÎÝç«ÖM¯—BFÕÝœ‘†Ð¸ÇĉÝÅçŽtÆYº…;ÑÂqDÒ›/üYí»6õ'cQV¦ë"Û:ù§è…ºØTN”’QÝ^ôZ)fÔ2UÐ>ÕÏ{>CšøÙS†zÓ ²@‚UGJ?æÊ XL¹†Ã)f¸¿Ý¢(ïÞ;¡bä蹕ÂMÖXI‹non«Nt·‡:/ßO†ËÃ.«óMZLå:ÿ9õ.º÷ˆÐyçñ8®Ðõ éϳ4 M“SÝ‚Ó|Ìœœi+:Žeb°rY§¥Î‰NÎÐÞÖYs[sHˆê)€è¬¢Ù'Fw©77UáÍb3•‘ñ. £Ž­ý±½ùÓŒá×Àú]æ,¬ *6ÃùW`D^"ž3G+œB*æ'©î*,ÑóYk=:ÙWË•¦Ñ«%謉®á#xôrnYC„6#Ÿ76…Jqö0>@Æ e&úàa““°v:yJbxŽ}ÍíÊÃèe€ûð­€sR"”F pÅSkÅŒœå6ˆ çò7Ïî·1Õ3Ôÿlè/Â2²Ìnk@B%ðˆB”ï‡÷–lß\_ýx…øÆ «‹.¤†[lvWoÞÅ‹- ~‹sHkî,èqçÈbñúêï. Î6,­¼M|5{Df0ÐÈÔíÃVBFš g¤qŽBÕÿ%£c¦R¨''ëþ=—©>£Qºk9Ù? Ë*Ñà’ÐBøÔ‹®šœw%¼:’‹Ñ‰@ÓÌÞ —š‰±&Ø _(ï:¡*´¯«>€€ž]ÚÖùOØ–6¬Ä¾µ‡G<’§É²3iþæÇCUø©ò(üò¹Ï³9ú@ìl†ÌêÕ 4áJ«Ð„2 ú0kaÐÚ&€–åáûý~ZçŠ6.e†Àm’‹áq¨öD…|k›eûÌF]л®ÓrsëÚveð:ÊŠ¢õŽ$¸Fes'§ ü 5ÇövR&Q¦·¡–×c´v­ç¥ß¿É›~ß¡|ˆw̬7‹G®oÆrè©åÐ'ðÃlv&¥>‰s^Úˆ/o=ÚeUïÎŒC * #²¯³›ôP´£tΔ@™N¢l0Zç…ónr°ëY‘¶]€¾OkÌÌÓ¦j¨Os±(8 &éÔœž™è+¢g$:<ï)(/­BN*a2 >:žDËoS•G Í"ùÚT‚‚º¼“)>Í;±«Ï;™ òN³²ß.×´0—§•T‚Ö ÞâáÄr*gbPéçÔ• ÿ5`úçOÄz¬7UÙä[p#[÷Ûšj·¦~[²8› '“ô9¿™äP¢ÙÊH½ Kyës"OÔ/6UqØ•a5©Ù¥E‘ÕÝâi9gËP&iÎKÊ(Q¬7øó… Â1ôlaEœ(¬ð„ÑÛ¥¾lÒœÌ,}6èOÖ´`³7^¡ÇL‚›8ƒñú,Ÿóƒr.ü†Dò"-¥`0ã æ±8’0ͦõNzY½óÙe[ "W÷âÕ·ýÎ*¼ØÈQ Ÿ‚ð/°Eg`„¢£ gÊ`ðë cÐÀÌ3Tka½¬íÛ0<°àªÉl‡ìKòn$. Ö“s%·%»´Õáp¾´ó=è 4#s–iqßtJ|~µ'žíéuž‡Ò¥­b~è³¥9ê±,GÏ# Ú,¥:m–4ê«où´ü ìì`AQAsɃJ똱ÈÀ?s±é„ÇâÈTb¯tE_¼¤›Á ;¥éîú°'XÆO¾5óûô=ø±Ã6s#ny9¸&·VZºîÐSØ®»¼nîÇÚ© ˆ ž(UYw…â¾ÁRäÁ:¤˜‰VŸ¶Lô‰%a”ðÕyüÎ0Jæ…ã–Q®Ñ»Oüéà1è¶ðH6a/-ºª®]Ü},·Ü$ cÒ;îí)&¥‡¶ÚáÁ`¹û¥’xMËy½°Þ¶Ë4 ±9Ô5ÞÍÚþò ó£g؃)›SZÆÚ벊2Hm QÍåALÚ;/8ò“U'žˆ&“Xo˜)ª:q{ÑVTâtKÅ6Œ¸Pg˜™ê¸8Y¨ÓŸ±´úP]Éób\>Iº®j.Ä-¬œ"3©œ¸ËXØÄH Y/NÊ)ÐÓ—SFvbM/[:èó‹)<*¦ø©'‹)ç¥Ì†‡nöi ³UÅÌ€YY=8Ÿ Ý~…9ö™ï£¶$’ñð$/ÊMµÛ™Öy‘·÷s±@'<(PèèÚ(Ñ_¨bÛõA²Û/ê"3|ÒÞº–Ï åq¾ ƒC-EAKþ”;X8h¢éS“åÑ…„ŧ¿låÝ‹)ºR¨*È35:zCgàd0$ò^šaÄv9Šþ–"ã~©Uìz!¶Ë'žÆèQ­Ç½á„l_I>­:o'î(‰Ç ÈNÌË°ÑMõ„øÇ ÖÏšB!ßbMe…˜ó …™-,A@ ÁCÄĘð_¾¹¾ú_¢ endstream endobj 3640 0 obj << /Length 3687 /Filter /FlateDecode >> stream xÚÍZÝ“œ¸÷_1•'¶ÊC@I.Uv⻺‹ïb¯7•çF»C–10^oþúô—øZÖ^ß]ªò0H-©Õêþõ‡&ØÜl‚ÍwÏ‚ÅóåÕ³ßkÌ&õ3c¢ÍÕõ&ÔÆOU¼1iì‡:Ü\í7ï½?_ü|õÆÂÌOT“A Ó™"ß©#øÃÊ Êãl1C¬>;ÃÀøæý6Žww°õÅV‡©—ã#óNå…Š½*ðš~…©8ñ£4rsžÊ+ˆ±iãhÊŽgÞÛÞ½ÝóWÞñ²õ¹ªžÃ«N¼R8iÚ½m™ªoøY•Ç²—¦ƒå—òxÊ‹^†\»N·Ú|ÔÔÔ‹ZÛãa›­Î#³Ù†Ÿh‰"WQäó¾-?=Çã!;؈ë©(ö:+ ÀòC©%‰o’Aj]y˯^9Ó0µå¿‚xM3´¯œÁ|PŽ$™Ì®Tì'ÉpNùéê5®Ä&™.jü NÇu+TÙtÝæŒÕ ¦HX*õ€"õƒD Ό젵+ëÁT3t·_Rq9PêaÆ)o*õãè²6WðŒ ²Æj9e‰qà©m Ûu¨ñ£ú°ž©(ôCà{®h¤ì‘·#õÔÞõEx âMËF‘:tÖŠ!>è‰oZ´h÷qI¦Ä¯>œó¾d¥×Þìd'(@ªá_lã ôþy‘žå¥Z[4Ç£­÷<Ô»/ëî›k 51ïšQ$òª¼½³º±Žï@7ÀÌEèÕ7ÛSSÖ-ÀÂLÑdóêŒ"ŒbÙú7þŠvG°Ýx°’PlDg“³Ì|Æ`)i ³«5„L ?Úl'd,©Ü†¦“¡Û$öñ#?‹"ûW{Ÿ«žÙÿH;YÑXÐB~×A aÄo뾸£ýd±K[åظ)Ï`¼EÍìÖÄø*—ç1E…Áz†F*¶ý½S2=ÐZ7Ýì6Ÿ…`U äbæhf>ùi4óQ¸Éº‘Ã;wnßè•ðÉ– /ŹmmíebÛìLôtΚ,³ oT:g-y„µMb€Ð½E¨­-ph”ŒQ¦(;²olGˆÍÒyû¶9Èdñ NONŽ¨x{Dvn…H{/__r#˜>Lßuh°n'bÏV¸Ÿö»ó®ßOÌ¢Ô 2Š×qè šªB? šúæwk¶F´Ñ¨€F©,/»ûÅùšN×ÉfÖ=¢rùŸ|ÜÒ‰8 WŠ©¾JóxÍ0 辎×t&Q8@Á7ásfAñ£iù©Ÿ„* ÁŽôB²èP…]e'¸¶fü&\7ø´3?SJ–Ò¿éÌçB`Æ£ì³!ð5D r†dR óéæ'pâŸÊ#´¿Ü‘™Ið„¶…°%þ·aÿ¯Üò Ì#HÄçGØ>ãŸàâ ²žæQ¥cóøG²ÙÀÆ `ybÃqagé[ÿ¹Có•SÄ<}ÂÌÿŸ[\†'Ä+±Ò˽óövgú:Ñ“c!âò®(wJÕ4VÓ©æ šç¾º(#KÏA¢\Zr~t½SBì,Ú$Éq+t^#†a;gmÐ28'GâÖF÷Eѵ°>sA»ª)nq]•@—Å_KiÊ‹Ci9cD‡¾çÖþÐ6ç!EnUêõí¹.øü±õ2¯oåm2>¯x?Ðüö’ŸüÝQèýá=S°2ÛêþÂÄʬÈeëDpî-°`tàU 2p·m™%èáùdÏœII˜vÑÞÉ<'ÛŽôùZú¤~¨oúör-3Jý4àmÅWâäwe`>Š¦:¥u–±£ø8SRàUÂp.‡áS9ÀŒ•ˆ%eƒg×Ð’*Zä÷e~ÓÔyÅEc¯qm ´Š’b;$"™)®<„i… 8¼& pqéCIðÜü]UÂýÎÊá‰ŽÑ‘Ò hú¡©öxVì–ÀMëG"—ÔÉÅÖ+™4FAñ`Ê·_ò9-@D=fS€9Æ\àáµ›f«Âa²d–¾˜(ÝÌHW*"Ó2ÇŸpw‰÷»õT{’Ê€ÍDA(DŽIÀEí—ÇSe!]e\ŒQŒ1j€«¶Ì)pÐPVðåõ‹7™ò^\DàîþÆDï_‘QBi|¡ Û Óeû35¼ºzöá’!qj?sˆTLáNq|öþç`³‡N°m_ƒ~Ü霺Á]V›wÏÞrUqæ"H „gJ”Èõ»Woß赨7ó#= ÌÉŠè^»Ì¼5Ê ‚ÔÉ#‰8 1a¹ò¾Mò ü¬l¾’†ŸG‚5|›áµJÁ{7›PœÚ²°ó•r™—­Â-‘û¹Í „XIÜçOMoÝ”ùZÑRc¹ÅLªja²7éÝÊN|I„ÏE>#Ù!:”âJ½’ýim:Ø]¾ëíúµGkP°o* ^X c´ò\D¯œŸÂº-Æ åèp¸•„ïðÊü¿ŽÕK˜‡rp–G\·MÝ#Ž¤üΔ“)Éu°låGÁ¢ZZƒ éþ8õÝ:ueY%×¼c7ŠãÉf¥&$n¸¹ÂŠ*BŸäÛÜ‘Ÿûƒº€ôžIƲ“¸⧠½H­„&2óŠ›uRƒðŽEáTÜKMŸµNGŠ´Žˆ![?ÁFØùGšKΑ ^àBÑ øE_(#n.ÀÔʺãE.#v2Àâ†?\åœZ†SZñ§0¼;æcãÔ†ñ%QTMçxnÖv~Ä8¨¶‹àšF åõcùÀ²ðá²tðR&ÔóÂGº ãÇ*Ò¡ŸdÜç­ý-ë2!úAÌÍ0å…¶Š“VZÂÜ €ýfÁ!íʪì¥>°³ýµ²hsÂ\ ›Q ±Høñ!‰=pâ„d8>‰ d¹D›L%ŽCÚS^Üæ7–)¹Ìó£"I$\ðÁÇ Ï‹F„­‚Ôðv3A‰Š»D·šÄV’ñã:Çæ\/ÖûÜ•u>ìy©6D§µã`Y‘÷¢:r)zH-'$ÒJç /e½·t°šã{”}%}¬ÝˆZ6/2 «å׌gY¦Ù‘XËæÜ!"Ðü¸¶_™ð ³œ€¦ÍCo ­l)K†T¡ÈÏTí ]. /CâªBÐF Á³kŽB5î‡ÈSœe˜Ðæ 0 ßs[Y/')¬ùðw”Ò ÓKÖhÀÊqåÕ DäýáH—)‚X”î`_]d<;4îþêðâYÓÙš–ŠsMwx4»mûœöa0è8*Iæ}‹ÛpóËãŠ'"²R ”ü®mhŒF x£K ‡ òUÉJ˜Ê±C]û.É,4§øDÆ¿¦öS»ñü–ØÛÒVÇòd¥‚÷C{6œDSëîßX¹q=ÜF.“¿ƒ«ÆÌj©®±oj3´”{;ï€ôCÊ;¹8¹ÆáìMÕìr©­|,“™ ÿ0Ë1wü@œþ—ŠÄ/Bª+¬3ædô 0e«2ÕCys¨à×wLD¼$kpóÙ8øÒv”Z>¥ ÕJ?ïf#÷OƒPz W¸æjÔbb®S†J5¶fáÃÀ´lÞ.½ØpŽùPiÜß qv†Ä8\l@ j5o`pÓk¢ÿ¾þò…¢2Ùôˆ”IEe¹}M4…uHŽA?ûcã ZëóѶ±q;]ìç$ÓÓ ;ø Øó®È$mÐŒ—2™D †ïþgÓÒ¥ pñØÉîË@†ïŠÃ¹‚A~° ¦¹Z(?ƒ˜ÿñã›wkYšñÓl’Ù2'aìÇÑâbø’°žÅVbËÄÅ” ðABü)7Hâþ>ðôbchߌœþþòs·˜”Ó7µì9¦™àÐŒ òÖÊeKY$ Ä.Û¶”.P[^Ýw”2$âš±y´òJ¦#;Ô¾Ji¬8L¼c¯KÎ2“¤ ¹95-W €¦|ŠÝÔ `’hiò!D?ý‹‡4ùCy`ó\8;;èyàë(¤(šs%4;™FJw°“µÈ…ÛÖΩ‰OЃ“ \ÌIé!_2RŽM}Í\Ëž%¹»_Ÿ‡?(ÿSTæ«ÑBʼn–¶.–NpLàÅ“8±tÅEòt&–éLäueÏÿ‚ x#Ž&ñ†qpŽ6ý|ÄÙ9Œ&è:†nxô•eh¢iìcâ!ö‡P±Ôiù~i@èùf/©êxm%m HÃ뾟N§¨Îâû•àgþ-íëÑ‚_|ZûsPä›l¨7|³2 ÞR ÁÝê_‡²é¿‹ø ø¥×p‚ä_‚s» ´²hLÏXáú˜l4HHw9è¼45‰ÅÕ´wTk隇ù÷2sÇ+uç┤‘÷ò,ŒL¬IPÜòM½Zþ*ëòx>n÷pµvòO´k‡§1ƆP]€Š’«¶9Ý°™'ãóžd'© ß´)?Á‹1ú©‘=¥ó üÕÕ³ÿZh“ endstream endobj 3647 0 obj << /Length 2763 /Filter /FlateDecode >> stream xÚÍ\ËrÛ8Ýû+¸”ª"„xèªY¤8Õ=Îcg1ÕÓ F¢cV$JMQq»¿~.H"mŠ2 Lõ¬H[ÔîÁ¹/v}‹âèíE|æúdžkáÇ1¢LD‚1”P-7¿ýG+øð×>R2º¯ÝDL2$(ûuôùâ_@¸¡1ŠÇbðlƒñóÍÅË+N"‰”,º¹,B‹"˜ÏÍ*úmvu(–U¾-Òu^=Ì”1ûOÌãËmQ•Û5Üâùï7¿^¼¹iMŠe€ÆNª…‘„1 b¥ I:†½K«2ÿs¾ <žåÅîP5··Ûr“š{mgm ƒ`^ˆG¥^Dûç·z Ú(ˆqÔCürùþæZƒ`éx²2x4C#á¾—«qÃbŽ°TO†åçFeÅÀ‡ù^ÿZr^’(¯µtJ' ÉaŒg(¬%LN•¦†æhŒa2ŽTm“DœŠf.3p-ð·}¶zºL€R°ò²€ XwÄ& ¬(éð:߃o}“xv¨ÀˆÚ™Òý>Û|]÷Ùä$æa“S\eLýÔáƒaÕ1£G±D4rc®×pûê4h¤”šÁ¾ÐúÍ:Û€4Óõ€*=˜³ª 1û„CéÎ^Ä•æœó‚L†ãYæ,ª%ZlMàOµtÌ Ÿ¥ù‰‹&»¸W{ÄE •D¿àÊ%E\$AÊ.’œ7ô)ö›Mqa Ü3,&dWˆ5Œ>Ér"D–³®?Þþ§®‚Cíú8!]_­P·;]’íO‡€ S= ¦ºSxßë")¤ÓAÁ‡SBØÃAâ1`L¶Çz¼=ÎÏ@o˜à0~ºc6Ìí²rs¨Òúp2=|Ì=0œNÐ@E²d‡†ñÁ… %…opùGÜ^œ+xpf]!eL±f:eêeÎÛ<(s©QÀèÄ75r(‰’@©‘'BL ú¼„b¿ø¶Ÿ/8Kp°¼(ƒæÅÑÆ÷Œº¼Ø&pD^ 1¥‡–Ý)|(Öí94÷C‘ÀƒP à —12l˾ù!yÑ\¥¹nË“F:ßõ0Ò¹UHRìÕÐyaXõz`8ùÆè“p«Ë2p_Œ[±û°ÏJ]Ä,våvŽùìG¾ÊVgÒ‘‡MV„LbJ ,„—INr&¹t:ø¥  =JZ»Ä¸ç%xdU¦y‘­^.·›Å|…bÁÒ&gó†D ?7oŒf¡Çó0éòF›Éy#Äl?՞¤~ʃSëµìqýÔT{œËzØã¼ ëk ~ S$‰í§Êl¿·{˜Ûr••u©vZð£'Ò#x §Ø„P˜t Õ&Œ3g[+Ò¬WàŒ) ­†úÿæÌyžg.Yb}õL–Lq$T˜dÉ Î*Énæ2ž=ì2ã¿·&8éúaŸë–Ò8Xê$2dêÏÉÓH‚Ws¤(ëòú9ûãUn·Îµù»´L×ëlp3]g‚a?ö1Ûøq«™äF™VÛÈY~ÒÓ|¬²ž¦1Ø0Æ3¯îš•ý¨÷NfpÙ÷ôJ{Xæ¢%`Ø7ZrŒ¸-9ù6ôü¼Þ.¿7l\ouj¼_|J ø VB‹—”,ñ ò‚ž‰š£éV‰N†8é°Úp2-À?—Ù®:Ý߇˜‘íïÛ3šÒÞû0lÝ:€9º‘‰¥/ÁΣ=ŒrÎHð‹Ý>V¾£1NûqÃ{§óK$" ÖÅÙc—&£Nê¯ÜÞ¯ì)GsÄqŽAËjÛïéÎ'<¨rZöÂh´ü?e›%îÿF¶ƒx0åRHáQ)Ïšeý_eDÔi‹é}à1X[Ë[ít¾jÛÈOÍ9ªKS½åë¼Ê3[èeÕ}–Úäšô4…rÌWï¾¼ûøÙ<Öž%ˆ&î=ñmë ²CŸ”­o6õiÞÅ“ƒ¼{ÔY½s×ÎÒ`!õiaª78ðà©D"¡ú¥¸¯ FÐXŸ“<³¼ "¢ž„® S_&±ã °àa¹Ð©ÓäDÂÕI.FCô¤kÂê8K”gÀMÓÅ^¾º~õq®ÈìÕœ®ÿÙ“¦ V8"dþÊ|Dá ¡EáḘqäâ4^¢ ÑSUê2i(Œevo?\]õÔà É’ƒÒDŸþä}? ½é\9º¡–Q”zIÏÂ’7Âq1ÂÄw #œïDðz:>|z@X>§C8>§C8.Šp> !QÌzæª"ø\s-±i¦¶ýØ库ú¡{*Û`­ó}Oûá¸õŸJ‘IÒÒöû@dð“ÆPÖ³è§ÁTDöèQ¹Ýº=¶UvnK~ ÖŒµ¢GLÏ^…ÑvÛ‹Ó^ªñ§omسvIÔ™]e«´±ÆöÇŸ¯£pŽ|¹Z¹éHòõ¡4ºÈoÛ<ô*F.CþÖÑÙiõLg㨌TâU9û@¸5™ qäb2„ÍT€ §{F¦‚æ‹žsè3|z@X>§C8>§C8. àçþvG!ÉqÛÓ„ê‹LD@on\íúõuÓÏ&qÄaÑ“ºŸ%1’ (’öÈõëz[[¹ˆ -ZO¹„2ÿ«>Ø?}&ÔŸçÚ æ9ÿ1]¸z4fç…QM•í©õÄÅåë/=lb^–4¼t›í¤À”ÛŠøøúí››OW=@T!³ËJ½»àN=/Ž¥©G®˜!qîØ0ÓN®X v‡È¤Ÿÿýn({ÂH‚ì+r&}ú›èÜ6qPÀþc:·Ç<^šàbÛÜëÓþé.]~7‚nýç†NK§Ä‘ (8ÑK`E‘°¾úþ°ùš•ÝSbE]›C—T™~ÎN¯“³Á«3¹¡à`L¼:c®›×ÒYùu{°CÆNÒמŒ1£'Ý#©'d“ë 41¹½§§ž”Çó›ï¯>¼ x¶ÞÊm,=êñgÑ©§Íbë\Ï¡¨z %·71œŽ<ŒtRÑÿ•%!^ñÓÂR=Âq1¤#!fL>êy3h^7b˜?y3H9ÑŸzÞû1ˆm˜œ}íGëù˜§Êl]¿í£œÔúÑàPB=zKS\m›ÛýRf>º3óZ§ûªùÕ*+ö™Å«Ï.êßÏ.¢ùB`9ûå¶ù µ7¢¿’YYå©ž~´R%Žú{.Ž%uas •MNëéð vcOíÍ— ˆÙyüdó«z´¾kÎ5Ëٲ̫ªMý÷z ÷±V?•ÍÍW3‹ý}^-ïjŸm&#ÝÖñlŸeÏ „­ÅL0¬æÓM„i$<~sa¿Úðj^@§ëên{øfΖUw¹ Ñ›üÛ‰)9¬àƒÝç¬/ûMêv²šÖ--–&e­š)ÓUÝZ÷¿.®Ë8PC´‘ØÌE²Îþþ »ž^¢ endstream endobj 3670 0 obj << /Length 3476 /Filter /FlateDecode >> stream xÚÝ\K“㶾ï¯Ð%URUO’®JªbÇë¬Ëë$»““íGCí°,‘2Iy3þõéÆ‹¤DDP¾ä2 ÁV£Ñ¯9ÑâÓ"Z|û&ºÒþú†B-è‚Š„pž.T*H’ŠÅfÿæÇŸ£Å<ünž&‹Ïšt¿à,%Œ2¸Þ->¾ù÷ É“…JQÀì&Ñ"!‘Tg,8DÄ,¾zxóÅ[É /UJ,¶ ."¢¤V U²xxZü¸,Ú¼ÎÚbÅäò·•Ë|µf2ZÖùOQÄÊ|Ÿ—íêç‡ïÞ|óГIPE„P÷I0Fc™òº®j#GVf»—¦hFdˆcÂ%£ZoÇæs¦A¥ 1EÕFD2aæñöXnÚ¢‚)íËù ˜„*uáY ô‚‡ÿº*ÛºÚì]jêÀÐG€ ‘‹ÃÅÝ|øÖŠÄG­'Ò»¯xøþ§HF4‚¿T‹æBoÜÃþH;ß‘^Ñ9àTÇ®^çÆø‡Î‡B9tÎÊ¡³U0¯ÊP­Ut&Z+NbhçØ#œ…7H8 o‘,œIÂYxuJITÂî¯2†ˆå&RßwmqعŒU|zn×ÏYùdî›â)o^ÝùByÐí õÇ|ÄQ¿x ƒôh9KMôWK!{)‰Yâè+ =_pÍ}Áß•›j ¯$ûù{À½m`ç‚SqAh…LgEt8 oºpÞ3X8u†³ð( -S3Aœ0™ ²á,:“³èLΛ$˜…W'g$¾È‚nb/š¶.W,ZÛÜakµ;baû ¼NgJÝæ·/¨¯ÛØ•ºÍ›~¾Æ<¹ ¤óö@zÛÀÎͦ<âfL9HÃYxÓ…³ðF˜Á©3œ…R`Áç)I:HÃYx“„³ð&™Á™$œ…Wg”’$¡wRJIâ¢ó-î®Tõç–YmôéXå's½ÕO6mU¿gWÐuªŒAèÚ—Þ£+g7¢ë|5ztr]çìÑõ¶ïMxÌ÷`à™è΢3]0‹Îá,¼:ƒYxtW*Ýëð*SI"챃 Î&3X8›Ìaam2ƒ…Wg¢Hzx• ôA˜êðü?7®>Ý øâ2žN*OâvÕª:ÃÓS4‚åõ;yekàºu˜;öæÞa`‡¹7ìrêÀ#ã€ò> Ë8p'-û!«Û"Ûݺ`š,F˜ ö wAöŠ Î×fç‚}a¯ºàü;¼i`ç‚SsAJâˆÍJ1á,:Ó³èŒΫ3˜…KûÈ Õ™i]C–+6 gámÎÂÛd g“p^R‘èN(+cìóÛS¿šjª}~º–zå`²LAÛ—¶[EݸGuµy8rNçìáô¶¯MxÄ× MfÂi8 oºpÞ3X8u†³ðp ­zÅ p*(¡É<“„rè,Ê¡3H0oP^“œÊÄ]”ÃrNI÷¶Èþpl-~–Ç«\ÙÆv>f£/âxM,Nû"w¬¼NçëÎÃé@«p:`§· ìümêÀ#Ç$I£y•P8 oºpÞ3X8u†³ðp ,âÙpJÂæÁi0o‘`Þ áœ=‚9xMFÝâ+[Z©N€Wá”4ÐÔDæ7e[yc³ÚŽ¼Âq þ•¿ „8’ƱB ERP7äoËó§(Š ú‘'‚ð½üæˆ7ùÔ©t_ ]½ÝÐó­áz ÈU€ž?°èÛvÜš“¸°[.@[•»;jy2ê3x©–/ßmMW¦·ÂÑÖýyö^ü/¬?Å7þÅ#Ì%Mž[¯¼”?jâÎþx“ /-tC’X­Sž.ßµ¦cS•mV`æCjÔؽ­v» ƒï³N‘øÌØAë9¡0ÑS´=A×vIóäu²Ü{tÛ‘dB)¨²óèKÉ„)’¤^›_^Ê»}Îk K!R¸$¢gýýŠ+¹OëTé“ÛD‡Ì”m!Ãà¥òŸ\AU£Ô @þ)@+Š¬<îÍOb“g … ¯@qå§õ¡‚¤eŸô'f¦&ÁTWšþÖqî'¸ÝVV$0Á•=ɉù®Øe¿¨èÅÏuÕÁÚŠÇ4Ç.iNAj¦=͉(qš ª³7¸ta§Œ ‘Àé §½úÎu¦Ÿöt¦ïKCm¼:z:ÃÛmUwFg)`ê,kš|ÿ¸{™«0~¢0þÿª°“q.;­¥’Õ±W-7P*›çz8¼øêûæb›gPpÚ^]šB s¶Ÿ\ÂSغ¼RÛœ•ª p¾íÜrêk%P q©–Ì̵ƒqS&M’ &jNrI¢5Õ MPçš¼l›†‹ Šù§TH½ÕÍ{ð`Ð՗ݲ§…"Ã!n»ÝºÎÊ_.¼“yt—ƒ…©>.sL”&X¸ŠFƒE2 ÐH›ës›o†Ÿóâ#§䃪Á¾ó8ÒOµÂÌú ±]¥ùñmõBÉg'èl‹ ”C Ÿt¡”DÔ$qèÕ’ÿzD»jÕ4ÿ£ŠAÍOw@„+á÷ù9/Oæ ƒ{|P÷E.+;‡óè¶%]J¨8A˜€'i¢æ¼Ù‘[3.l•Í±BÒÇ>ÐÕ¾0°tª€[½ü¶ÙCŸŽ1Ä:ð’g³›`è@Y€q$, Ò¡q´¤:âb7Þèu$¿l¾"Oœ×¯:vyöÔ ëu\þÕ¸Ýr,—° %iÜÇ‚8æ âXtŸÅS(¡”ñ²Ø*­¤Ñ»ºë *küÒ<¯L qŽe®åŒJsYÛuµ]oª:7„£ï¥XCaÏåãÌŒMÍ^v5/b½-‚qËb½Ê€¦®ŽŸžñ2q5¬Á f WlM„ASüž_xôT4¿˜.{&Š—Ei¾×K‚O+ð­¯^ZÔõ)­4I‰ˆÎ b;ý‹8]~®‹¶ÕòÃÍã‹i±^álr³y…·ý’n‹Æw£0¿Í-aQN­*`ÈÎSøuŒA§ðAŠë³4Ö{>ƒixS¯J“D8—ÉʜҠ2 Ñø iÐÙ /LJ¤´7%¼kÚü`=’3e=r@TºÛ1(s4lVÀšÞÔ%¦V MåXfí4e¬cxvš°'ØXêo{+zN™ÆEó ÞYq A}ß•Uúvlö,À®zç£+šf–-³QkoÖd#Bãn·JdgTjÿÉ»í´É¤Dòé ð°‡àÓÓ€–c£ôyÞ:µÄÚC§i>Rà<"‘éÐ}@žžû tMsÜëÝ}g»‰ãÜ(µ¿¥Ã J O†NIÌ–9£²ª³O¹¹99þ ƒW{´£0’Ö•_Žt_pÑ1^Þ¿±;·$ï—²3–wvNµi™i@x¬ôA~“Ò# µÙi%?îök™2³þ¬'M,ÁßÇÛ¹Šµ·ƒ ÚÛ¡å¦1§-¢ÎB¸“[:âÅÀöš¤¶OÐgrK^ØÙv`¦µF¡‚ø?[ÿìõÙ‹BÌž@ú»ª¡ÚêÐrÓlݽñWÛG y}¶4u¾ÍOgJLÝ5uK}^ÛÛF¿iÀS¢ºÍT´ˆ™àSOÓõˆ{ÁnÊôÒzXäÛO…Lq¨wuíç…óQ—“íî™)O^‘;ß^è•l½=·Êž×Í´wr¬"§wEô±´:‘§ïPüÊX endstream endobj 3574 0 obj << /Type /ObjStm /N 100 /First 1001 /Length 2801 /Filter /FlateDecode >> stream xÚÅ[Ûn7}×WðÑyá°n¼,Œ±½òz‘‹aûa³¶d{°0¢HYy dÿ>§8ͱ–Zƒlk‚GÃff±Xç)±,!±¬¤xÃAÿSJ›¢aä Ú²7,˜r†Ÿµ¶EC©)äšN¨¦ g‚®Ö84ër –ê­›ÕmåÈØ»å(÷~Å•¦ÞÂMÈ[%pÊå-˜åÔ¿m Þ‚uV|D p3™·¯cn†¸V·[Ñ9qÿºPî-€åÖ¿…qƒÞ¹¸ÝŠAKòyr@•ëö¥*Ð6ïÐ`‹£WËÞ¿QД0P–”;º–‚j­• 9UX€A-êöúU–aÆ'oQ0ò¹È‰ƒqóŸzËx3·–YæÍŸ€ðÆâ-¸¦åt‚V9ÁS’•žr¿54JïVá8jþ%ºa<7&pb7ùÍ-û£ÉB¡ÔAexVz¿Š†‰„ù°þº©…’ý…2¹ã«?AJ£žCMÖ¿•PÉç7“†êëGÜ_U3{+‡êsƒV µˆÂ@ÖZúë¦P[ÿ+¦‘ôW«¡qÿëkÅGŒ&}ú°^›&·ë³n&[KþX§x5a¬ÈD5&€’tØð+%5wŽ$4ݽhš¥Ïæ”Rí%£¹„IŸ\Œ@\|ÄÀ‚5‘©?frõqÍG¨Ý0L5óÁ ÑÀ©Ï˜yq÷2Þ±dn€—µûŸ‰ÞÖ¸ävòðáÉêÕÿ~[‡Õw—›“ÕËÏï6ýó÷/~9Y=º¼ú°¾z°¤·«¬ž­¿¦þádõbý~^3SÌÍg%El+ŽxkÝè÷]xø0¬^†ÕÓËW—aõ$HÝò£ùN“‹°ú×ÏÿÆÒŒ¢i.>ŸŸ¿½µ£÷žf-b7;°³pL‡M¥É½µZôå|Gï"±"úÔr$øòŽÞð0#.TZô/ëÍIbÉûsV/Ï/¯^þvö~dûÌó³Íf}uxûñï¿ož¾ÜœmÖa;æÉêôòbÓ=yŠ Ó6=vŠ—Ô–Æ kˆSõfú€m²ìººñøÆݶýèVϯ.ß¿\caÒ“Ó°zµþ}Þî¯ÕçgÿYŸà.6ë‹Í'Ï/ÉO—Ÿ¯Þ¯?m³OÿÝëÏ]þú*öÝ·4Ʋ|~v…§Ñ‘§Ž=>ÁpÏÎŽ§'ç©QG£M dæ©1:—ѹŒÎet®i4h4x4d4t4ÆÈuŒ\ÇÈuŒ\·#¿](ˆ³Å扱JA².1acÎ#g½1ˆ?}~çÿðüÇË‹(ø—ÛUH[DþË…"h ±"¬°ž*>W¹ÏÆ¢-E­ÆÖ¾`ÑVcÖ2‹e»áó’û,Xd$óì?=·aŸõ, f›Õ¹Äú膟 ¾Ó„„ƒèO5 v1À8Öÿý|6­’ìQsŠ4áÔ3¢S[KžŽ8!œ¢"œµ`œ›àgÅŽ¤¹@òHÐHXì„œ11ì„;&¹3j$¶%³åIÊNÄ…V è½à³éLÔТ,)#Ãvõ±…!¤0?‹bâ&lK¯‘ ^-)Gí|»ô5ÝÕì¨Q³u cÿßß9†+MÍÇrŒ‚N58†3ø3‚WsŽbN³ÞgÈ$'4×X4rü)ŽØí“`®ò?éæˆyÿq³Žç?¬ýu}ždÉœX¬36OôY!˘$f™ó̲»ˆÑÖìC\7ã^bfd<Â~êÔvd<(SÄòñ¶UV¬ °IhLÆ’EÌBx’hLåf /þaA` E]sB°ל9úú „ó!ö»:ŒûNeu½ãÙÞ¥Êa½]¢Tkö¦ªbÿ8åšÜXb2ã›ôÊž’Ù×+ו ú{gû¿Í“*X:›.üÉÌùW²ÆkUZÖ´¡BÚÐmè‰6)/¼M I©xÕmÛ`I²xÉmjØhä% – )Ô« بم~ÆÖ ·ä‹ûMŸ™ ©îê?™ñùx{±ó˜âÏè2‘ ÜÌ«¥!Ù݉œQ/_˜âD1‚ C´e™›Y4aì8'”™W ‡oÈ·g®e€ì³ i%jvò«ÑãÈ%$5¶E¬ZÑZq†ýî—¿µ‰8I‰·«¥Üs©—§!d!boVk›³wçëeÅ|‰ýàù+WOè :Ù‰ Ç"4B–Ìâà¹M;{ðz4t4/z7$6ºÙ'ÿüéÑ’«3Göz:BÖ3)ô¤@õãle63 ºü¾A ÜÅS/4sös'è"J4»Õeµ*6ªÒv@ÀÏîƱhõZE?10ä7W>h>Ú×Õk?è:ˆcíuEcaăê’Þ†.ÖD,>#¢ ŸeðßÛÊsc—¾ ©ÆÚoáN@¨Æ6dÙ¼5€Xuf÷ˆÙÜvs`ÌH¾ ~‹Ðo X#­”¿ˆYL~½uÉvë¡ßpͽ¬¿­H×@Ð3b÷$!\ýŽîBí®›¯²ìÍW‹&Ø?’—‘ì×í‘Ü({Ž¿ùìc:ø¨KÞƒbˆ!P*ÈV¿ï®Ô¹Mà¬q¾r¸,÷Ë£~F7p@9FÏm38úý[àXT´bëE‚iþç²…åøÊw8¦›ƒì‹C Œ³M°ð¹¶ã¹E¤ípHñ# y÷8~èÐËíÓtø¡ƒÜq‰‚—¾5˜üš8”pÝä0ñ1ÏNDz%@¿wåõ}-°ëîð»X%êƒvÜõ!ñû`ÀÓ‚~R¿FG›Q¡¢;è÷çpÜÏ„ Ï–dýNˆªlãÆ®àsã#Æ-!»ô¿(ÙsJTg|í™?4°^ endstream endobj 3707 0 obj << /Length 3778 /Filter /FlateDecode >> stream xÚÅ[K“ܶ¾ëWÌ%UÜ*-A®ò!vY*9‘xוƒíw†£e43Üœ¬å_Ÿntƒ9œÝáÊIÒ€x4€Æ×tcÅêÃJ¬Þ¾üûõí«/ÞµÊc›¦Éêv»’IËL®ÒÜÄRËÕífõst{_^]ëÄDåöJ™h[®» ÿ¾’P‡MIÔV¿s§ê@¿ïKlþpe¢âëO]ÙR¿zK­Ý=üEµ£V=6UוLàîõèüôëcÓ”‡Ž>šz]¶mÝP§Çj·ãaÜ»)»cs(7Ô«úõö;عˆ%ü3«Yà?~|‹ŒÐ#ÄêZŠØK,øñÝ÷o~øE‘Â’I'Lt,t-nÜk˜]ÈèîJ‰è+WVFõa÷‰JŶ+*ºMba{%ET¬»º©~/ºª>ÄW׉Vt®gÝ;*–mWí‹÷ˆŸ›ªýH¥ö¡Xsw\t{ÜóÔÛÑlŽαØñ¸Ã"6]óvç™eže–‰UÏ«ñB˜B¦`ž)úÃnEWWµô;œ³«]xÎRÉ8K¿·ô·¸vùìâŽ3Û¯>u †ŒØ¥tgÀ§k™Ä¦=®S6¥YægºÆ£Jð$§˜ù`g­ElçãN¢uÑr‰gÏ]êcw]o¯×uÃœôþæNc}DšTË\ÆaNô«÷Í÷·E*J=‹Ž¨/¬íÕ×l×u}X—©6T`ØZµ}µ“ƒjSn@ôµ6Nôqkä ž%Jýª…;ªmý?¥,‹E’ψRú_%0UY®ÏˆRv^”’L‡¢”©^”2P©Åúž*ÿYß¡ͪlЈS8é‚Ú)¸˜¯ÐË,óêÖ C´P%ƒ j»šÉh&¼Uu-~æMÑLó0¡9àˆàŸÇF§c¤àjoÊò™ã\ýìŽýæx×¢…wÁ78éè@ˆ ¼ì”d[9¤üü! fášÌgE>#(ñö£3B 3büW¼‰3g-¤„ã'­dŒic‘×òþ§÷»™Y°²±Lz×vÍtæ±)çyDع9Ã;¬Ž7ß7%bh+Þè¡î¨àõ”ˆü¾;Ï–ÞwÂ6²­ó.j`¨3•Ž`·œýqÿкõ{ûê_¯pwb%WÒ¨XÚle` ZªÕzÿêç_Åj ¡b büèºîWÀ:ÔÞ»ÕÍ«¿Ïùš&‰óœ(I©iÖ‡¢ù3Ø„}¡8˜äÆÜ)lTo&Q©i™8 §¥–t„‘khšâµ9¯ª6Õ¾<´úø™ ÐÀ ¿¢wõÞÕ)“c ÕÛz·«Ñ“z¬¨mW¯Q9c±:€Þ“Õ(ÂŽéh½‰ëԟלù%´ž‚ÔXpaô³MãÜö,üò"éÍÁt§r SEyNx»‚Î#?à‘lé“X…µ3L®ªžÙZjbp.?«û^ÎâyÛãµãö¸CÏ!•ÑaГ[ ôöËs˜ß²iÜV^¯m¨ÁyÕ—hTì|ãÕ)ÒÉçt©[œ.ëp pÏ„Cã¡n«éŠ^1€™\Ú{s b{K¿Þ´# S½;P5ˆ[W­»¢¹J„»­ãU-¶ìÃ;‹«!#بnü-úŸ~Þ‚'aé ð{æd"¿Jåüù«,6¹½àü•î{=VÝýBÏ%{Óã绾~ÊW‹&‡É¾Êhõtt ¼bIÊñ3愘…¾P¡þ‰ð¹™5– ëÏ ïØø+è§Py šjá=2¥1¸ŽËÖ—Ÿ>®`Sq°‚ÍTm›zï$P†ÆŒá(جvÓ¹¯÷½åôÞB(Ox"‡«^æ=ôC„ëÁÿÐ㳚é3J[WÚ"éñq_ï6ŽiTl6*/wÓHÍؘ¹wµ l@‘8V›ØŸ~ƒ¶@CáõÆdÑ»-µÌ–ÔŒ ˜ˆUÖûb_-C˜Íp ½¾–— Ükô³Å„…ÄŒ–अEjϘòÑE¼µãþÎ{²¡‹º®÷ûã¡ZÝR]"]|Àøõ~óÃû÷OíT|©Àæ…<ÞWÞ¿Ü>Qlî¥ aYv`ÜЬ\Íòx'±Ôô‚ø 8ü"°>~£ÍÂø 8‡V¥ésstNË‘ˆ3‰Ýœ·èò N¸ÒïÚ™LÆÂœØAýìNT K}Z#ós®$¦É]ˆê€ý²¨êx@q×Ö»#\CÜW{¥Ïu îeûP6Ü»wˆòPÖ- Ñï`&XÒÎÈÖ±T:]V“9è©$è4[Þ5•‹ÌÜéj‰Õh‘ð×£ ©iˆ¤o€]S˜Àq¥FFð„î(çÇ·TÁa}(Ýñ\nÚÍÈ̽á¤uˆ~÷ÉèW l®žtv˜Œª—KŠ4p%ÎìK%%%Wà4.üj¾"(¡ŸUM}üpOENðº9²î#"Z÷ PÂÄÙ®¿´Šƒ‰Xb](­tÌŪ; Ÿb'Â_(‡X(Öö±P5êªÂX(Ž ”©k-ü8î^ßáµÛ÷öÔöÇ]W=ì>±þxqrçb5€îf.Ë)È(Zq, "Ž_ˆã'/¸ò!`"–ÜLÂ̱äû’KgÔŒ7Ü™1¶(Mþ®ÿõ‹”)ýn}E œÛ•¬hoã+gS®+ ‡ !Ȩw.|)ͤ QvÈ‘ƒæ4 ´ .R)Wlî÷%\J\Ë´Q/Ž“Žpÿ+ÆÈ?Þ¯™Z±kë?&Íg–¥ù|Í'à “§*óÉSi½„JNËHŸ±ÁªfàÄX;cC/›I笠5“$í<¢5Ү؉´+6ÝõÓù ~-ÍhiÀW˦æÕ>ÇÌk?ð$<€1–ë$Kaac]h´²ªØ²ªXò¾aÆi"¬›ËªÚ<ÞèÓìYL´º†#æÆì©Å8ÝXèi¦/Í“å'y2•ûÌìÁ§.2NJd¾)óÉ#(ùäIG ÝÒ ÓµC¦ >œþ )rð‹áåˆT<¾Ç™“ðçpñGì[Š=§ƒj~iºsí WÞTp§ ãõç·ä+ÊÒa—!K7¸í.‹ïÔw™SšâÊ'°”f7¬+¹Ž¦,1U %¿þB¯Øs)pk±ÅdƒWJqi ùE©RSÓkƒø³1‘ÇD–^Ïà=Š1á’=&„ŽÞW&€ðAÈ€L(ñmŠ ©öfšö]A3'« ÅLù«—\ìèBhuó‘3ØçÝ «©Ks< Ô‰}*Î'ëÃq_ÂýÚ¿™uK&ñƒ< 9Òz5W0MyšéUì‹NWJæ±fšéMÂL¯Ól”ëÓ°°l%r˜7}Š†ž$ö”DŠñ§Ï#áwò<‰ÉNN³Ö¸ð¬€+.ûf‰Ñ° qÆfäç_m†èš+‚/ì^l9(¢wP8‹a­wP#Krñk&0$Ä |Ò µôQP éÄ`8DisÂë/¯”Y¬R}~ᤒD­¤U.dö"ü¦øˆA®d®\&ç%à³øÂðóHøÉ'Î\¬a|-…šeâãn®2ôgåKÞJeb‘ü1‘2\si`aº˜fVI8öt#t¹&›=ºÕ"çÐ-öãw†Y×±é(®£Ð­6ºÍñ}Š¹$t+c“‘[GóTq%}–vEn –«~>K¥ÀxfS2–eŠ©$põ§/’_ÑH ­@Éßjäèõ1~î{Õ#ýK9ì¾ôE1Jkš÷'ü×üåT²Á5uÜ$ÈEf’…oF ðã•"JÆ°6ÿéæÛŸL %±Òµ´cŽfKåÙ"TJ¯3¤ôƒââ9)>j«;÷÷YØ[ïŽÊhd6♿•AM˜Ážµ¾@oÛ,¢¿\mKZ€_–┞…æ4tfŸÐÐÈÖÐYøÇpý—ùä=Ý ¶õ8Ï­FjÛçÕ¶T᳃§Ô6øJ†z‰Î%×D\ëß—cµK®adž“kþý8¶’k˜.è“kôh,µd'ZaÉ1úð/pøù8]ìþw®wÒàÿB #Áw"lõÕáI’Qì †¿@™P_ d…Y[†Û¾ô™ TárÆ*Þ'£Ai¦ç®«tð ­ž>‰]Ùω]¹®º‚}£×±R%.ürn"?ìÛñZ>b· endstream endobj 3760 0 obj << /Length 4153 /Filter /FlateDecode >> stream xÚ­[K“ã6¾Ï¯ðÑ]+|‹ÚÚ’T’ÝÉ$›žÔÖV’ƒº­žvÅ–z%9“ί_€ $êå¶ì¾Øø ‚Àb«+¶úî ›ùÿêÛϿÕre£Äµúð°â’EBª•±:â’¯>lW¿¬ß¾ÿö‡_™fœÁ/¿ùíÃ?¡—z)I#`H×|s³‘1_§uVb‘­n8[§÷uQîþJë]‘ÿíf£5_ßîþʨqñ@ÿõcF]vyÝp½þHcðuõ”Þûºc•m}·|Ðí©,*|§º r¯ÎzMy0)\Ñj#’H ½Úp%:¡¥ÒºÜÁ€6±oÀ» 7Q"cøW‘rÀ;>Ç; ËÞ ÍÞaqŠwH?”Û¦ 2ÿÝÒ°°OËnwUí)‹¼N÷ôàõ'•=¿Ÿn¤|0RÇO­×çqÁ/ˆ¸ \ó$ Hi¹ u2-A’­ßwM'CƱCèõÃf»K?9®©O;¤þq# A]Q*Ûg÷µ&C‹Çÿú†¯˜¾<ÁãîÁ³€E°e‘^•Èƒæá§3Db#Âä×uûßï{,0䇷<ø‚‘XJ%£D˜¾\Ò|’uÞ,ßX¿| Ñ¹¹Ñk`­ž3j4ât u[2€Ð[´]¼hneľ`ѲåÐÜÏÉ¿[D7cÌúíÂ9€jk›Qß~ýþÃ;'²‘¿¹é(Ø0ž›à¦ƒ}={ìz›‘4÷5ŽöY£>d$Ýéö©~Ü“Œà6åÏûýq›yÊp+çô@%:Ø,-Óý>ÛÓSY5•òbë[Ôe–:!Ƈ»gú¿½Oß}ùãM"Ö_Þ(¶þú_Ñq%ÚY²4¯š¦õàÕ gI7²þªªÇâ¸Ç÷1"¶è{®8„+éäˆG[ CU >z»Wÿù×؆)®cs;Òü2Ôü‘ÛöPïËÞd¬W?ß~óÓ©ãåìM€ÔqÉNBܧ•çì'pѲe<Ø+#– Ðù+¸c,¸tìrV€]‰`47R,’3YЄX‡jf‹rcc2DX×"2DH­ˆ¢†ÈµACäGm ‘«(ý!Brgˆ ¤PPר~°r©-ÚHÙXô÷¡³ö%M Êд.î%†ˆw'¡{m²Ô¥W%S3ŽW<àS³ñ¶Ä+V0|W±@ø»Ñ xlëÕ*”Ü‚.cµ}§U¡}¨l[2÷rÓØ­Á»Wú+4E‹ä™éÊ#úyÖ_ `!ôí¬h€û'Ê)Ï”âXoŠ‡\ÈÄ…1ž¦“8㉜@ä õJ@”‰: §9 ÿÑ s ¨ˆ«Æh–òòƒµŒ1¹°ì" ß&×@rs$˜;B†vÙè kñúĹˆ§·À|Ô DèÓ®~ìI•ãÆTSÕeêo¹žo Þ¯€ã)=–‡ %¼•Ä‘Ä ßÇÊã{( ð}ì\,ôð=V8|…ß»§I|«Å:U0 ÍGjM˜3´©õ5êøñ{—ãzi=®'N.Åõ€Ôâ(—vdVÎÄ÷kÀ{jëŃ »ÞÃ<>ð«xO@‚÷.Ìå὿ |=$oD$ø’·¯ïBX¼ŸõåÇ6^†7‰TRÝóf›Õþvбí1[*ÿ 1¹ë$5¥“ô|˜à%µÃÏÛE7ÉŒáOæö^%dºÓºÙ¥MhøcÁ×ßq;ÝÆí4ùFHq’Š„CêBy@ê|¤÷nþ±º±ëiY¦ÏDz{Km1 ‡Ï΄;BA}F½!Û‘MXx >Š^báEK³’ òRÙËL¼¤è’tZP\fžc0©qrÝÍZ^ãe— Ê¤w \ä©5­=›×I­ Õ¢U!{hUÇ¡ÐbCZ LÓƒƒ™ÂßÂ`_’[$¾9ÐË,ÝÞ»LÃ6áņ·~ÀÂ÷;æÝZÊä¼ìJ}®ìŠd‘è*ÐRšHs±èÆ`@¥ÐàÕ^,¹‚‹«†hVòâgÉ­2†²‘3Ùâ¦1%ÁmÅÌÞìI'È©™h(¤wU±?Öþéì’îîocKD`E¾­|·bbk¹ÕQ«•Zoi| ÀÕc¬S_Íu*œŽdèÄ|u–×åÎ €Åè]±&ÃAñ¤œ•Ì¬ßÖ¾‡oç`”ï›ù·tç»ÜÇ°á,–Š…9 ’‹HÇí x7a ñÊ5a®‰0ÅIÄ9 s^XÝTPT;µË‡˜ ƒLŸù‹Æa²—ËÒÃÂeˆCá Lq p$á´Á–B·kbq"ŽÁ ×n¤¸1‹bqçm$õL&š8‘§ºHâÎX¶¸Š“¸ È7tûÞw¨‹C`‘R±ä6þicáí ’&Ž"P–I·¿ a¨X”á°"0&Ö]‰õ¬?Ô²CRnô)AAGÕHn=¦¯ÍŽÄœs¶ ôó+ Em{©MµÅÒQ[“€^§x Bñ <À›.ÅÄB€]“"ŒÖ Jë £µÒÄdÃæs?#Ç×Û° ƒ§Î†Q¨Â ’€é6ͦ àÃتó,[—'Ô8wG‡6làðvzvW¾q߆¥i`»­™IŠbÞ³JtèáÂ9m4 §4MÀƒ²¦±.ÿ»x)>!7´Š)^’lÀr6¥°ö¾’ôŽâ/‘üµtĸêߺN] I®ü’ÐfÙ¦=ê&䧴¬‰DÛ'š*.Äü4±¡W§ÐÌgN†/¸FË=ŒùI{¨À¢‡)Þê髃‹FêB5Gû£y$„£ -¼¡Áé>,] û`ÕLžÄ ˆ¾añBJ0¤× *@¿ÀaIØsq¸ÙU´Ðêã\$fÕàwµ7UÚy†[*T ¥RumöûvØ6¤ê*ÊF‚"mDp}¥ÍLœUêåwW6®ŽÓ(:„3få‘áâò0k˜ªÙ½va Þ ëï aõÛ?ðe–»ÛðÏï²úS–åÔ p¤6Í´耥Ôf€t²iT&Yü€eç›3´ ÕqïãJ:Ká¥9<öB‡tÝT?ó_÷7 ›ö5XÏH6YÜ»ÊH7¢PøêÝOôêé©N¤_7{m~"Þ"¼Â'*âDÒe?¥"éR*’™” Û¦Tˆ.‹Í)GbœþŽ´&óÒí-÷_&ð&y'ÃÏQ6šÛõÛa##¼+m¡p2„%Û]èÀ‡¾É˜˜µÃ6ž½”ò\e õ¤!G~ù²³Ñf6Û£˜.ûÊ”ÑlZ;h(ÿßB›ªÒ“ úoRG¦ÖJR‡›YyM&Á8ñá Æíï&€¿Aà/à_º$œeš¿—#ð§‘ð¦Ò½&‚%èè`ar‚'‘É+ÌBIngfáâÙ8›'ʧr犄íîå•O@Uâ‚«Lέ»5b§¸-aVè]¶ÎØ1ÆÁºÑ:O™Y˜}‡^¸Xͤ")“QæÛ˃H€!¶øo ¦Ý÷SÌUà·Y€×3WY€‡I¼ˆ¹)cØ[ÓÚ”±Ì.a²tÒÚùwÓ‡¯—áÄi%üJŸ]s7NÌùÜr{7ð]Õ=|¤“ðÓÕà®IÐíÁ×à ÎæV̸l]ÂaoLxmé“0Ûï³Ü½æz ™ŒŒý×”î¢ Ílÿ¢i>”È&d›¯’lï:ÈáuTö£>VÍ\gÄànw_Œžû)´.pƒv«)ªN°cX…6\6ßùF.Ä>èæý‰8r€|Žyøuˆj™ç$P(,_,=xIÄ’Qø‹¿¨Ô¡?%åP1ίù˜ËóSôßvûÝœMZØøÓK¸ãÑý¿/„Ê.+áÚUÏ@ȵdí÷s’ußÏ!Ù;øïŽÿÌÈõi:÷ŽSá±ÃÚÂFÙˆ¬Ÿn…΋pÙ¯í+U7ú€ÅŽÖ¥jÊ <ëK¼æ+HûæB¤m²Wí¼w6Í÷øŽ—Zèõƒ}H¤S¶É¤¶q¯ ØÂÿ¼  endstream endobj 3677 0 obj << /Type /ObjStm /N 100 /First 995 /Length 2612 /Filter /FlateDecode >> stream xÚ½ZÛn7}×WðÑy‡U,Þ#@l¯œ,|ƒåE6kûAq #†&ÆØäï÷öP¶7Ò¸7i7`ÈÕÝœâa±îdÌY\p1gu ‰è´ s&üTÄ%ãüI59 Ñå(ø¿º\ø›¢®h$]É턹*‰o’«˜¢àK u-al Ù‰ÄÊWÉI ÞeãïrqRªCsÒ„ãjp’=>¨4å;uc§Ü2§¨æ4µL*a1J~5;­™Ë©Åiký˜ŠößbrMœ­aH¬s4<¦þµO”ˆ¯x£,ø§Eòk”H&?Li:—â,vq¶êÌJלe,+ΊÅPb-ýº( é&¡¼K€¼µTR[ 2äšl_ž±`“^B6‘pkµâRŽ\~Ÿ(ŒÃ>í¿Àd; “URÜ\J½EpnÒ‘@qá%$—Cà/ð˜±GüŠíÏsÁ»¹ ¢æW0ÅB)à–é+ÔC)ª¢æŠaÍ‘»SRäš¡<•‡½'*­òΘÀkèÂÀ*«R] ”°F#gh@µ¾Ê©pý+t°¤þJXûÞF ]Ø& t°i«˜0šõ¯ ¥T—bâZ×€bêZU®Í Ì­sÆ>IÓghqP%B@’»°¬õ±$ t:”LD)€¬}PÀ¢“0G‘.z춈¶.{Ì&F­+™cSŸ‚¦+¹oNæØLE–”H¶rr÷îÉæÅï¿nÝæÛ‹‹Ýþdsöþ§}~ôö◓ͽÝåÏÛË—n ¼Þ|·ù~sÿ¥ô‡“Íó훽{[ó©pBóã2k’p¢æSŒ÷­»{×mÎÜæáîÅÎm¸;ßßòâÑ«;1½úê+÷Í7'ø÷×h 5®OP­âM¸f<[ˆ”ä5H=”È©&o}{ÕgIëርú ŸrÀa±zKå8Ž'§OãSÀ*çÞÏÝæŸ?þ êíiX´â‹÷ïÞ½¾u äè+LÁZòšêçF‡ÐùZ¯Ÿç}›ùCš9:*6ÃæŽæK™‹ÞØ×yÉËaa.¤0ä$j[“§GKZ¡'r3˜’º`f¤´R:èìé46l`…ìQ¯ÝãïOï- 54ì€R¼"%^r ø‘˜ ? `r²¬µFL+×0 0fV†aØáôpWÆ4 a; «Áßœ~ýµ,¹â¹P cÝ%pU(S,£°›âþÓÇ—MŒ5ô*Ü£ŠBrŽ„˜¥8<Åq§¹pÅ"»²/5€Zhʾ¢Š¥Z ¤ÏÏÐÿ¢8X01D®Éš?¦èÛÔàñåßýe §CtH¤ 2"$¼¾²â­H¬ÍÖ’Ç5 ˜Ezd }ôQòjIë VÒzÙ”ÎJ &‡ý)Ç ¸¶¬8à-°ze½‚2öPïwšÊz)† ¥©(3¢ ÎG€W¨kEþ@êC«ëå ð[±`0h]X‹Ä¶šÑ"áklN(b ԉϢx¸0 Ö¼°6[èRáÄÂDºh+úÒ@°;¹M 6å€PÿÝäÑ~ùÇÕöryÏ! U¡¥ \¢'¹Ã Cè΂ÝF˜k¡µ4¤Ã •̵†»`ª§» •ÆÞçölÉŠÐjóZÎK©ȸkCd…ÏÀ†T¶yÁ Rͽ*Œjž—zгx,ˆ‹.›ë"ÇfÛLƒWöZQŸEø™„Ø¡ªëUB–¤7[S@`I×ua6TŽæþK·Z¡ •a…AŸ·.”¨bÇŽâ(‹&yGÐø4#@U?ƒcñ8j²S/è°-b›ø\ð|˾üð…*C‚ð{]XFÚmëB€Ç,• ƒŒH’ûÅ€Zõ¨ZÔeÛkÚ+óD¡®me‹Z{9h„dÐõZ8‚:~!`ae"ªýŽ–ï×R~³2žfÝÒy=Dó²žt:@,Só€”/ÒêCP“Î5-à¹êj®Ã¤øÜoZ -(žyq­â9Õ[6²ÔäQÜÀdÚ‡–#bn½%û[¼‹¢=¬`ñÅz//ûA9jYÉÖ„Ò­ßèè­FTã5²}€çVV -ôÀÀµxÞt\#Y…}*’àè‘›3À"àÆ´’˜mõCËÐÏu5•é ^=ÞÒö]CL>åµRßÕ ùFÍTöG.•¥Oj`ŠX©ÎÁ¡ËvÕ’³Ï‰Ì&OWJ!Ü»ÀÇoÚ-,ãõ q‚ì¦tw‰øAX ø·„‘³§ÞíÞ,éº Ix»Æ0kÇ0EeË´lS;ÀžûŽ¥E!¨ÔJž^¼ÓÍóM^ØfO¾ÞR =ZýD@¡| F’x ôˆ'Ï¿;[2Ý >ÃC ¼ÃëÇ«Š!Âe±ï~  jnGA| ½Ô”¦!dT…ˆ6¸ åUedXºÚ7­’1#ýß(z“7ͼ ûÉÀëÎ~K½2stabZ掆°­|Ô}ÿ/PVà¿ endstream endobj 3813 0 obj << /Length 3634 /Filter /FlateDecode >> stream xÚÝ[Koä6¾ûWôeˆ¾)˜KI0Ùd²;v°‡™ä¶z,¤»Õ‘Ôqœ_¿U$%‘zØÝö,²ØÃLS$E‘U_½i²ú´"«ï.ÈÂï×7_~+ù*KRbu³YQNRÆÅJe2¥œ®nîV’·ï¾ýé#‘„IøŸ^þró=¼Å‚·„L5°¤~uyÅL–䛶¨±i’Í%%I¾n/iRÕåŸy[Vû¯.¯ÑÉþ¸»uÓ²¤Ú¸ém¹¿¤2yt½‡ò’Éä÷KF’ªm\îfî͹¹»ê®üH+îÜóí£›Û´°õÌ7Êý§îœ«+–¥ZëÕ%©‘Æð®h‹ukדðÂÞý¶÷…kêj]4MU»GÜkS¸ž¤þÉUèÞ7á1iFhGRäÀw1 z&Žx!IªT÷Þ¦ÛD¿¹¡QµùÖ5{Jâi6~xà)¢+n!öì%<ÅÕ:å&ƒ†H3ÁFpRËpâ\‡p’ª‡4›j{ôâŒ'Å7·–ø]¾ ?³üÓ·JË%üXàð§K™ä_?¶EãFq;»r»…E}£ƒ´À$»Oûz×o·®ñ€Ð®ê_4þ“‡|]¸Émåºê㾓ˆ¡äØax&÷t¸Ï›" ?7Ý´]þG¹;îÜC¾·IÓõTx8G€ÚϱÅ%;T6~ .ÜËuÑ뽓Žt: ¨,3©ÐS rò,PiJDÏe<ËY¾âhÓsø>}îû˜¯ûïá€^Í!Òöñt¸+®”íc婗Ю@ÒU€vRæÑŽÍNy†šSÁV`¯t-µˆÅ¾bßÖ%âPâµÝó.‡IënVÞ°,°íÜãv{Uçû_=–AA)S²UP–˜¤Þ…ï:5è¦]q —L'o7®?ˆgx,à¥Å¿oå—Ìo­ä®ûw|%ßý㺪‘¡ÕþÎo$Ò1 À]ŒôHèõÀ”Uœ¦:3ÝD ¬¥}eÌÈFôäFEÐ)¯|u@¨À9MÞUm§5îó6~m ÊÀ¿×óÀ>6°@þ©US´¶ë@ô)Ô‚¥„ñ^¨ÿþîæ+Tò$¡ê)ô†ø­Õî—ãëVÒLòà·}Ÿ£UñèõÈ"©c1ìAŒÞœwІòPGáRæ¹ÃpÍî­UrÜ7»]3f“SÌ0gNø•íü±M ücSB0Ý ð Zqï¢.š¶Ü٣£ô!XÙW4Cc—[ÉWVx‹z@ÃþºÈ·_âY·V ÿp½]¤“×uþè^»îžg#›€¤ƒSØØÞ¸`¨£L‹ýÕ3>ãT2)Ó) MñHô%×Îc¸øææâ· ´fdEWL³”káš«ÕzwñᲺƒÁ탺[Á¾¥•÷íêúâ_£5ø?E_Ÿ\ƒ f²'4UúUKô'y~‰ÑI\^'ÖX"Õà(H"SFU(ÚÈ“XóWltˆ#èbZ(Aç¶B)zð(ŽžïZRβÔ/•ù^,ÞÐ/X˜­Ð…e7R³Ö˜ýTPA²Î˜˜ÎÿF`LŒŠŒ ÆÆÄèycB3 4“§RE¶ÖœŠ îd°0öTÅ‹Ú}¤`OP6^&AõèLƉEŽÖ耡²êómcÅ·‹³ +Ô*ð¸ë5}m›ÎàZkËœãÛILð- ø¦±7N3bµÉ2 ÓŒC·¶‘‘gðå4•±Ã¥¹Ð]ê›Öü¯ϳ¸‡‘þ:²Å8ÓŽkã^'¶ùKЋNyú½Âć²½_Z?´+xÃø™‰Ôdê³]î}&?Ðq#oÏ'óÖGžŸ3âoÏT} lö 1ÃY²×£ /@ dJÆRõLQ<ïÕļ7ƒpT"˜ˆ'r—ÅQáì4 }¶,Í•½Ìƒ%0½LK Í^ä>a”F_·„?Èó+<ë€AØšf™¢Tól1_Š|°€€­^Ú\¿Í³`£¯à$?ÛW°'ΰØ1Â0Ãb_®}Ò ÐH²‘ÿTRã/ËÃd`П– Ô)µ-i^\2 2¥™™~W¿RâÌDÒr:Uܘq…È&EâÆS=áÕ±½ª6Oˆ5ÆZxaýü§ ÃgD—P`9ÄÆ ú¤¼Pš øÎD``u õkÖèŽr£³ÌHMÍKXK¥™^®R ;|5†R‡ý¾öFÃÚ[8»ë×ÞhW{å5q “º ÀjÄ_+uÙ_$u/Iºb\ƒª:¶n×pHQåâ–³6Çá\Nrd섽 AÛÃ}¹¾w;ˆ}Ûc£…ªvÝÚTvîŠ]U?v0–À–uèrÿ„wàdÚo1~ô«ýÖ¿ì¼T‡%e¡þtAÎf³äÝà÷Y|Ž®?`îÌ$w¥Í)ã݉õqÛúÀ³ƒ~Ö%_Íb)çÄNt¸·»ˆ™Q½ÊëÅÒ϶5•³8:r1?“Ø>\½ìíx%¾Qáéµ)êb¿ö}·EûPt.âÈ¿üÎ¥ ¤Š Õ_[æfù¾2¼oÁûš6çjœ°Å}ó.ëˆ-Ëoøõ™z鳎زŽø4“ò€Þ0eòðèz¯Ýž ˜R­ƒÌnfk¹ºïXîQ_ŽD™òÏnkÐáv첩±³“ÙZ÷ò\„Κ`×ß¼"Bg ]·W'è<Aͯq Ö‡;ê¤ÊÚì-ë´ö#›ËÞ¦îB•M½Ñ'Ro–Y€º”1:)ŽŒoTù8I¢|œ ÓÂ|œ\(îPŽ¹Ÿ‹üÃ]¶®9NIÂ"?òqÎ6ût%Ì™ÔÛœ<)2r"²"ìÊÛk»èU\eŠ ®­‹®|áUà{²ÁŽŠG â¾í(l½˜¾Î’è® XQÍÃ)VƒSâw¨Sv l$°›½U U½ëœ+WÁµ¼'q·*À—4KzoiÊTïðUJG¥gKWOkpÒÍœÌRÉôŠIð­Ù¹ 2¥-1‹îV’Ìs‡¼þÛ{ëÞŒÔûÂvÀ„ˆ†í0#R©ùt;Án¾òqÇ«X£å^È%8§ÚF®LÉ×KbìëV"°R¿¿[aÞÜí^ü<=g„Ô€S©BeÆ5øÕø†¸:Z„a8ëÒy8Ô¯4õ¥p4Û»bßÍ  ÄçàZAÃ&Åáw]í[0Y›íKá4ÙT[Ÿïò%p’|ÚV·¹OØknâ„]¹ßÄR1¹:ê• JßúÌÛÌ%9Á±–CjúÇŸüçõ ¥D>¦'èW§•-¹¶ù«ƒ yzf) B6\Då¤yïGhæQyݦ„~L믣ÂÕ¿SS„Wè {zu¨J«ª` :µ¥hã^ÀýY²iŸõÀÎ!þòÚñj¬/)½–‰ Ù–»r°Ì/õòòï@F¶DFŠZ5¼LM†ËÔó÷yïP›áf¯ nöÚ;ÞŽ”1z éèð>2žÆ±žŽ¸žŽbšA,xÓ»ÛÎ}þŒDäÿÇDÌ"‚ñŠÁˆ=í"o}¯»‡†­þM{uƒÂþ7EÞkß‹j§—$l÷ ²óÀ+b>K~ŽDxÂÜNÐaÇ_ðÜ»’óØ DÀYÚ„8ÒÞPeg0œO©™^¬¯ê¢õ®ñ­ú ’ÌÜÏoZðòÚ»Ñ}O2çmÏIÐéÅŧeKœ’ê({öí¤””ᛧd£ä`ÏP²Å`d²wBøêu]ù9¡!":ùɦSp ȽÁSyn5[«Tðé}&:w]ÉB¾Á̇Læ”°KÒá®@í/”ʈ¬JôÔasÁ~ª†»ÎÝí ЖŒl ÍªÙ¼FѬëò0ØÀg3«vÞõñ¶)ÖÃ{2Uã¬8vÿwAlNø;>Pä|c±mcúìŸH•ª,*:3Ö¡ào®û*+ xÛ鎅Ç8{À1N;ÇxÓ‚©—ài©$ ÆgQˆ¾«ú_†¡Ý/Þ’:XÉ#©6ÌýÙCæ s–E¯@ôôjÚ¬ endstream endobj 3864 0 obj << /Length 3894 /Filter /FlateDecode >> stream xÚíÉŽã6ö^_áË. Íp—Ô@¦é ƒ,3éšS’ƒ,ËUšØ–#É©©þúyÔf¹«ä0—4ÐEŠ¤¨Ç·/4_Ü/øâ›~¡}wóÕ£1K¬Õ‹»íB(Î¤Ò &”XÜm?/úøÇ¿ù….$ü·¿Þ} ïÉÞ{&fqdaS÷Âêve¬]¦Û&¯°-··‚/ÓìV,›²*>§MQÞÞ®­–Å–V79u²r<5n ½\ŽWlrØx_ÒCCnûš–Wù識nò Í!Üuž#ÐppÎü7‹ 1~úfŒ‡•,QÉb%8KLBÇúøî¾Ãí” hhQ9‡Ž™qÀ®~3€„q+ÃûS¸ôe1%Lx3+MZ3*‘„@ìTyº£Þ1­ê!–U¢ºE=,³ÛU¤ìònbŠöéøšE‰"ÎCK\¦¾-öé=ìP=Ñ£'ü‚,­sê9Ðp8c—ß ³ü¯ß«*š‡}Þ=_Ek)c&´˜@ö³d6 ; 3`Ê »üÎRû¬È’ø´öÈ’ñ—íO»¦8ÃýíJî5ïD:b<¾Ž{šÉ³šéX½éä€'×JjšÒ·È†Ø9–·Ò,AÉÌ‚3âáS-ŒJ¿H¢“ð",í½2P"2Ñ̈諘Œ¢Ëˆ¹J›‚2ÍþÒ¦/ fÖÄWq¦eI"&´©ñÄÎ@“ÙV“Y¯·z+‡*ÕÊÄ«ÔáT§I¹†HC}âEà@½N³ô%攈Kò—ùieÁ¤š‹JD_R"‹¬ê)­eP"Øõ.Ù@ƒØÄ^pAS6è%`7ß"Š¶yÖØùM°_u8í×aKäw JèÎU {îWDz@µâfyå>TÓ3BJÉÁµÛ×kÎbi‡L¬Ê,¯ë²ª‰¨Zò嶬¨CàŠd™ï Rt8ã_A‹a-2Ž¢a jÍN:Ž˜ç0ðˆ}΢Ïs¨d¢ãíG'ÃÝ óþ»Ÿè0ÛÈ‘ìŽ×©i3¹ßq¢–ƒíà¡y,vèxÆÀfOÇ"²?ÑÄ:§¶ÞÃò>4à,ÎSZÚ0)å5´,¶#Ú 2¤ ‘!‰Aã!¶§C†¬—îŠÆë› «'ㆾ³ËÓM=ÔMh´+à]Øðe:B€R— sIG$,ầ#l,‚Žp]8ÏS]Ô ÀHç]à¸C vNuXºÉ³b“×~¾ÄD0¯@P÷a3jËS³*·«¬¬ü&gšÈ« pŽìž¦åHé Ñ;AÁJ'ÂÛE§QHUåéþºàÅ€¥öú¡§­¼ÂSÂS˺ïê³?[¸)êßhú˜f~°8Pû½ PîoÖ¼n?†‡âÃãÐŽÖiL¹skáᢚÆÐza‹Òu:mHÏEÝŽã‡ÿ*lüÌ\ቄ¦â3Ïö2ôEAån Žö”†€oO»ÝªJ¿yñBºk§¸#ûLÍ’Ø^«ÃâN‡ˆÈ¡ÎÚÄ>‚Ö=É áºvÉžš²‚‹€ÍÅÍÝ0í!–‡É -ªD·¾Å‹›¯Ë°_ÚÌt¿A·i®‡¬7‹º†uɧָò…Ófðä0„Ô?wÀK®Ç"ØÂããÌŽ©¶L&òUˆë Þ!j‡ ßðÜæ{‹Ì™äÛ¹±IÇÞÚ"ã)å¼\%ôOÞûRÑcÚøÖ³­_ì¸tò¹`ÒÆWéËlO¸Ì@Ô±‘ƒ¯®O{´¸':ÃŽtÏN8,+OaOƧ*÷îG‚âYVé}ÞÏsõ’aë +œ[æ–Vø…›SE°No׊9_¡ÂlÌL,þ™¥8èqUQBnoÃðõ®d<`n©c NL¡UÔlÃ3‰-t:íLO›Ñü€ä8@~)öÖ~ òLîß+<œRóѹ`#9D¢×w‰Fö(sª+òw1ü•\BºQ-lÔ!tÀÄ$ñQEpŒ‹iq•os¿O{ïÏ •s] É"¥Ï#ègO¦(jOèãN¸¡ð8[jp…G„ ~5%K¼ÿMw±ëDŸ@-0ÈíÝ{r±ç@ìnqwÇO†÷Ü5Öz€ ïÙ¸ü1öRˆm °bñÙ/BØq¤çc®ÉÇ4>ÝdBº —µ^%Ž¶^%ΠW‰ƒLè{•nuA3Ö ®¨rˆH]¢ÉC2‹àü¢÷açf“(©s ñ©ñ¤:ìÝüË_è£OÍâ˜vR %” N«¿yT›“Ã’Î wè˜ ˆ‚à|\KëT½”èy6ÄNOàDU¥OÔur í¦Ø燚„^Ÿ=7é2Þ8ßU­ð‰+ÑkÞùÀŠŠD0w¿+טÃ~q Öïk—!-%àøª‰<–s¡Î-‘· ç ‹Ùlý,¿·ÆI‹Ä·/Ò±`ÖgíD{èbŠ z_QÃ|OœEŒâcb{¨ Ôr'h95yÇ—)f&ò¬IWÀ û¦ðQ¡3ƒäq˸]°ÚVåž4-÷f¶™Ò}¹o-iðÓ‚àŸ30f: Hx÷.Q Â~c<ðB_.ÒLs5t7Z”ÊË*\v ³‡rêjéfSPu.x}ㆠÖåiŒ² :c㘲§¥¼3b8“Nñ¡ÍéÅö2Âsßb•+P2óÃë¼yÌ]„N]Ç/o¥w—¢P$ôÓg³¤* ¸‘‰]`žŒ¬ß`Õ•†I¡‡ jà²2ò4?6SZïÁ™&AÆúÒæî”Ó81˜º7é_6ÝWiüñ¡p‘Ìt)7ZqøÝ}é¬0 ]2ŠóTVvuÜáI0DLI+ -.‡à7}@@ÊR1ø—£Ú19M)ÞmÄÈÜhg•êƒÄìÖös«à7Fá£Ç iˆÀ-nÕ¡²¦m “ØñÝÌä.ˆ¦n½QýŽ¤Ï»—ÄÁc"wÏ#`J'cú<{I*L¯TÂáŸêtˆ 2ãÐ)a¬´FÏŒÒ#>wŒ¹D‡d¯!<·ò‘%x7·Þ_RêÅXV,²­œ_xœœ™°g¬ؤs®9Ìwj¬Ãs…4©=óò ã&êaû‹N Æø5‘} 3Oh†Á¦4ƒfVÚ¹—Ð0Ãøl¬M.¥íÇŠïçÈ´é® ¹«àíõ’Ht÷/ÂEnL²àÃ0Éâ^t—!Œ8¿“!¿¡G¼ëþÕàæ8Ž:^V¿… Ftù/ ™Qãü%[£ …8¨WDÂÛ'Üö«—ÒLö E&\EùÓ¯œ»G_IÂ%WÔ!ÈÖÑk\æ"h\Y Qá®{lg¼ÁàÊ'ã²ùËK@,‰Ô‘ãdì O"4šV46Z¶š>Ž—EãßI×u¹;59 ÷œœÌJ–ëcyØÔ4߆wñèÎŒéüÞ=ØwÃq"Ï#A[´Ðåòà+ç܉Ÿ7­*ò`t,BŒŽÏšIKεŒ‹ör<}Σ5ÀIU‘åµÏý½åWz+mÆ9¢AT†²ôᎴuRI,ì^ë]þ@(B1“U]zê.–û§ èâš2ªÕ,Ñëð¾0Ý•ŠPBQ"ÜPðEDìöo™¹·¶Ô¶Ç£jÊäÕKÜ"RKØ-üFTèóWÃÁõR#Ž ¿Zw~u¯š¢ûÕª(zTEÑË,õ+ua »Üø*ŒÜ.Ÿ§Ž”\Ý™SöU²wµ›S´ I–Ý™ZYÆáN–I„"p»…œü¡Má°u¿Êq­Ë¶‹ Ê4æïƒBïB ²ôa±ÔÈ" _Æ£Ö±Ì Kë·4 1÷»œúÇ*Ï Ìéú—6åi½Ã;fgÓ’6 7I½j;dnÏóe!O~YU¿ Îm}V§wO·Öàe?‹E_¢«çÞ§Æ߬Iõ÷ýåÁ„…vvàB¡ë ^4aQ(¹6á­ =-;1…‡> stream xÚÅZ[Å~ß_Qð@MKÝ$ ›˜9€lG¹Ø<3Šh­× ù÷ù¾š©18ëÞê á­ê©>õÕ¹ŸSmµxHÁjÉÁ=H7 }ÌK+|€§Mù¤ÕÆA Z¹Ö±PÇâ /X­)¸è…¸–à™‹«„œÌrÆâ&ª’`ÎAðGØHËsŶ-óEŒòXW[’;G=Hí~aµ%ì¯|Ö$h›¥jâÍ‚š_=¨WÒQ-‰{´BüÄÝp¤VÇ»ø!‰q„×Ä;ö t`ééKÇ?y`éX\:OÆšñ‹{!•ŽóKâ½W«µàVÇܹ°†%^xò–$ø€ÑpïJ¢ÉÀ¼"yÈR`Ff™£ŒÑ7)!|M*F…T„ü»€˜ð+1“¥¹¤ÈÑ\2éJLj!•\Ð$ššBv [i%±ÖÆ xÖ•@pÎ’zç!r(Eùn*¡ÔB)§Jëã8-Ôd„™€AÈ€&)Têê>v³%á:œ½ÖÁØVö€BmÜ›7±ñn x>Þí¡y"S,…–]i¥òW,näFZÏD µî‰æ»jÅÙ­Œ_kè9_[€D‰ úÔkå¯ÐÞ©J AÊΟ]1”l”dJ´©t8ŸCÝS®Ü/Hª2@ÍS;P€ž§Þ¸+^ ip›ÑCb"CƒZÆn’éâ8"ÅÇSì&ŒÃ¸òâÁƒ‹ÝçáL«ÃП†Ýßþþ‚ŽF½¨{¸|ûÓOß^|úékKŠ š³rµç¨±nµ·3¤»rµõH¬[m]¢ôµ¸aP¿¬]í-x‡•«“Æo±nµ–%¯]-´µ„ÅV+ù°{tõÓÕõ³Ÿ_½Þ;¼óÍ«››ýõeÐÃô¿Ü|ñìæÕÍ>Èxp±{|uy<»ÇPCï‡Ç˜Ð…¥9ßëG‚E%Ž:Ž>'eNh÷ÍõÕëgû›ð(>vÏ÷¿Ü„ÓÉžÿûç=áýsØ—7ûË›7ô+c›‹ÝÓý›«·×¯÷ok<ûóþû^=¼ú%¼à&…a¨ë·ØèÕ5Þ†3‡+ ?»¼¼µ‡E<#Bõ8¨§A›ƒ~´42:6>s‹6·h“r›”Û¤Ü'å>)÷I¹OÊ}Rî“rŸ”û¤Ü'å~¤Ì@tÈèØ(¿'„Á®‹Ý³·ßÝŒù“.¼Ø=¼ºþ~=X¾Ýýq÷åîÑ Jç5ä ï{eÀ¨pÇ–`yaófX÷ÙЬga÷ÅÕó«mþè˯ýÅË4¿üøcjÉ&@Ür,p°ø?:€Ð%¼ 7]biK â°xøžb™´ ›†ZÀ¹Ç¬¾D¶b­ — —+§Ü‚MI˜—yôÕó'²©h¤Õ˜“iƒªø‹@œÁ¤äÈËú¦ü¨=Ó­# —;ýÕ™a Ú(sš#MØ:ÄÂ|°åˆbÑb6¢ÐÃÏÄ Ì5 YvÌ[]à‡ÖMÂÐN9q¸KÌÌr—p܇žºvè%’u_È·¹a©ËùpÓŠ6 ‰ÕG0Žžú­@žüëÇ¿¼Ù_oïÆŽ]Àvd­(oàEnwìÝC‡fÀq)\;råÞ¡Œ+óµ3 ¤Ô(¨D&—3ÿ®Ò65Ù,ÈüPè!ʲVAµY“»`ÞCKÙ”!`€°:ž8À „•58ê}ðµcìí?¬\‰,i÷Á#CÖéÛÆZt¥ ߥpi……4¬V$Ÿ®÷‘¡L‰ªvJ‚,c^õ|¦«Ùb§†(|§jPçÜ0¯r7fEqh”ýp•þLà6PUHƼä38˜‹‚ H†¹³E O§šnªPK¤lyÄ R©¦=2ÃþÔtñmÍ9`÷EÂÔ ›:zΤåÄKASuD6­”ÊYØÄBa‡:Yáɼ8”>%¿yûݼüÃÕeD¶½š0ADâ~Ò’Ä„qY8Û:U&^"‡Ò©%Y…c[á8¼jÈ „ âhí/¹W%a†Ì‚î¨#`“þÏ*Âö¯Ní-dyìnU½¥#÷›…³VzF‚nkWW l}íj³˜×’f#öÖ–æí«•Y¥¯\í„­õ®Õ‚1^L@"½®¤mlóÞÖ¾uµ66@ËÚÕ¼ÝמR/Y]ËAÞå÷Vÿ 9óªç¿»¡¿»:nóÞk€ýÝ P^í{eê´9˜=D™=D­C­Cõ9˜uÔIP'Am´Ù”´IÙ&e›”mR¶IÙ&e›”mRöIÙ'eŸ”}RöIÙ'eŸ”}RöIÙ'å<)çI9OÊyRΓòì/·Ù_n³¿Üò¤œ'å2)Ù²{ê:û°§®ãRö˜cnšÚi²Xò; š‘Qù2S°Ômû} ©T)ðœ•mD+Þh“šÞ¶·MwáÕ”½hg9;[оÞØy÷¶è¶Î*.ðêH5á­ ò‰ (g{_‰ÿA# endstream endobj 3895 0 obj << /Length 3466 /Filter /FlateDecode >> stream xÚÍÛnã6ö}¾Â/ 8À˜åM"µØ>t‹¶˜Ý¶Ûí¤X,Ú>(6“µ¥T’›I¿~Ïá!%Q¶;Óû˜¤x9<÷ ùânÁ_½á'~ÿ~ýæ“/3µ°¬Ès½¸¾]Å™Tz‘ÛŒ %×›ÅËwß~ù¯¯~â×ðO\ý|ýX%'«t΄°°¥Ÿ¾ºZ)­–åmïZlêeY—Û§®êþzµÒ…YöM_niîÚíw4­¹Ùò7üG am˜÷Ð6k×uMÛyüt×õÕ®ì݆¦Tuïpí]<õñJðeÓþÒ=”kGsú†~»¾iÍêïÞh±’V,V‚³"+è*·¸E¹†ÙW+™ñ%×Võø²ð«úŽFJú¹Ýo·«¶¬¡.žVÞ9ê4·ô‹çÒäá 7†ÐPjF¦•ÈY¡ üjfò•²STʘ„ ŽTò•|s¤’&襫¨vH)sÛÔ}¸\õ{¸HUÏn¶nv[ׇ^ß:wÞå þr‘Ãíò?ævõ~w?E’ÔÍ&’öO¹ËœPæ´8ÉDšr1HS.§7É”"qJÓn\ëY{;×ß7›°bÝïA”žè˾svµÊu¶¼Žk[×ïÛÚ‹ô~»’ÈÞÞÑòÇÊ‹!|ظW‡M›z©Tn¦"[öO¾¥=’q$BO£®½mÚÛ¼Õ ÄÒ±;Í ˆº_÷®î+¯)`Š þ>”í•@Åà¯Bœ Ôà x€e‹É;ßÐEª‚I£"’’(i2¥hBËô¨ëHb`½ünëÊ.\¶u·.À *ç"ÈVÒ–3Eôîóo¯¿Nxæ$| ¸ðJ ÖE§‹Œq;,N•ÅKÇf°_×Ýz}©ŠåΫYlm\_V[”.e‘uü I4FÖõ«<ëvÔ)¯$ YmK ýÍ6,ªÂ.SNñ+èÒ€@À I"LZ‚ ø'0ÏT+P¯u݃[÷žFvd&Ï–¯“íi­%”œj-5XN°Ã‰Öâ,I»YnéªzÙ=íYí­#„x¡Z;¯ŸYXÁ9uü62.«ÖoqØ,Ó¯h½ÂŽûz˜Jv·I&Á·LÙÁ—–Ž8v{0 a©•d??à©…X®Â`Uoª5šŽVö÷e[Žf$׆“kÃWoçË°ºnÂbPØÀ,{2`¢Çûj}O]Rj¸þ†~ì&¨ù½T{£07ÝU ûO<ƒaxfDÜÖí€eà9Tx¯³ôÆ°8mAx>5† ¨M4GŸ£ú½ì«¦FÏÌêÁ3ƒ)£g™g†›müÏ ÆZWn?!‹‰k>ÐèÜS†ü1øþMý1©OûcJËÁ{‹& lCÓuÕ·sZú×Ûý† "ÌÝ6(ÖÁ/ÑS»Qp¡Q‘ ÍÅ¡öTÙYF¥ˆ ?•Á¬d6_¾»%pjrn¯@¢‚Ê‘àû›{/6šc£X.Ì1f–`7oºf»ïCobç¥D§E ØÔ^÷Âw$ÿ˃³'¹ílb=,ã£؈ouG k† {LŠ#|ƒ£ :måµÀˆÎK \àÎ eÉX8ZÍtU$÷ ‡‚ŸÄ ÏÓSýnGýnåQAT&‚ˆSAÄ¥© úÍ¢› "~Lb"¯õRÄuvˆ‰Å;Ç£ÒŒÏykDã*—šø5Ëæü¡¦äBcäGìMýNè&ü¨2|©ÓIž³\Ës˜N‚s3å9<$ a``7<Uxðt:É›²ÌH™âdŽf4Í º“!`f~¼ß!ÄiÆÌóÓÑÒQ¾ôwÚÌ£¦-:äÒõ“à0;²‹ç]„`:!aòÔE3E15uf4u温ËòÑÔÁ” bÛ³ý/Þ®6Uy×ÔqæCàdPDMßÑXu{©•àóE€ßÿ÷›ç ÐV¨Ñ0ð\öô‚)>‰“°æI¹Ô¼8¸Ÿ”å@ÅL3ʶêïÁùŠ!θ˜d*òKP0hÐOÀ£%_Ö¢Ö¹m˜±æÀR uYø‡App­—f„iãˆçöÛ>àˆc¨S|’iC×ÄuNZ1ÅmJ§VÓ9JÖŽZ=ø¶^%A{Œh°×6èc Óa6h°ý!U–/ožè÷ýºüú³ï® ¹üìJóåçÿd4Ž×¹öcoçסGî9µÂö`“[ju÷Í~ ³Ã9ë/# ?õ¾L—ÔÐF›VÒø…UÊì8¬ €»w>$@£ 1…1Jìæ¾sÉŽ¸•Û04Þhsi‹¨*­À¹sid£3€z¢5AŠ=W„%ñ:7çG´“ÌH(ðëIÇIs¾Âm µôè[ÓhIÁovaó›f_o1vÊæË}‹‹1ÒGœaº(ø¢¨Ä"gFfôT7:‹ «.z)†i;óö:{“1àWÐÏÅ)­™”æuú;œé ¿òíeG+°V$­„<Ov\˜h ‰çGhÔû¿ “\d¬0èlÜ.rÁ8´³<`ZÈç@0õdzÊÈC|þ‘mk‚ÌßjÐ×Uwñc¸Ç ÎGµÑí»" ÉôŒ=š(<:o˘ÔOàŒ©ºŽí›àËÝÀN!¼ßY¦D? _L@Hf#Dß6C¶™2"Ùå– ·êõ¼Šn^ÀÊżÊÇÅëxuôLC–f‚_>$Q¦‰ù.¢ƒ3V¯ò¥3ä9æ©ÓÞ´6IOƒ; Í£î4çC˜S†‚´)Ƥé¶|¢xw®¸‘¥¹»í¿‘)k«’’£“-BHŒÆ¡º«êxÚ®òí§ 7ËTžÊ…G{¡' @§›ˆ'%å`°¯v^@óÆõÎ .NÞ¯Ñ<¦†ÆÇ0:“ Rk‰’J{ÞcÆ·§&â0ÝÁAÞÃP¹^ƒ9êñÄGà;’ÞîÆâµ9G—¾Ù1¼¡©ƒŸ­)E¶ …D38Fv)ø_hÈÚDOÉFŸàè7"I,ošiZ4ìEÇo.P~çA/Šå{×÷à ø¥X¶pUrý,…¡88nç‡ZÜÊ—™â5ù/n@­æ¿òjPSjXw¡¢‘LŽÑÿp¦ýSÏó§òÃèáÅ£ y¨@fÀ®º»ï‡DAjÁ]³©~â\Æê,zôIJÁûäÙE¥‹üD A?“BÈŠËsQéeÇ«°;2õ4*÷˜ò\õ@:¡½³W^ħ¨FøÝõî¡K‡*Xàc éVûŠÀå—: Ωrx&ÏgeÀyž³Ì±Ðæœ-WÖæK¾9–ªr©¦Ïð+eŽ±…g`Œ„í¬£"ož@éÅÈ9SÅáðRJfŠÁµýæ‡o¾{ö•’pÛܤµ@LæµudÆMÙ—3ç¢Ý×õð¸cöªã€½%Ä @7&ö«zµ†­•YR¹ú‹ë7¿¾Á2 _pîA{v!Á£Æúïz÷æÇŸùbAß3 ŸýÔÄK,Ó¨F¶‹÷oþìa™Ðf!3ÒŠÏìÁÓº8Ü‚'Q|Üñ&/o1» =HJr¶º`¹Ep4pŸœÖ—G×ü®JÃ…Œ'¥ Ê‹¼Ì‰H…¾¬’“ 8p!8ø²Heù')³tÚ«,ËqÜÀ_>¾5 ÂîûAíÊàõÎ ˆ›è9…ô˜Y¼qæŽ.¾ :q¦]’ÈëS©mûŒ3ž½ ú4įöPõçléÝû|tïç˜ea‡r™¡¤ÌÇê„%'=h¼t踶Vøçy/h;‰Õ®Qé JöõJŽ|^0Ága0Û¬ÇG_›};ª¿ù%gÌ Ûd³G[°”ý?aíâbmÖ,}ø"zŠkBS ‘Žÿ”a”s%–¡óxïÚ _6 .€·êÿ矇–FæÀÎZørm|=ÓÏjªŸÁÍ´sb}så+ ¸“Òáš?¼ÿâûçT¤Ô ÂìIÒÎ#Pèñ[müc0ŒòNôèâû±-fl&…ïûŽ(Ô!D„Ã7dïm ,Ϋ™eÛ–OÝ…\HçÏa\X@¤È@ïð¹ÌG`\ØŒnüN v:ã ypŠpÿÚ1f±0„Ž߬ÌÕlšÇšiÌ󔹱̪SÏ:å3t¡¦tQ ¯!E‘¼†”6yµŠ_½¯ü&£vÅõC;xeüèy&/rÃqÃ#_œ7ñÓÙS½è³)èG¥ _t6ÏÇm¬5›¤8nÓ⸙Çíñâ¸ÈAÄÇ}ÏÇWiuÜL‹á6ÃcÊ&ˆẪ’AÅÑ-|:$3a™¼ìáüð…ãä©>-bºG[3ç’O/Ôˆ¾ÙCk¯ÎJL|¹•5…OMéøvQë$ß8û>TN&É(,³¿‘$ÏYÌðŒëo>$UøŽ¸˜e.¼½=îÉ¦Ê È‰Ê¿€XÇÈçt›0Ü æîþXMÜ2 :´\Áói=ÁO40‘ _v`V¬ÀÈ ôs,dìï›øfoWÞÕU¿ß¸ôi^·Ã’i;ä×çϽû¾–u|¼± Aû˜m9ƒ#°¢)MÞð.ì8 Æu B´ÉŽ“ YRÕdNT· ë…>gmˆs >§ÞÿBßg½ endstream endobj 3937 0 obj << /Length 3180 /Filter /FlateDecode >> stream xÚÍËrã6ò>_¡#]a‰'TÍ%[Ij²IvwÆ©=Ìä@Kô˜‰tD*ŽóõÛø’h‹ö>rðháÑèw70éêó*]}û&ù~uýæ/ßh¹²Ì£V×·+.S&¤Z«—|u½]}LÞýøÍß¿ý”êTpø—_ý|ýLƒiš3Í ¬éÇçÕ6Œ-mXªtÓ¯).Zs}µ–J'ùm[°i’Û+ž&ù¦­åy[ÖÕ—Wkò¤)ÿ(hpYÑÈ}¹ÛÁï Aë[‚Þ<¶Å §Au²/öõá‘`Åí•ÐÉm±iKlüvÅuRì×Õš§‚q…_æ´#$M±½Z &Û㡬>SûQ†+tLXÁ šÃBŠYÑBŸ„ÐãA×Z„gðgháK| a«}þ;õkD˜°>$ßí¨q¨7EÓÔ‡f¼M xæR»q‚GsÜ_Žr‚EÊžÐãú®> àIYmvÇmá{:iï G¶!pŽm~``Q„„5t²«7ùŽ`ȲúðK~8ä‘D)ãð§W$Eì¼ÿvªBBZ¦¬Œ‚û¯¿ùé__¿ùõ lj+¾’΀Ðð•‘œezµÙ¿ùøsºÚÂoßÁ¢ÒÙÕƒ¹_ f4v«oþyF]¥sÌ(ZHkÚð§_¿ñl¢W†ŠˆÝ‘ªznò&Påá®8=¥<‡D&™scÙ©¨yŠRܸ^‘²ÌñWŠƒE“)­¤¿V’e½Yót ¡õ]n‹íX—Ë ÷^g–YeÚL- œ³€)3Cè5‡  oVùî±)› n¿¡°ç»c@ Ú"^XÇDÚíöî¯?^È™ˆÛ‰”fÂÆióª¡ê]F.ä ÆÈôôRbzqñÁFXþ§æI1K0ý2‚ó°H¹ê¸¿‰cÐoâ·¸ÌïÃi h›ÞKœ›ynì¾Þ–ŸÒTDwzÖmZÀcsf8ۺϋN=C*3Ø^Îg# +žD8ÙSkfÃÇvô÷Í^`uÆ“¢iË}Þ"Mð×çX¢¬u =ˆu,§¨Æ¦>ÖiÈAc7‚Ñ ŸC€ÕS®s?üôÃ?>œÁ~-…aÚdc7PV€~…~T¦&ÙæmŽ­,¹­:«Ê‡Fع=îvëC^ýºS ÛÚ!‘3Í2å"võ±]×·ë ,/³¤8ãkÁÞ; ²Ö–¥ÖL=ˆx…^Mv>d¸gV¼ÑSKÀhÎ =YÂ(f2þª%âIž]brr†CÞI“À@D£…þ›9{jÅ9r2ð!ñN™ qÙèÁˆ4þøöŒä9æx—H¤A¬Q|HƲ$§þçM­Ô} d,¨à4Š_ê Ëø©PÏ:N$B'Ç“œ`­€Aܽ8+0’¬ {]VÐ\dÐEÆ”Êæ¢+;g}!ÓCë«x­/6Ïy?£Tçýp RüVGD[#¯D ˆôÐ`’ÊjSÑH¢o_[ΓE±Pí´„ðèTæij27>sðb—o Y1æfv¬/q{ùÜî7îíuÕw!Ûèñ«ÒÛýQ„Ó‡ˆ|âú ˆ|etrYȤ „äÙ\àžšt,4¼Ñ ¤³#¹‘ò|¨G ô"%‚H·¯ÚCY4ÔAïŽ_O¬á>õ~€¸àPnâp<‚×3¿àHÏ<¾äöfOüw¯zAsa…¼Å¨œ½ö.Gšs9ôÞb„SôÞ|—7Ô¸)Šº/Àÿ=h¨€p6ywK?Tâùù lôJ˜¥ /*UÄ¡¨Ý4õîØ’9OÇGøR‹B„CÑÜ×Õƒ# Ĭτ6#»`êT¤`iŸFû€ ö蘆ëûLd±Ñ¨sCZ›üX·E„TÅMã!ŸY€ú=×qæ§T@‘15˜E¥lÄ8è.wü²ñTž ©/rzç›ÞÀ×[_’°ÉCA°»ÕÊ L«lúrÄ.øD°³Å—ó•e³4v œø¿Ç’¿¾²¼<Œ<‘Ë'®)„µ#ê“x1JâUÔ„·÷¡E2Ò ½ Þá<ØÖU˜àÝûâ 1•Ìè3Ùš]–¨àhð^Z¤'ÄñÈ¡»¹•aÊפf|² Îq2)o©Û¿Á…–¾|ýE ç‹òyCSºÜ…–4Ý•›;jF¼€F"ĺãeÏRÈ0Ý“öP´ÇC&~ƒ³…ºb‚OÈS¶)¸.©ïI½±vš)O…€:vo:Bi‡’Û Äó§•,•ƒÄum‡N9Ê¢tQ°»‚>ÈvüÞçóbG½Žéd!C—b¤v’ ¬I‚V$ ’ ¬}$p…õQ#"N$ñ¡Ø°À–ÛŽÍxŽx¾!›aöR6¯9ÖzÄ$úèÕß- Ù.óñF3©õœ)»ï´õ©›K›„IvãÕžóÉå² f“¨‚½H´ñÞé]KXЕ¥Í€›º½£V,²+È܇ÞvòûÙâ(²W3m§Y˜d(È Þ-¬g]°Â½–o³ s;î+úbnôHMȼ|ÚGgÀàì¾·¥ÆTd<òIh ÙÝñ~6ñ©äïeKÐÛC½›Ç[L¬ýuåkãJBÄ'!2fœ 2Óš¾Í&ßQ¦ ;›zlIE¨©˜­*>b±ˆ,î~ȱ­÷á†×(6eCnVúЖ©+ºÍÆ”ú\âK‘‚Ȳ‹,Ö³ ¨gèåD­Mqß m3~ ·Ì_œÔ]Î,¼íåN1%õ  $\ta½@ƒÔ 0ËCÿÈ…xm¨½§oW4”dü/V£ôÄÿúµ‡YΉÒQøsQžc˜›-0Iu© ÔŠ¥Ìbð ’µÀBiÅÃÛ,̾¬òª¥}ô¿0iè*){i@)¸ºSvJ¹Ì£„œ_¥é9ò¬À ˆô˜Q›ºjó’\«Œ®U¿ùÇc#Ä—Ó¬ê‡ ö‘§àb°ëËwM½<ª†ð'žå}w‚ î-ãòÅ¥Xž ®ÝÛ>K|-Yæì@À²lð²CJ0âzBì‘,i™yϦ¥IêdJBñ’¿ûã®-ïwÞòà°åõ%®3ÖÔ‹¨::Þ˶…@Ée¯'*ùªž$^ì¢yñ_FlÜSÕºX®€-`Tä$¦;Õžÿ]L§çÓcžî¸SÛ¥Çéù[°*saÎŽÕrl{»—fƒÂkrÁ4ƒÂ+º9<~»5&ÕpRÈÛ&Ñt›ÿBWÚÎáxMÖ,ßø›õý{‚Žj¸ðšòìáß®3MÅp9_ W$C­RL×ÃýôQªíFåïaÌ`{ϧR=¨h©”^E"´¿ŒHéáþH&ãº6Ú ýÐ0Ü æô~V½4jLÒÔÓjé—]©î,샧"Xx« ŠDtí#a÷"Oˆïä˜R|&ÅZZïË]exSÅ[®¼SämŸÇÄ»´]‘oÔÉTá;³×«»¹(|ùâL´ç\‰6{jAûÜ‚âtA{á‚k!Ä\9Ù1žž–ƒ¤›N%ûÎøžŠw/–}³/ '†ïyðWª.c+¾çÁvÐdz¦Ævú\a-L6|ã#ŒéÀçßøhànÿFuî‰p¬Oû—=¸,½ìÁè&@ÝËììȳÅ[&cÎ^ÂÀ‡Ò'ÅÏLihH·WR8|T3qƒ“W(ü¯|ê†Äiý‚'£÷uËC<͸=ÍÃ¥}wZiÃ2;øÔÓ’é«+@“‹^žxp… ›Â -ÝSï”@¾´²g\qcÀvîKÝÓ¥X^wº€â½f~<ij+LÎ0þ¯bòpMs½rp´”ŸåÍÜ$íò¿ú¢g¯}ÑÃN%q# Õ¤…gØGfm@Î…„íßÆ>BË endstream endobj 3869 0 obj << /Type /ObjStm /N 100 /First 993 /Length 2428 /Filter /FlateDecode >> stream xÚ½Z]oÇ|¿_1öËÜt÷|‚[Šd¶#ˆ2GÖ#_ÃÏ O€òïS5wCŠ ¹\ÄË°÷v¶§¶§§»ºg­¦ì‚³šŠËªÓbš‹¡BÈÁ¥˜(ˆËU($W¥8 ø@ÈÙµñ¤4×RØ”’\kÙ•’„¨|ˆRí 1—XtÕ Õà´ÆêD5:+P,Zˆ)+0 A5.Ä€Ršn ‰“¦¿é $sª³€1ëw“Ó˜9/°hj}\áKòU Ð×ã] wÈ€sðmñNü &‰ú*@&ãƒsGU Rˆ¹g­[ ¯ ûõgaI>Ñ‚‹–8®‰‹±ÌÑÔÅÜß²B*‰OÀr±OT[q±)õ5èkKk.ÛBqÙ­´9)ÇÁ®9gŽƒ s Äõ¹ljº –£á=Šöy%ºb‘è%9Lf”ànþ©ÀñgƒÕ - ©¹”úð2U2ŸPqU;UW#—¼Á%±ˆÞwã°¥q e‡%!f¨Æ~·:Œ zxc³>›l:gƒ—5¼%u­ÃfØ‘sp„PúmØ=(^ö寚Œb¢ˆ— ³H0ú—"|ÈèÏØ`0”ÐZa 9*€Í“'›íëÿü±sÛ¯/.ö‡ÍöìÃ?ýúûß.~ßl¿Ù_þº»|ÂÛí·Ûï¶OßH¿Øl_íÞ܉٠aäê]šxl7nCRÁ¸¯Ý“'n{æ¶/ö¯÷nûÌ}ñÝÏÿúâ—/ì—/¿t_}µÁߟǡ|ƒq|ÈÍiáp’Š¹ÇÓ_iI †¹ÇKLŒ­}ÄæìvJu5{àÝóJô ’šW„wÂxuÂ!iY °Ü~ê±OaìõˆéSi‹®K:¶9Ö4dÏhÓÜ5MÛ#ßÆñ Ê*"Dp¯Üöï?ÿ»Õ3Ú ø¸‹ïß¿½w 6s™[òpæèØ<÷ôÌÑb¾!;ÏrñÁyÞèhêëì·D~ó©ÎÕm5úÜæâ6¸µÎ«9{-sqh€fDîOG»íÓýûýåÙçïvîôÌËóÃawyáôxù—‡g‡óÃÎIÿa³}¾¿8tŸzŽPÛñg\`/¶0.ó÷é"3—^ßa>?N Û——ûwg;¸1&~öÜm_ï>ÜÛÛ;ãåù¿w ½8ì.WLµ‰Ïs\í?\¾Û]Óoÿí‡Ý¯¿³ÿèúžÉÌ¢›ñåù%ž&sÉÇ}¿]aâήˆ§“«“ C°!Ä!¤!ä!”!Ô!´“P‡æ:4ס°…u(¬Ca ëPX‡Â6¶¡° ¨õ(¼](¬Ôä#ˆV–„üSHàÃ@²}7¥ˆÿ¦ë1‚ˆÌ'ØÜ°ŠO™l9‡|=™Ïr7%8ûù‡—¤€a)¾Q¥)²øiŒ¸Jíñ§7œØizSÏjmjþÓ:ˆ=Ɖ Š(°C2òSîëQ¢¬„oÎÅ@P§0Ð{CAªTê¤gj\Ô"`?±ÄÕ³–PflB.L-®à™V|éõë þ³Ñ0`°²E£§cåzÄ€0oOùö_ûýÓíÀc\“ ¢žPuæÇ6JñÈ^(ö?ïaª ¯ 3X¾PAŸX¢Nxœ5A|lÈÖ&°€öÝPã›â2OƼ( Ì«ùFŒà‡mŒºlШ^Ù‘9ÁhÕgðŽ0–]FKöy4…#á)øÏÞYFP³Éü.‹/…APí£Â ¨øÁÄhɸ¾§óð·ßºÚ].¸Yñò†‚Hà1õ½ÊVYê5ÿ*XÜêÁÔì¼™€õ°!*„"«õFrm€‘oا€ j²Õ`˜¨g·­0ˆVg‘ùEXå·r÷&91¾;Jüg–øŸ|¸Ä¿s4ýhö`8|*³Äà«Ì@EäÎZùÎÑàöl2Í ÞUfŽœ¹Æ¹£SñQç¢fb i®µ-0œÌ}Gmä–³G#¥²ûÀh„z–ÁŠÀt®j».;¼4#·©k¤yº……LÌ–ØivSŸ>³ßãõSnº&·ú)ÿo …MóÏ[(<ý˜ÕBiÖ>o¡ð¤£w!Øz< u§ÞO9N‚ A‡`CˆCHCšeh–¡Y†fšuhÖ¡Y‡fšuhÖ¡Y‡fšuh¶¡Ù†fšmh¶¸lãîÕ- BÂò#ñø¨Ò¥WMÿÉ6#ëœò'+ÁVÊÿÍK`»E}áaûýÆv‹úz_ÿéXòÀ‘jñ<Ó“æœ4´º"=ÆRdžIƒ¥^܇\ Ám²È×eûqÈÒìY&”¸šé`BÀ@ØÒŠ<9ZDQŸ{—!WvlœÖ†ÍË+vFÿ¥ÂUyŽ Â^•Àp]Ê|vöç”lAÓ.­±)ýd,ÂcB´O sAfL×@"¶lïGMy„“1l•ûQe0Vrˆjåˆ+Ô¸Þ SXï“߶ã%VÚ¹v“ŽZ—훯Èò0 &ƺ€±‚².×É#Üe;é•'¥xãÆå·& l±ô«h[¯£Ï“ß¿(÷­ö“Ÿ;·íjÖу^‘zݽEþE¥©ë+h®0zã 22X~NÂå”Vk1|~U…ÿŒçjÈtðZ¶÷[Ë«á0˜Œ»U Æ¯\½äOüp5µÁ endstream endobj 3991 0 obj << /Length 3857 /Filter /FlateDecode >> stream xÚ½ËrÛFòî¯àe«È*™'©òÁÉ:)§b;i/‰s€HPB´GùútO÷àEŠ¨Ý=Èô¼zzúÝc±¸]ˆÅ÷¯Ää÷›ëW_}gÕ"’04‹ëÝBÚ(c¹cH-×ÛůËÏJÙÕo×?tó`R<œ$)ô¸ÑÕ¡]W»õ¦ªW:Zfnâ»ëWÿy%a„XÈ… m Ø#Ñ€y›ý«_‹-tþ°IâÅ7t¿0:H Íbqõê_£5Â@X@SV‡ç–€Ñ20Qx´„I`yÑÝQž^cr”3WÙÀJ8[¤%DÔ`DÿůkkC¼—þÂÕZY±ü,¬XÉ¥Ž¡! ôõj­¥XîÓ?é»ZI»üÿÉj‚¤EAûºÚdMSÕÍx'±XK$VÎÆ#9£9ìgà1ÞªÛrml €C×Ò \ŸCëýÇï>}ÑﺦŸ¾/êûÒ:£FYµÔ84Ù–ZyI¿íÙê:+y£ÝäUù†â1Üâ3¸%'p«³&«i¿í̽ì:ÄâAàb»\´ ²ñÐÂkÒ Õzñj-…Ëwu½’ñ²âËßæémY5m¾ix%=8¢Ò, þýá§+6…Òz%§h`ñÄ2öÐØUEQ­”]~ÉË[…Ë=ði¶¹K˼Ù¤­h0³!}durÁË¥-µöéÍ©6@‚m5/>Øø>­½³‚Cºý鈷9´@=^d‡g‚£Ò1€N t|dZ)Š—›j› K°ÌûÝk€Åƒ-¡?åa$MЂãT ({R=JÐ0ˆ“ÄzÍ;”ôëHBMw|¤N”,«r„H'Ì+#–Œo{—7Ó^÷™—»ªÞs_:;, ­šh† N4&Ò@SÉåMË9ÆUn øõÔY{¨KêÙÕÕž ÌåÊQ‰,Íò=‚lyY¸§nIÀ;!Ð@{À$½u,©7,=jÊÍ]]•Õ¡)ܱÄø<(©;Gå™&Ý߸’ y{èÙ­@±¦›¶ªó¿Rf'èOË-õ7UA’Jðû»$å¯C‹~¡ámÀ@Z„å.ßÜMöô—Íîò¡N·mœ„É0:^Ì<‚füþFòý:Øè*áûKÞÞÑ ”Í}¶É? ¡6ôí‚m 2}‹÷'¢å§’´‰nR¿E½ÌaÊn2²[Rôg„~§æ9ÜÔàïäe槃v8q™ÛŠxa¬gYXõlµßÊ|ãîóõD ï‰>ïÓÛ¼õ[tCýVMú<%ŽMîBêÀØ1þŽ‰ónpèîPÐ7` ,ÉhjAp’ßD?¢4(t©ŸÔ@  µñ£¾äïJÒ·ôÅÜ-Ö¸ÆiÜ}ÖºÂçþ°¿oŽýP£âÀÆfa’tnǽg4¤ÃüY¾8BUG'`GÜ5p”&Õ ÿ6g©dßÖÅÛÃ&óBK¿‡Þ• ;C3̃ÖàbÙù§O‚¤WÕ'½Ò$PaÇ/$˜SyÔ`£—˜6¥í|Ó6E$ÓÌÎï¬pw“®Q¬€>Õ îù43”k°"ˆb5 Ì|„°¯U÷<ÇA¥' !È,48Ê¥MäT½‰,òÛ»Ö±!@·à{a„›qÒ @ä× ~Ôۢºq²‹Ë8câí¤P}Ð̱0ˆF>È÷Ïb2~ U—ó‡ ¢ðh×'ùÃWêÛ¯Yf#ĉœÚó£`’t`ÞÅžcø±±û&Ç‚ —­ô6ù§V 0­æY${µ˜ ¾Ð«M#’çzµ tãyµ2N^z·Î­ ø‚†nñ)!ûªš&¿)NËh3¼°A¶w¦"Æ’ˆºH 9tæÜ¢gòÊböIpÖG¥Ö È4iŒz1KKøøzº“;)Ûkt§Ã Ñѳ¼=%©:ʼ-înà,áW9MÍ#"hÙZÁY*ÈH»äÿ¨F±^«I-ã1Œ¹¼ôñã/O0 =d¨Ù¤ÀG§xÏïÒ…Ç,”³Lqü"Ø ´Î·Y0ŸP‚õyéÍÌÔ….ªólž øXþß)~žç°¬«E8å9}ªpùXâü"©úÄ£ Âñ‚µu™M'ºË¬ÆËdì·Þgu—JˆÏ•®MY”îWŽE_‚þ®Æt*ÝÂkÍ<à^v~åË3q´ôGx ÅžP±¯1ô4M(Kc©V݇#B©¤'”òX@cTUº„@1&D/#îªWšÈ3D,/ó6Ñëka Õ¼.ETbÊCËËP]ËžŽý ©ñÅÀgÊTÍ6UÉ 6ßsbNaÖ2LÆ7åÎsæ<ÆâiÓ¦¥ ¹J ]¹= 9ÿè Ê°qrÓ\q¾Å(µ¼Ê-ð<7u~Ï7ƒÜ½›É5`êÕ³aD²CÿI÷L¢t•m<~ñÒLŒÆ’OÄê†{ï ¯¢h*>–/Æ®~0ëˆkÅã躟>ª¶åbch˜B¬Ó•mꢿЧÚ@pL­QùÈpmÅpèv!Z×vý—×Ô<™QQ2‚3„ó^Ìt–LöÕ†gûJF¢ç¤œéåJDš¬ebU>BÈS3ÀË+ªMZøw1=)Éœçû™@ô噶þ¬/.T ¢#¿È÷¡ÍN™®žk1°á4Õ¡hóû"÷é"*ÞŠ%',öyQ=a}ž(‡Ïåi[çŽS$È|‡"­ÇL›¶>lÚC=7W|€º¨¨â'ÝUÅvúvÊããÍ:VYžJvÑzJ­èŬO $¥'o0­ç+3Òùè¿ÈÙ?™CξPÝ=ePz¨ÿ´œ 8é?Dž9êÉftx®@*!+O>‹Að W££Û)ÙìHâ@ÿTbÚ§]VhöØ€É3~oéÊsý•dî½ã«;è©9~º9Pq„‘Á"m&ùÒ{ÚWa¡1Ð{ÂÎÖ{!ÄÑ%|…ñȯF”×vþå¡œ¶Ó¡×vø<›“Z§ð }ð‘ÂÓüZ~%­ð,…ç&Ú#'9ž£ñœo,CÇué¼þêø^ŒÉ-v ÷WøUhö.Ã&y ؘ&€ð›ˆ½Ó#È̓u(ÅçžA©~é7Í1*ðA”LÌHVVçÛ@0{Ï—‡¯Zñ8ÁÇ?[Žv÷¨ÉoK|UëÞè¦%•t¾§TŒÄž¢X;Áˆýæ˜{ÉÂ'âÙ6ç70Ê]iì…` ]L÷ô¸¸ä„;24”þqÓDñ¿0~Ã0 ߦ{Áùöãõ®8ež+*´½.\ʹ«>õ•©‰@ôœ”y«zA¾ " 1+skƉËó¦U±þ‘‘Lž/`tÇ&6§ÇØÑ@Òð ]߯èa2ýW ˆ‚®xvC¿Nê°á¤ÎiÍd¶ÖTàô™qmò¹zsð‚Ô£D‘äXašNa"ΞlùY²vÓíXúK4V¬)ÈkÆ–{ç”GÞ4¼8¥E¿W<¨õÓüàŠÌ“Óg©Q÷ úÄÅxSÿœjã,J^^¤.Æàýgúê:°á½¦© ¾–ÉD$"0šþc>&uS’qIóÝõ«¿çΦ endstream endobj 4056 0 obj << /Length 3173 /Filter /FlateDecode >> stream xÚÅÉrÛFö®¯À‘¬2ÛèÀLåà¤ìŒ3Žã±”™CœD*   åëó^¿n¬ŒDPIÍAbãõþö¥Ãà6ƒo/B÷ûõÕÅË7Z1KŒQÁÕ.à*b<â‰5ã’W7ÁO«·»õÏWßÁ¬qøÓAÓýÇÇoq9X$f¾C7ùý›>…:ð»uh÷ÉÖ*dR&~ZÞ¬7"IVe¶æzu»Ö«´Í×B¯>ãwöb½‘œ¯Ú»¬¤qyë&¤×MUÚŒ¾>ã”´8¸Ïæ®:7Ô¾v°ý¡hóû"Ï<ü~¹ë΋"¯J¶Þ(!*h·mV×UMÍOB˜/lÜ*Á†‡,Ñ ]¨Únuç2ÆscìM†Ó¥îí¼ÜÖYÚ¸1n°]>«…dá:aR›Ž0ß¼¿z‡”áê)ÒhXPt¤¹ÎvUíΰM;åíä »5W鶭êüw [U7[xd®Xµßù»¾~ì˜Ü0®üد:† 6x+Qcz¤–§ò)¢Ã•e³ß¶Ù}KßùBäꈅqì7÷¿Û鯯.~½à81à°½Œc$S\ÛýÅO?‡Á t~«Ê$¾Ø¡û@0ƒè.‚Ë‹ÿ8)n&„dFÐJ‚KÚóÇË×Ã̉ ÉÜó¾®ðæŸóàÿE7V‚‰P=zcBñÜX†±%Ý3nÜ ÜÚÊ>RÙ Ú ›®3Ü|#ˆ);*Eëm€ÝÝ0-¿ûûÃ>«s—Úº±9iM_û´­óßØBéôakZ™°¤?Ù]UÜ8f †FyØ_gîhÕÎIH‘ïó2m3‡Ã{§Ž i›ÇÈ#ÉBÏÈOGàÛ²Íê2-`scV@µâå¶Úß$¸ý‚z§ªIë:} Ð%ý€’^†Z©YÊ'¸[T‘Ô£zw ZI }2w'aGü¶ªè¦ÍxŒš;kš†‘Œ˜ÔÉb{žp9}ŽA•)8Ë}ÕäcKN*8#ž˜LgÝwŒ)Œ @˘𛕠;YCÚ»´%pjm4öyÓ(ñ¼|ùn©ÕQºJðb!˜6z!]G‚’G´’4f@W:aëÏìOZíá2Ôþâ.?èöÎ4swÝ:ÍRÜ€ºDÏê1ÉŠV)Ê)9y‘^ËÌœ{Ì—kœ\ÂÎ:Z_Š;_*r÷ƒFéu$}ÞßföǯݘêÐnªÝf[y@Z.´[Üh«Ç —S-Œ çÌ€/Ú HŸhZI…щ¢ Š„!“pdª-dGj-@ÿ&Ë™øÀ0.:ñÇ/Nh¥ÄmØ- Ï*+_Q*}+£þ¡ ðɉB*‡ó~ó™/ˆG‡ÝΛeh_»m:³loŽ¯uí hê<µF¶ËX@B„ò|–p±·¥3’p_g/·ÈµÎ«¼/œðªlôqxÂ`&1„aff/ÅYöö;b/:µ—ºtž€5'è¦8sM¢-zM°ò(ó{| CQf¨Ãz>œ{w—éýåé÷ÿPW åö jbcMþú 7÷é6CèbÍWEµuq ‚üè&ÿ=[b…àâ/6•‚…¼ã­›CmížÁÊ6ŽÄTö¬µ;kUxZØÏ6»'£÷ª™‘±“¢˜ö¸Âu¥tIÛ"ÓI- ’+@Ó/é­ï¯mŒl›ýo æÜ€/y{çà4ý ž¨ªÛ Â_½{÷Ã7¯ÖdüêµÛ¿…ùdöð5­0³W¶{¡½šèŽež „=†¨}©ßĦU¼œÀRDñPû+aI„¨(t®Ž#†Ž{ ;êì‹uöë!k¬cŸ~Ç꺅øØCAíZnÍd≓áR(äeå´¿ÑÃlŒ'0`Ôâ†GTˆ³QÙ)k?à0œÑçw¤V¤Ïz›• ã Tã&î¯s(­Ù‚»å…_P>óðäE‚Éo–à+èhLcá[~•6{y0  þÚ‡ûìOºòòþÐ#VjãEм𚾳3/ú`·ð‹ºCÜT‡k»¯³mÞOXè<’TçZƾ¬dy„1ŠoO±ŠÃ V¸ÌÜݼ׎ë8¢sOô—o ¾œS%} ka˜f§²6›øäTÙãÇÔ úËSŒëeïq,Å ÇRŽ¥p8††Ç1ôŽvÌóðÐó àÙ¾ô“<,8-š¼A…ÊÑh8DM÷hœÉø4*p CÏý÷èt™±šˆHA9uA„–Ù˜ à×è!v( ;+WQ—ýˆœKšäÝ47óæ¡L÷].—z F'™áì¡êˆñý߸tÃF§N˜Y³Afä-l !â6kšÊÐrKä5iä4©wTU21ñ-®¼íq¥Ô´ƒLî T24TCOƒxrqúOÅü¼R‰1³J‰ ©R2G4X¼(>ϽÆöÅ‹'Le ñÜVÆ ¹PIpÿ€ƒ~¡¨DFÞ·”.Lj ç:ðÇ]øŒšÂtª˜á^DOºJ1S}eGÛ3X‡ëSÈt@GˆÇ«[wX›±w@c„[¨…èÐÍ Æ. As¹7@›˜$`(9bíT JVÈ”_ÖàG‚ýщìÚpGo€¤ÒtlTeñ@½T;$èŽÆ¿°<¸-ÞÙ6s«»Àl>¬7p©œH-CA«Ÿ:ÂÎÍØ-Ãòn‚žõ–¾¦´ Êxuh€dÍÐW<ÕE’L©³ÑÛ—AÖ«¡#Q5\½¦Í÷)Õž!ŒŸßD—ù·|ØÓǨ2}††Š8“æcŸ,ôù´cu²ÃÓ%²ãny²ÔàÉ!š$™.+6ÖxÉЩlYüÂïLº:4,í«úa)>ÁÚ 5ǧk4÷åŽé§Ñv5îº}Žg¹áB &Ãdà²c& ÎðY‰ÍØbçÔoÇ!.õ ½ßŽàߎ}#¿ûûíŸ)~‚?i¢ýp «¶piç—oT¯ÞWõÞn ž‹+× Û*ؤàdÙ@Eø¨xåAø@ÛF ÊçÕ€Qzlƒ]¥nKtµèã&k³mK:^E^ (_>„{ˆ3lNÓB+ú½v I»Šº‘††®O„pJ6¸…ÔŸäÄ ì, ÃÊô´r‹sâP¯µ^-}ìÁ53ê¬ÇFêécQÕ9/½yíÊëa_{]œ¹xh3Éyݤµf"æs//½˜¶™sã,Óýb=°ü¦þþXïïõ¤ˆ³„ƒXðÀ濶,ã³óËñ(ÓÝ©?¼úxzFë«v¤TR²*«–cçOã›ÍmzhüKzK•@ˆنÁ‚33ýO²BeyœN‚Ðè$%*Dç„[¶†m益ݸô<àx–ÕM÷Þ÷á:Äùãg„|2B?Má®är bœhÁ™m“;ŠIYÉl†/O8ƹ aýn-yÒ“õ(YÊWW0ÒŸÐÉ'ž„äóˆžÌò¾&ÞdK+ôŠÅýÓ½§¸ lQŸ¬i«‘íïŠÖǕDZRÉðê ]¤Ÿ‹Ü‚ý+·_e÷¬¡/;}£9òoÚ¹Âì9?Ýbxª@³dúï“㔾Ëï)"@É6GwäE‡ÚÑxdtdùã ÞYžóTiÈ„`›“‘Öd†ž·KÞoÒÜ}—7sãB×ø”ÓY(¢]±‡ª[)Ö¹Ü1mÆËž·ô –'É#ž:#mr¥ùä9Ä¢çž]îYÍ¿ö¬fÕ½mUƒ•oŸ`ËrZ0L»BÞuæ4ö?æ'Â'J`¢lh !Z‚jh:…‘Œ_w¼¾ºø qÛ( endstream endobj 3940 0 obj << /Type /ObjStm /N 100 /First 994 /Length 2573 /Filter /FlateDecode >> stream xÚ½[M·½Ï¯àÑ>˜Ã*‹$ °äHQ È‚¥ŽeyVvÕ Qþ}Þã GB°;½}°§º—]|,Ö'‹“RÐ*ÌCέ…®üíAr R“iÄ Ã2þK^1ÞùM Y5H7|áD&¶a`—ø¦„¹gãzO¡Š€0 ¢©‘“L&d V)Ι ©6Þ‹÷ (`HÉø®•ÜIõ Zù®¦%¾+´€)( êu¼ËAÛ˜·XPN ¥:Þ¬b  °¼lã üÁj%…Ç=*¬.×1¯c1Íù­õqµNA(9;$¡…¼Ëëp»¤†9 Kó<¾hÁª/z°ÖùQ’’s•P„€zÕP´“KÍ¡˜]J¡L+¤ìü°C¥©`/c ô´ÿ¶Wå;¾kÜ:çhÜ÷ÍÁ+Ý¡Þº`Y¼ç±Rü<7™ÚSÓXn7Pc{á>—½D0‚ðÀ½jâ½béþg)A32¶£Bù Ú ”å²±„TŸB[Z M|¼óÐòЇVC³LÆPåV(ê”$@mÆZÃ_AåÐÆ–Pzê s`c»‚3(=s름foažÇ» _¾ƒõ@¡ù*-`:^B“Tòèsʘ$:YN˜R,ˆÐ 9IÞÇ€ ²I# cJÜ30DР0(QåÅl’©e‰(²‰Ù„êdÜ ‘ZÓæÞ½Íöûðè0ôÃö§¿ÿL¤1ÚJª±€÷Ňwï^m¾ýöôhk+ôêÌÑšc‚þ|at¯‘¾ÖýLÞÙ{,)Ÿ;Z€[}Þh- JuæèTbÆ®Ÿ7ZŠG/_”wÓØès­DÇïéÑšK,ùÜÑ9aWàÏn¶.ß]^=ÿýõ›]Èûož½¾¾Þ]]Ý?þéãõ£çׯ¯wAÆ‹ÍöáåÅu¸w/lš­ï_ãÚßÓ|ÀþöÇ-ôr>xš>€aûìêòÍóÝux‰‰¿¶/v¯Ãq1/þóûŽˆþ¹ÛéÅõîâú=Șs³ýq÷þòÃÕ›Ýû½ßïþºûõíëû—ÃKÎè°ÌÚõ&z}…¯–¿»¸¸·—û¸D<#,ˆ< ›D™„O¢N¢M¢ˆ’&19—ɹLÎer.“s™œËä\&ç29ûä쓳OÎ>9ûä쓳OÎ>9ûäì“sœëä\'ç:9×ɹNÎur®“sœëäÜ&ç69·É¹í9ÿφ­ÙlŸøÇõx~òöâ·ÍöþåÕ¯»«±­éÕöÏÛÇÛ/eº|q`+_=~úð‡_¾’_¾þšê¸ Š–#´e¢€CˆË'Q|óM[n~“¢>(5ö³Ä KŠÁ\"7Ú ž›¹ äà Ä¥GW[k7$s7„‰XtÜÂí ó—[¶C–T‡RBZ  êÐJÈ5"qZK -p$CÈæ"3#Ef:F8ÕÚjÆØ•z>ÂÈÕ0½cQ儯†m0kÆô´• %U¤æÉbË·¢x´°4¬X”Q¶`ôÅÎ@±¬02,•eWCr™kû"ÏUV“-e”2C rDzžSlâ3^àIë9‚XtCÉ®°rEkë95è`iì²^Szû„¿ŠìK0-î¹0X8–;l¥c•vùÇZ.ƒùsæ¥È¼eWdŽx‚ÚôFOŸþ¼àüÕÈʧù[£²>`Áùqeíœ^㧞œþvA;*;õ#Œœzl<­Yk²ÂPˆ°£ÏXirÒX¹`L>dø,Ô>9ã±Ý?ÿòÃý}¤É^ ó3+ô‘kÈb{;døAÎO3ÔEûÝO¯È'3Šox LÈÃFÈÃyä€çºÂò‘VWžGæÏëjó+òhÔƒŠ(0„K§ *²Âú Ûßë@vì¿ö ºÛ€%å$€÷øòíåE´%Ñc¿ ü0¢rb8‚\å‚ç¢+8*Ï⬠I:9ý]„IQPãjÍ‘‡¬ª-Â3”DlÐ æÐaµ;à©/Ý òÙñl7û£g»«=¾XR#{4ù„Á‘ÚÛI wQSÑ!sr‚…2$ ÅÙ˜‰f¾ö¹ƒî“æyì Òà'V+0¹<“äÉn¡>tÔ6ìÁ>\}½=A)—1­×!…ÌãhGPâáw=3e•_Æt¥Š:qžŽãÙm5ÖàØ«j°)Hã¥ï„nôt‹4<}ñ-ª£L–äˆc°%zÇÂI’Æ¢!¬§ÑéÍAëe5aêX-°œ,û³Ü%À@zÿNk4ð؃ø}«ÏG#¸"ñ¯Ã»²ãöÞÈGG·³`‹ÝÎmØ=w0b]¯çaÜíÜÑ#Ë-gŽ–†HÎ]¤Th[=w0€ÔÔÏ 'Û¬.Ú⺵«Å^m×ùðy' 1¯”åú]–ö¡Ïû]xgÿ¿«Í6N›mœ6Û8m¶qÚ¾3ZéB'‘'a“(“ðIÔIùô!i“³LÎ29Ëä,“³LÎ29Ëä,“³NÎ:9ë䬓³NÎ:9ë䬓³NÎ:9ç´dŸJàïfCFöšyi&/h0y^¯C“ûȼ"YfIË6ã­<ßvþ|'á-Å ÄZ’êI Ëfñ¬Ý<ÃRS7X\Q–oéU=ù÷o{¿»ZDC†Š¤h‚à±¼ ©¬ ¢Ô˜áœ§YG›(!8t#¯—=7Èン”h<ìbL(TÙב›ìèO †mñ“îâÐÉL‚—vdŠ¼7_`,fd½D-¡ˆim¢0èïËœB±øvHC ÁkoP ^+T…ÏT&o¨h’¬ç3‘³vÞlôq „úšÅm(¨µ«äõšûÓŸ’YXùÈÀ¥aFx«Ù)üfnr„¡È_yQom¨ny&XÉ"Ï¢‘ª'k€•c[ÏX ¾!A  G^ûY„xäå ƒãnP÷ w^üë9ß}uª¦U¬›w$“¼~bºBWJŠï½$ÞhF †Ä ®ôæ}xºìQ¯†ÍÙyÔóäôwrþTáŸò'^F_K Ølg…„F0-»4‰7s Ïk¦–ŠÔš÷gaÒÙ½´8îÞª#Óì§ph]ö¬©ì¸Ó€J•rÞ†^1õ€`Õ㯜(9pSÊë¸ fªëÝ;ÈcÂ8Ê㌻2k¸ëñÏ"ÛhµŒ’,W¤:rZAòÒ1L•FCS“ÇÆÛ€÷ëžgh‡ 2ÍÆË:ÄPÙlEºSÎͲþ j‡ûÆ endstream endobj 4151 0 obj << /Length 3810 /Filter /FlateDecode >> stream xÚåIwÛÆùî_Á[©Wk‚Ùg^Ÿ²â$rd[•”ôµI Yx% $c©¿¾ß,X ©½ƒ!0ß¾Î@Ñäó$š|ÿ*záúû+ ×h‚'„ ÄÍÒl2[¾úå·h2‡ßO"Dµš|±.'X2¤…yq1¹yõ÷Ö"Â,¢$Â’÷-M$âįSÖ@|’¼Š›ëï_½½}õÍwœN@lr{?!Œ ©5ÀÐc1¹O~™^|üîÓ¯üÁ'¿Ý¾/)|w[ÇO~”ãç° 5,(ÕHF¤‰Eœçñ³…Þ€Ê0FX…Cíà¯ûW ©Q„å>4$×/RO¸FTIÀ'B€Yêñ.å%¿CA†(Å I›È\\l¨A‹x…*ƒ¥}8Ëý³/mAÑ—ï¾»¼½º½~YåJᇲ Kpç"8Iõµ$>Á‚%¸:2ïÏÿw‚ûùlàYÐ!8A?ŠØG˜1Gí[À ¡Q` o¡rõîúÃ.6”SD0³RFûð!HèÒeuå4„5^| ¼0Ftˆ K†"<.áÊò¬Gx¡ ƒÄG$jãrÖgpØ@Žaog] R"®ØAúAx…U`ßô#”×Â$ÒŠEC˜†%}2Á{4$d˜C~bk sýé7çgøŠY?#D=?1RB:D?AŽãg ™óO—ùˆY?>Ç ?”!)G‚ìáçá )Žuâõ7=Éu(ÌN9½8 §ˆ@Ô;"ÕèPˆaé·g—Ë‹›2ëéŽÕð0gú±ºöæü‡Ÿ†¤Z¡ìè!† ‰§¸\“k_Oè!†‚ óÔº‰ËPn†âÕÁͪ[¥ã&½–‚)ê“|õ°3fXúCQde[æӯØ^À͈âC ‚g⬠óæêìúæÝ!†r£Kˆ1¢"ÄØ'©b_Á 3Lˆf%ÙÄæ¢[ŠïáQ"ÉARt¥Gèp)²cWŠ\S¥è1¤È5ÔcØWQ¸§ú†&EžM6±yAŠV!Ì>Êñ¡…‚ s  ƒú7Á¼è¡‚ȈÉQD¨ dâ>9Ç=€`˜£DXÇæâæÓe•Æ!Â:ÐE6 ÂP^tˆP*„9=Š%íëÜÓ†9¦ÓÀ¦[‚PÚ)Êì“Z‹ƒ$èu¡s˜CYÑ%Aó<;Ž ¤¾8Á¼O‚0ÇÔ— l®ß}[xÒ= Ĭƒ¡‚X"ÁPÁ JkÏО‚=fГ&H›h`Sì'4M’3¦´}’IuˆI`‚°ÔM˜m“h·Â0­è®½k̾Šï-÷–¹mò(´q MÒvp›¿·ïj„C›RHí£­ÛòBU¸Ãò8CJŠ£XfßÑ^Og'ä¨t¢†Ìž„ž<,«/’‰Èaâ eD‡ø  b|”âš3Åj!¿ž†S0ÌQ¹D›Ê2ŸK0e7«KÔa“`(+v·ã9Pªíø¥]J0áˆÀ .Š"ŽŸžÚç'M·.*]݇«‹“S£é—Mãµ»Ye7HWé&é’¹›¸{v×ÍCâÛu’»Ñcžf~¸ÉÜ5v—Y¼X”?jm2Ì!¥J”~úpuãk ®AqKÄ¿¤›‡0«2ú½ÿô¶Å%Á_Œ&o:ÐXéâ_ µÙ^‡~JŒßØäƒx‹ Ik¼õ25“_NÁåL?¶7©ZhrQî¾¥^ ÙÖ 4»w×<^}NPÃ¥˜^>?ÓîËK$¸n°2&ŠÀ=øw÷ÑN0Ôú%¤~q`‰Q"o‹ƒ·3`¥ ÷ÙÝ"Yº›kB0Èf³mž[³»tå®Îlì„7¬x“fþG+›úCo/ÏNX4=¿Aîþö!õ«/ãg7¸KŠë,St7ÏÙÖ âÜÏl×é곟3NNâÎâiî“?N0Ÿ&«y–ÿå„ó©Wp{Bù4.¬ß­[Ùzù¸»ukækG$LÜçÙÒ;™d³Hï ?³Þ$ñ|aë:ÛatÙ®rþ híÇ0 èÏþµë± €5Ä]ð©8:$YÃÂmÖ3zÑf~1¨ˆWóÀ0Ã!Ì”<ìNF 0š‚&N ! X¥š¶»“}U ÑÀ0 ÒJ”.9H£þŠ­®[šg­\cof% G­ê¶á¥ÑX{’ˆhÕ/]Á«òÂef BË–ê¯(Ü~§aÎï °ì¶ÓPaN£›ïXš#=Àȱ1?¤FÇÒzÆxƒ9_Sö´X'¿oãE3Yƺ/ÁµGt”îGøÏÓ~ •ŽÒúR0û©\é`)°!ìÉ+h„æm¥Ô‰Eg¼TJ¨ÑÈAQ¥RÂJæ#šb…®—PeÛæ!^¦;2²£xtŸæ1j»Í­ìbxCð×Lºw8 \AºTåaÒm¸œ=Jι=JÐRr…)yu¤¥åPœkÓ)ˆÈC”\a¤”[(’þôÊåå·áJþU3öÃò‹òݸmºfLˆÃ¹MÍY9.¸¢tlˆí**²!‘š’oÝõLâßn83¥åól‘ÎÜýúy¹L6yqžû`¿UêæŸGš7Ø5 0‹® ýfx3{ØúÙY¶|\$Ëdµq÷FUÍ5‡l µ½sg;[vdvÙGÛ%¢x!%p³Æ¿8ÿx{iã¢Þë®b¸äÆúpÑ u¿¡€Q!#¾ h¦lÄ óÌHètn)ƒ™Ø= ?Ì’µêsžÎ‹µâ{`ž%þW›/™Á:Þ¤ëûçÔY¶Zoò8††ñÆÓÖ`͇·—ŸÎì5kbwlŽÑÉ „…Ø«û Ár +Kå:=¤HÉÊÉm| Ì÷JCSóÚ‡±üï-ëT˜³ÿÀW"xB"Û!8Èg$ÙeØ Î0£Ø:‚¼§™hñ*õëئ¡öôOyäá” ê>;…•dwSœðªrtû2-p²|I[àË@úÆU{•šo7ðù59nôÿUl€VsIúµZwjusêrÈ£éÏ'cë ËŒ=ìðÄ;JcO‘»5ñ&Ë‹MÎ40ÕbqÍŒ·ûö>4¢»ÝvJg¥MŠ}ØIÀ®2æÊ&# ×›[Ã.©é½ÉzÍü|›Ûí 3^g ·÷ãžy„´0q¿ð»o(—Õ™É{ k)·Çì{„¿v’& L ±ÏDIXP+že‡XÃZ d™«ˆ9jÌÀçÿfXÏÿÍ}ÉTscS]ñ:wͼå®Äí•ãU¼x^§þ}Ïa3ÑöÕ©Ý Z$Ô{mCSq KÚbåWÈYL£Iôžm2Xøn ÌBw-wg¶°}£Ámëxldž†,¼êÀ/ÄÝa-í¶V›k»ón³œ=MòÜúº)LH×Ö}ÁÜ—‡dåFΙ7ŒçzzŒWnßÚL ^.Ö5ÇZŠEF˜\$íùªpõãfóPT:oð3,ý¹ ¶mÒkhƒ´SílvS1¶—D1kô’Ìýˆ^’®ð«ÑI®Æ´•¤àw&ñ~›ã¸ÁÂÊÔ £("Í8´ˆ<5thAŽ’÷ë¥ñÙRz½¤¥^ÊázÙ¨Ø%æ»ù‰éq->Ukø4[­²Ø<1£u¶´sdšÙ¤|Œóx™là–s£KT²éÅ}xÈÃZE¾‘ J \TÓ¦"jmÜxÂÀÕ•Ÿž À×-ǘ®æ.}u·OOÍ(‡ô907ß‹‘?¹Ñ‘ˆôŽÓTÕóÊ‚†dѱ©*å£î®1 CIŠô:´c'åýrIÞê´P™™›«ÛM¦§7çŸÌ¹ÚÛó|ÀóÇ7<±’MI^’'­ÓFõ­¸=!KûÕ{›ýztÌŠZ1 ¼÷}hcY)ûùK8Í‹bä %v£Ãþn?,© ~J0ÀtL?ÆŒÿÐbÐ鞦‘›6ÄIÒJЛöɈ¨Ù'Mq×¢îƒÁc¶^;m²?¯Ü¬«Ûˆ+åü«PËçIëçe¼ÉÓ'76u°_}»Š×ëdyç*J‹„e–»å\ïÎPµ“Òª“W÷®f'?Yo [,Y;¿ŒŸÒåÖ7À7y¼ZGä‹ó€/¬U /½£kÌ‘y…´Qì&&+ÙH¯o­™DgžÎb‡'üæ6ؘû2îAxé&5 è›_çɯQDVéÆ?5¢ò”)&NkTÚY´,žÏï‚PÿELU~¦c7·²Áõó hð.U™qµµ<ÁÌ£Ê6Î& w°‡Šº‹V{8<èvYJ!û¢RmÈߣ((|åyVøÿâ«­›Y|yveâ‰ûHãÇÐÂŽ1Ä«óÖA'dˆ·ÙvQ|LV}C¶–ÈD›tXX=6íiÓdÚž'rÿ_‰µ¿Øû/…„\ endstream endobj 4068 0 obj << /Type /ObjStm /N 100 /First 1007 /Length 2713 /Filter /FlateDecode >> stream xÚÅ[[o[¹~÷¯àcö…"‡Ã,8×Ö›vzÙ&yp¡4µŠR¤ýõý>J#§€¤Ð#Hâ9'äÌwf†s!i ’]p¤¸˜2‰ê¤4üg¼é.§"WJäÛêj/NBŠ®¥Ê7͵Æ1¹».ý,5ðè•ÓKp1§an …˸#Ç— “@©‹µ5yLÈ ú˜@x:&TP­ŸA&(1Ç y€ É¡|‡’ °K-‘ÔIü\LK«/LÅ¥|H’6¨æ’Æ©»”•ü4¸T*g€ij‘\T\ê:ÞZå\U§• ¥<Æ6bQ|L‰B Óª d(¦µÊœÃÐ9>?ÇD¹Y\–2Þ%Ø¡•Â"YHUÌ(yÇŒ:LP1£G¢ªÉ‚ °/±R“°II‘XjqE•øð%×ñ®¹Rƒ®>¦´DªÁì}èŸPaKRâª$Î…Èš ¿£©«Ú‰¹ÁŠeh·Wëð™ŸiÖ°o£y@u×âø¶\“N.¥Cn×VVíÉ5@€Œ®ô3Î…"Z/c\q= ½€}_¡êð¾4ä‚iW0ÐÃ÷"B*Ò7;)q½s pÄ€epŽb#3·¡pAØyŒ…†Lá14útd‰¯éó½p,T¿"½^¨qú>þÖ ið¬Z?@z~€¬´~€ìq¼åÒƒ7 c£û ¤I°Î A _ŠeDŸÄ‚¬QÏ><›½ùׯs7{t{{·<›]ýër<_|ºýûÙìñÝâã|ñ6 $„÷³³—³ó·q<œÍ®æ–îmêÁgàLZ¼Â75ñ¡)ŸCĸGîáC7»v³çwoîÜì‰{ðòÕ³×ïÈ»~p?þx†?ÿ; )ÑÃ¥7_à)D¯•?ñÜN"Ið®%­ú‚µ–jô°PU_e‡.Î_½¹x÷ ê”@bKª@˜îÌPqá±Ö­8.]M)?z†T„^ßèð½Ã)˜Hð\N ÎØb ža ËÞŸpV¬Ãýá‰{‹8ËŒxåfþù/OG¬‹îöëçÏïw„/ÄE›ËG§äùa£sUŸõàѹûż•É£• F®8p4°8p´fÏ<~àèW“C‘p…"F:Z’Gf>p´Ôì "á£Só ±âûÑnv~÷ùnqýë͇¹K«9—7Ëå|qëdõøôÛòùõòf9wq¼8›=»»]ç~ÆhÜÃjÜ3ª¦ÇõRlOò’f—‹»×s¬°òÌÍÞÌ¿-Ýûÿ^Š—7›ŸÏír~»üÂk0ãŠûr÷uñaÎwÚWï~šütóø”õMí‚Uwy³ÀlÔHi=p,ð/<*5â…ÚšHF¨ÙˆbD5¢Ñׄ#Œ³g5ÎjœÕ8«qVã¬ÆYs6ÎÙ8gãœs±ÁÕW\mpµÁÕ`TƒQ F5Õ`TãÜŒs3ÎÍ87ãÜŒs3ÎÍ87ãÜŒs3ÎÝ8wãÜs7ÎÝ8wãÜs7ÎÝ8÷5gÖ\k"!F$#ÔˆlD1¢ÑŒ0ÎÑ8Gãs4ÎÑ8Gãs4ÎÑ8Gã,ÆYŒ³g1ÎbœÅ8‹qã,ÆYŒs2ÎæüÑœ?šóGsþhÎÍùãÚùßOTB)J(¡4&OH⊞ªtı~²J.EKl;šg›˜R :ÔTµÊvW¯&”¯¬îų„€÷ï“ÿôâÍ囫c¨  v{JÔ­~w~ ¬ÅoT°[>TðÇ)+¸4Úd)A¡ì´‘KH,·×o—óÅ?^ÞNYÌÏ.¼dõé!%õ¢„¤]íV ¦´Ä!îmÄÃý·Ä?ý¼œÒ ˜îp¿TŠgz,èìjÚÞE\½þÓõù£#`HÝ éªê^·7vç¯/¦ÅuD‚‚ê¯"Ý$4W µº–íqñâÓ—å?o×~ùº˜R°}áÎMöµG*è2´²†í±éúüŦ\—"žUAAcŠ\v˜!«kÚî¿|A »ø2ŸÒ&Ýk Œ€Æ–u|ó¨üa£mQ/GÀ!Õ£PÌ]ÐðëX¤HÓ%ˆW);Q\.ÓChê{Ì!wEÀܾH_^¿¾ø|÷aò`kõ1W ÖuDÛ×èôVq"ôç¨:-NäŠnPûv·|úäêÅõ„[PõÕP¢/Ü'`E2{̾«p™\ -|ê{! p˜4Îíiƒ€NÈdð=M `½ròhll9 R–´«z|q}”åÀM(Vëå¹E²#BN el™DÇ6>2ú¬œj‰~ðúñ„ûo9øŠH#R%T¬:6Á2Rh Ûë·W(!'\ŒX ìp Àjj{c[ºRœÜÃèÕscþtŠ0S(Jgäm³„6<æíÁùbÚ°¸¶Ä€b€#ÂP¬íp:5lìÛÈ ’sJÛÙT½ú7J§ !ô•hƒÀ†?ò¤j„ÉËQA…v¯ä _xž¶O“Z‚áö“ä8Îܧ†#ìs ZÊHC°xjyJk¨ +óˆÛ@ ë<¥-6«Bz,q±3OÓ6x®'òHÔŠEï1$T,<<Û‡áÛ^Pã^À»léŸPk råîûƨâŽ~æbêR^Ðګ܃€€{Gš4cô2{ GJ(çÒA8&õ î|ð¶€Á@Þà>ÿIm²q 8)7¤yž»PÆ ‘moñ¸÷qñùã„aÍ› kÒ3,”÷¢8†EPMÓ#åˆx!§Vê(^TA·‹$î¤Á"«6^ÒŽ¦û矦?bO­B ø‹ÏÜ%De%mïU‡>éUÃtÊBù+â([ ·ïÎýôøâõù什nÁí¸5áö}“½^M AP=ȸr²ÆÀ#vѽŽr õôh»×0è §5¯­ŽöWRŸC“[#qƒ•%ª+,JCyÂ=÷o¦­«x÷ óÖAB·±ÁzyJž4XfW¤  (0y sj Š*ÿ{”ç™ú m¸Åû£«“^Ž¢I VÜÝ?‡&Ú´k”7Ndƒu¿/%ír“„è °5Í(m-N­úoAl€p;/Œ‰=Cƒ/wŒá!…=±z^?HŠ¸‘û)zâ€ø@X#à p‰ºÁÒ‡Õ™IxÐUƽÅXÚ8{Í1ïuÍ2©GðÖo‚¯(ï•j=H’iÀ0L%(6s@ή$”q-çò¨³¤Í•Ê#2þÉÚäØÊÞ I<àˆûQÃAÌSÇU_^ ï¡‚§ä´cCqê'Ô…»ÊktŠêiA$n¡ýá]ãÕoƒ´qh\6ý„&Q^2v¼ ^ƒŒ•¿Ã Hð5ŸDÓ=ŒÂ»áñt8XèäÞ7@x0WÓ~ “%ÄЬm¬ÑÚtœÉ"– ôÓvÅM+ŸGˆ &Ÿ;k-Ê^ljá…ÁI6@2ëîlír„ÞL°@i! ÇþvÖ¸x\õPÇüQ¯ùY endstream endobj 4234 0 obj << /Length 4357 /Filter /FlateDecode >> stream xÚÍ\[“Û6²~÷¯ÐË©’ª,w{6¹8gØÇžœ=µÙ}àHœ+q–¢vâüúÓx“4%»j_F ‚@£ûë+‡Oî'|ò—|ðûÍÍ‹Wß5IXj­žÜÜM„4LBM JLn–“_§ó¹³ÞüØ<ÉÎCÒ2ÃÜñ£ßlåÃcV·ë|6W©™þ{&Í4[ïÂey&ã bfRá¬ñâÃ_†kJ4³¢™þíßþê}óâ_/°—OÄ–̸–~ÙJM/~ý'Ÿ,áÞ0©J“É“ù0‘̦ÐXO>¾øŸû—Æ0§dÿ¿||ýáÙýÆ­Œ ¼Íë§<ßÐ^ïf‚O³E]VÅ@’2tg›%5¶åz»íôq•mó-›Í6Ó›U±¥AyU•xÈ>áJ&s¡³RAƒ³Ô¤ôêr³þ㟖‹Å±éôiåõ*§Æ¡UÁHÿ>¸]l拲ʩóÜðqç%lÊxCŽ7ßþ|ó'‘þ>ËG:aZ¤ñÁ¯Ž9›kŽKŠ›)+ZåhE·e½ìpQnê|So‰XR8¦U: ÖH6„g‘ÅÂêq¡° 3bb­‚}È+¸P8Á¤ŸG u&jÆÓfuÈ_ã6g˜‘'dLÓÏ°;©`É5ÛÛ®ÊÝ$H&Ä~³í6}»Íb•mîófHH¼ð,‚B€Ýãù]rÉ„køöÇwß<·aXZ&'¡ðo‡6™+„»¶H! ¿`•J3÷‹ÔÍUX#¼7"ÔàÙî‹æÈ‘ 2i¦iTˆì=t|Ý“_çÆØ7ÔIÜp vÚÅå>ùsÝ"n¾æ56ô´.©CÐ%N|WV4¶ZÒ½å®*6÷4`;"i=½I>Ýʼn‘Ÿð鎖Ãþ±ð"eÊŒµq?øáã #tsœÈ¸†°=]•Û:0“Lé>/=Vå"ßn½R1†pH^€æ®ª|Qÿi64˜æÌƲ ®27㕹0`,(yö65s¼! ¬{&€ÒÅEW“ÍÄ´ÍM¶þ´¥½´{ÚäøÄý Ö\¸ôãu\|EƒþÈ«ÎV%rZvöKŠ6,VIŸ€"HË랬¦ßC Ýøü¡ŽëÁK\4þ.‹;|Á]^ UåµÀ 8½ŽH64@/$¼­7?ÿΫòS9ö¨¶*×Ë-ámÂð%áØÉÿËÿi$r¦­:›­s¶QwõÊ“ ^Û`‡Çº>5M ¦Ù§æaQTԖîÑkÛl¬1-RµgœYÃY‹NÞ~Å×7üþ;N¦« ÞÄÓ-6K/¿Óåïá·‹ß‚\DÚ‚…7H$à¥ÍšÊ1kýûü *Ø‘“ž >ÿ=)Oº¢Ž—^‘Rs¼.·°y*Ç×.²Í¦¬©}W•W <ºr4œÙ..³Ž;i1mK3ñé¬ ó¡?ÿLæý x®Á-z\zàÐd¨i‰å‹uB0¿,K;žGRÖpzY±9[£æ,0Ô1ã|¤çÙWÌÙÔg‰SëúÈ [Aü—^<ëN™æͲùÈcˈëÿÔSÔg+“³Ž;Æm²wtväÑýý—ªPnb@8¤¾ÊMµ†9M3q<¹Ì"P#ÉIfA¶m™LZâ!l´ø»ØUh aÌ/=ša#[¯K<Ø'r¥ø<æbËÛð êg·ˆÃªâ~UÏÁs\η ô©óPƒ3¸ýˆ½$¬x ¨8°â½ÖÂùíi‘„íaP¥*ÐDÀ âj8‡´k€‹©M#à K³~ã`y+0ãÒxXœÓ8ð_ÛqÀ¦™H8MÇ°8æ™<øãÒªü_`ÉÔù’60žÖ®svGùY¤Nú¤fc=6àúd4,iÁô>,!5È{:t]ÉæÏ_Ø\:p›Ô@—Ädq43Jê«°@0˜ÍÏ„q†#XpÜ4y Òzßsçb¯£Hˆ4=,€bºÌ|Q‘€¡ |]‘xÊQ&pm™ÀË”À¶gltŒI¼ Æ$6/ׂžD}p‘9ùrì»Àøv—Šëý†›`L@ XÛºѪG‹Ž“qฎÓì_„0 ~C’ŸŸs1ÛÆh£EZU¾}ÌÀ7C'ìJ#Gð„ ¥/s­‹£¾ôXàYË Ý½äL£ Ξ§dl2ÉОI‚Ì x,{ ñ…Âúø¬aÔ\Ú}Ù0€R ßûÚ'gŒ|ó÷×T°ƒb¢MŠÞ5I#bEœœ¿ÈßþðËóyÄþFªV>ô¥1ÀE¿MD˜.îúÓH®RL´Üq˜ÀÞ”»š ”Œ¶ö$`È1:ü9X¦ç“8Ù°?(žÜ+«±nÚ(KÌg Pª˜ræ4ÜQßfFºÊÀçi9ÃTƒ×/‰ïÆR䔋ü¦ðæûÕäÔ ÀN%ãän®PqØÑ„ŸUâ¦å²U!}0.±>Ç£b;|ŽÇwmANCg¸ëºé$T`a †é¦rðc3VX¾M)!³ i°àÒD\Cg hšÉ%âLB+x‡Õ]sw>H$%v´Þ™+.X‚F|÷¿ˆú¾2Î µOcæŸáû|í @\SHâ,ˆx­‹7žV…/Ö&Z»Ú»8.TT`^œËõzî&á.x¦Õ2¯Š™˜ÆŽè­`;<ÚËÌAwdE›rŠéø‡f&8¬°’ªhAÃ`•=>æ1€G5-”Šiâ”j¨ó Þצ¬i¸(ú+Ëu´—ë]'ŒÓ asQ.£Åz²ðòªŒ³Í½[×'¬JÁR±É3bÜñ­§Ýýaéì ï# ~Êëbûê=ŽÌ*jE’ònPzóí¯ÞßÌR9·=/i¶÷ï>|ÒÜ8ÝSe5xCÉùmQSï2§X>ìûèÉÛEi×¼Â×+j‹T‚rF†õ7œÈ³ r>ABnš¸ú3꾯²Çõøätm‹?rja4«f°Ë{Ÿ¯V˜yÈ6´¸”†™6o.ØášYžtíuŒñ~“3­Óž5ÞÚõÃ!ê9»ž^8€‚³Õ*jòÑ!(´$ýÒ²þVy‡¶yäŠñdzÄEA6;¨<:)5Ùñ¡káÜð¶7.QãÐÏf÷p‹§…·|8ú:ŒC­?óßСÔÙŸ(ÂdGóûþMÞÁÑu|÷­¯£É³‡õSYn›÷÷{฾x\Ñ[¹ à æ¡X¯‹rsÈóñàoTÑZ«+Œ¾ã{Ü}YÕU¶‰z­Å`€ Lƒ`5òÒ £ì-¦Ál¤@STq0WÙ=µçEwEÍ» "?ƒÈ ;ˆÛò!¯W!ä%§Èh³ö¨|=„Hì´Á²†Æþ~*±ìÄ¥ÆH‘Dž £ú@Š£[ Åûëâ¶Êb´PÅÕŒreUš6(KW±” ÛÙz[R¹ã*$>C¾îYMŒíþ©CG÷DZ3æ’ ¶lÍô¯h¾> PDú_;U±) ¹,$TB<ä™×½6å6!¬Ž{íwª5éÔ³§G©Ö†èN-Šµbë 6„qìƒnÂn÷ù&¯²:")MlÅÃvïÄ(̱bgÀE”2£ŠH"§,œ¶îeê)ÒÔ-c¼Ð£»¡XÀ¬¸šj’|Ïã.n0«³ø|,¶Äg½GSÆ—l¶ùb7€i¼‘­×§¨@;‚æØB ”­ÖÕ\ÄÐ9Þ:Çx!¿¬¦2D°ñ½‚EáiáÓa<ðÒ¸%Œ§f?|gF¦Ã8- Sè(bmáÁš¶%㎨øZj&µØöa›2lScéOrý6°À3Ð/ÄËü*Ì8+ ‚û—ÞIƒ0@W(”¡ 2v q¨Ú/m0|óö5P;Uhæ–Ò#ó”ûR•~æ:§*!8†æxAvšì2³³j†caäýLû__<'é­êq‘Ç»yâ+Iº–âÝPøUôƒSnó|°¹e¹Ø=ÚÄO$¿ *–ÝW>o£›%>RüÌ™Rv®Íù@õ]t¡Á ÎJKpkÊà@ôÊÁ05ÒœÑO¿üôþã7C¦,•MÈÐ|½[6/j ÿN™šjËÔ I\Œ­%(ªà@þ[Ò)žˆÄ2™”‘V·_!ÄLS? ”_YŠ_à0W”8£”fÒ2”¯¬ËÅóq;.—´}~ê•.óÚ§áúÚ3ªÕí"_«€/HwhÓ&ãârû_j$ ü; ôL>wŧ‰“fÒöŠ¬þ¹ÀÎôÆh?˜vMúõ0Ë)'˜}s==•ÃãKúô<ÁrýFN™I†)­÷àÇŽ‡i$¼D€ì8?&È“gÀhó›øñóR®Zô â¡?À6£a-öáow᯷¨÷–áÙ¦wø(i^ɸ‡¿¶‰`Ê0ÑV¡d&‘‚7$ðÌ¢«>UäÀ•œ&âç¡p]Âíå‰<·¢ýñÝÛCbjæÒô3ìÎ8À‚ôòÝ=–Xüæh¾ýI£ NwöZäŸT¿eU•}¢®hôŽ# ¹I«ƒ¨.$\r=q@Û³Ä&'ˆÓKpö‰óçÑŸ>&mÈÛƒ'¯}¿týæɤ±£Nþ DžÉ›œ”‰øŸ¢|¤,H Ô¥»&&A)XE3qPêŸ[ùŽ‘uãèAºG¨¨{Ä1ÝcÁ¨u'uømùxS8–´5&£ü|‡qªèÔà6|-§Ía´«Éñ†=Ò^üÏßY…gBÑ3õ›mmyx‰7AG«N%Ìí¿ 'ˆjŠ‹¾d|üú•±Ø„ É`<Ñ]ùñ3F¼p&«ÂK¿{ól–œ<Ñàb{5¶dñ;if8¼Gé?'QŸaR%éTï?¼þþÍÿ=‹5€Œí‡ÆþÐÅ4[Wy¶üDÙ.Ðú©ñ `tã›ü.äe„7‹ˆ·HÐðù ýF^ŠW”ÕÁèåZx`]ÿZ1¢›4ñü‚©ù½Ü‰¦Ä§+_± ôt»{ôñï=ú›WV„_õë˾»ž«Pf8Ÿ¾Ãï\ŸŠ-îMÉԻݰÈÁg˜që°¡&tCã&{˜!Âþƒtr·¡·ýº”+fœ:òué…E| qÞàexqˆ“5ѹÆ 74SÔ*§ÅU%â*qCÛœØ!~‡ŽŠóú‚׆öOw‡g 뙕§ø‘qbÒa|Û,Ä÷W1$á‹=bDb¹ëTCÄá`HûßâW¸åfðYn3žä – çùrïèi°}½-­cʸsœÆ6 Ô&.ù' à™™Ë°Âû)“‚¦T{Æψ¬îëppXyAå8R›HG:1,¿ „j‘x™°ö[™ H€)xm½e+{ª@øL2^•˜#ÂeKjPž 7²[,ò|Ù®ÓÌ/é¸å¿Qën·^‡Î7¯ÞQtÚÔÓFs*´ MslÐÿ¹à€ÝÜLyiWç Ãbøm!•§ôólÍ?.1Ã/ÅcÞ i[Ç‹¾ÀÆ©‚³eŵ€fN¸°±µßþß±ðÏ@ƒ#E/ …QYVVµeû,t‰ve!†œÀj­´JØO&sÀ˜$ &XÚÓƒ>ùI@—~ endstream endobj 4171 0 obj << /Type /ObjStm /N 100 /First 1006 /Length 2595 /Filter /FlateDecode >> stream xÚ½[ÛŽ·}߯à£ýÂ!‹ÅK‚KŠd²$h$Ž¬‡Íz vŒÕ(Qüõ9‡=ÛÀnk€ô4`{«{ÈâéªbÝHkuÁi”ìb*$Š“*$ªÓÐH4—5‘0W§àZ¬$¢³ÌÁI\ £SrQD/@)Xfã;0WˤŠ‹Eú»êbÍd±5þš1ׄ(2æZ‡‘³“É9Y(‚iƒaÜ@å>ל` ¨@)9—Ê8£ˆ“”¸.Hê«u¢©ÏÀZû ¬‘¥ÏÀ¹p‚5Jì3°F)œQ±F œ¡xW\Á߉Å.æR‰ü,™ªr] .µÆw ÓiÿÀˆ5(_é²Uuªg,9 ^1­tið³ZèXâ8üC!çš\–þkU—S×gÍÐ^¡>jq9[ŸQ]®‰œ+tÛºL«¹lFT€Q¨tPÑélâJ2òkÉ•Üç6u¥”>.»R²Â›æVWC¡Ô`5ví7s5 ñYpU»åXt5w¹˜¸Z»ì¡²Ú2¹˜:0îã2lN ÖŒ6¡ÂÇ´ šk¹ËÔ̵’!b °ÒJMÓ,šI %ÎBîï’3~(u–¤ÏÈÎ4· P†mý×ꬦ>·9ë²’`ΌҀÂîcÿ9FÒÜ ‰Ÿ,&2÷’DØ4ôÔÇbC„j +ÁL`Ê™`KEŒèHÊ ¤L=þa„¼Ö/$±Z¬4Pô0+÷±X "_îm ­\l^ÿ÷—­Û|}s³Û_l.?þcߟŸ½»ùùbópwûãööM€Go7ßl¾Ý.±Àöà½Ñ–­ù uEû0Á>@T>ru ‚éCàs¡DƒT=]…ÒÖRŒÀ.é Šø3I¡ùLRÅ#˜Ç¢ûE’ù„}‚@æ™=H3_áßÒ}lëáHûafàH9úî2?‹cY3…Ud¸­CæŠXöyÑucpŸLÍ ƒ–˜?£,* i¾†°à1|Zeê(>õn—ß·¤Ó¾ á×G&iÍ7:¯€çl§¬ÿ¢Œ™K¼r›¿}ÿ÷Î Ù[Å^»ùøþýÛ{"÷‚42§è òÇGG„c¤)'ŽÑcóŸ6X+"ÒÍG—€8˜N­Ù#½:u4Dâɸ!’PO7qÏJç´Ñ©¨—r*’„ͬáTåŒ/£ 8q4´“íT3A’Ù-ù´ÑHδ˩£K†vNÕ<^"ìªyä½=xþ~´Û<Ú½ßÝ^þru½uišóòj¿ßÞÞ8™ÿôiÿôrµßºØ_\lžìnö}ï>¡Îmz¤ÏvX÷ ôZ€ìðÀZéø J™:=Ãæåíîúr …?q›×ÛO{÷ö.èåÕ¿¶@z³ßÞì?°8d™ýŠžæÃîãíõ¶¿“éÝwÛß]=Ü}rÝ9¡öBÍ#p7/¯n1Û!—±i`wl°p/1‰§W˜¡aq2ˆ4DDDÄà\Çô:¦×1½ŽéuL¯cz=NÀÚÖ°68·Á¹ ÎmpnƒsœÛàÜgœmp¶ÁÙgœmp¶ÁÙgœíÀ™µãˆƒA¤Aè ò Ê ê Ú ç88ÇÁ9ÎqpŽƒsœãàç88ÇÁYgœep–ÁYgœeâüv©ü.÷4·4éù•T¤¿°¨b‚¿rg }öŸŸÿòa{»`ÙSÝ¥"©ÃÆKpQº) Ïm¾*[¶ÊÅSc(ú‘аúH¾B•¥"£¹'íþë€åùö; ’)Ã<†Å5¢9{ü{¡5õ¼wÄŸ_<\²0ÅB®(3»Ú«@…÷-Ï%¯°<›%)’ªÈŽ¦g_±(žmÎ Ó¢‰ž¶çõ¶ŠŽç¯¾¹\²îϾiöK˜#q‡û%qZ¢7¶3£xƒ;dRŒÕÏUV+ÈñáÌó –7öŸa!ðöD…lj9À1"Ûг‡Ýè¸ÅeCEšÚš&Ù|o\O8q£ZæpœA l†Ã1„_6®…ƒÇ’ÖðO ÁåÂå7|6”ÁöLÐÕ„€j5#^P$xKC¢8‹â`qÙ°9yˬ0ÌÞË.CF^}‘5Ü5Ä@@spWsΠÄØòFêVY×ÄPVŽýTéýå¬xÎwÛÄó__ýôaYÁ„e@Ðfø;adseimÍŒÝɺ)!{àU³û#,Û5´Þe@P·xžÎ9C³ÿpæIÙÒf®r+³_w_6±¬m$6’(+H¬¥7hÝxh>…z~¿j†ÈÓ€"¬óðzÀYlb(CÇkoËXïeª!à ²†«@˜¨Š¿µõ`ˆ˜ý¤õë>i·MÅø=—Îâ1ao ¨ê½-™3lO²¡èr©é䮑ê²K™à5Q ¯C°<’Ë$ðÝôžôå9^¢/Ïëuà&xC O£·¢‰XFuŽç¶F>—`ØŽ@BPç-À9#z,{¡Ἢ8)¼ÐbŽb?øJÞ¤­$ñˆ5ÆÞ75f˜ÕÁcÁc±2nø¨ôÓ鈌“÷æˆ+Äõpð†SE†KSU¬?\¨$6lîÞ)Ïg½ß]/¸OJ`ì$´xïˆ×Ð ”ZîŽ"@°p/‘Ë~›•¼ çèÀaVv¬ ‹ž7ç`,®ØÏðF/<ö‰ î£N}î{Ž}· `¿Æ<0À…ɳ._<[Ãtà7 ¦!è,†Å•¡šçÔâp›gÄÒ’šÓ‹È _º^ö0ÒWŸPHŠˆ¯6‹bygÅËUýâ;ý¯‹#¦öK˜k´šËCRû·Þ¯/xÒ{®5]ý{ûøÝ’õOdضJÀ´}ÂËÛí?ß}ZÒE « @¡½Q†Øû_$¾Ú:§±;©ÏLfxxÏ1½Ýsúµ¼*ú·#^]&ó–Ö…"‘RÞ\ï²Þ4Éü?AP¦\ί &”™gÁ¼1h²§®ý®=D×Û•ÖÛ!¿9ÈÀ<óÄÂç¡jiÄ endstream endobj 4294 0 obj << /Length 3995 /Filter /FlateDecode >> stream xÚÅ[[wÛ6~ϯУ¼[#¸`÷ä!u’nršËÆîÞÒœZ¢mn%R%©¤É¯ß x“dIT|v_$Á\¿€|r;á“ñÿ®=~aÔı8Šôäêf"¤aZ"g˜Pbr5Ÿ|˜žŸ[uöñêUû¼${/Ɉ.à‰ïýl]fùíÙ¹TzšÐß,Y,èª.p IeQ5ï¿þùõ»ËÐk0 \ƶéõ9«ïMœÁÜÌLJ$®¹yÿãÖÒãºyýÕÛö­HD°ú¸éüÄ}‡ÔÛi‘§´ŒUR&Ë´NKº-nÂêîÂóÙº,Ó¼¦›,¯ê$Ÿ…GYEÿyÏŠå*©³ëEèЬlrŽÂÐÆÀg±‰‰šÃpxæ¨VE>'vCÑYNÿmç*9“|úéL˜i:oúYl9ÒäH"çå›oá†KøûXªbÖ2tUdy]‹ R³Ü¯lVÓmŸÕ»VV'Ä9¸¼NÅ™4ÓÏß{Bž_=úýª%Ÿˆ‰ˆÓÑ$2 NOfËG>òÉž½‚…ªØM>ûžË‰Ô°¼i]L.ýmcŒÇ€¢½cð‰e°zà~Öî°¿Ø2§pÉ7‡x>ã¼Â\@E0— ͧ­µOðÑMY,骾 =ª´îžƒ/—MB>#Ú„æòéߟoë ü¯ôKS€)öñ‹õ˜µCØÂ@9dÒ³—ï÷æ°1S „Â$Ÿ\ ¤ÀNX ……qõ DüohÁ»÷Ï_¼üçÞ¤Òn‰œëÅœÄéq ù:¨F±Jó4<8L ¶Œ4SJlPœº †rb:Oê„®ø㡉¼Vs@T927—‚qÛÖ8ŽNÍ5¾ÖÖ_°@Ë%;‹2É£+ ƒG0tüÁô\9Ùõ·\çÙ,©‰écê5àEMKÖÅÛׯ÷º‰eèìWL$ç$j¥•€>Dýù.›ÝmÔÒ²,>ú|&ø4 uŠ9¤¾³:³M"ú4Ÿ±ÀY4‹µn™9Þ™=§ù•Œ<ïÍಯ”p”Rš”Rp°LƒVþÍÈ÷ˆ´dNW`c%`vÌ@=‘Ùœh$c„–j=›¥i蔧ì–}·`}ÞŒrÓ<Îœæ˜Ý¥ó(¬CY¾|üe‚5ŸbÑÎDSvv.@~ÿŒËhf•m\X÷Òªo\HdP7ã3J¼ÒÓªÎ|•Ÿô:!‹rBO_ŽSœ”|(²sJ‡ÏÌ䌥6ÊȧaQù`yº]6%u÷ܯŠ`’¡WÉì·ä6Øb™þ¾ÅoSÅ`ŠÅudyÓzý…þ—îW‹/m5´5éäº*ë:Ü}Bº“Å:m“ q>¼¥RÑI í¬¼!ZÚAô`7û} DZ&|9xè\¢ñÎE¸Ö¹Àå<]¤ Á¹n¸ ¬š›Ñ~ÄêÜ7Ó®'çªq3FN«b¹‹ ´ü¿ÁõTÞµàÚÒ2´’ë1Äüuž6hàB×ÍF.FAðd3ÐÍj½Z•˜ÏGºm˜v|\æLv>¯ý®±-…¸ŒM>‘ï?jã2¶6q„æ[â²ÅÜMŽ‰ËP¦Àìi51¸O>¹pòࢸý`Ùo;oRÈ÷Ó‘Ì‚$ ·Ñö¢h .:Ör¢­dvéõŠ–ÒE#ëŽKœÔP˜7اÃC9ÆÒOYYäKÚÒj}h™ù½*M»AÐ1LÇnkGo#{ˆ ›”§®»? &Äƺ/Ÿ‚–˜éμÅA ,íCÌì¬7í]ßd´e¶†4ùyŠn-?¨¿6fR«-vÇ+ð»²q-)SíO“)åoÞ©“Å¢˜‡]æ͆n· m¡Kº øäê`£[`¦¢PnB€Gd)ËŽMÎ5ƒôpè ²|,b'8be!iE+d<‰YƵ>%83b  Öý@L9€˜2Áßã‰C€Øàa ºð¦ºð–f´=Ð…­€_(N‚¥[¹ážÿGHLHhâÿ@µÛŽ&ñ §$ÀEá) 5§$¸¹ç”Dä‹Š‡OIt€IXf݉§$ìcNB4ç x—Ãá¢mÔáÊ5|îý´`u&´Ü…îý­¢Ç·á¦7h„»GÙ<ÝÁ- ª‘Ž± ³KP"»áU´H˜y T£¢®k?kOk7fè‡>(«ˆ¹¸çVÆaJ¦:I÷‡I]Ï:·íqø¼eVŸß+ È\ ¯Î, Áåª(“ò V€\ÃXŀƫb–Q(ÇG>=ƒöPmw푨qî^W«*÷Q 9VË?Hh!Äh;HÛ®ÿãõéšÝ%ùm ­YÃ<«’Õ*MJÚÆG¾ž–AÏâù9ÈÍ)ÅÒ¬<€ˆ•ßJžX­1:Ä~# @ ×±nä„Ô¤Ô¥¡WA}¼ °áÆ'WÈ/$i¯Ò0Ú›[² vP¿2û#¼ëµ‘8åÛL Ç¤Oþ6­É´&°šNžˆvöjHA_ºCgÃ>vR ¿~zO ƒŠ2ûÚÂd~Êâ¸`’«­å©]ëƒÕ[ŸcºKª#Š-‘Ók¿#ð@&µ(˜·µPp7(rèn"Èñá§T‡YUÖÇšÔÚ‹x;ÃYÅß câP,†;0ùÀÁ=‰Ð? ^reNµ.hhÃJ•z¡^]7 QÁ_çô?>:œ Àg0ë°tÝ^%d«ÖŸÑÒÇîEѶ¾éƒêÖŸö.ÍŠ™æ­FÊÐ Q2¨™¥wþ¼wåò Ý9É|î ?ºâäØLP ›ß¿9P$Áo¡óèŠgª³ÖWoŽ®„†},,Z®C…ÒoÀ™œ‰)„0ˆ: ÷ÓYØxÁÒhò*zn1ÃÁˆƒ% “å¡6êÍFض’šÝæES7Mrdoû¢· ,²æàë› lØRžœ[PÑSvÍ^l3­Çž.ÆÓwæ¤Ý ;L’ñ$u•ú#Öãzç³Uw ªwx›Ü:¤®_¨OX+Ö5 éx–Bú»¨èÑÆyoå‘qY…ݵÏe •j»‘ †}’uÕÔí²›3IÉè ëiuÏu¢¾F×9"’qëÞ£UüˆJ|dþtع>^äíÑÍ.QnxÑ}axÿ¤ò(Aà rÇô3×E{)EÈ÷ðš‡ó@ØJ‚‚‹¬öÛ×}„ƒ=ËP  Õo‡¼¨÷ |úš²1?R26 pFl§‹ühñ¨}÷5L ½È+¢„<¤Ô¬sÌÔ¹°ÓyZA̧ó1¹M6TáŸÌ¯ÂÙ¹íÁ]<4â÷Æ|›7uÁèÿ¯ôYNÚ™V9 ù:©² t¶ýh‰µ~Ðò|ùÊŽ¤HoîwzíÊæÞõXÙ7€+ÜcðÓ‡¾°®² jò•×m© ã5‡+®1ˆ½•Æ<ÃO—|Z /S\Pz[&K*¬^fËl‘”Ô=à+›Ê•ð›ÊX^Š6ƒBÀjÕ€AXŠu¶ÙSåD@¼ÍÄRQŸ„ªº\Ï°¢A­Ÿï|hÅ'ËŠ<¥·|ñ­¦Í[4ƶWS« E“MˆYo¤£#تykB}’lÜ«©GZ 1í˜Ô_Ënixcu÷_M¯îÖõ øO %ÍÊlb¼!ò®GûõTx5 /Ó¹ÍCäùáÌY~ˆÃG;CÇhçÛ«ÕÂÃ܃CàÚû<Ò»†«î:c BAñ¡„PµìIu[Mð u ]>\>»ø÷Ç{ö‘¥Œ|%LY¥þ–ýsoË4’V!^^½ÿùbǬ&bÖE1«U·ÑpÖ‹&ѯp2âà•¯ñ y ·bÚ4·ÛËtëÕN7Æ7Ìëyx)øwxBc!,µÖø¡šÏ¾~\®—«]_Š8Á·Àí4Ó±2fÆîvîãÜß8L–´ðá.mKæÕÆ·²Ë¤©mvì¿…i¾’ÙÞŒ¦æîóza KnŠ&ô´ü]Ô_Vé÷㹘8o7„eŸ > stream xÚ½ZÉvã6Ýû+¸´ûX(Ì R«´+ÕÃ9u’Ž^Äñ‚–h›iŠTS”«\_Ÿ ‚ÔÊV‘ÉJ¼wwߊFþqF÷>ÿ~söî£QL¬Ö2ºyˆI¬"Í‘±ŽnfÑíyý²HgéÃÅDSz¾¬«Õ´¾¸»ù÷»Úl¯4„Ò8š0F¬R~僟·£A,Û™•u+ûe~éG‹¤jG¿—÷ïàõ‹ôÞ¢i9Ÿ» g?ÜœýÿŒaÐ(¨Œ”1$æÑt~v{G£~ƒ$"l}nfÎ#N´Å ®Ïþ:0Ö Ò¼ÝVYÕUR¼÷Þ5ð”À4·}¢ ¯™ö·æF‰ÑÑÖã~õýªÈ¦I]V~:ãÄbÁ¡ ED¼-Çëpn ‹{N4›u~«éÝûÖjkktwQuÁâó4É6ã”0<õ™Ly™à (v§¶¡7 ˜²Û;ý~¹Lç÷y:ó2Ó¢®^š©±&Ô˜·Ÿ£†(Û‹õkkQ<ÑòSœrP\DŠÅ„J9€TœJLp’ÀNÙâèPlÃð›?)Údû0«Š½…2&’½¾ð÷i¢×$¶¶3zÇŽw`ì"O¿„<[Åå«ê’Ž7&&¢™¿åÖ'2ãC†x”ݯêCnXÀ§pVý<þˆ1ZëI+ CøÀ4‚§p’±ÔèÎËi¿=o TÐW€ül´\RÂGà öb0µFV “ ­pÇeüñM&‡[”Á+c‹9Û˜ž-:?3„ËxPþ!Oçiç C’}F66àdSöúXš×{,j¼Å‰±tQW{«áŸJÅo[ýœT!JHÇŒÿ"JËå"’†Ï¬ ó’(—ë]v”Ð5ƒD‰«YZeÅc[§em}ø˜=§mmsÿâ?WË´«æ>¥u¶ôÃrQge±l¤s®€Cœ@$. ‘†2©‡ù̾Á‹´ ÕŽ1Eñ+#)5Ø7Ä ,HÝ^c²CÙZA1¢¥î)kçÍIõcÈ=àöØ ‰AR£¾5Ê­¤w!ßÆ”ëi’ƒ(>-8²oÍÊ{Î8Y;t lÃ'§e¾œ&m¨ÊÏN̆cÆûç^·Þ¶,ó•³gûµ\Õ‹UK¯YR'~”³®³K@¹:›~›OîÛ*è¡£ÜÓòÒ#õiû +ÒÙzQkÐ7© ÔR1Údª#D¡ÊPL!æKë% Ѻáýï2½<Íc`í@JQhù@Úó] ¨2NµAè8]Ã1o8J °<>@¹®…,‘¯&ã]ÖÓ‘°, Ø;쾡 ËN’ˆÅQ>˜ WÊ• Z€“ƒXb&*°6Çæl[üÙÿ;(Cœ=Ýâ-›¡| ÆMç ;Ê „-{Ê„¢ hÍ0߶‘®·wuMàn@Ç0PŸ2/Ir³›=”°‰¹`FP/ evÕ7&^J@=0kTv#¨‡» *úÔÂà„ë´»Úͪƒ£o™\xÌû®‹‡ò6¦w—nðèFcÞVx”‘íAT^˦®ì»5<©~_¾¹úðo£Ùw¿N’ê.]Ïàㇳ¢y ÌUŠÄXî(8% \^ÞÙ•”`·|PI9O‹M«W¬ò¼½¦ÏžËzùm÷Ö °¥Uƒ’ñ× ·ÀŒ ì!¡çHQ‚«AAåk„—¤Uk‘¥ug¦ §Ã.>¯§O«ê4¶ç¾~Q|“}Mû=ÊÝØZ9‚C9AF²Ö‰ÝVú¯¼oÊësR…*tJ”´Ã1sDx.lóa¼&ÿSúÄJ×[¡7¢ïmž²óÕzÚv<¿G6ú_÷Ãö—eǦ½4)‰Á-®5±±’&¥lvâ$™î½bžÏ^Ño!ªôKŠ“´jWÿÜåéÕR¡ûl Õ*F–g»ª‹M}'¸!ÔŠAñù¿iµDŸß…çù}êcƒ+sìIïÇLØ^Vž>Á¿ÉÏ­šÃa5ö¿v͉rZÌÚæÎKDaÓV³£u‰M\í½}¹Y†j®u C½ÈÆx!Ì…ë4ÛxPϳ¬ºESÔOçͱt‘+ŽÑ—ëA¹ï_EVE’¯ÿ*ÌS> stream xÚ­ZësÛ6ÿî¿B3÷E¾‰âÅG:ýàsÜžn'gËw3u3Š¢,¦©’TÜô¯¿],À‡5¾&4ñX‹Ýß> `ò8 &?ž¶üÇüìåZLb–„¡šÌW.crÆšqÉ'óåäazYž_-§ù9×ÓßÓín“SCµ¢2K7›¢|<ÿ0ÿГz±`\‡°˜!ôöþíû;;j¸ªH7jUW[¢{EŪª±¢¦©]®2[ÀÍPCÚ4ùv±É—ô¹«+ø°4Š†ÊÇâ\èé'œ•—D®(q/À€qøéIlq·?žMÌÔ»ý¢É³¶¨,8gÒÎ$>¦6L.¸P,Š4T–è„4_#¿â²ÙT¸'ä–ij:Ú 5,‹&Û7ø%Ó¦ÚÚ©mž­ËMŸEÓìs;£]§-ÕR*öM^[êç|º®ö›%}.r7¸ðtΡVÛ&s•fp;wtºm¶p<`0>™¹ ØMÙæõÊÐËrjj+4hœª¿( !‹“N,cCÅT Æ«ÏJ»ÖÚ.:âï j{²}Í~·«·;dÙñþ¸àL÷âZ,=»ã’wCÖiCynw³Ì³ °uI_¤"°âç]îY1‘L†Ý‚w¯¯~úÐñåìz~öÛ®LøD_¤“P ¦€H¶={øL–Ð ÷ÂdOžÌÐíD0£M›ÉÝÙ¿­’U o$J ´öÝüöþʳª™jß`U Z®“ñªWk&ãÑíC¿ž€Òìp!eÂDN.€%¡Ð4¨ŸƒxÁô²®ÓÏN2—EŠr¼ JrÄî0çÀ]òÄà‚)¯¨hÚ´n± @ÓºK‡?øPñ´Îë<µDP(aÄgú*«z ùÙQ½´DUG”Wÿ§Wu[§%ƒÃ$q¤6ꉢh€]ÔT»Ý7–ȶ´é¯¨yÙm­ô)0@%.ó©X’ªóöEœÀ:hñ…Nàኊ¦­÷Y»¯sØ™ŽÛ½RçÀLàFA»é5i'}¸»1+=ÁÝÐmÚÖÅï•\d<ê$äò ôÂí¸"4 {ÈJ¹Y³Û›ŸðW77?A…{¹ˆñÖãí‰XÙsÄzxÔC&¨nÈœÀˆ¦CheZõÛ…~ïv9h=TÕåCðª,ÿ¸à<{ #ƃŽ%G{¼:ÚÜ«ârŠ<¸©Z;ÌšÁ̬è/Û†šáwŠ,gB`7lØ®1Ig Š¶É7(* 3®øt_fë´|4¼æ§¢]SíJVº!«yûD˜ œŠ´\Rç 3—jß•956ÕfŠI Fú"º1»ÐÒ/×®iGýÎúÑ? ¢ˆqVWÍ«‘»àÊ#F>¢8I‡±àoË|U ­´lvu3ƒWBŸtÓ•íæ¡k Š¾ë‚ ûõÁ£¥.ÿd™ôÄÏ&n•ëÔ)@”ÿÿc>å!ãjÌR#RJâ’j{ô lVÔœ…¼ÎR×^VmJþ~‘`m\¤…̖˦ÍS»â–Ö/!¢/uš>· ÔM‡qhh¨hXÃÑ€`R«S.X·5¤  Ù{3Ì2~vÑŢŒ%5q~Pç¥Í<äb÷ ƒ€œ3¸Ú',æ½ÿï¥ôÎ_ :…SaK¼û‹(ˆ§Öêè¹R>ž Þ-Ÿ!PãV‹e,P:–nóîfcé»8b2p…yæÇd=2cßÁQTB°b^©5K€þ˶äð Œe¶Î- Yû›µènŒA’pÛ€T“ÕÅ®§UØòÎ#_ŽŒ`´>ƒ:”}Öìð0ˆB[­„9¢åœåbÕ¹òÖ8Ü%7Í£!Æh/È)”,PGšqÐ@sù"ädˆ¡¡Ùkâ$´n)6ÂU¹rñtPˆ í9ž Æ`„ób̘¢Üí[jF-lòül‚y£ð&kôqŠJ eÇÀSI¡éñ¹w¥Hˆ»RÄNÜyØ2ðv±¹)ª©‡ z©°wiÜG™ðR±V˜Œ¶±Fgu6›ú¼Ž„ ,èC¤|ÓîÚÚ£Nvàöàå‰>!Ô’c:Á‡S8˜ qN°« ʵIÐN÷îâïg8¦­+u<Ýæ¬Ðd vg®‹t±A…vÙYC&A«•(êñû‚-Òƒ£}JŸÃ"€±°ó>q©…]?ÿmlödO„&*”zz½Âý¯Pû| ¨G¨A«Ž †]"ˆX¨Õ)0“„V ŠD AöÀ™ãH86FÖžBË!#›&Šã™‚pä_µÁ>, >Ú!zd ÙIÉ÷ Ù0øŒ%ج(ì Þ€Ý‡±Ý¸é*;e™CÅ$ïV¹~3ÿÏå-bÔÞÏMí#ªsïû|oùIÆñë§[¡þg8Õ$ƒ!~³$À°K)þ<wƒpað™ËNêÖçe8m]FÄàõ0kc“Häœk &Å bÒˆµÛí“_=#”G/Jq5}Ì˼N7(KÚÄ8ØhVÁÊ(.S\¬bƬÓsX‘´Ó©XV j£™¦)iÆ$Ïx«Xi§u–E“mÆfÌe‚”€3Ÿíê1ÕYo¬\Q1J»ùpGòÙ×DuŽH Ê;lh‰”Š³°aÈ,»¹ŠJƒ!õ™cNÈÅð`Wœ0 Rn IûòPऩÂt æà«òPaÀ"‰”À=JäsÚÃy@‘ë0‰»àJ¤#W jQM×Ö×ï²>‡ó›ÞÐFŽ!Â|ŽØF|Jè%m‘nŠ?rÛŒÅÑæö±¡ÙåYøŒŠƒ.’8 í–²SF÷‡ãF÷w|+RøöýìøF¸@ Ñ Çâ¯_W @ÁŠpÔ|÷ö­gÉà|æo°f˜€7ýï»Û7¯} ÃþF‘ æÉOÂÚâ3•ãeÜoZ›±›­¨çsµ§J™»Ix­XâÛ‰O/ay/w'uw´µEÚí©*mÆ’Š³èµ™Mì· W¯ìA]³¼i,À" ¦å„»Ô†MLá¹±4Ï!e‘4¾hŒ¤‹$_PJÔ¦¼ ?ƹ/“K:Wnë¶Y’Tá@rÏ9¥¡ÑØ·“£œÔËœQ¬8wÖˆS"?„ÓX±ýU2Ûì Œa»Æ îJ=㶢> ·È³Ôd U»ª D`Íe¾ËÁí.m³ñýá<ªCa B–D3bÕõÐa‰@Ò{)Æô¬‰Tl`ÄÉ›Uöv7vÀδ³Rp±4Ñk¬<TL‡|°?áãgZ Ó¶C§`[56ŒÃÓQnt„ÆÎ ÑÂî àãÞM]VÏÊÃ™Ý ›5ŠG†é—U‡¢½k…®—¹ò_f7óÞñ‚þr…s2±Â!f~†ýßùRU`ßÂdœªêÓ¯Ê$]½V µ7ß'D@Ç`ë!¶”_c>¾~FDIJûŒçö]h¦}„›xŒˆà§W´0k¸g±f™ýña»ßîšã“I%Aù78™T`]Ÿ,cë'‹;y&gÏbØ¿ö(¥Ò´µigpÑ»v8ƪ,*‡û?HûHº}Ø´AþЕßP½ío›ÆÞîhR“nóþ©G<š'fôïóx‹Cê¦Ä“vù*­Ž—@²ÔRÃÓºÈÖÔ’U5 è®*—%ãûï 8Ð d¾O8-«}ûÅ$Ÿ=IŸF Qá*&—Ý)½æ\²Ù|†Âœ0È UÝãWLq(ò.£ïŽP/Á`4T¥¿saíê•»´±9BøHmß15È®‰Yð£°ÔŒCŠ•l_cò¬¡YMãŸ^èH™GÝ¡—ïŒ>ñÚÿq93ÐY…E>NPíÝ¿…ÒÆ".Á¼kšq›Ê¼ -çz›ƒ¿¹¾mµÌ7nmû@ø¬—b{Ç\3éëîþ·ïîç³›kôwï¯o~˜½¹î_ZïofóT½¹|{=xwõÄC`j¯¼¾ígzÿþõÏËÛË«ùµ±îùðŒohüÝt˜¿c ZÍ–ºŽgçƒ}»ÿƒi}à‘‘öà «b“³Nóöz~{ãë¹¾y=º £g`kBZ«Å”I&`œ­|%ñh ¬ÿ½º]x endstream endobj 4334 0 obj << /Length 3397 /Filter /FlateDecode >> stream xÚ½Z[sÛ6~÷¯ÐÓŽ4c¡‚`3}H\·“n.ÝØî6Í-R7©T²Î¯ßspÞ[î:³O$A88—ïÜÌngÁìç³À^_\Ÿ}÷SÎ4K”’³ëõŒ‡ #1S:b\ðÙu6{?OËl± £`¾Ia0ÿ¼àÑ<§‘?ƒ((Jºo7vð‚.‡&¯énUe9Ìäô”Ò¥iÓ6ßåeKÛâã‚°î‡ë_€(1$J0Í–<`I”IÕ>/×ÅÖÌ>»¼>ûtÆáDÁŒÏ¸Y'3K&b>[íÎÞf¼üe0‘èÙ3u7 ™Jàf;»:û‡åÅh[-ážVâqHãKó¿í»}sL@jIõ g¡PcöiÍ^^¼¹~…”päê9ÑS¦»|p{L˜PÓú[pF(Á¢x™m^Þ¶϶‰‚µ¿?D’°@Oøqs÷9Ýå"Åjó2ŒÓBŒuW¡f&|Þl‹ÛM»½Ã§`žëEÍ×yMj ²4-+Ê[šQ•4LºËŸÐªº­Sûn•n·öx€/¤³™²-ª²AbŸ-–´½©vy»é&7Ůئµûò°Íh“›ÜS•F®À£Ñ‰ÚÊÚÙ¶jò‰1þá6g–;ÑŒsø¸ì A,PÖÌ&°,èÏ»PºËaÞÔi]ä‡ÁH¬Àí ×fSÍÇ<ÑržDô¢îV†AZùŽÞ¬ªºÎ›}å˜ ïͱàVÕnF_Ó0àK6žhß{ $D[NB Øúú·×¿^yÎ"îf%zÁçù§CQÓ~Ñ™X´öÚЕ¤Ï÷y½®êÜØÙý®ûMÚ¸½ °Ìñ¼±ˆ``À\x"`oÚ<͈¬j=Y৉ÃEÀZj($˜d;ƒŠ‹VŒ•›æâUße$Y¤ã©GV‰_–m~ ”$áüœÈ9êyžn­r^ iÞæÿ¡‡,·t·Ïzt¾íbòÍOˆ–{'Íâ÷…FǶ”ZÌÓ¦9ìÌ=¨í G­"M8'L«¨ÓF€$«øéÄÍ9÷­Â€Ø~%=>+ŠX æÉùI>+ÒLjZ‰'£}„GLèG“½ÞV©oã …›…ÒñD1 ugÓYu¸éb´”bŠwaUÀH¬¶âB=IÛ?7/ȨœøÌÍШŽ)Y†"8vG/ß\_þ|ùÎGRÌTô lÁ‚NAìBh¹ùæÇô=^Q ÂøIJ¼ãØ»Ëç¯|P)X¬Ã¬‡`²_èÇ·¿½xuIʯï./^^½|ûÆGŸfBvòröˆðÉcp1ÖÅYSÚ—Š¡‘”ã!&!£u£žøÈÆsÐæò¼ÏšÕ×÷Å}la4‹Â€ÉX<Å„dÄi ciqÕg³œé(þ"Êx¼#1}sR-±œGÕ~—ïÒ½Q¨,ØáÝØóÀ€s =Vë6·oƾÜ'•‘»]¹¢ë.µÍÜ"·1DpkãiÛÖ( ÄÔ†|§N˜ÒêH-i3%—7Eëb͈sGœÜÍñ$àP“£X€ ±ŒBCàØ`/Ä%àÛfCa ¾O³Ì}’ÓˆeƒÇò ’agžËá`W/ÿ¸$ðŸMAÆÄ{‹;Ô&m„¡p4%®ã+ˆŽ·M0ÜŽe Xâ#¾)ðžò-+V':ƒMÛ‰é¥k=óCÌ’‚Xâ}‡3ê“ž½Ï“î9€Åƒž~ÎEóÐw/ ™ðÀ)},+ŒÚ¿€6öÁý@Ç''5È0ˆ¿Áá ´d2‰§‡ó•3D”°PʱRÙ88DS)óŒQá¹&›wÛD¨*-z®R 5ä@wv,c³Ÿ‘Yéöw°æq¥ <ì§)¾æÕ£ÑûXÀÑ£µð) 4㊊BÞ±ðžø7ä »Sp Ô™ ¸]¦á‰‘eÕÒ ÅœR /¼=ùó: k܇¸.ÿô:¡HòiÌAK#cÛMa·ìËSªOpàÖ}Z“„n“²´ÎlÝ0„„øK>¡œO#dOBèNÖÕvKö€wÞ§Ñ.=ÂgWshÑ ß âAwÜ‹·¯}uùϾù^xâ:ñ%÷¯ƒsíÃZÜ}ïMâböšL8Ó11{4m}XY¯ jy_æµöf^*˜d½fÉú¼xæY0B¯ÔÍ÷y^`•îv¼'s˜§‰™ÃÐò)‰ø\9?.¤¤i÷3Ç!Ïéáb]ÕŠÊ[§CàXWEC‘¾í6øJ Qš¯ºSNÕ†ƒ²Òy_ÕñZ˜êBø´-J<(é„ñøé’† OòrìȧHÒaÖQ:šVV¦a€bœÇßbSÈÆÏnû€~aQ+HF Æ-ÇnxP#? ÁÅ*OÇÀçð€ãÚ}}¼Ú9—CQàh§k,öåÇÎ(蔟ƒ:¥cÂáÎö7KoëÔ¾æ17ùiÔîš é ¥á¦‰á¯ÅÚݸ«l)ö*ÿtÀæ‡+½~6yzÝô¹ëɦB_ƒÅ«¦¤oåòÂÊ—s@Ð+‘rô“ŠæÑž¬9>QdOôÌÍ [Íf` ,šÕØtuï~>›½7¯7M¾j;`-öKêÒº …x>R*ây¢?— `Ad­Žå+Èdn&Uë×ÏI4¿~õüÅwoW ?adE1ä,pÕ©±KËCÂ)ê&-?"¿bÛ~+®ù9§û×àcÍcf±-Ú»E™b¼¨’‹ÑGöSš#IYázkˆ-A¹96aL¸ƒ¯ÓÆÝVö Òñ|!bsd7ÁXó5/:M˪Õ;Ói/•}½» X:ª$:݉2Ý6¶3grSgÕ®]×iSÇ’7=…Óbÿq#¼£y—:b°ÿ˜vÊ»>”«®F¸i§\îêi¹KŒq°^`=y‘‘‡ú.EY´óžx©½“33Ó4•ì‹÷ç»´ý@÷ÔõHd²Ê×Ç­2M›|‡q=Å“ßp$Ë›â¶D) jy5æ…ƒOC¯›V„h¢)%Ð'EM·‡&½µËö‹Ô}¹às×òŽï«¦!ø¶ß'\ç oÈMKuº®·ôèÙ¾“ª«GG •ô)dFBŸ.Þ(¦“AVeöx[š¤îhWy„Þðʘƒ²]¼+<À•ñ¦Ÿ\aˆô˜âc؇ùÆla‹A¡9C€RÈîCã _H„“´»*Ý_Ý¿û\mÞR.Ïu¾µ •X£ÎR'“S&÷%Ù¢=L#»—†iaá’VÑ1—/ F€œ¤,Š$ŠLþ… ým¤Œ,H¢'ª¶ÚÀùWp|ÔÌU7ß½§œed†a4ñyËÌè’•Ï)#‡!SZ…kJ‡sÞzäÛÁ jË_9R}fŽHcÌ÷{ï/LõåÊ"ûá¡u•véaHTÛŠ6ÜÝ hÅ6kì±PRjIGdlŽC{S‰8!¨×}¢íüÆ—M±Úxê÷%ó"c¿¼}á‹s±ø2 ¥š¼û¼%(ç2¨OÙÕ¿^ß·?¹WÐg‡²¹ÛmÖÅÊN®¶Öàl<|wÔOèBõ^+!0ÅæNü8í%ô“ÒþÁ"¥êR¼$·øhz<'Çýør€ øaBD,Ò'ÿwÁ~tß~ N·œx9ÄC acCÅ0w ãÎu[5ß8ýÄýÎsOÌ“ÖUƒD:¤8îÏBìÆ9§xÕƳ2˜OE¢'³7OÀŒ©s¯±¡S¶ø¦Ô°ªÑ.ïÔþ¹¯Q Y¨j!®·OsÜcvc=õ~8D¸…¿ÿ”Þ^$Ú¼·ÕìÞ,S‚[8ÕŽ7uÖ“ùêx%{¬”NDbøn «±ˆ4=«›C4ÜáÀ?>œM39ÍbÞ9öîçÇÈÕw‡Al8þÓ(˜üóøM%“½pß<´ÍÑŸ,ÿë&oþxhVÖ75ìOŒi7Žõ•®`qb·é/Xñd1“ªcý›ËW×m6®ÈÛª„&üèB‘ŒÁ‘ƒûE € Òä²Ø”à6û%°_¨¨´‡MIó™Ö¶ š$£O.¯Ïþ Sí*† endstream endobj 4254 0 obj << /Type /ObjStm /N 100 /First 973 /Length 2383 /Filter /FlateDecode >> stream xÚ½Z]o[7}ׯàcúBq8ä g“mÑ$†‡m“>¨©š56°Y^dÿýž¡DÇNT…M¯…ïÕpx8ßCÞ£¸àRäìˆÙâH“ ÔÅœ–좈½(Ž)Ú :΃„™Áh¹”MÂï5Ï0`—ímLÉåbÓSvÂ6=‰mÓÕilÓ‹SmÓ«+dÄ`VĈ3¹Œ8GWsçÌŽBh˜#FÉÈ+ÞÙJ)Füh‰ÅQÉ!VGµaàà"Å6—°;,~Ø7Š:‘ƹ(v˹:Ùª­Â‚Bã\³SR“ièÚ¯fbœ+L€ÉV«#¨"1×â #ÂV’l3šj²;ÍÉ 욉A)N›™&´CrÚ¬ŒkBc Ó­µéX!VðmˆÍÄK(FF ÖؘX‰TmDA‰1·¤fï RûU`¶µÍPWŠ9c£zÆ."L˜ÚÍ4 Õfâ'óWŒŠ-…Ù5ÁÂð#FÛ¢˜©æŒÇZMµ †žb=|8›¿ú߇¥›?º¼\mfóóëß6íù§‹ËÿÌæWëß—ë×~ÿsþÃüä5µ‡Ùülùvã^SNž¡Æ† ªGîáC7?wóg«W+7âüðâéË7â›ï¾sß?ßxâ^ÃŒ¬ÏÜü_?ÿ¤žSÓº»¼~ÿþ×?%¤˜½y¸”쉇©Y½Â®Ç¨3¶7¥Öì+‚Ï u>CãƒÔ,ÞœcŒ:AŠ°¼AbM>Ò0u®‘d82´9*?®ê+î‘M~2ªwx­· 1H­f%£"A®€•ŒâŽ!ùZF-¤øŒ(8HÉ[ö¤âUî"qó“ÕûÕúüÃâíÒíæœ.6›åúÒÅíã?>nžo›¥£öb6ººÜ4wÚloû–áÃîA´%îÝCµ„±{°üŸû¶”;™˜—ô$̳@Ÿ®WoÏ—DÀ÷ä©›¿Z~ܸ›=ocÛéâÝr† ]n–—›+ ¿Éæ[»Z]¯ß.Û»¸}÷|ùûÅâñê£kQOÈ¢|D ;]¬1ÆÉuKØ"æn%„áiÄnPw}@»ª‡Ý@ú OÏ}zîÓ¥O—>]bp¤>蜥s–ÎY:g霵sÖÎY;g휵sÖÎY;g휵sÖιtÎ¥s.séœKç\:çÒ9—ιtÎ¥sÞYÑgêýÖÔMxÔsR¢§jÎÎ^pÅBDŠ{s×/ßÎZ3u&ñÉJ.Þ$ƒÚÓ£R€yÏÇ“çß„QÅ[½–qa&(&½ù®¡*…Ž…‚£-a„.~H> $"$<Ù ãüççÓÈf`UzÚѽNMfî+*ÖŒR*¢Vƒ À´ðÄýXüwùäb=¡M­Éé R¨Þ‚Ç×@œ®—\|œP›GùÅÖo}¥·È›VJùþª(>o`aA„<àÜ"IôjußF*â-΂qòòù„~jÉÄdô‚ˆ ].¥gö‰Ž&c€êÑ“eøCB—fšÉÙšSZ€ÂþÉ `ƒ‹¹'FQ´ °K”x©d¨'1Xx®éX0Pxa(µcFOiîaG„ÇLGÈÕ¶ÛŽŽ<,Y‹2|ÁN˜“Ý÷X;%6yìïGÿ¸xw½^ú8¡0¥ ÂwGÁ%x»=„â 3/V—>O™E²Oú F«([G`È„êLF pCR»;ÐIú⮎ÞÁÕ¿t·:tÔ£Ôv«;HXi—×cÔP"¬ºŒRgEA™F©Qç©ÆAjF®)2ŠÛ‚B¥ÑG¥Ž( Q,ŽR3äGwQoä0*ï]fùª¼CØZ=J»ü™ÜÛm–}ÓÒA|vµõéš d躶÷Kß|gÅÄ_ÜYÙ§#wV l·,·eg- 9úBJhZ¤}&ãC÷&ä;¢¼%½;âÿfQFÚ#Êú×Dyûúo»}̱h”)o¬’JÛ]ÍîÊÊî÷Ùîj\Y]]ÿÖsz žò@T½ÚWFÛ«Ö;‘} dŽø'½Ë}$aô*ÉN: «Þ¡ˆ2å¹,RHBîE±jõY¾¨Ë;-Þ‹âÃb½x·^|ø·GœÃ?þ<ÛCc>z›°BûÄEX©¡ÉP¤Fñ!OûÉÀ¸z'âÞöÿ»Av☿ü0€9~sd°Ï°¶q ¦>È}ÐcEÿx€ã¤±‚¢s;j!¯–§RBWmnJ¾ùZ¬@iFSs ¬±ƒt¶dŸOæê+„CÓéhç>Q¢O”>á@ð°¯ᘲ±Gi_NÜ,oß•…zxù¿tÿŽF| endstream endobj 4341 0 obj << /Length 3833 /Filter /FlateDecode >> stream xÚ­É–Û6òî¯Ð‘zÏ¢ €kæåàtì¤óÜn»“ÌÄñ’ '©Tœö×Om HŠí%öEB¡P¨fw³`öã`ôÿÝí£'Ï#=Ký,ŽÃÙíf¦Læ‘šÅiä+£f·ëÙïw­£ùÛÛŸºy³7‹(Š½vkç F^]ÜmÛÅ6/×ø{M±¶Üúk®"Ϯڪæoþ¼}ÞÖÅßá#‹¼CÕ4Årw/“yÝX ½¢áÎCÞ4V°·•ü»å‹²µõf®/_ɺ›c¹j‹ªlnØ£éíÑèÌ7A;¡Ý­÷ÇýÁÁõy±0Zù*Mf øY”18lò ìâ­Žü Sëû‡°šÐcíÀŠè ì% ½¼ž«Ô»;îmÙN,¥@QØÍ^û¯¼™ZDû:ÉØc^#od þ¼Y»|ùäêé\)åݾxúWËÿÁ1ÌïAÀqä{ nDvéG³…Á}¼þáшTiÿDÃåÅËÛˆNð«â4">LýP¥'â?kÕ…‰”¯u8<´—¦‡–„ƒŽTö—„M›ûò7šüìöÑŸP‚™šÁ‰ùaJØ™ž­öÞ¼ fkü pš,½#ÐýLû1’±›Ý<ú·¨ç€§i⫘1iexÉìMÅ ÉYˆÏŸ/ÔÙ_^[m·Ç†[E]Ûë4~ò²ÅÓó‡Ö`‡¾3`yègaøa£q‹’ç ò·=ÖÜ\UûÃÎ’ÈÓwgÂXyņ;kû籨횺² ØïvÕ*oÑ8à绢ݢR…*c¥ÂΑ iåÚ¡muÉÓ3ÒFÒ‰pZAšTšÌx`ï”W6–¿˜~àjhRïù±Bê}U£Q3Sv€ë©|kïæò·gçâcR8L“øQ}¦ø ÌB¦ü8fLθß\üøók&‡í7ÐÑ)«ÊHYi´´À$ä Z ŸŽ»Ç˜²B“aboiù¿±®ãžÿy×&òŽ­ÿ…öEQ8`ùëÏÍmÌ,VpÊ÷<{m¶\åCTå;L™ë@„ªØ­COÛCôÅ{®6#ÚvEÓvC¸Ù`|þ$´¨¼F]äËmOÙêÌOÒ¤g«yúúüt5xÜ$‰f±Šü(ûã C ®…1ÀÔ;Þs¡c?Í:«0Vhe`e°/Ÿ¤Ñ¿ÎÓÀCµ So+ìG¯Ï=«mÕØ’Ûè¹ñÿØÐ`†®¿K²0ïø£Ï× ®*dëÉÏ[o®_L¹ÀØ×YìÀÜÊ D"B[ ¢©vGŒаd ‹¦µùšÇP@¸Âñ¶êwuÑ¢üÓ¶@ûœÅ£ˆá½ôø B<üO4ª—À`‰Å3`«c»¨6‹í;V9ÅT&MºØ(Õ(lÃãhFéH³°Y†8WUÙÖÕN:Ýk0ÅÖÝËtÔ-„.Á  ™b÷‡ªÎrdRSÙShÒ Ø‰:QV2˜^¢Æ‡™"‹‚ÿBÈŽlu†´ÔÕñn˃|šÐY A‹º*Å¡d#]•“HªƒEë⪫Ÿ¯^Ýœ«j!^”ij¼o’ÆŸ©ªýõBú:fLØZõúúbbÍ0ñ°Õ_aÍ(ðC­†kÞ^½úþrÊ>€‡Ðq„áñžsma@F#ÕâþóT™Eªg„…©N¾`#*U`1S¬Ó0O šô+¬©ãg:®ùêõ³ç—ÿ™VìøN‚ÒÆì2k?Z‚>#àÍqÙXRRžùÉHíÙ\ÌYâ§a8´¯v6§P$1ÞllÍMÊ›~Ð(fËí7‚YGDaƒòt:^û-Î ½M%˜sþÛ“µÁÖÚ¶à})a£¯fUÙtÛeJƒ­ÐÉ$Ù`#ù®©xÙá–ˆ ëh(†¼Ë ñ^?{úýÕ3l§bk¸ŸR/ès–¬€­!ö ã;¦©ÄÒ·áY ÃVÀ9‘‚²Çѹq{äÔO¢NãÖˆÔŽéQKmÂjÚtbŒT•E en‚8"禞À‘Éà;ž£W#¼1:møø;Çp3…<`ie*šñ6G“ŠŸfßI³âˆ 6æ´€rwÿ}dæ_Ì!·öG ÃÓ¡f×ËBi§3ÙE[çä •—Eü_˶ Ÿ»b žˆ:› Ò›æPI<‰]ìõÄŸP=ÌMH”§6ðuú±s…P*á¨C¾ú#¿³ÀûXH† GŠ£{)¤®‰ñØ*ÊIrÂ`»ôHÞ÷ù¨=Ö‰¸‰EA±!nÛ GF©vaà/X¦Â¯Ð7Q—îªÖ/ÊÕľCã¦ã爞CZšiâB¥½Ø­m=MØéÎû\Ò Œ%¤@C¾-yA¿YÙ‰M@°©’Á&Äî†`’õÈó=/JÊS@J1–LbшТ ¡Q}k¸‡‚L€96 ý.ÖÀØààp„X8ÕñÛCsÊ€”^á`O§ÖüA;Ú™G;UK •¯âN®ž}:€¹MtM˜aôÛÁÜ\\ª'Ö1êg€ËNzu0ærþÁ8%–äC]óù\ÆRÁ¯¦t£ ë1:ºl³Á/Q}ìv<Çv{°<Œ~§¹ßƒ¤ÀÎxðP5EßqïšüsY´^Åiêfå ‚{ø®ÊH䀑Dz›.þ5uþEËÿ,ÐXWüOò€° h_ñÞÊ ,Õá?‹48"ã9®%¤æ4Ü!àð“ú[ Ù±9©¿T3Š“)ðÂÁ 6L|¶R¥fqcŸL—mÓ/Í펰qé—h6Ù'0þË7íIødV;+ÄX`³$ôÊðI%*Í„Ï_œ™žTBØåä‡XwPПK²ˆm¶ö8ü®ÀM`ßRàjÛwDç=凵¦ÉçYX!ï$Q9ƒË!"ºoy9¹:#HqX¼wa­†,=É&¯Ûà êœ.éH‹›¥Mqžx¾—2¯@t+ä"òg%;%ã]<d¸î:osÌÀh]¶ E*† –,ÍUp$Ù UÁa@̸d‡Î†U‹÷äêá0@2Èþ~eí™Jäc…pÚÓ)„Ü)‰ MsHè¤C²PSJXŽKÒ/R*ºÃàNŠ“ »©÷œ#YüÒÜë.tuPêGs& :ë¹ KäH̉§ƒìòÌ‚wìBÕ™ ì-¤ïßâ_ÒñqëÌ»±–olgd ¹8m"îm†Bîã”  ¹Â€]\Ìi÷å†Çe ±óX±]Jø6»öÕºØÜO%ìÄ&ˆ!² "²DŸô:="§bbàMt’áHzª;# ¤6Rn¬-[¢ã®åŽŽ)óˆÒ†Èd§ <(‘tñO©°ZïyÙҲɩ^…OâÑ%5ÝŠt@ൕöÓ«ïYRª²TÎP d–[û¤q0Ͷ:îÖ &Ò¦:&¢¼$Àø·<PBy/)Ae‘Ì['ËÒÉÑàRƆÎΔÍ¥¶Å² KYü\ÚUN»ÓòjÄÙ¸ä4e|Õ]b<X®<¾×ÕNôx™^êJ«ÃÁ¾»ëKX¶³NÉ)´›Ø‚<*QÝM_ ®§q¨r¥ÌTÒpê¯+oÀ­›½º•¸~Ç lô‡OkzZã—lê¥ßtWtÝ/ÃÈ€7ß„B$ ìó{žÁ׸ÐC‚[Õðd[ï¨ ƒ\[ÔÞ}E ©™ÕÜÏ´;€ ž®lÈ·r®ÎŽ§±ÃH ¨YÂy8·#£5¤.û½'Óà‹7†Éfl Ú‚ryß9®³«Ï­oê«G¯ž½¾šz3bÀrEtñBnùyWÑàºiŘâLX~ùrÂXbõçô. ôIeºW#m¸«2É°ã®—å”Ü匕|‰¾`»‹àñ£sOˆÝ“dß8FI³¥ˆ‚í‘Ç"[ŠÏŒ¢QQëä&turh‰/i‚ÈiŒ ÆP‹’h¼ï­¸eìp|1‰òÕŠî øešaGÀXñÉ™0Šs›ÜÇ,ÏBç&FjòõEïâúÅÍÅS¹Š/åʯ«ç&ð®ç ¿âø„¤@ôŸ¥ýÚ¡¨åFChº_“N²À0u~ßp»“üèdFN²0 MdA|(Ó0àÑ8¤A5fa€†Cô…ákóôÁ«þÞ£…oŠ¬ŸÌé(un-Ú|`›¿0F^Oa__²¢lÚûDøºi—‹ÎÄ$f.&OOž'’Ã⎹ºƒP>¬ Û²±îePÊò ÿc],ÒÙé]–ÎÜ…O6z—…Ï¥ I­ÌR§•Çl¥Én1öTYJ!&ò‘v™¥´‘¼q LV ”oN/â>-ÁÅÝ>Ž„)Ý*OÄ èAä5É°ôpzeÆ™Sç`n®_|uµþe®ÀM=6RIäÇ°u„¾Nô—x•$õfLAò‘ÇF&òÓw,ø¶tàXè ,ŠgèRdèÇX¡\Ãÿð‡¼œÍ(?l^3ŽÑ»ZÓ…s¡†s¡{­Çgã¡G(:Ýô¯å{fJ»<“B W÷DÌŸj‘üóRs¬Ô1ß¿ß}Ä~*sàÌÿ{“±, endstream endobj 4351 0 obj << /Length 3376 /Filter /FlateDecode >> stream xÚµZÛrÛÈ}÷W𑪲¹a8µUñzå]¹lÙ‘ä¤öö“ˆ (èË~}NO®„,ÙRô {séé>}ºA±¸^ˆÅÏOÄäóÇË'{ªE$ÖšÅåÕBê$¡\Ø8 ¤–‹Ëõâ÷åJ…G^¾êžÃCáà¡8 r76_ç'?ÿrAL&e$I;òŠ¼¸Ù7GÇ*2Ë›´JwY“Uüµ,¶_¨.ó+–`æI.ŸŸ»Íœ\>ùï‰ÙÄB.´Ä~­uûÖz±Ú=ùýO±X£ïÕB:‰ŸÜÈÝB–¶°]\<ù猴Œ‚8´c\¼øåý9ïâÓ‘Ë´ö{®Ê#.?æëlÍ›]﫼¸æÞf“qãÊ=³jÊ*ÿ+mò²`qZ¬é ‹c‰ë¡!‚$L¼"ql£¢å鋳Ëפ+eñ_þ XL“/³¢©¾°¨)ý'­KºÜ~¤ýe<ôf“ÖÍñìè§%7yºíÆîyk4”?S}Ò~9wÎB¼Ì¯÷m:6õ&vC‚%ŽsÚË£XpɃRNCÌE(gc0 å÷À-—<£;/VÛ=¿ä” š¤ÌXLwÏæâœ%£ì´¶»É¯‚ÍmYF]®I3¿ywÊkù÷pSˆ]E²|¿»©Ù£_˜Äº×4‰ýÖ´i´¬ZÆ»×k¸ŸÈȈÿ±Âtm˜Fd¿qqWƒýz(=€á_½ýqÂùí¸’è¸ o?Ìl‡Þ7ô¿§¯K*÷jíç´-ë§ÊÒ5+$ç7ÔdÙ®t„°óQ“ünStªXùŸïPÛ/GÂŽôÖÜqö”ågg¿=eÉéy+{õâÌËž{ ãç¿\£Š»eÉjÌ?¡î¾æ¤E7 ¸bN¢tö—)å¡Z®¦€V%®²º.©¸K³àBT,¼OÖ`Uü ²}EæЀÆI£„ã,# ZW¸ŸÈØнYüÇê50{@*ou¯&ÿ¿>ÔCŸ0÷W9ˆ=ýÁµ|NMPkAAå*m²Iþ¶N›”[.Ä6`Íu—JÝVIÍ‹ºI‹U6νºnl‡4»ƒÐ}=yyÒç“ãLc¤2°/ú‘×HèGDÃwnàƒržP3³$ê߉„3zëèú»ÒÖ°æÑ|¢s_\’Ö,üÇÌ.¡6‹`‡ùÔ×/)—Ú}Š¥içBί|„Ó3J1ÓCBú:³|B4ýLiŸ™í˜~ v1\õ>sJ¿{úÄßÒ]Í‚t„Le8™ò~ØcŒJ+–òPÙ`>9 ýÌÆØvÁU?÷Û´£×d ©ÄÆûûá ·‘ˆ¢Ñw]f2¾L1s{Š¯ÄEŒOžÌ ¶ž£ –úp÷ÈõdÝ[?“TÝÚ V!<ãN|1äSWîÜo×·ýH#m3y÷둸ì/Æ%p©'JÚR£GÀÿð é§ endstream endobj 4358 0 obj << /Length 3309 /Filter /FlateDecode >> stream xÚÝ\YsãÆ~ׯàKb0eNæ>\åy¥]ï–öˆD•;~ µÜ]–uY¤Ê±}¾ž €Š'Z¿ $ØÓÓw÷4ÈGG|ôb¯]¿™îýý¹1#Ë‚S~4ý0R3#ôÈòÀŒ£éûÑÅ»±P¦8ƨ‹·qþ¢ñÉ~œ¿ÿ8}`²L)¬ÇJÊë±ÕÅ) qönlUqB¿Ú;œîý²'ð‰‘ð‚y«"NûÑÙÅÞ?òÑ{|ùjÄ™ ~ôk|ôb$³óÑÉÞ?ÊÍ4×^a3í½ÒÚÿ¤aŸ¨PÑÅ ‡å.š$™ϸM>I0^Ž'¿œ(ü³#šÅÏžÕ³éxb¸)ÞŒƒÉ0ÄY?š`ζ' AÀ숆Sº= ÙaŽ´†qg*Ò~1žˆ Š \¸,®é¢ŠEºûtœ+.ÒŸèâñƒÌ>K˜Ãâ%¹(ޑв¸mÝ]§Ë2#A1Âo˜Wý!Ð"PV•’°L+¯:7-ä΀¸Ñg.´ˆ6UüklH®0ËQIJ¸•þÍ Oœ'ª’"a8­gïhÈ©‰ó$ÛÆ9hKO-áL AY[ç„–Òp\âcIº] lÅxâ…!úH1Œi~M_äx)ib]©,^¶Ñ½ŽËÏâx“c˜Ê¸yáž&iÆìE=;Þ`Ï ¸üÎ p<<‘OÓœFa‹/l ¾Wà?ÝGwBÊÂgO3¡K #ðgcga¡œÒav”"ëªî¬ëÄ‘ÄMY ûâb“LÆ5È~òbóFEP *b`ù7åò4ŸI\)ÜÂøH/é¥#¥âH_D‰JûSM²`Ã]“e@Ëyq0ÿ°¸œ§ù,]ή..n/g³ÕÕMúäC5Y}*½žý<û8g9ZÂ.¸ÖRëÂ-JË*`  ‘Ú°àûÑÖH¦aN”ó>'ÜðµKÇA ñ‚?6äQiм¯á{ ®pm’\›ÌÉXƒ«!p–p¯J©6ÎÏhÝ·4¼NCÆ$p&¸I´kTû®Æà˜†#rb&ðk-šœ ‰yy¹X-fç‹ß+a»L×Åår5»<+?½ú´èìyn-›GérZŠìì â»ø}¶Z\•+‘ú,»H7_§ ÿ2]]¬>•³«›Ÿ—Óͧ+¬R,W µ^ÔáÁ8  !ê°cÞmurǯ ÑàåÄß` ”ˆMFªÀ¤j8UÎ3»GªGDŠÆœ`&ô&ˆ€ çÃDÀÍðtŸ{¸ç c„†i£hX_ð´%i™v²ï–8­fK:®ౡPZ‘Ç÷`€`¹%‘ó˜Ò1³æ¶ûKDj¢ÎFÆ‚SˆEãi='JóŠÿJßE.ýŽ|¢êdÉýFº G:x&¬ëgY%s*\L¤2ävf£EøÏ”kE2AMz}sõÓù¼42•å©­Ù§«åêÎáÙ³ùrY0ÞXÛ´­ŒiK Ü¿uÅó c ï\„v4¼9¾ÌË,…áD÷Y÷“Y§àlÅ¥Û,³pÁ¯ËPŸb |ã± =4å|u°6´ø%C‹ÀW1ZÏ19ÐÅ&J+&k©žŽ‘µ|KÃáØ[ÄcÑ ±‰kƒÇõ3û4;ȱÅ3-e›-¹€A\+8âZ‚-ÈxƒÏ°¡º”°¿Å/43þÆÇeÞ ÜNÊä4“fe(nâ«Ot[·96À–}Î4´’b¡!@qÿ = ­NÃ÷¨iD+oÞ ˆÒ ¨jB1.†øÅ”†MezYšBÆ3%†¡@ ±™BeFÊÌ‘'Ý°3B{pÅ»ûuþšñJ8­Ûd©i#.±ú©14Ò1)vÛCYÊcS²úò¼?ò5Ï· ÿgâ¹–±;ÏJ¸‡ÝÉ~,‹lÃ8_83ši˜ÿ!06)ŠÚŽñŽŒF „xbŒV †Ñ%¹{0‡9¦ôå[@Øàz*÷ÈWʽ yçÈ éä#uÚ¨VtOé‡3!ŽRwW4MeЉÓío= §ÌQŽ4¥²Êö èM”w%U‰/PÚÄâ¬éM!–¦rÁˆ!ucÒ¶ñÚ-˜BÊb]»€üØàT<&8U݃SñXEF‰±=É)‡‰$PP¡¡—¨C/ilCDéÜ,íJqO²"•í¤È^1§Ä ›óÏë­›»bˆ:ÄvoÊXØ0ÄÞ$¹}ok®tmC¸Ûd°¤’J5 Öá8æyŽTc‚­iÁè„–[ù$r=ïk'Ò± U*Ü—‘Ã(•“¤}¼¬ ´QçdåS&3’9Ããç*º<.H15}å\è$Ž\ÃÑ ²]Å]Ì£¶n7 ùLµÙSz]ø&Á3>Ę­ c­5c´cçª|÷lv~Þ>lhz-¯Îoã)Ât œgùûÅaE·Ž1r°ŸiqX9ά6CÄ¥Jkû˜âp;f°Ì­ˆw©ÐÊŽZµÆ{ ñë'8–Nzd¥Ý‚#É?j½Á®åÅ è¯O¥+‹S™%šåª·T~µÿ£±¦Þˆ\ñ6¨FíVÀ„Ñ*žobbcïå¶â­ƒõmù®ïÆŽÏõ8BÅéMm&Z­±Mh­‰Ý-°² Žšt¤,¿Š\l2Á©¹«¼c& ’~ çÿ»&‡ÐðÆð}Í%bëfRêÜ‘0ë!ÒHzÃýd7À5V2’$¦’‘6ëMáx1k€ÐGœïŽEFG5GØÊp[9cSWÍ1ÍÞ¦ÛL¨]õ"@¸ zj뽄~R‹ ‰;†) §cãÓgäYaq¿Ê&¤¢>„ )ÒìAK®Ì R¢8zÚ"LÔ((Ç õEòÐ>Ìû+â$"¯NÔØåOiX¾¡hQ° à-ÔN„¢&LØÕ~Xh:¶ï©vÑc_/ºc‘ë¸ó±O…°1À¦kVÕ :ïfc ¢…IW*uåVà È*S¹R¥S—ƺUóÎzI ëÁKé KdBúóRR¡J‡6›Ê;q!t ‘Ž#„¹@€™ykjÞÚÄ[[ñVI_[¥À™7­Tù‘F Žš«~FIùØöÕÇ(õÁ"¥>J£Ôg¥QêŠÅF ØÛÃ(uÝÍf£ÔÄdW£$»¥ÝyY¥ÝyY¥þ¼¬R“‚ƒ¥þÌ-ÒŽ¼Õ¡®¬…ÈÛvÿð½â‹ã­©LE>§EöÈ‚Úó}É:›M8¦àÙzƒe¢Ýë4L礪á¤6¬Ù2M~šÏËfËåüâ§óùû‡:·žLo–â)• 7‹@Q–÷'éÍòí:L+½§Fzg6¥÷PÉ6k´Ù½4¥ƒ–ØR‹ûõf˜+#î×›CÌÖ3ïâ8…Ä Dð»y;JÛ´Œ¹Wz'o¨Â¢»c‘«žÑ[f:bã„©^z=qõO#'?Ow·é²J.¸â2WÃ0NdJÃEJIåàŒÕ ”¢ŠŠ mJ`âraBj:qî³í7º×þc3‹dÿ†j8k’òiˆÇfwarîí¡x ¡[¼Î»Ì ˆ Ü8ßFq§ï×½ßt@#:Ð8z7à ±Ýx``¶ï6ÏBM>>”ÁÿóÅGØŒÔNf¾"%ãÅáf×çå‡×7WoféævI¯JWv®A§µw <}ýî¤fóÝcŠª.µR̀Ϊk]’»¿€õLé:¨=x{úÍÑa²€ïŽŸ½> stream xÚÕËrÓHð£T…fç- j«6° L616pPl%V•mKÞÀßoÏLKHöØÀqsH[=ý~Í4#„‘7v¾œM~{­%14OeFf÷„+Nóœ˜LS.9™-Èm¤ã$Í‹žÇ‰0?ÏÞ{’—§àHÄ€dúO€ÈŸ $eCTÕzìy5¢!íÏð jâAkFó+Ba*D‚vªRÄÈ\sB R&<=>ŠÌ)kä÷È$jÛ³€q,hrPzBýá6≱:Ÿ_ÿuc  ÉhnŒ²•˜pCS™T4Wʳ›EœÍ¢§ÒÃú®-ªÿÝ.ÙÔ«][ÕˆñŸ˜füãó»Õ3„#,G,~ðLS4Xý¢Áp°)e¦Ë§.ÎlXÑ”rU®ËM[¬üçã6æ¸Ø@@qÅ9JFeÌuôµX?®¬·JEõ½?(‹­Ö1ªU±õß.þpÞ.‹Öc|ø y‹¦)×àë ã(÷gœ¦›Ý]SαôJïùèðw±`ÑMÙÔ6˜O#sòhY7­´ªÒzîc±-‹…u•Id`j`0sÙpÈy½~¬7¶Íq!­v ÞèÜ â·g— àô¯ÆYŸŽs0Šê>È'‘ ‘s†NØ©o_Ãû!¶!uÒPɲ_ÓçôÀý¨`Œ˰Óca0•^NFÿd.MLæ¨4UJ>wý{ Þ¹”ùG(!0+a[Àaèv«€e¶-8aŠNxÛæ(‡T‘¢®l©À›ýÞºqzjJxkª*KJ÷æt”Ýs^ïV8xöÇ!̨ß›Ç];ºj;¸¿`u¯Z÷n4ÅþJpøŽ¼¢³£[ îé÷°ñÎÐm"\nåèW˜ïÛCÓÿÇÄqâ€2q‚èÈ6Ô³¤½žÙô(ÜÈþwÛÇ°ÀÄ°2F¡Q»HfºV`rħÿãÎ¥¾ endstream endobj 4425 0 obj << /Length 3502 /Filter /FlateDecode >> stream xÚÝ\Kwã¶ÞûWhÓ†L#ïGÎé±=çxf\[NÚ¦Y(¶f¢Yv,ù¤Ó_ß2$K"'u²!Š¼¼øpßÉ{z¼÷ú€¯¿üõ•1=Ë‚S¾7xßR3#tÏJÁ ×½ÁMïûì<Êdhuö.ö_/9Œý7ùƒo@L.SŠëñ¤HåMnuvEMìçVe—t×ÁÉàà—ëxOô„Ì[9pààúöàûxï~ÓãLßû5^zÛ“Œ‰Þ¤wyð÷r0ËÏ^a0ͱœÐ³ÿAÍ!1P±¢³3jNÊQ,CÒ7žáî¾Ã™‚ÆiÞ—¸³¯p'zgÔ‹çŽêÞ ïn²·yð€ MìEò½>Fál“ ¸ÂôΨ¹¢ŸÇÔ;IAkw¦‚ö³¼/‚Ènqà2»§ƒÊÆů÷`ǹŒá MöJÏZU@QêAʘj(ž‚ÖܯÛk$Ó0yDÊTBü)—å£\@E3òúÔ‡h8Ú¿Á?¤ÀýJr¿2%˜ YuÁ³ä)¥š<ÑsßQó¦hf‹3Ám'((]Aí»šƒ jΨ9NÉ™ÀÝZ„” Î~^¦Çéìãííhþ0¾®ïæ9‰Ú_ 4FÎe'¥aØøâ~)H8×ã/#- ’µ>ã)Ô@l¦@ûún6/°ùõîáçñôÃ'ƒGZÆm7ð€! Œ×ÁCÚuž+²Éh`¸`Ý+xÄnðœNÇóñp2þoeÀ¦Åq<͇ÓëòìÝû½Œ×þX h£ìK؃ 7`‰ð åìÛì+4RË80± ¢ Lª¥HŽóÄè1o¡ºD$ƒHÉl3ˆÜƹ"òuvuœ N!#µWuŸÜ-õ/)ž-% ôÅRè–Dò€ôa‡¸ÙÎ K¤tððqI¢îÌZo‹t†)+žs· y|¸ûq2º-¥uºòïOµ \píõh6«l(_âÁ4Ù8Ùð¬Ë^%fH ¡æ¯œÓ²Oùâ.í-‚ôv²`H IqZ+ûðÛoʆ"%4Ç—¤D:ôMÉlâ"¿$°P]]]Æèy&‹YÎÖA­˜¬Å{#ûšš“Ü[Dq1‘FƆË©ôE}Í!õŽSÓâ™–²9-IŽA@/8¢p¢|ÁÓD ·T\ùyüC3c]oét™)·Vi¤qRw¢UDŠëMóê ÜV­ ¬é~w"…6v‚!Hº jÂPQ¢§¨‚fð¢!u‚ØÔ”Ôh]ôÔû–šCúy‘,i„âE ÀPBlS ± C†PZà^´«@wp=‘Jn‘ãÂÀ–ç0× ªå? ¨YW1S¦•“¨i=ùÇ.¤„Ý ½OZÐX16tΫÎ9 ½çH\€¸NFâ%CÚ÷üH´{ªÒ}¡³¿ S5‰à¢êeÝ:oÕ§(• ÷Â$By€ÖD€”p´$:Ö·Ht¬o22±¾e}%ÖÇ‹¨Ú®MÑ«l¾´..ßtØY#ÌKÃœÃv„9<›Ü€9—ÉJ!B'aB'œ à. FN¢zœÅ6ªJ•Y8é×/c¹NX2”sÉUž*[ .¶RWJÌõ “‰ìÔt#9´Ä`äÆbÁÕ ¾¦é¡ nOæ-žºaêl}žyG&Sèä63­,Ó*4r¶ÿ[„ë}òŽY8؈u„fÚ·C™–B4)éÅž.^Ô.^ûÓâP 2 ÷UÒy<¯b â%h•R«aSÂÁ•Û.¯D@dž|*ÐÇü'¢‚”È!2µF¾ˆœªµÄq ÛÄ”bï·9 ƒ·}БªÑ9æMøCL)æ4»˜Q¢¤´Ø9@Q”ô]0¢s"4Y Trã˽¾â>Ê÷kå&ȵ1M@–¬l£–y„é+£ 95EHã×Û«˜uú"˜œ×`R]RlÿÔáÏoàθ†wèb´Š;Ô-FK0© > ñ[³¢q’Çû‰PßÀ6R©ÛÖ¥îFmžöY*Í_Þ®Çï?uõÑdt;š–uwt>~ªÕ"…¸ÔÚ.‹ˆ’¶›Œ\”˜@#gJú!Z ë—ö:TÙ‰såêeØuyîh8™4WÜš À³»Éã||7ýdÐÎ\'ëpDÉH±ë:\\Ó´))–ŽTj9Ôy+iJ#G3]dyD ãßb­ÊXæV÷Bí²†%w\ÂþÄÜJi<·Ý¾ž"õ'JÆoÌ\NsRÅ€1Jå³×Ð_ïõ©Ìweã©—ZÝ*u°}Y>O-nµ´¶%àè)ž¯›dÞËç·\™Zž¦ïrGq*šSèõÖì/¤Œ·éݵ‚ÊÄmpYJʸ;SÊòï  $ýŸ»zËÈï£u“t·‚õzrAˆæO€T 7i«ØJ,?"îDOJŠ1¯ò õåO¼€0£‘B`*i’°E"”âa{)[Þ`'˜ƒ€îÌEjƒíð´‘»ˆçl±›ò‚z‰zŠqÕ pN¶À:ë½î ‹ ±æ2@€„Í€š«Î1ž‹ÞSg_¦¢m$`Ö·Âá5Ö®L'2¢8Ä ZºŒKThŽ(#ð>í†ç¡±÷gZÕ£D5©J´›×!Œ£B‡{ÁDÏÄ$€„‡»ß &Úy›ÚŽ MÛfZQ0°*¡Ý8 »^ìÎEz‰Ñy¹±zçØK ¸úˆèŽƒIåHÀÅ6ÙÁ‰Öu?rä:•©œ¨ÒÅ©Uƒ†ôص’"Aûƒ q…pKew “°avdj•Ö‹|“ŽֶvXÿ;®m9ƒ Òu1\»¯Íó£-Ö¶š+[M§ B‚ëôk#ÃÉäîz8/èãlT®¡Ü çÄ•W°àºeÓf±j©9«›wÔÕ ŠëžZv 7ÇCË dÅú©4ôú½ïbUd;›Üî6€×n¤h®>¼(aÖïBs<´Ý1û{®D¨n@T^TØw‡Iœ”[Lœ¬l1qzCfÂa¶•|¹s…üÓv4Wð¹6ì¼é4 ›§mûŸ`;Âñh6¸û¸’=5ßl%@oV\Ãx:=L‡“%÷€žÈ@íñzþø0š-¤ó%wz^ßÅš;‘â›VO?Ù»¯ò÷úî+%#ˆ‘ºX²'RÜûg×ì{Ãâ.¡%`ž+NÐÞV'*T¶û>‡3béû:~ÒHëô÷98#(S¢å*¾ŒßÌ!RB”P¼Š?û‡±=+Ù¡þ¿bK¦×­~µCǯv˜µ_íh¾ÝdÑ]Bö2×ôMߪÐôEŠò;Mô=’5ˆðák¾«ŒüÕJŒVǽ)>”»5^?Àd»Êì—¤c<;ùÏðö~Rž¼¸ûð0¼-~<Ο(PË„5GÊVï#xsõæü²žæÅeŠjµ¶P刈Ëc¹% –íé,Uê:Èñ»«¯ÎN x~qrtzyúîmâyÁÇ—èʻʷ°ÙFÄz”d³ ûAǶx[žëÆmÈÿ¶”\ endstream endobj 4336 0 obj << /Type /ObjStm /N 100 /First 980 /Length 1713 /Filter /FlateDecode >> stream xÚ½Y[oSI ~ϯ˜Gx™Œgì™ñªBâV`ŲíÃ.—‡R[-JP›Jìþúýžÿ=™ÞYœ¼ž Ó?þ|T£Õ†£œŸ½{÷òZ ¥4µhL¨V>´4Šî­‘Ú±!~œèÜ#¢b¦wï'ûïfa%³w¸\ÎNæ!Ÿ_Þÿ°|°¿<\Î&ÓÝÅ|9·kÑ©é·kÉ¢tqaI³ÚaÁÞÚG’RËÅíãM÷NGû3¬¸·¦³Ëðr3ößÎ&0{¾œÍ—§V‡N;ôÓÅÙÉÑìô¼þÏ~›½>>¼³øFœT$aÓŒƒß;<4€H­1v Å£ÿ˜=£ÿ¬t±h‹>/·¨è†µªÚÙ«;ˆ1x²v\÷reœ>ºûäàñ‹9½¸¹½„!F‚¢Z¡ÄŠzMUcEñ® ”¯I˜§÷·hAË° }´i­Û}Ñ‚Ÿþuº=ÐÕ£"bE(¢ÛJ±¡a£×ÇVôJ NÏ^Böx1Û˜’,É>™Rà k0¥F ™K4¶ ̱©\iËÑñrßÌÞ½ÿ%ÕK…Œ“³­ѹc¶äÆtÞÿ§|¬‰µZòÝEB®(üE‚eU àÂÕâ¢6ðVkuì#£yLåœcB+·(íׄã›ã·g'³([줖 j¬9#Œ1¢0€FäD1ñÕiùëïw¶˜”•"‚à R;Í=A/xÓH¹þ|ý ƒÑ(¡ Œc«~F^‰7劬ÔbÎʼnŸ½}AÀ‰҇νÅjùÓjÁ:{Ø( Õº“^Å+lFLu‹¼Búå’!õÛJƆ#›÷ìÛ,çc“µÝ¢`¼s¢“Fa?¬ºyÑ¢%b/º (ª·`p¢­f©Mˆp¯¿E@ÄŶRÞÝè‚<&7:£]°M±77šJÔäFcêÒâE³6°.7MQµ¹Ñç=Ó‰n“¸ÑµÆÔÝhé‘ÈN‘ØæsêìDëäFçŠÉĦs­ntÅw£SŽ%{ÑEѶÅî5Ú»*'ºõhïc¼è™Ýèš1{¸ÑÂQ’!OŠxÑ¥côð£Su£A¢lÈs¢‰c7:UŒ®^tÖí%±‘ÝhTŸÖÜhTŸžØ‹FõéÅFõéÕÕU7ÕG³ê£âF£úhw£ 3ùÑc‚ñ¢ðVœhRp¶ôUtEŸDw¢F‘´l•SoÐèk‡mÂ\“W¤ú{Ù2“^bËöBÚÅ–í;–Ïl¦Õ€m%v›¯ÚjCÿÀÓcp_ ­Þµ£h•¿4O×-ÎÓLŠs”Ž/P­Š}[öV¿ö’ 1KŸ–öuk¼Ø~¢vF‘¶{¯s®î6æ¹Ín}¸ÛÂ<ÇY.Gh.ß¡ë~Dµó9|øqŠÊ ¼±¸Ñ >Àn´E— V/Å«—õòÍÖ endstream endobj 4489 0 obj << /Length 3877 /Filter /FlateDecode >> stream xÚÕ[Ûr·}×WLU*®Ù” ã~±ãTÙ’ìÈeFŠD•d>¬)’bL.•%e;þúœîž™ÙIQ»v%/`v4}9ÝÀêæ´ÑÍ·tW~}ðà³oBhŒQ%Ûœ4ÆeƒkbÊ8Ó¼i^·øÝÍöŒÖºýj1Û³A·Ç¿Î/ÞKãòDÊ£ùùùÙâtvxðÆu“q}T>`Vpÿåþ³Ýg“é]V9øþ³“åÌäöòBFØu°MV%FOßïÐé´G%)m:z"g&´5BçR¼YžÍlh¦ÏŽ—òîúRÊ÷WÇÃ:V󕳶¶Ž1Y¶(ãÍj«%pqv%åéhúŽä³ ‡Ò ýUh–´U}ãù·š×üÝ7g§ï—ݪR×E6ªÉ Ж›¨JrYX±¹4è‹-qBãgÔ¥±ªX| ‚Nòú/üº(‹u^?žíåÜþŠg"^¢~Áõw\?ç'ˆK)ð«Ô.ùÕ%×O¹¾\ëlcû2æJ{%Å™ )¸“k¯Ñò¡}K…ç)Œ!®¦`¸CÜ!{þ­ci-¥u"­¹´Ž¤…O ¶‡6Lcö²Šü)ʧ  ´%ŒùóÝ0ä%².´~”Ö¹´0k.ŽØc"sƒŠc)Ž¤8“‚øSߺ”b!DÿŒVHÜ/0—©¸’âLŠK)4Ÿt÷š“n÷gɶ/gÉPʹϨùb¶ç\û)>÷…’íOò´ xðï$ìº1ÍQEÓDçÁ“Ø]Û1û‘"3iU\@ž!.šöQ}PŠhïÁ>{ƒfSvÈ> !¨z9‹^@çq}=Rˆ`yÜ’}Ðç )ŒÐŠ'H“?1ÊBm¿f’Â×» †Å=Mx5ðœjßS­¶“pY‡;vÑÛJ» œŠo3??#¹™6pÝ×]%ÖŒ6Úé3^´›¡À{mN è`Ê°›%pè†ç?)f2^Íæœ.¦¾÷Íæíà <ÇÅ)ž ¬×à¸2›G;ôƇâ·üœTÇ@›3Z­A#à ozøäØ£=l¦ ¤þ×¹»åìŒÄØ{Áq•ÝõÊæÁÌT¨€/Óˆ'Zøh?²O—3—¤öŒ/*b ÿ0E€Àïl%Ç(Ñ&JÛÐÃBGxÍ-/©ö°¦MFé°2 F¹¬‘AQ¦ö½ ‚}rˆ¾¨Ézpõ|“¨çºðòåAÔ„³3Áí: «e.ìVösë£g= |3i$¾¶_„ZKPÚì·Û/ ö<”Σ®)ZêÎîùñ.MÖcê¼#5ráž¼ra¬èɲŽ Xþ¥ Ü!:tlê ¯å6=ADó 0ÆúT̃­9H¸¶Ø~z×x_ÜÑʽyW™§IØs$Añºã…]Ù²ÿ^ä<«4'là\Æ£õ£´Î¥Uƒ”›³idæ-œãkA$™°Õ‡Òª ¨tß +y[Nò W”‚‰¢ÌD϶¡ô¾âƒdE;7r¯!Qr#pæ)p6ÁMûZ§“,âjÊ9jV¯®pÑM“]W^úìXú®:ekzk°/hî™…'{`dbi|`+ÛÙ«@™•ÌCY Õ‡ #TÙÙw¦M—4qºý„^»;PÁ^D¬ù ±¤Ï½,ÅEŸJëgR@Óe\LI=ßàf’5÷à[Dd¿Ï{ôŒ÷«Ê5 Wj@ k¶âŒ2ô™†rÖîP’‹!w¢sQ!|.»¡ž7fJÃ’ç3 ®ÿ$J"ÛÆLÂOÏfuY ¾g³ ò¬.œ1Zcæ}JQ,¹â]P€ÐG#t›Pðj à9Qð=ÕQe%¬VsÖ¢æKÎ9rfÃÆ°.¨ Ö‚ú±Ø®Ÿ"¬åûb¤ÑëG’3=– ꉴΤµ~ò©z=A‰¨…Ì1ÒŠ•œKCñpö÷ÉêMàpΰðø¶³üVŒ4Yg#ÖB Î8”Ö—Ry©FŸåæ~›¦~5˜© æ냱åЖHK‚üµôé>ge3€,÷›v7µîvÔÝNÈY“Ϲ.ñIkâAÁÆÆ)“Ñ Vn|Œò„€c8*È&ZÎ-Ë[ö³£O~“§íù“)†ÉÁCöR{F$óºÏ*/¤¸eœÅâ¯~;’â˜t&d‘(xÅY¿cªÓqŠ+˜¨½fwÈû8h="ï˜ÜV‡$  8 åÓ`w0ïS¢`Ÿj5»S0sÜ –/¯Qðj à9Õ¾§Ç#9裇ȱù¦¬T4Ý¢¢d7)VgÁá.034 ¼vd »p)V‚@™ç° ï®%ügN`‘)*é-ý'€ ¢#Ï)Gws’ë ¤‰E›Ér¢,‡Sis)À’^bÅFÀºç6»[W’¡w|Žg|ê;롳 ’.ÇŽ:—¢ߟiîn}ÍçW)`Þ]0ŽÄTG3eÜɈŽ`]OZøZfûrlŸ Ä£’ trâ.Hv¤Â$OH~H©·§’¬§]ÔŠÖˆFQuB@=HZÐù ie=¼N4Þ³…»ëtƒ”Ú'ÌLl§1.Ã>ÉPÁ¹qNm‚È“ ºKb‰uÄb3Û‹ß±ÐYñærÃ~-‡ýºHÀ˜%R,)Ê Íˆ:Éé]”LŠ1•!%ÅHj|)¹.%ØkŒ¥c»ðñ§›>Þmä±ÀÛZFÀXC²Ê"Ó.Qв—e.c!µ„õâ ëÑYôfúÀåÜ­ùʹQ²wÖ‰? Å*±å…5F,®­tˆþ†,–Ñù-ÌͦۧʹÅ)4TÑ•”•ó7fÊf^‡@É—rD¾™óÑ6€·ò'0Ú‰œâ‚À|øMüqˆ6 q ´©ÑU®ôr²¿{Ñø$ÑuZȬt2»=j+Cª >¸PPk49åBÞ˜ %{Nš¡ŠO¤3S\—á )®%l‡J»îBBʽá2†ÅÜ$ìÉÃê˜;câê¨Âpè{X1xd‰Wyµ;îxÂÑk¹ô3çç‡\K®_’iâ[Z6s@©ªk)]Èèîï“lOênih–ËÄ8™ º³Œê…qwa 7oåbŸÍ[Aq‚Á$ÚäÆÍ`’mo„¯¥5µ:;=Œ²è.Ô8ƒÿ` Ú S‰.çÜìCÖî†%;á+¨r¶0ÅáÒ{)®¥ 7âÚK ma’‹³›b²|;j¦‹q½.&VºPz)†É3üE@¥–FöYÙäï”äìãH’3Û›l˦å£Ëz7©i)=i™"Ô»H#¸¥ÿ(ÒF\s;$-lOÝ„êî…A༆ ì¨è~®ç€Ñ]Î÷Teréë¡„…óÑœ 7Hõ&â‰Ñ q¼[‹ã­„Gš“„¡Ž¤õ“´æÒ:`–_T—x 4Šùè„Æ­mߌѠS6¤uBð;ãÎz¡vÆu|åãcÁx ~ß+hð¹ýBLÐœÝwt°Q¶[3â!x2 EWXìæ…†Z¬röþ›p€ùÓ.µpGѬº}¤l”J¸ 8¬kôôJêaùÂÅRŠ )ΤXÈÕ´¹´®‡XÁÇ$ã8éKÁÚÇ;Tæÿ&Ø¡ëƒ#ZßIš~)Å™ YÀµ´Nhß{© °G.2RÊéÅ覸Øà5L7.“o*_¦ßÓ’™[i:•ìEZ¼éñAÙnî¡ã!È™ûSQ±¹(ç7K°£»¹joá½w[­¿ÈµïmÖOÄ:¿‹õ[m°Ÿ~ºþÏk¶ Šcì6 ·:*ä6 ·ô¿ív³ð‚åéÂEk Ef<—¹®øiI‡Œ(êúé^”ÛŽ5"èíXC׳ŠÛŽ è9m;D„}Þf!ÑlÊ;ÙcO·}Ö”[ o’é?´µÑÉÍ ¶œÖ¦[.ØcV7·j·`õêöËbt+›³ôO›h&É9cL¥Ô¨ÑRRÊ%S§KåPÒs+ÿÌ âPòâêéE5ùB1°ŸBøÚ£\4¿ËÝŽd€q6ÛÞ톇ҦÛÓo&—:ºdÐ\Zç“ß~’H.„ÁKúžyÆ×oÞ ÆŠ›„Ô|9D2¹Fü'Zï¥Õý¶¨ßòa¸¨'wä¦<òfºløÃßzÉAУ]€©é_tï·twö&'üœS·Çÿœ|·¼<]Î/úÿFŽÿå¹™o‚&Wÿwäê3g•KùÆG^v…œ÷åÕÕñÅçÇoJиP·.¹»HH1]Ž«­1:LºAÿ ÔöœÜ endstream endobj 4485 0 obj << /Type /ObjStm /N 100 /First 973 /Length 1286 /Filter /FlateDecode >> stream xÚ˜Ï\5 ÇïóWä¿ØNìDZUê¶ T±=«–íPUT3Õt*•ÿž¯³KUТúôüò>¶'±“ךJ©¥5ÕÒ,ž­L‰g/¬#+îµ ¸s–acJÀ]Ë´€{+\yÑètí G¯¹†ñîúRæÒ˜…%º}d¡aŒkx0‰¡‡†iá&¡aðÑ|iÀGg >º­6ø°ºÚàÃÖ0 >lF›Ã‡GdšÃ‡ƒ˜â¡« >Æ §ÃÇ\ñtø˜+ ø •cŽð×RGüyÅÔ'¤å Ý^Q\DZŒYqŠ©[ÅLŠ®ÈÂB‚¯á_aÙ$z5à×[而øŠÈäMp1áKEëøTH˜H Òœ!õ¢Ü–†AšaQÑ¥«=Ãcù¨ÌF –›ÀG¯°†Ë—,÷¾4`ÙêÒ€eÃ24 Í¥ÞBƒáÃGh0| ¬#|À¨N ÄZ§/ •—"WmiaŒÈq_@¤†F,Ki¡1”1ŸÚÂÂŒ­Òî7\—~7‹ìþµ¯nxøˆÙ1^@ÌB#v ×ЈÕã=4°…±xwq±Ûž•kÌhÞþ¹l¿üú6D%Ä{Ωcnß½{µ{ôè+ô˜d’§™¬§iW²‘¦­“sšîN1áIºMrÏÓL£¦iUš¦¥Ó°4ÍNc¦é:iJžfš=KcßÓizE¦NÒ>¨¶<]©zš6!®iº7bMÓ͈-Më ¤ý4]I$M‹ô4Íå#IW#å,­sà™§ñô4=„©³´7jš¦Í(ŽIºŠê˜¥+E¥HÒMÙ> k#w’°å‡Èƒ¬¥áJ¨ÜI¸ eY™Òy[upŽJÂH:(ÈY¸Òà4œ3ZšFÎùž çÌš¦‘s¦æéJÓÒ4rÎœiš;UIÓÕ©¦×5ÏIuäi&æ4=”¸}•Fö¨ëš0 1ÿ]¶§ÇwÇÓÕû›Û}Ñ;7çóþt(r÷úݧóó«óÍy_x5ì¶Ëãá\..Êv¿yÏ]Æçôû'ß¿à`Ë‚¹‹7øÝ^œŽ·Wûs¹†³g—e{¹ÿt.Ÿðò¯÷ûèÅ›ý½;œ÷‡ó‡¸ ,ýÝöóþÃñãév¿Úü®í§ýë·7OŽŸÊuø7wŸò ŽnNÐŽÛ߇#¬]ß].¢?ÿq»€Ývõñ÷ózÿñíáÏÝöäxz½?-ãõÕöýöÃöôš×Kôç#Á%‚"ãjƒëŽ$¸RzGÐÜ㲫²=?¾<LÓ7¼}óñ´'ÿ6‚òåìa¹|ž=,Ÿ˜j0E þ³(lb1?x,{nƒ°m³4Š…©§m ™¥iT‹¸/%i” —t¿Q/¼çéJ¸ giTŒÁY—¤ß4¢1þà•ýAÙg|yeÿRò^ endstream endobj 4545 0 obj << /Length 1231 /Filter /FlateDecode >> stream xÚÅX[sÚ8~ϯðd¦ØU’-_:“×8©3`3ÆÙnö2ŒKMâ)Ø,6ÙÝþúÕÍ‘’IÓ}A²tÎùÎ9:Ÿ.@íVƒÚå ”íûääí!BÀ!kÉ\C˜LtÍ´ @:Ò’ÏÚï:otûBØq‹n_Gv'û']®û°:å\ ÎÒÅ"/n»&WÔ®Þ²k8À´ Ë-Ž®G㉔káëTÌÔ±ùºKÍ–Ka~ÞŤS®ëuZÜMÅÐø\}—‰Î$eR÷];ÙÛ8«ê’ÛȘÖG¶tŠÔG:p [¢di½‘R}L`'->‹N´©eg.Zï5ê:Ölà˜¦Á<‡Ô¨ ’9c‰bY‘N“,6°Z—·ët)>òÅbSÑ€jÇ–ReUåŸM%;¥ôƒ‡Ë:,\ÈÂ%4Ü5WΈ¨äǬ\~Ê‹L†õw^ß0{Ç¢ÛIÓòÝ…‹M`;ÙŽnÉ:éö L‹dG—±;êöMúÁ—zšø“d:qñ§1íE±Ï׃å Òµw„>–úÁh< ¼ Â(lKËeÓéÐ^|!|¶\åspw¦2o¨6ËU5¥‹°™Ð#R/¹K¥? žl’Ä×ýFbFX[¥ëi•Þg½ýÁf…(æֻĿôc¡øq,*%K*yîp(Ó=¦A$ÌE¦Í]ShÚBÜÍ ›ÓòýT4´d–›"Ÿ¥ŒA|dÞtxõ±Î*}Io3 p¤k팼ñ¢‘,ŒóÃlpú1Š‡ASt»m Á­¿ˆg©Èë<]ä_§ ÑæEU§ÅLŽ2º¨Vù‹Pa­LìµLB:£ É¿RÊ–Å®ª—­¨ \5A5Þ+×_8ËÙÇ]YÕ‡Vau殢÷-ˆ>R±éjíÉM;íP m¨•ÇnÜRVûM£àËOÛàÁз$¸Ø¥vÏ— ¼ˆ.Ù8bVÀ0pG¿äƒ* 3¢ØTàc$>Ó6{g¬q{n/0ÙìœíLŠ†R(’ÁÇ~r‡ïätO‰Ci¥³éŸ$Þ©¬¦'ƒ8ßšTì!{²jXç™°ø°øÐja(Ñ.£$6TÖnN?ÈÝìB)‡Û|¸-Ñs“ž‡’e õ¶Äf„Ú• •eUÕ0>Š@’ëŠzSfctHÏAöh(Ôè|£ú0¥1x¹AÄ*:ô ¥ggbJÑŸùßÿŒ:_Þ„òZ1ÀÈÚC%¯†úÛS°¦„¥»@乂mê ‹Ãodí¥ø`-ZÇ¢^yßÕ>ÕýhŽDDÍ• µ)÷žZ¬=[:sÆ|\Z€8/ªº¬üòÁw«ÇÉßÎÉB8Ö^ éh·Ÿ™ìÙÑS¥38”(ËDm·š1Õ R?n[Òö¶äÎêü>­åÖEžR‰¨ÏÒÀ “!ßWÅ&¬ŽÀl#zôeÕ¾Á´odí[‰Ê uÜ¥ÂP*Û/>Ùuç•Nvþ˜“Ý@ÿËÉnàz²Kbú±'»aG!ƒ<¯ ™£J;æqul)•€¿KA|~ú¶^®N•ªöªãØ¿~=?•OÉœ=ökúÒã"js΋ÅŽ“Wa› F=ü'kpLlò¿†ˆ ,ˆ4ZçÚFóÞ3[:~rò~°ºî endstream endobj 4549 0 obj << /Length 1010 /Filter /FlateDecode >> stream xÚµX]o£8}ï¯@‘fg² Ôlì•úÉG‡Q*J§;Ú]ElB[4 dl5óë×`†ÔNèª}©]cŸ{îÇášíAÚåãÇàì|Š,c[ î5hcÃqL d@ jÁJûã2ûº…øðK_· {}šlÜì6Û|± ³Eþ½sçSïòO€dàE_/Ïô|<ºwÐÿ+øÌ(éQaÖz¡Yóf«½R«¶°véÇ@Hw"¶³ä3™ùFw*݇ùÓ‘ ?ŽÂõ:]†EÄ×wy”ñÙ*,B)‚#,1ÕÆÒ©³¯®àbDÿ|ê30ø4™K ¾Žì’Ûdxuå†ÁDiÂõç  Œvû¥Ù·8yE˜æ…ªšSÀgŠ’XJ€›¯íH[…c+Ï_ýÖy¹}ÔIÑS,i#ϵ[³q B¬Ž¨:ˆãˆ¶yç»üïËa8\\þ¡%ÊûªÇ‡‰ï{"þ$¸õç¿Õ\f‡œ¼Èý¸8ŠJPO¡IQx97SÍMè•ÀîÜ”·bv½Õ«[“$v[Ü#Öû$o¼Zó­·u£aωQX¶D©)ÔY¾Dz«Õ;ü2YŒ]ÿ¢w^l¶=éiçøék2u¿èñÇy¼Ù®£‚m¨¤‘¼†š };5SðÆjµMá[¨™š¯¡fj½ªš÷¨ö+¨™¢®j¦¸›š©£¾ìd¹âöRöܦö¶YºŒò|/x dO:|ÍìƒqâƒæDï¿DŽ}:ì-ùŸnNÓ™‹ø4¶k/udXm€ þ|yrÛÍ~ 6$‘ ̨cVÚŽKžˆ„Ä°f» äð½¿V8§fµá- @ é6AÓ2 úd ŸêšbÎI¢AÇVÁ {Iž®wªË<Ý»…%Àÿçõ\ÿ¨r>E¦F ŠM\ý¢‚mM·m{oÂi™gÿZ& endstream endobj 4563 0 obj << /Length 1918 /Filter /FlateDecode >> stream xÚµYëo9ÿž¿buÒ]à\¿í=)Ò4I©èªÓõ¡jK6 :)»´jÿú{¼°KB ýÞñŒçéŸ}Žhtq@Ãø¼ðì\‰È’Xkõo#&±ˆ´U„ õo¢w FM³%9¥öy³¥a|OÏÇ÷ÙÇûdöq–fùt–þÞîœw/Ü'¹ìê\ÒyÖi~è¿Å-FI¬âB¸á8þéµûgn¹>:tÃÉÑÉQ[»?±s¸”õg½^·‡dï¬ÿ¦×ù+|>ªW7[Â}ÿ£Ù2Å07>fÉñF±Œ.Åz;·F {úîø»ãÛï΋«—"Âê‹n¿‹ú¥õ¬2äÊYçrBÒ”mÁ¨ðói°óz:šçÃégï’ ‰Oi¦’,KÇŸFé þ,8ó»4,™fyý–tMú"õÐWÿ¶Ã¾Iú… EËKf•¢d9™qÆè0f‰P¥Ãš?ñ %¤”æ—Úq¨:hüsˆ’Á‡1Ÿ®îÇ®„¿¾r{/¯Ý‡¶OÏö1;zÈÒYŸñ#/9­FüEšŒFÓA’‡Î³t†ÔM’'õ"ØþB¹6ˆœ‡ ¾8;¹¼ìžž”#Yë¼R~Ô ÛzH®zh”ÞYäy–|-jàv8J³Úêâ+ÕÕ™rjÀi§é,r™tE~ý—ÞçaÓœô6™ò¥ÿK]¾àÉæ÷÷ >«·RW÷–Œ²éŠÝîiÉBR/¦8•Zôªû—‡æØõlp q{ºzsõúº¶JÖ‡7^Z–ϦßWLN²<™ Ò¥ßnVò8ÉÓÙ$•j™Ïæƒ|ÛX»A·÷¯—Àöâ ÁƒÜù€ÔRàÕëöÇóvçä²ýÖWTNðõ’Š¢¹îw_×s”`,ÃKX¦Å ôÒÓ$—ô!ÈX=šPk@¼çñF׈ƒþJ¥,¸–Ñä"F¯»5gýƒ/ ¸hÄ".9TFÂpÕ Æï>Ðè>‚5´lôͳŽ#¿W¢ëƒ¿.«(—’Ä1Jrý 5:Økù>tª˜hë:³¤Éiãk“©F°Ý5 ?N†ù0 ¸æä&>ApIÈòáäsã©;ïØVž×·a~çÍ#¬%*š98[üè]<µ¶_W¸Að³s­ªÌÂ.¶t\³˜H ï9×€èÀP†¥î,¾ŸM§Œþñ´p¹[ÍàYš€¯åà<Ï(ÊMxPã)W0Ûâó`:¾ŸNÒIžáºÎÎw:oÕîs¯N êa¨_‘LnVdÞ6ôä”ùðG‚€Ão1ÃñôáÒy6l²DÖÿêÎkÑW÷ܳÆ)t ¤üYú¤ Eh¼àâ¸â Àº.˜Š­·Ž%ÃsÌíÑíFH]GpÒœgÓY†à {˜ÏVnìé¬ØNÙ¬”XŸÍ]ÐÚ˜Xx,I!}ôf”ÚüZÓÆ$4 ÈB€;•U;´©1% «7´1i1ж÷ Óh"¹®ê\icÎE™ÂÍ•QMâ2»ïn»›ØÔÝ\ûÔâÑlp$ß­¹Qù„tXð×· ’¥%HÕ&·$6|+sØŽæ¨_׫9Zˆ‡têtv;‹ :øêÆ22óówX\L\Ã'šR5OH Ø•¿ÑÜ åÓE’Tº_ë„–àÈ]p«Öv—Ã\k`@IRÛM€.+÷¡Ó2"Œ¬ê,— WW€IÚ°ª+×@5å¯É'¡aªªÁ1µªÁ^ë0C dÌnH2/HÑx#PSéì>T*1[Õ€:íÎé,˜>3”ØÓ@~lžæõŸ(}SŽí/€iÄuúâðó®‰ð™§ëj®É¦8aàA5ìy‡Ð1%‰µ(H© Ù ~-¨Ú]£ø¡UEã"Wµç™êd’ãd‰Êx\P¹o“îk’áÔ¯ !clwBKÙã^rÊÆ{ÐàAš¸¢±Š!œÝߣ$m6½:‰Ø@ö RR±©j\Bp–¶#ümˆ÷”òQNÅÖ"€ŽV__À™³ÜõfÁ]§ñïÎîªâºÔåŸõJ¯ŸÈ6 ¾xð^àýtÀFž–Çœ B— aõ]~o”> stream xÚ¥X[oÛ6~ϯ2 °‹ˆáEÔe[¤Iº¹X.‹XŠ%ÇZe9£ä¬YÑÿ>R<”%6’íżˆçœçNcçÁÁÎÏ{Æw“½£÷œ;„ ˆsêLæ¡QÎ?äˆ0âLçv ¿ó¡K0ƃãbèR Ò/ñò1OÕ"¬æzsçyV< ï&$_ÖáëyrN¤ØšãùÍùÕÎuä³yAdŽÍÅP±_jö'ZÚºT2êj‘êÉ8R>xî¡0à]€¾æü]VÌòuvù±¬’l…?Õ„¸Kl¡Òý·„6’ýåc†û¶ó‘õ|ãš@äÊ‹†]B‚2IçY„.ßMG£‰^¹Ä&‘-„g§@G­tÔBw3>›ž\žŸO?^^ÿjÈ£0ð¹×áñD˜•³g”Qª%$ÊSÏGJÂUíª6bÞÎn*¨ÅQ\ø!fèü6]¥߯D%bpÜÙJ7—¹F/f÷ø7½žË³›(k«ngžɚWÑ W$x%P™s2Ùq]T™g÷"Ïe™I¡±åVt¯¶Ë<®ÒrÊðµ(¡2Ô†$-Z[ÓçlÑMò~F÷²I!o邹Q,Ú5z%V“ØÁ/M½y˜ÉŸ'³¼Ï¤¢D–?76¸qeà–éX-×Y+*iªq[¥Ê9•3þ` $Jm4†ÄÍ”É61”'¿Zùɨf¸.Ѳ+^Žƒ×oÖ¯¾u7Øy_+ dj;ö04 •µßÚ3 ‡g‹XhS1Dá×òÛ6,bPn÷gSh¶§eü”NEªZÛt_Kv}qÞ«Œ¼Dþ›VyníoØHˆPÔ¯5̤þ4×î¿TÀzúW!¨´ßÑô] Lâ©×1ÎÆ”.ñ‰Lä¼×¬y;,ʸ¹B‘È2c;áƒOë&q:ž\ßœLM[›Ôæ8”#XÄî ðÐ,FP‰‹Ž©6ìÓ‚‡Åß/!ì¢3QÜÞuè¿’CúÍÊÃÃvÌ^ÁÃxc»Koéý4µœ‹rëyfKDž××TSM1¶ó{Q÷`©›T×ÿæ=Twïº :•ú~?ó½ÃÖã£e¨g¾çÊÒ¡ç÷k“À®FÛ+…']•zŠEþè{çNiâªPYeynžJ®3aÞ#•ìøc‘ôâvn´ÖÎéºÅ‚(íÕ)´'øˆ‡½tâÿMé=ý-Ÿ³4›I{kû"ÛÜ9BÂ}„Iï©à…}‡² ë;Sô?úXnbo“‘ÁsT‘° 4måö¤ÆM|)ЮÒÁ¦£"SÍ)>heç“iíÙ.~'«år*›ÅÏõÕFó40Ü•îí¿1¨# Oýú¢ÙÛÈg\˜OÔ¡9›ìý¸T“S endstream endobj 4572 0 obj << /Length 1188 /Filter /FlateDecode >> stream xÚ­XßoÛ6~Ï_¡eØÐ1CRü¹Nkâ.;pô! U–u–dÈJ»dØÿ>J¢d›¦Ûéƒ-êÈ;ò>Þ}ä :wt>@ý|?:89§®#€dŒ8£©ƒœc‡ ‹œÑĹyCÉQ ߜݎ>:.˜K§ƒe²ñ¶ì@p欈ÏÂi”„G¦tÿª~2©Ùý¢T’Ê-Ö(pŪ±jòr%jšŽšMRÝG©^¡²zo=໢‰n=¢š¥&4T˜Vñk¿ŽÛ†s«Tì‰L/‰òÈŸEO‹ë‹Ë«ª¹ð¿ka”,r? BP½^/êÁ—½ñéàâbüy0ütVN€9.GÛÃèb Ê¥®z#µ7Ñd\¬i§i–g~â]_uWfµ‚Ä a`îgz§½Ñ²ÅcìÙ1fÈPÿ–~õ>Þ{ýÞh]Ch ¬5&ñC<_Œƒ/Âßµºj#û<îOˆçü^7æYúuÆÕKš½÷é"¯Œ±"³Èö;„‘JAéK¯S1šVö ‡ãÇH'•çUOXø^5ÿµ" òÅ…+HëekõÄز$yÒýªeôEYâ©Ÿ!ý$žúÙágÆäþÚä¾]‰kÇÿ³öŠJ÷×ÉÊõNû£O>½%Qä³›FØA·•¼Â $"Û„BìYªä NØI„‹ê%öóà¾jNÒà!“ÜÏ# e¾BÅbÈÝ>@0n¸-÷ ä¾^zúÏòŠˆ©ˆ‹ˆr@¥±"n2@³ ¨ÀÛë˜lÐôã¦ß²¿µ™u_0KÊ~;ßp¼'|§þlfäù Ïýàoÿ.l!„Mz_&²Ÿø³Çšå›“rêyšEOeôî€j¹R18Þáä$u¾¯3(w-œKìp‘}È–S«”í ½õ œ†~þmx ÆPÞ’ƒj5Jfê¦$‘áJÍL‹< æ(ÍQ§þÆóLqÒ?LJAù–… µ™áa;^âys“(;><Éãù3&äO9$Ô<=Ï¢$ŸF¯üïQr·òë¡éøM3á(¿¯ÏÊ‹º|A.I­“«•Q²zm¨7nKˆ[ñØzvè ¶ àvC{e€ –íhŽÏdšÞ©èŸ/îÛÜ¿¥ÍËáàTc;YZ뇃aÕvG×ÃþZC)ç½þùàÃ’žíÂp9ÀøkÆãÍñ-ÉõFhl^í¼UŒnÛ‹0ËÒlíöТ ›(G…³še_—"Ò’"J‚° úÝǤ=[%zîf#±-feë –[ÙSKGaG‰Ÿ‡[2$¢ @D7 ×' _§GHq‰ái¹Ôwûö"BÒ}’L2«ÔZµIa•ÚXó—2ÂÌ(èTÄš:‚u,Th¯¬õi±{9(ÕѶK5H)€L˜¡åE]¯dç’A¼iÄ( kq{eˆ »iåÅêA¢µÌPÒ&Z£ AºçfZKÄâ[ÇKå!¡SºCyØTkënj«WñšºÛu^Ç»ñÂk¼j¯¦ç’Ñš¯M'ç;H†Yù©‰EQÙ¨[)Ѫ®©tGÿèH¨Î endstream endobj 4576 0 obj << /Length 893 /Filter /FlateDecode >> stream xÚÕXíoš@ÿÞ¿‚™l™K=ïn›ûÐÖ6mVmýÔ6†)¶l °[³ìp€ˆZg“í ÇÝórÏë/@í^ƒÚÙL×#ó }ʈfÁ9Õ̉†(D ‚4s¬Ý¼EP4ïÌ‹H¤… L¤Ç6[Bø¶©(2"ÀxÊò.!DB:× Ç=¯Ùâ‘œ·ç‹0H˜˜HWI3@tQ”–·µ&@'¬lJmrÆÃÀz´ÁùqÏü| DÑuZ胼{ŽsºÒW\¥—lÐK:¬PKÔÇtÇÈ^^_^}‘†øvz¾-7Û ÙÆsŽ„–;²A¢“¨V§ÃPd  QvƒeA›ÈKâxÌžœ±Üu:r…q„äë/u8x³EqDžûŽNb-Ab¼ãÞKÁ‚ã™'ÙN®¯¹þpÂù6÷í‰ó3£‚[D¨Û8\1ÀÈ Ð#¶bvãÇpìø‡«IOŽ¥ÞاŠœiT~«É"%¡?š?ÅÎFêÓ\o8lŒ’]JjT߈áF•±/v8›×©)ôV&üÍûÚ1*س–ϳy0Å÷¾YÊÖ\Du“ÅØq'Þý ¼û¸±l0]/›$ËK¥WƒþqZ㥺î`ÐÈ×A×¼ôÞ§‘pxÞ;íŸ-%—Ž' ¥GÎ×ùKå–ÎÒr‹{¥Tb™ûÊctWÔ¬‰lß÷ü´åR’Ȫëy¡&lö4Èšêïú뉉®BñÑI¿×ÍcéÖU£¨m#Õ<2ªÉH}ŒS©¢‡¯’ˆmrŠ1ûØšN¥âðÁ^C³¹5únÝoƒÜKƒoú˜´W æº:ÛË ¥€@£ìݘ¶žü8*(_q~Õ³MåAx}yèj,#êV Æ®XFÄ^°ŒÂõ¨u>ýë@FÑ ÅÛY.A^È(ÝQV[©”«õáæÄžÚ¡”'Ž}ê½åŽKÄ~V[gjTFßÛOˆœŽP©±¨±T¡B5"μÇVb‹^lJ ƒµiaÃP‹T¨Ûybû™†ý„½Ä(Äøs„í{ÊêŸícbõ£‡êc´#‚˜¶?s\+´K0Qó=‰t ¢ |Zt„Ë&cuÓ]ô†ÝÞ‰::œlÙyù‘ö)Ú‚cžüáÄã… Bü冢H×<ømÄL# endstream endobj 4580 0 obj << /Length 349 /Filter /FlateDecode >> stream xÚ…R]OÂ0}çWT–°Ú»®]§áA1š0Ÿ€ÜŠ4Îx@ã·[;üàçÓõôÜ{NvzAݵˆÃ›¤uÑg s¢dŽ LcŠ¸`( $CãðÐóAÒùô¦Éƒ‘ú@pÌâ†f‡¯¹S©¹çsƒÂÈÛVeö«×³HÌ5ØãÇá9‘çSògΙԺÔÿJ…燡—Zëy%lÊ|³Veaujeñò{ô¹ÀÙ•®>W[&@âݵ¯ôb5&Ón0­Ø«ÃÛcgüÓÊd¾’§ÜFdßíµóYǵÇÅÌy.Ót£eæL-s9kæ§ ™¾î Ó2s¼–ë.¤ûÏ[‹ƒÇÁp„mÒã©"Ø¥úI‹†Nv%¢M)Œ1W·}xÿÔWÅ,Wﲊ~ÂASGÃÕèÈ[féÚÍ®ø¦õŠMë^·ž‡˜ä30í"'…à—æ6i}ãÆ endstream endobj 4584 0 obj << /Length 1706 /Filter /FlateDecode >> stream xÚ•XMsÛ6½çWèÖxF¢DÊR­ÜdÙî$±]W–3“I3„DŒI€@Ûê¯ï’\€†’ôD ‹÷v˜ öƒÉàw|žoÞ¯f³AxLOçÑ`³„Ñ,ˆfÓÁül„Óp°‰ßÞ‡ÑÉ(œL&ï¯9eB³“ï›OΈ}‚¥éà,XÌ秕¡Iðû|0Š&A4]ÔfV2?(¾OÌÉhÆÂÅ"„þ(¬?W—ë«åê~ˆ_·kûzy{_¿\¤À¶·wõËF©,4³íBq2,ýŸÀç`1ÃÉoŠ,×8†ÑDÈTî9Ó8îAðg¦47‡ú[îêç¹T1#Åk`MFa°Ïj“›„£Åj¬ݱ77wè¹ý/Wò™Ç,®¿Œ¬ŸYÔ/;ÅX×MˆÚ³gœ5ÏKÑÖv!b¦pš®ØêãõõhU¥ —}SOfm]‰%Û‘_Ây5CçNµ:‰ˆ}Öcrýa<¦Œò4 ¸ØÉqå ez|]¿<öfLL–‚W¡—ZöJYŽØì$®ú™@$£»x.o.°xU\ìO«—׊´ÇÍúávµÜ\^<®×­}s–£Ÿ-Ø;%³Ö×Ë»åê3²NèÙ[8¹6Šo ãaêü½›ŽhJŠ9u–·êÇS #`ª·b"È£]¬®zëMÕ#•ŠWGÁu¿zQvëe¯†)AÒž}™È ÛÜýîÏõE/-<ósÌ*R?4ˉ"Æ©5Rú;¸”Íãõåòâæ²çþuË2UFJ‡K4¼)ÿÕ¦*%Ö/ú$äKÊâ}‹’B»U*¶cªŠíúû[ø½‡Ñ·è{9_P*E'¥®xp±ü'B0s° ÄFS΄á;Nñïb ‘T­±d9ƒPHq‘ÛçRáW‹ÆÖqUë®’¥Æ¢B4ÄÅ6µá3“gYØèµÒ($¸|èÙ'…I¤ÒÿÇ—nN´0kP¨ùžÓ³.厰;\Пˌi#vçÁÖ{|^»v}¦ÏR›êûaTõŽ¾â׿]B’¥)0ô¥þ÷HSĄ胠‰’öÀº%+R€ ZŒÍ:-Óg;m+0ßQ|$ƒððÀªiÂâ"…±¸¤ûË\Ö$8†Ì Ó¯ô´ÜEý2Ï-òÚ+<_$¦8é-EˆßyŽß³ÑiØ$€M`H¶_as‰­ç…1°‘8"}Tõ¶ ,êà]ØS•Ð€&ô†jJR²åé›2Ä…ó6•ô ¥[¾ŒOÚ=“îH©“üßVÂÛg5´ÜÐEn@V ÅüÌ,WÈýæ×`¸äðM$¬ÔRjCã^îÌ QìÇ\ŸÎl:i]0?ÝÑ(?Dó6ãᢒÐÒôèm /ug¡²ˆ°‘˜®Ú4 CA¯õ‘N OJÇ}« ·7–BåëÍèLÆNß ¬Éͺe@»<Ýöõ+‚¡ÓX«¢ÄrÚ­;¥ùð°ðÂMÒ*åwÓy¥”-çm —šáßt[¦‡ø¿û-‘©+xÚñí+ì`”™Ý±j`‡Çç/*Ö ,kÃRnõˆ„Øž €ºÑ.Ñ3{Ê1½BòQô÷H—Òføv×TcÊMØf‰+ò"ŽD›âúÉŽÖZRNŽ¸Û°—J×R]-±Ò|ûQ\»ðÛb(fÏ,•¹ë³íŠAøÄuGزü‰Ò‡nm’6gAÜfN eS¬hCLÑ+l›Ã’þ‘´˜„àA—2Vo•¶—›.'TfõÕ?­pó¼H¡£Š-sucª¥ß(wNmK_ôOÐbª9nôc.ÄOØ+4ó²îŒ}ºŒîÊ\)ksœÒÃ1ÌÅÊAO%…«\\¹‹û܃GošEú²Z€+(ÊzÀ–aÛSB{òOTFÜtöLâ0Ûk7œ+ÿ©ùŸsGE =1omm¬,W;9€Z(߆Í/}€ª/ÓGÎVMöCºxl]m¬a+n AÉ\ í™`Š@M8ìpÕvë8ÆšÃÙÎ[ÍIÆüˆx‘¶x¹1ASe9bç±Aï®AZÛĽ0¶Ø…CCÜ"À&¦Ðcê'Ä«›½ãÛ›’ËkÒ‹SÏ"hs\vªI”é ™þ½ÛïËN§Á$œâµÛ¯ÝVê$<{UÑ¿rõ6é^»ýú5UbÝ2&ºÓ«=ˆ£<0ÖÓäî^ïâ®í9x àq4¯. ÏÀßh0šNƒé|†«‡å·‡\nÞýêÔ±b endstream endobj 4588 0 obj << /Length 2820 /Filter /FlateDecode >> stream xÚ•Y[wÚº~ï¯ÈÚ/…µŠkù†7JHKvH³€¶k¯v?(¶:±-ŽlçÒ_ft1`Ü´ç%Y×ÑÌ7ߌ„{væž}|ãšòÃúÍûËÐ?‹$Š‚³õæŒx¡ãAK‡ñÉÙ:;û>˜ßÜ®¸¡;»YÍfóOX'£ùr¾~7E®;˜—’SS_4Å®ÒÕ5K·¥ÈÅ=g¦…–™®|)ù#“¯_ô·Øèòƒ£Íóùðßõˆ8"®“„‰cV´lX®‡Nî›<f×[ZKž>˜ž‚Uµx±Ñº˜Y_²B”™éšäÉ2aºšº¦’Û·<ç»ë“c*Š;VµËKn¿h$ݯÝH–sª?.Ù£d¶ã.®~l˜,D“nmßdžç9m ³à•¨r^¾ë“ኦFð¿EU3iV¸b´ýóh~ývöœ²%¨uêÏË ÓÃY.vÕÍѺü_1õ-͘¼²t¬¯Ù‰´4<<˲—=ËŽÔí4+x‰ÒÒšÛQv—^⩘l°©¬ËÙ©ÆÔå¹ÙýŽVÖ4íîÊŸ_µÐµÀÝ[¸=Z+ü¥deº5è¼Y¶cë²È¬‘ xÚb©(š4û®&\ÞYc~”¢ÙæßZ7®±Ô9ßÌV¦>»¸´µÅǶq5?XÅÒõ¥ Þ×n®muµžþŸ F©P¤a8¹\NnÚÅz6ýd¿`\në¹Øʵ¨i~ŠnªU³Û ¹wšÃí¿øÊ)Nä×ðœ,'×ד¿o-±l *AÓ1ÙíÀ,†®) ›Ö"B8­ø’UŒJk~𸴩*ÀpÕ Yw™$eã„…&/7ybY—Dž„|èÅç%/inç?ý_`åeUóº©_ÐûÈ3+MSVUݵÑl=šÙAª´žÛ ˜n!îTç¨ ,ëÍKPb¡H·Ü(ï·ÉLkþvVVŒß—Q}Õìä\M¯E•G`Ô´2[^N¦Ö¦“ëÅüV×qô_ÇrA*ÕXÊ£m²òLiž6ù_F8‘cgV·æM!–éý{$¼d@œTwý"Ê’òªw']ÿDÆG· ¯òRÖomO3Ód•šßw*cuŸ$™¿K°°hdj¿m¸9µÒ*å°(ßì[P…ó‹åüPá×ô iÑfL>°œ½tìÜCy{·{wì‡'vÈßžÊfÏk@È«‚õ\PZ.°¡¼ ®Aá ?ˆ<¼d>qbo¬%[² DðX*}kïP0Ó;¸@Nûà±®ãùFÏßÉ¿G3ξÂ0Ì rÂUË\d¬ñÁZaè$žsÔ2ŸKhwÆÊ禉Í(:òÇÓx9‡à´ DþÓ  7Á€ŠÝ×T ¾×ÎX×âge¾ê.¥OÙ9œG<‡D­DpìÁ]颕 "­F}8I2>âÅj×ô¢@uˆãmß,¹ÙþÍšë‹×Èw‰ã'É1nT/˜+Ï\Ç Nvp ‰±hû4e¨=4Œ°Dß{§«7bHÂÁã0 Žnñ\7vŽ 7òÇaaDÊØš×ë5ïí¢Tä…ƒ¥*#s5Em¿˜"×té,GªÜA1.ŽGVQ­-±bkÑäàƒR©ˆŠ-p'ž`U2fºŠTXiÊêò4¬^°‚Ñàj9cpnHè~ÔIîËt0£Y,ÜÊaDÊX¹(ìD¡KY¬°ÞêÚ·aâ „Ì3ý9彆qòÛé¥. ëüp]/µÃ‹]S+|ƒý‚ˆÀ"ƒÌC¥Á8@y9V0°s“뎌Èǹ éHÒÊ@a¾˜ }`à•þLƦˆ 6èq :sýت '€ÿ.~ˆÈ@†õ¾û¯ãÇó<…,;øÁ¼x0µ½Õ6•tS›æϦùƒàµ¾_aëĶ¶ïØzåŒþ/±^£yŽp”Ò*vÛ¿ cà}ËV”"‡¡‚µ¬[˜•W¡YN°eŽ æÀ€Ó­Èn¢nÒº‘–•®*TAyøAÊÅ@ý4’*éÁNÉv˜ž•$U½Û8a àÕ|²ÐS¯p-ˆ‡¥HáÐíàPÊ,Ñ}Úéûá)Rüĉ÷[ øc ¢>Ðó Bò@ •qðÎ2(®ƒ$ˆ ^â)ø \_É ú€D| è=À´az{°£46 {=v(¾1YJ\Â\Â@¸AÞyV7LìT¡j?¤ÑvV[;/Ñοb«cD¡7xÐà؇$tÆãø8ùØ cªÛ¡%lyÍôÄqtmŸ ícû1qµíÇ»·ý ‹x\Ãn †’H‡¡Ä„!àY €Å |O쀭‡ÀÞS¾v[`ýL rXÝßNZ¥4§w‚ÛŠ:šëÀUXÝ?ã؈àhÎlýæ¡aåï endstream endobj 4593 0 obj << /Length 3637 /Filter /FlateDecode >> stream xÚÍZ[wÛ6~ï¯ð[¨s".q#Á¼)¶77»Í‰’vw›>Ðlñ„"½$ÕÔýõ; xe»OÝ ß̇™¡¢³»³èìÍѤ}ýù‡üSñ3¦q,Ï>ßž1ž†‰ˆÏb­B&ØÙçíÙ¯Á¯éo‹ß>¿ï†ýºT*>.cA¸XÊ8 >Q»Ú›¦­, ± ^.–Šñàõ®©½8Ü.¸ nm·²rëäïÃå¿ð ~Ö«Eʃ—lLQ˜²)‹®E›ßÖUÙf…Slªâ÷S©'øž·»¼t×íθ‹8ÝêÓjýÓ¾ÐS¡„—…IÃT¥îeM¹Qð{³ïÝ’"bÁ;˜Šs¼]ûÁŽOâP%â, #©Üè¯c¶k…2ÕØt}Ù]ÓÖn]²$ã*ò㙎ÆUû—¸¨†Ýq‹_TåÝBY]g¶' .©ç²Ø×U»#}»­(öYè(ÈÜ#ˆ4Œ…?C,ý3pÅFÏД¹Aľ7ßršÝl󶪛—8¬H¬(–!“lÅŽ]Ýß¹¡Gùh¡F¬2À´p ò4 #0·çÕþþÐæð®`M°¨ˆSD0B" ^¤šÖZp¢á©…_›†]™M{¨Á „TÁUkw‰"dLK™ÚIכܔCc¬B'fJ2’Ýgw~Šä+ç1ó¯M]ä%Ý°4Õ¡{AzªÑû­ïkx9X”GÁògëL0:» Çζdi˜20 &­µ9—dÑã>ÉSç“iMš´Ö¤5ðIìvÆ“Ž}õŽ}R¦èZˆh ˜ÚæðÐ"•§ÌK¦ÉȼL‘7Y›W¥[bkÜÒEæîoñÙ³ ˜Û@ ØáËPû¬­ó cWa°ùi¢Ç{¾©Í¡Aè¤AY•ËæaoÕc¾§ŸwìÊúïÁÏs_j¼’ð$$ÊêÍ.oÕ¹çaàô1OÆd!â“dáæÙ{ž’=ûáöUŽ¶Žã·9pN~ƒ&v°ú (+RÏÆÅ„3îo’*ïbçY±9Yk`&Ú€±Ÿ;¶äa ö‹óÃtÇ; ùÙ ËHxõPq>ò“{x¦ñ„×Ñl4ac²Ã`)*ü\»~hZ7Pž~ö£ífïž‚Ç!ãêÙÏqŸÕmÞÌP—aéuá,úbðÃ^©(E¶Q<òža†tÁ!zÊìq¾€M¶|í _ÄÒò…Üòj ùº-_`ÿ/Pï˜/à&G8Ž»·ìa 7jh¸­Ù:!8ë]oãFà’Ö=Áa’8 Ú#»ãt&a;ä0èqtÏp˜¤“ »fÆÁj­™…΂ûð(Tvöã£QI mg!8‡®ºÝ…%Ib»»àçq¬ÎD¨#cÉfP€$5°l 6g óáìQÙ ìs«‰XÉc&Á„†èâÈ&,qkç<¶Dtεì-B1‘‚(2ö&Á½I¨'¨HiGE*™£"­ÖšÚ!A÷…ŸäÿI"¹€ì5õä$ŠI«ƒÑ P, ð× P=nŸ½ÉŠ;È[ÚÝž&ÀRÊßÓj×áIº²Á…U±­³ÂboÓ~[ÏðžBۂ팧€ª›"u¥Ü–ì‚'©BAž\ŒæÓxÀµUS‘Ô¹½¶çÔ^U÷¦±Jì±Â“2=ã¼ÍïvþÍÁ5M gú>ƒÔœøL§xóS|¶,¡(€i’[µç0ôQžïË ¿ý|yN†Ñ\qÁŠ cÃêŒ*ûCË(iƒÝÖ íkе0›ÆÝy•®üàWZdìÈ]MŠêÖõ\N 8£HôTY¡ ôó¢‚ø v¦ª÷U?x¯‰ÙAôG o¦ÞW‡ÍÎÙÏ8KàÇ•>îì‰ ‡Öâ‚)ƒúÛ‡›:'…¦Þœ×á½Åûâ^tùÅÉh²*DçÊíØ”&«)‡€tÑìgÃÄ4 EÒÏGU®'y5‰ÂXÄSZå=­2ÛJ“Š{ ã# 5ä üÉä RRGªÐÎ*Ÿp 5Àñq˜†Sú0ûì„¿àHR¸¦vo—Wٷݶ#Z%¡·ÚbQÐa®óË“hú_émMiã2¸ü†¯fêÒXCÁ !_7åf¡Xu •ý¸Ü ’.ÒÃë.ñ°åi®‘ág8€Fp>¦6‚ÚœöIjrÔSjиãÝ€ÕzvsJp,Kwµt cíÎ]½+ŽÊÁ” V)oKZÆÓ^l…r5'ĈÆÙøO”ì@XzW•dÀ_Ö«—>6 2vã͵Ëagñ@}HᣋO·ÿ÷¼±5fd@Sçú;ç‹÷†ªS3eÎC!§ùù€bÁç¬ëŃW¥é’Ã9z”¦ëY׳õz aÊ-¤nG€¢þCâ×YN’s/ÉàªÛ—6Di‘m¾lIþžäf¿7ÅH¨§_ †±Àá¼®þ$ኄojcÊ›ì°yÒÅìcD"x›í÷Ö½íÈõ¡ãzóc/S–¢î`ðŸ|Pç‚t× —–³9x"C-»c÷jåÌئâÜð/ üÂÝ¿9äÛ¹äZ³0N:¬)(¢(†}¬Mcãƃ»¼È€ƒîwyöÒgPq¨Ø¤¦ì¾*‘i´»¼&ÃÃ8'ï¬$õ¼swþk›%K —UW:·M€)Œy‡9˜2Ñ-×”˜S4Ìûh“aØ­5p—ãèëª)píO=+w§ž»ÁïjÇê7`‡¶p“Õ´°©ëŠØ|Ï9cz:S¹¦ÛVâú²’êâNW Ë7™«ÄÌÅo2Œ’ù+³±ÍgYÚ—X!›úz$ÂKå#àøü' âUÆ°:m¬¤åç»*'ÑÊ‹ Á{ v\RÇÅ‹ÕŸö{œ;y¶Õd®ÎPøÎ epö\X{©iáQO{ºHƒ7¾Ã”uŸ˜GŽ@þÑ´yk£Ôþ@Òu›•Å˜`ÌõÒWJH®è°ÆcƒtРô‰”Ïý ]6˜q¶‚Øó¤û2¸ÞdG<ó x„b7jtœ"ˆÁÓ¾Fƒ.‡dÝvG.Ž’©YIj!¦V5_¸·Ü­y×NØ=e}Ï[0&âxxãwÔeaÕãÒoê7YS1ôzØíwy0PŸÓºþ8I_ÁË& ³c4ö‹¦ú®ÖZ8‘p¯³&ߜ΀Ñ7,jnêŒÎøÃÍ}]ÝÕÙ|8Î~qGU[:_µÍ dk—{ªd+CvT)cñ+[ßgIúqy?…¡üˆKø#¨'Ôé©î4êºG þZªÉu_ÊïúµG‘€ÐFÀkž&[9¯ x} ¼vÀëg/’¸oÀƒÍ)L÷˜(¸Î|_,¡R]eî,Ûl1Gµ¢Ç,‡c¬‘ÎÔûa܉z?Ì]•D4zô.Ùœ´ãˆÏX“-¬qýˆ918šgSsš¯ð[‹àÌ!ÎûOzxÇýßGˆI ý€‘xÕ`¡Â¥ih6Ÿm~ ê[Óäw¥Óì†êµö€=Þ€'wy:t@€¾§äo ÌžupGÃû¢*ôµµÝÒyvg•SÖä“y³àµÿ·Àì×À(äQ<.¶ÿ-¡ úb»Ö¶Ò“F¬Çÿ84„ðdŠ¿> stream xÚÅZ[w›H~÷¯ÐÛ s înº¹äM¾$VÖJ¼’2»{2ó€%lq‚@Ã%‰óë·ª«A€°Çg_öE4})讯ª¾*Ä&O6ùpÆ×ËõÙÅ{%&zžœ¬'\(G(wâÊá.Ÿ¬·“¯ÖWü9ýsý±]7ùj+åY3gj‹ ´ÞãàÄõŸó s˜T´îæzzÈfŽ }¼´cñ÷">‡åah}tìÿL¹-#în ë·›Ÿ›8Mã¬2³¢l‹ f­Ì´û"Jã ndàY«M’F4@3¡±˜M9çÖúnvIK“¬Š‹Ç)gV´‰KšTåfò—ÅýÊH[O}fÅ›]–l¢”vÀ=G„ ®Ì UH{XƇ¼¨`¹Öri«€{ø²Â·æŸ–ó™nsëc”94G0æa3 ¬YZæÔqTÄ[š•Ô{óius3¿]ãQØóå|MÃEç‰ëåÅúnusÁ¼ ÆÍjØ9¾-ë¿çÝüÆ;.‡ör‰¯cãõTkóÐ yWé„R6_F€'­u\ìóz³‹µ4UÐU’|5áNè ƒ XdÎÕñŽ—v즪·1‰+ºæ‡*Ù'eT%y†=ÊÚÖ4²É÷¸¥x@¡ž½–Ë}äà]8©ÍP¼Ï“bêú–yð6ÊJj¥'ðD’ë)G‰ðÍb«]¾¤CTL¹²¢”¥„ÃÀÀz’ºö2”6bàlô×eŽ„}M?F›*/Ž'zÖg ×}T ¡î6´Ûº„RXÏ ðÀ‘žMk© d×cÖýîšW»¸LÊsý2t n•:Õ­žÖm3v³ÉSó>Ÿòb57«ú —øÌñE߇tOwèCŠ$®‹¸¿Ï»ç<;§æÇ:}¦@]q.”ïpÏÝe/]¸ ã½4¾='N ¹ÖUž•UQoª${¢u{€^ñlï“ þËt»V OØÖ¤t˜õ˜fzVÉc‘g•qL­µvP°×¸+ÇLÑUN ¼F±³©Ë¬«Ñzª”EÍJÀ È€¥Ò"ÍŽ´W$½åÕÈXÎŽ<épнyœQ‹+þ`Šqøáï¸ÿ‡ž+Î[=ø#[t‡jâ/ªIª®š@°bª§©äHŒÁYZ›z½™ö¥ŠŠ-´9ãšïp,4?Òµˆób 8D½éþŒTì ýöE/k®«^}"ež~GĪgL¥>w7hÎø~@tk^Á䇞º‡Hå…ÐH'«³Ž$ú$Ž’€>½Ò›ºž¯Öïè•ft)Á'DÚB`SÛNò€Áª®ºÀ™€‰2¦6XmŒLI÷µ¬ï1¦™°äC4ÀD•ÏpH!i’Azl ô¹„Lo”×r†ÎÅÿÿ["MÂ&¦9“d¯P&„Žç Ë{ÁðñY8̺5h»Kj„÷­õÎèª 'çš0W0WH3šÔ¦TE¬=ªËÈ~ázÔ"·L¡Ê_zÕ¨‰*å¿=‰Õ|¶ I1äæu‘é#q¹y„þ?©o˜‡ ÏN($(®òú  Û3œ)èˆ4xª;L •ÂAdäÜoÒ ˆêl¨‹€i Táªb=õ¥¶U ±À`§Þ¸ÿRü–.^¦9ñ<\:ËØË(ûFbö'qç ñÄpFĈÀ4•ºæºI?“ Ÿßð·Àoø•¶ l5¥OŽÃ¥wÑår~NcCÀ,B(ÉQo¯î4Ü’;2}Ø]bÖÕ?Iùó£‹õßFÖÇ«™+ ÖV–G ô´MÕX J¡‰Ipsm„¾MgB²±@h”œ¯‹;4º)ӃơGpðmÊnò3'˜ ¨%§ÄèhÝØ<Ï‘~‡³Ûž2Õ<”ß­æÙ.ÄQßøß9l3©êŠjXŸ´ÿÕ@`ÒºÏÓçJcã¯:¦ Û˜†ÆërOa¤Šœ­t}GÈD‰!(Káºfv³|3fSxÙ«-¯:p„9TØ>ï¿Mò·¾½¸Çˆ9»`òiÂ["Ù+^¾5\~™×ã0Á ¢5´&Ã&’õý´Iʲ¦ô†S0†¾Ã€ìò‘(ó»AÚÈhc&Û({ªÓÈÐ. dVSŽ>¯ÍZ× ¬IµÃ–ßÇŒ@2¶«ì¡Ç“íxÙžzdî9Ù@Ä´QÃUa]0ÔAÜ Ñ¥-‹†úè2Œ’žÚÛÛçÍk©×¸öÇ‹‹×aoY'¿4t©¬=V©7` Œj·7HÍéÿUCÜ}(¢Ê˜ÇC®OZEŽàÿQšõúp~ÛHë}fz1SÕM¥á]MEß¼ËéG«±¤kÙý4õ Ä^Ìî?_0~!=ýôÆwô°Ü| 0_°ÔÇ/Xxg¸õrv7òÑivg¯—6Š±™+ߦ ñ2–®µÚìêôW¬]wãsôqjöZlñu¤Ô‰)Ì®Àš4ÀÍ&¯¤7¼Ó4® —*ßÛõnÉpi~°·$:£ž–,C{ß°Z”Ô–„õÈËÕø1]Î×£ÕafM"‹%tFilÀtº|§§©þñº.˜þÉñŽ®Ú,çÂ\O #Å+¬ ¶¤eÕØ®ó]¢9º¡ÏÐÐåsl4ž‰î¨`'¬”2³¦”¥'v<•žÒæ¢É *F·… 8(Y힊Äà«TVµi¯ùžÖuëz&EöüUS‘u>‡„Iž|[s®¦äU£ºÙÑ$GëJ×ñÆy¥nr‡Ÿ|9‘ãe¥õ/ý)BtáF¿ã¡Ú™GÃ\àp®^)Ï€¸NøÑ÷…z>E:œ¥õ ¼®ìüÑÞäǯ±Þr ÜuEtð$‘ DúN؃›>`(¡ƒXÑQAø-ˆFªLíÃŽ>epÔ'ê3ô;!%CN„<œ°5¯3̆@ÒìÐÔðp"}hJ²ôR½Ýð¬®Ã>áYâÈó);2©ðB…osÞãU2ô(nX«,)ðq˜§º†€‡aë|pÊgðƃáÛº,í»œ,(=¦(8÷–b™~ÓZï>‡B,ÿhf^ç€8—¢º ¾T†­Ž÷ów´NW[PЕÎÉ+ƒ-¬’ƒ€]Æ19ßØ÷ ÈÔÀ-P5+Tú HÛ‹¸lòí«hþê©IQYF˸ªÊc©ã䋪RŽt‡¥9^uºÂü £Ï2NʇxÓœçË!À÷Ú³šï•â"2HwjÒØ«ËdÔñðŒWð±þCva Àë ïÁz¡^q,²àmšÿ°Méï[ë÷ƒAƒÔr0>;Ϊ+Lpr\¨¿û_%¥GǪÅÑÆQ‰½âÑc°ƒ¢~?0> stream xÚÕY]oTG }ß_1ð2wÆã±ÇR„ÄGC©h‹HÚÒ°ªPÑ.Z‰þûßÍ¢ ¹!›¦ÊÄ÷æÌØ>öØž®¥„¸,þ³#ÿ)!—悆ÜØ…¨ŒP ¤Žå 9˜s(07 œy†7jóåØTÀøµ’ú‹T‹ -Xòmj 9%WÁЕ¸B 9‹K5Äwl¾{-!KÉþŽCVq«j…£Ê*Rv]UåÑ­ ãIÇ]`='7˨·_8ˆ¹”á[NÐ!Ø¥ñˆÃZƒ‹¬¡ j(‰\™Âõ,n œ*T}/%¹QÐX˜FIC©y\ÁªA…hS_Ñ°‹ª›¬-”6âö³1 v'„õä°†-3¹qnNMwîa”KxääNp Óe€hæ‹s1'Ê3y„ªKÐ&ð¨y ((W¤8,„ÖQà­VßBMÉ}Çf5™ÿÖj¨™ÝcHÍÃgSà øÂB]Ê€ð•…ñžn$ÏÄ4 7ÔCã‚n Ô!•À¢Æ Å½skíx£ÐÙ|}ÊÃÀcëªe› öy:ÈIyôÁ‚dO*<!‚7„`ž€:$œ[ó ²SáäY 4R^ùÃî0P*Ò¸8â*Ù âG‰àxÐi! ÚýxˆªiäYŒì¯qR²yìü?ÿÖfÓp‚`6œÛ—aøí÷?üøÄ‚]ÏC_̆ÃåbÂpˆ2ÆvŽ;DʳåíÎ$ýü'ÕÎw?Ì~¸­mŸP ÁŸ`Òðbµ<;š¯Ã ìxr†ãù§uøìÛñ?ïçnà_ó _¬ç‹õ¯ÄÕ×φ—óË«³ù‡Måßý<óöôÑòS8qkܪÑk(:]a5L¡Ñä]ö¼|fä9Õ~p.Ñ|¸ ?&x{Û4_Ÿ=›`O÷`¯]ÉÞ¾|Ü4R.S ùû(.Kìv²Üžq 8ÊVà­P·‚lÝ m+ع ¿ðcÔ8Ž>þ¹ŸŸ¿]ü=-Woæ«ÑÚôzøqx6<>Éãƒ;xjЖ#z9ºxFE@'¦Ñ ðl‘sîáHôQž.—q½÷Ó¯î;Á7b@®È 0Q¸EÆ0E %ÊÇ”ª0D' xöø—ãç¯î½ºs†”š¢O …¡˜}Âièß6äF™À[óf(PˆaÏPÿ1U±DÌ°ÿ½þRÐú0Q–Ò"!åKEKÁ pk`2Œ><`^A©(>FóG¡| àøäRR‰©0.ZlÕe< ÝBü(Ôr”Ñq>…úà Ì·@@-ÑÇKj%²øàNH½=<1 btÆaÄ@XšB1D‚ä[Õ ðÅj06 ¡ÿ« ‡àQögD'ºQíëFu£ü"Ò9Îìïì8£t™=M×gOógT&(à=(¨wŽ‚–&(h{P`w¾LA£ëSÐJgÙ~«Œ|Ñü½Ü™¢ÓÚײ×ÚËõ0cŒ'¸VÐЙì*ôç+è¶$½hüÜûÐ$ˆz÷ÞD-f¦^tÂà˜J': æÙÔkIf\Œ¤×Ë웾àûF‹Á…Ôýʇ•k§®MÜ}­óî[M/¥®Qgêî¯.“h\§ƒ:‰ÆM#§Ú‰ÆñŒÚ‰®i¼½t¢qµ¨S_''ÑÜZìv’9ÅÚM7gŽÖ¬]DcíeÄ¿îN—•ItªQ’v¢ýb ©—mb”Cë;%Eöz™qió¿´t¢ýrÝkvÆEØ¿“v¢"ùEÅÚ·Ýp¥‘41“YÛ£ÒXo¥±ïª4Sèj‘ÔzѥĢҋFÆùÈ>tõϽ[WÆ•zÍ®¹¡£öî–­›@žì¦“Hï½­í½wúN K3œ’^>JåHÜËGÉËtð©?ôÂX{ÑÂ1ïþYè_!:` endstream endobj 4632 0 obj << /Length1 1408 /Length2 1444 /Length3 0 /Length 2344 /Filter /FlateDecode >> stream xÚT 8TëÞÕSiº£\Êñ똋Á42n%×]´Ì¬1+c­iÖša’ urI’Úm*G©èê¡E6Ê&¹$µ‹JŠDIÚºè¬aÔ®sžçœgžgÍú¿ïýnÿ÷¾ËÈÀ‹gÆ`°3†f *Üíy~l@§3©tº9ÅÈÈ!Äð˜b´–â†rþ‚pÂAÚ!‚ºc(X)0¬8 ‡Næt:{ ˆI9À’#àN+1Æ)F˜D!E‚DYgì˜ð›Í2 ÜXŠð!¸C„!+ò!1àa|&ߥ0±„„C£…††R¡œŠIƒl™‚P„Õ0Kå°(GP¬J1Þ"uð0! Ia@ÄFq2D† `) «ž‹ð”Àè(Øm` T—TÆ×tªhe" †ø|,D¡  BD Og7*F˜(ÇÈxH!b(Œ´gî*‘ªæÃùRDBàT+g¤)Ó×ì„ °%pŠ²?GD óÉ{WÐTË F±P4|ì$DPP9†@&¡ù Èìâ¨Â&Ê7[LK:ÛÊÊÒ À[ÆÑ”¼xÄÉPšÉ"Â%˜É1àD“”p’ÀÊàˆð¿:¾?Q @ø„ƒ”ò-;i†…£grÿR$ ¬£“ôcºò÷õmÉ0†Šßà#+¦ùsWøòœ«Fþê´·ÇÂ@¸™9 ˜±™,’³,XÂd‚ˆïóxAˆªú·XTˆöh»ä=µ,WqÀD%Eàû\É\˜|#úzº%O>ÿ7ÝGBþË•Yþ'ÑìÈY&øMFÿá‡B±B… ™+#H¸c¤Ð¡¾ð¨tí1±àGŸ ‘Zà¢A$ŸÍT:ÓrÔàÎH,ðB¾h”4£v¥ÜÄ {a8¢üÀatú>Rcü`ò#‚“ÌqÁ¤„¾/ì„ò1Rkæ$o!©RPè$¡Ì--A8ƒ¥á2 QQŒ C9bbRŠr¯ º9 J!>,†…„Ò§23UæÑ-*íßÕåˤRRƒ#ü ›;†Ã`>¥õ.Æ_ºksÞ®«æpç…š=«3·˜^Ù7 æÛá¤#¾*ÊÁzè-3#þ÷zSgüP»úKó¬/…ÁkçÒƒ7¶mK‰çÌmÍ¿:QøÔt[½ºÍ‡—¸›Ì¼ÓõÚ5ÿMLT4·¯huuè€]ã"-Ó-ož5íZn½°èâû ¢¾ÉÆ—{¨ÓÆ×%ÄOÖ^²„9mü®îÑ’‹ö¹ÜƦRC¼ß®îU²žs×PÊo5æ–O*ïŸ5‡\¶eZô¥¤¡CÜþ|¾^ükãç¥3ÌõY0׸¯¶áq×pOmÙ佌ôÄ4¯ÔžÆ”ZãúŽ¡vŠ›QØk¼¼ýöË6Ã@_ÅÜÅ**ÿÌúùL½·iq—á£óÙ šŽwÏ– 4a†L³«ˆ×eðfu›ÔXûœ_ä ­g¦ò{~ŠnùÓ†ƒo¬š!÷+¨\ñfg̫ئî­Z³ëgéWbþERMÜw» úiÇ:z±ä§¼ªn¾­¯Gç…Š›S¾ä§Xh &¾Â&>œ¦5tøúOãÓ0#ÿ¹bÍ»(¦ãMáGµcÆ £aOïíŠæ•®j²´CYA¦·#«v ô×SGý к”R«,·jVKðâôÚ’)ËþÅr)ò0æV¢ýÙ-é9ÁËeL¬Q˜suh­e9ºïjy'b<§ÈOk-ÖéÈ;,ÎÞ둆 †9îڇݶO±lO¯ªÖ=‡_¼au&t[ nÔ ­;¾‘†Û’Ó"9ÙÖI›Ë&,xÙ—«iùkÿ1(q¯Á=;Q÷2‚þžw—Y³Î5¹Z°ñuú`ñ--Ç¢a«ù«tÖEzW%±l7¦ÌR_fœ”€¼¼ÛlP¡ù¤LÜœ¶çR÷ÁOmNÃÔ,yÞ¾÷§Óš2ŠúË>yž©^`Û®wºsÜýô~üÓ$‡¤Ö¡Ø¨õ¸œqòb¼åa(¼ß¤?CPÂÇò¶®8æ©-bí/Ÿ68²íí ­ëùÏjš¥®oS( –.,ñóÓIýµ.[ÒrùʹÂuÏ÷s§ƒïáÑõŸ¿Lrψ±àÝؤÙ7IP}Wðʸ"¯ý}fÀN™Kªß¹+§&úhsò’³¬i=¢è[ùK ikaÁ¾BL¡¾ëý½ añI‹˜ëlÿÌÛòCO™¶ã«³†â)«ÝâÊr_×ì=Ærß~¿L´§ÐÏØÌУžßñyÅ ó®ÞöGêìH‡ ̦»m[Æš¼Ü8å©…«$Â)ˆÖ Ã9Q—§î8íh8`ºøñì×ÎÞš£qŸ¹ƒêÑã|b`¡FÓƒ†‚¶×^"µmŒ,²· ìL»3\"EE%s÷,Œݲ»_±£> stream xÚt4\íÚ¶–DDÛÑÞ{‹èc †1ÃÌè="D¯A5D^¢D ‚¨Dï‚’ z¾IÞ¼çœ÷üÿZß·f­=û¹ïënÏ}]›“ÍÀX@ÙéÕ@"0‚ @UOÅB€@¢‚ 1'§ ‡þm'æ4ƒ¢Ð0$Bæ?ª((ƒµ©1X h{ÁaQ@XBFXRD@ é¿H”  ö†9z‚€6Esª"=üP0g ¶Î߯7„–––äÿ(»CQ0è1.PwlE#!0(Æï)¸å\0!!A°;Z‰rVàá|`ÀŠ†¢¼¡ŽÀ¯‘}°;ôÏh‚Äœ€‰ ý—Ãé„ñ£ Ö‡A 46Ä áEØꀱ–.p׊ø ¬û€øs9€° ð¿Òý‰þ•†ø †@î`„ á 8ÁàPஆ® ÆÀŽ¿€`8‰{ƒap°ð»u0 ¡l€±þ™ AÁ<0hA4 þkF¡_i°×¬ŽpTEº»C4ñ¯þÔ`(({ï~B–ë†@ú þ>9ÁŽN¿Æpôò2EÀ<½ Zj0Xñ¿mÎP $%¤¨'õ…¸ý*`âçýíþeÆÎàôœ°c@ƒ`NPìqì 0(/hPÀ:þy"a àu†!ˆÿk†:ýuÆîó¬@Xú  _¿½Ù`æˆDÀýþ ÿ½b!3 -¾?#ÿË©¢‚ôÄ%q ,,!Hb_‚þ™Ç ûÓÇÄj!œ€ô_íbïéï–½ÿp€û@x€æÒGb™ ¸ÿMtk8‚}ÿŸéþ;äÿÇò_YþW¢ÿwG^pøo?÷_€ÿÇv‡Áýþ °ÌõÂ`U ‡ÄjñßPsè_ÒUAÂÿÛ§…cµ Œp†ÿëah ˜/Ôц¸üE—¿ì¦¿„‡! H4ìקþˇUÄ ûù@c9ùÛÅŠçŸ%Õ¤ã/•‰`7 F¡À~ÄØ%cOâ@€0VŽŽPßß,„H 6À8!QÄ¿6*!)ÿ2ÿ#-Ä …Šë÷â±5ÿ>ÿV2ê …OO"!²\k´W)3ú¬Ës®›gðL£^{^¿–ÆSùìþ"êH9­¿‹bnUûPi†õ"àsSݵÈæÖ³Às»$£±õâ£7zG >+×ö01 ˜(m^xš…¹á7á¶ksæzzI]7ȧ>öéÖô­í)|8¹n¸Q)¡Cr^ú^ Î4Ö:¬ègžCÖ=ûUŒ3!/Õ¾/ù‡Ã£qªœ‘Ÿ¬ÚI|ÄA;q¢…–K"ñ'þóå&"è†[ –ôÌø‡Tƒc\*›µé¦Š_Ä.ÊOeK>Jè›yÐ<¡cÆÀl@zP" ÿ4T·úVGŽä) nѸn³ÖDpk:¥TpôÛe1ÁBN.8˜“-pù^w²tì욶ó&'ÐËÇ}vg9’§^iË –8?¹*TÓÔ½’愳À1£÷Æû!ã¼ u£~t\]A€UÏÏ<Á?\ñ]#_`Ü­dºI|¥è †Ï ê6Sö¾\¶'ºô[ÕWÑÒ†RصIG­ŽbD.ES$¿>àסS¹þ¥,KªO;c4AãŽf2Å35~‘Õö¥TqÖp—jGì Ô(æN‰Íx´`¦GˆÝè“â³°5©Ýlä–L£éM¯µK+÷L[¡>pýøÜFȤX:a=ü@¬/yâÆ:FW.˜‹ÕüID¹.Xڙʀ°ÓÓeÙ0ôÉpîWïŠ1žˆ=tµ§ûÅhåÛŽóDènscÚÉÅKƒ;ûI(§r?ÔµókΞÈ2. ê. 5¯ò$ÔÕæ³#t¯[!Æ\ÞóÖ™Îg} µö"ÌÔÝ7ôŒ—3KÖRžŒ¸¹}" n½f·p›k[C­QZ“ì¥ðDÉÛ-ºóJP)п¬Ý2öT6[¿šô®«Ô)û>áEÉåɶIEö²ìçYt˜Çý>²¼cëQpq’v 2óµSác¶Ë¼ÞúÆ«†ìc¥d,›Ã¾ÁMËn^{õ@+ÿ@Ñʧ ïæÊ „ˆËò“}ÃXINÛB)ÚñTãEúí¯xÑ›dïGÃL¥?¨€— b(îGÌXÅ‚“n=v®n9w"¿f½™v ´E$ù…l4bKÉýä\—Ε’ã›»Ï‚H G âjùV`ÌÏ1ª/º×RSlFÊ,ŠìžŠõj¦ùP7”¯Í‹¨l;ÏÕù|wpëШÊ&! Ó//rr•wTäH„³óIì”1w9ãm$œRòž,ì~Ig#¡æ76\».ò¢%ÿ¬œëv1â%ƒµ}ãp™Íë+óM]pÈAú¡»MëþWþÏB3Å…Ö÷nIÜ´â 3Uæè}«—ww‡›l¤FPí|Y·r¥”ÞúwYéØ_ôvÑ ®Ñ4‰öEÒç®F·s^áãN;xâj_C¯¶x)TÓ‡—æÆMÕŸŸà–AáQycd»¥òæ4’~e¢ÚúNXðö=j»£’wÉu—´„gÔÎò`n¶bmï)ôuò Œ·Òž“>£K«¹©*†ÑÃ)”z2‰Ž¹ ÞxÜÿtûWt¦WdeåcŒåâ5Š9$P€?sϬ åß‘v¾® ! i!Ód'ÍÀKz÷FXüUï4:âWëÆKd=Äôt°ZãÍÙŒZäöÁ?à¼vK¶¹Ç3I€š>¼"u{¯YaqIòNNn‹=nwüµÖÛÝ <”(â敆÷ñµ9šý“•x…ùø–ÁOU?¥ǘ ©Ç¨¶,‹æ\ št"w­¨S'•³„©ž[ùùV ºT=9ê9L`Í‚°có)¡¯°uÞpEû™þì¼nŠé ÆŸA[βÃíI5äå)J¯c&ïT†–w~>;Ù+™uGH gž DþXÏ=£-±¢HÆÃ-ÿÒCö†ôÆU’„P´GoÞoÅÿŃ þeEËýF¥S#˜Â÷µÑÏ…{;³ÞQfÖÊ.nÕÈŒ†Š+KϤX¯âeìíñ^mïe~¤¯uÓлHZ Ï¿åç#±©îaäBŠ‡Y-k{ÑÁæítöµŸr{C¦ÜÎë‡O¸ ìÇ4]ÐÏú;ˆ^­’¼; 71« h­$:¶»³—ciÕ¥†«¼]Y!Kg>‹Õÿ¬uœFÝhRPh—‡æ‰¦Œ <¹ ò[üRBŸÏq¨Mh€ç£%­Ï"¨0ûâs ¢q©ò¬ño†[>6ГwMZ=Y®VÓŠ£~Pš…j<$õ¥p©pñc[u3{gÜW!©ErlâÒ6I9¤™G~îûñ ž»‚ÔÜmªu,¿gs:žI¡8~åI’£ö±õ½R£ëeš~¡äbŽÜ‹ú «L¯ØoÀO¬£·¾ )3âÌcܽ}å=yù‘cÔ!`¶frÄ»îî{È ýQÎôMÞºw Šíä2÷JC¶ƒTèhÓ˜Ùd¦^IÕëºØ—T‹V¨`ÄñK1ËҟϤÔRåBµ™e_i¥¢Ù¶À¯ËùÁÝ”éYë&u 4´•÷V+é»,ªPv}7»Õf•oÕ{‘ád*Ë vW“Í`xÕµé{òéƒÚ¤è«Î-‘¬Îé‹È…926NfÓ›4­. KZæ¸?d"‡›MS9µíÕáùEüÀrÝRæë»ôV£QÉÃvÖŠñæ˜wr}B²Mq¤õìFL/Ýç»*ržòT•ÐÌdÈc–Y‚(:±ÞW1«ržìækÙ<åâã+6çÏŸ_a©9dt¢ï÷ñó ¼C“°ýÐ4ø†¼}|©÷•ùJ)N[(å.zvªéã¹ÝXk÷Ùð„‚ÆpLwz´w²ad¿+yÎ%åM¼äÓŠ, ZÎlH(>GÁÛàúD’ôèww7®áCñÞ?JŠ¼ ž6~òm ltix‘¡maìô[Û~u>‰ü©õáÁDªû…ÉÁ+F½Éö­üŒ®ìá|Ó}å:nqd†âtž h…—º¾;WøÕÁ„g—¼’<—=îa­B½ÏÖ¼÷Yírà-:A±í^¥q´â,1ì8jħΡgÅE'}]¹ìÍ’¥Ü‰7_éÀÕJ]Õµ–´a¾bæY)¼šÇL'~1‚¾ªï§{s¸î·›§M[k­ßŒB±f œÐi;3’fu,Ël̪)Òß,’¯q?ýv“²Sðñ³xœ…©½Ðìéëâ€kÒöRK´ä 1+Ý3Tj\º÷í&.ûËs“½ÁÛKÆëé²’¦œƒn²ø«º¤**ö»·‚ "õ®uòúPë¨;Fd½Cì™Û_,(ª"çüFö¼‚× )]ÊÜÚ½ÅÌ®äâÒnQé˜7gI}-N 饎Ç=£œ¸wnû1Ià‹þ4wPsÉDŠà÷$sX-¸àýFy\Ÿð"E¦²›ÁƒÏ,ñÅÊÝÝú=}Š!_Ù…ëýÄEÁQÏ B¹w6GÊøXâ9UÜ·$GIod?Ù»xÈûµG=õ-Ò“E¶=j¢eDhƒ2¾YbÛª˜T—br—ùª“±Ñ„ôÛaIžÆ£ÔùVŠ¯¥ö¢o%fç8®Çpq€XÇÇ©/«ºqáÁ3uÓ·lLô=ï¬YÑÔ>ê?¿—WNïH4—™OÅ‘<¤6”""ûR+GÊé ç c,"ž7óѾ€¤ÚÃX‘ó,ð]Ì &ÇŠðÇ ¹FI=ù“gï%éÐý£ˆú›÷G)ÆJ}DÄ(¦":…vÕ‚­x*O®9‹å‰n^Ìkráyè‡wq’§1O˾lŤlá¦ËàÆÒ{ln“nÓœtùè=¡¥ *)}t(I_ue³\W’‹)Ø »téï7 ÿÀó󂽘Ý?ÔÉ£Y ï˜7uG¾ÏÜ%œ)Àà¥ñ„f­~òOY’a£¬þ±w8û@ã„•(ÙµßNQ’½¶©©Kî7`2#ùMN}voå²Ãó‘y°j]þ‰û=†ïòŸ «‚Žœ§¤ …Ÿ/d©Ûo­}µÆËUà¿÷LYãl.µ÷I'nªæºf×6~.œÝ¦\ÃÆå¥ òíLÆز ã—CÎmÖ«¯ºÎ¢3?Ïð¹H FÒ°õÕ)&ý ºÂ×3Ø—±ç¨:8™'{ô™E³»­êyhAo%‡r]2}^IíÞ{ ¨§z“9^»‘n)ÑýËPJ·§ÕÌ_fÆŒè×^µMåé®…mu_Ìõ6òãWhoé9³¿¿%~*õծ͹L-¢Z/ɯ“•C>‘­H8Ü2<“»‘%¶@zz}N˜· Ù\ö¸©‘ŽV‹Õ’eðãcð£Faàù!øÛý5Û± Ú~ æñTWæ»/fÀ´@7˜Ìéwg›[öžKšz1ýÑ!᧷eœùírr>+ÅònŠ©Ãø³—®JåLnG7BÄžk\îýd@»D©6Гì{•GŠp|§›0…s2½k=ÑÐFî²{Ði4&xÒ驼ç³×4ÚÝeåjl–³m:jŒýï!?¶¹×åò-èß&Ò fm²ŽÞÙj"½s#ê-ND‰vÂa¾äqrÇ;–#¾WÓå2f“e\îlÖ†su[ÇYκöo—Æ1‚:=¥9\’ž‘>š ŸžfßZ2{4¦Ÿ×öñîþ^ÂSÄZëaÈRzlóÎPûN{”X”§›8—W_rS[²–•àò°dÉú¤N?¯º,ýâÉÀ=¥=’ÍBÝo¤ÈÅyƒÎ¯“.ªÔÂ<]Ïlº*Hµdè„uè]–sûf‰ŸõÇɽïKrÖBÝ;¡³uù´/%’‘#»o–5í.BsÏ'Ý÷S˜ª[vôálÜãÓY÷ŒÎ>¨M´fÛDâþX3øîÄs{Çû\,z¤¬S]Û,dØJºÝ½P/j•x…ÇÝÚ‘­óµ}¿>§ž1˜¹Užä*iþb›ãiíûä«ã×R§jûß6«˜ir‡,ÁÖè¬Ö´ŠÌ•å”^m®>•¯’8R¬¤ÞrÆ¡Œ½Ef2 Yò™*/ ¤Ö?œÆÞJÒeýî-+1élç}ŠG¬»,T¯|Õ›¬ÅS§Ã&jñuØç5 Ž®áuª€˜ahª ã¤×Z€°H9G9£ó6Ž¨y?uà|Íê<´ Äã MKm+¥#œqæÇë,”º×]<#Y¾m ÊÁh¬\ûR!ÝæÞ:…D }³/}-,z9ð´’1$ñGs”Ë$ÅÚ™~>c–öð–«Ü@ú¦¸h‘€}§mÕ^9»bóÌíû—.ã:Ý=¿»K×ãwFS r{«À·Á¦ B”PcY'ÝSçks~Ì« :Ïùi»4âÆwÈ8trÈ鬸H§Êé7 =¤¹ W¾ÉÊ=ulb¥ xS³¸Ò«<}{‹IJÉÏÏÐø³×å^ꈅÿe¶ûÖ´¨ïÔÁ#˜[ÜK´WÌh²cLí´<Š^µÚBñ;¼5Ékv7Eï%ff’ßxßÙŽÐΦ>]±- 9`1qì_»É§˜L˜çd—Œ²Q×Lš]{Î>‹wN,r'š°©×C<ÿ™NèÍ]¥V#Tw0£ëPF²3帲7môRvVó©¢"Xû™ ùò¥ŸíæìËŸÎÏ݃—žØ×XŠÄn.FÆ\ XSÖ†¤z"¹ÈgŸùe~kŪ|[IÁ&þÑ@æ|b:>š¶§V0ã<ùö8#äef›Õ8îªÇŽ:ˆ9åñ CTÐFøƒOŒ¡ÌvSSÜ­nL\ú«Ð|m32Ä NI]úZx]²^dx­úO=?1¦yŠ±ÔEâHOEŽ’ Rù¾5fj¹Ê¸…óѼ؉¦¦Ý÷R45?S~aÕ0”e½!»¬ÂÜ~¥f†'ó²:3äPÑ/ØÑg,º‚ ¹q’lÑû¨6Ž¾_cÚ×ûZ3Yù"ÄuýM\£{¨r›0ÞOÐ>ŠG5¶Ø¬›_ñ]~!¿ðʆ_o endstream endobj 4636 0 obj << /Length1 1536 /Length2 7774 /Length3 0 /Length 8802 /Filter /FlateDecode >> stream xÚ´Tê6LI ˆ” 5€”C‡twÒÃÌC C·4ˆ4Ò-Ò-¢t‡4Ò Ò!!ýžsï¹÷þÿZß·f­™ÙÏ~ö~÷Þï³_f-Niܪw@ròpE²ê2‚ äÅgfÖ…!í ÃøÌzP„3 î úY„Dar $Š§w¨¸Øxø<‚¢ÔbmQ‡3J\PÔÞü÷‘ò`8ä÷‚ñ @ÈuÅ(KàŃÚDÔý„Ü\p$*€jÎ` Gàÿ¾Oa~·îoè%"àÿÛâAÉúoS€Àm wAü‡lýo“å·¨Vþ¡$Çzøþ‰àAqÿÃD%ø'JÜHkô?Ž¢7ø?¼(Àýù_S» ¨gàJQ#ú—ýçÍBÝ¡`ü™I8øyMuPã¯Jij7Îõ!ñqæuýdvN¯D“Ë%N"{EúëEÄ™tb_;ñüª<Û©Ô,ý×ÎçZœÐ/ñÚ WÞ×f±/F×ð§G(º‡ów¤kºhñh8u¥6¼oœ¼õl1?£·¨0g;¹iå’þrëTt¯é*ž™\×Þ¨T½]<ÆõòIÀ‡oÌ9”ŒØHNZܧ$‡î¾ž“d ßÑ«Ä>Ã÷Ùâ{ïe´ÄûöbÂs¡T—×¹•ê •%-æ)ÉÀ(‹—Ì$•GS^…áµ9ß&>(y4¬¯÷ŒTA¾Ðº5$îÚs©úŒéÒˆLví Úø0½Ï°Í˜¡ˆ™>ªwvü$µé¶ßBÜlO‚½L žíw5÷MQ¤»qNNÎa]Ò«%œlâí“ȵêzcNUð¨×èNxUwÇTñ–wÈN÷³Sè«›ÓM,¿¬Œv|y¹=SBÙ¼˜‰èB˜¥J_I½{ÝûàÔ‹Hϳœz>2Dt–6ç¨þ`ZâØ£–ÿF¹ý=«:mšåש_C¡²'ò=}͸„£-gf*–Quåßq–¨«ðXÕñEß=>%9]:x?:›Ö™˜©Ú•þYóºî½’ÌawOl€ËÄ&¾Eõö“¨…7÷Øò+EÏõùϳ®¥„;zõYXe®Ü…('Šd]½ºô’ ¶Bÿò˜ð— éw¥,ÝùŒG‘ù¢©ýt‡`i2\‘ÏXO¯+èŒ Â¿$Ì'Çý@WaZ¸ëWBPá#)‹ ~º¥Í@Òµv:oœlŸÛ …â5¿” ¿~˜~É…gääPÚFpÔ}• b:üÜÆé¦/83¥ÿßÑ ew†¢}»Q2ض£/S?Ùºí­a†³+‹íÇÆä>OžùK1ì}Uóò±“™jÏëÇ_Æ ’0°=]µËƨ°±üôöÔ¥}u¤]JN¯î,üÑ]RҾήòž ›ÓÊõ‹ÎoŠÈH¸tùL¥¸tžU{tU§xµkyÛ?âÛ‘,ú*‰ñwdvÏ‘};r%>`Pr=ª-^¥¿–&l{Ìà‘x÷UÐc©gâËâŸÙøÞœë±raŒ}•m¹Ðº\÷Bâ<í¦;ûÖà³{$Ë^$Z?ø)7øE–ôÑﯢwÉG¹šo©y“É2Ð+i¸çî¸h/‰V°ŽD*67óG^Y´}oìm1'Ž£+÷Þœ¥¸†¹Ñ$К—3 åÇûE‚©¾ŒG>]Å2U´ªsÏÈaJb) öÜý\Ïm³çï*é>äq¬ëý1K…VñDfO-ÛçZ·–¹!G ²#]D'ªçymó .Œà]Íœã.³GªøSÏèrEjñɺ‹tÌt:P®#óZqÊ•gq†°Æ¦E†ž7´©2¿šå•ßñÐÊ«;F9!+õ‹>ûM>c©+yÙß\¿¥šº#Ï®|x˜X/mŽùHTüdãë&m1‘(2å/&]ñ®F2¦GØà毱_¦fñ­ÅêÊ.G˜mp´ñ:æ†0bŨœÆŒÅÏXm®±3ÌEqù'—Q ì:ëÌ}m õæáB '_ô¨§Mj…t§¢g'n„~г ñ>§]„^yPFïµQ>L£BOôýõãûCMºTæáNÅ-Í£Td—Ë:+a«ïêò¨ÞCM;³I©’œ§uXcœŸCB“Ö+è4·¿T'ñéPu‹{gè•‘@ÔwYÂF¶ŒiiG×c'çãšä¿ØÇZ·ëi$²h×ôsÆlJ¨ö«ÎUäE=~ƒ½f4g( /ŽýÌ”ú5ïÈM³é…¦z‡±EåÙ kyóñ†I Œi%6¸OkòíÔ<´=BO¶D=³Ìó<ôU;_6"(¹”‰œãyrÛW¼<=a!#ËÇÕÈp'ÐyxN6úóuß²`Ðì¦ÕÃg£—¦¢nò·ÝÌ0vqníúÄqÂ9ôÍ—X´šäB%¯Ÿ]î3 'ÆÒþج ¯†½K¨y|jh”ùãJß0¬\P2Zã¨ÀšZum½â1`¿öH…Ï=ˆ ]gÄI˜I!ϦQŒR¡¬á9ÖñšXymså áIŠUK³FáÏ'£Ï¤…˜²W;&kŒºÔ …Ñ’A döåtÊXŠVÆèoÕ ",Ù_ŒöNhF„øõ7^ÝÚRÔÖÛwRó™ç¹ÁÔø)Íð×¢‰†Üs¡”¤ÓîÆÙUF}M=zÅ' WÁ»&Ò'µÐ óóÜôúÌaž+ðµè¼- ‚³y¢Ö jÐ?gHV¼Sð bñÍZ5QZº Éc M ±øjÁ;? ›„ g¾R.RzÂèܘϱRDd„yš˜§œ «õ6OÞ.GMÂçĪÂî·‘›¶'* ò—§ÐܪÔ#µ—} FýÑl–ôg*bò©l¡P ãO1k€üîËæÎÌeëÌxÝbCCöi=ß4¿TUÅHÓä6w°Ý}@6µ\«œÍ}i“o­ã¥?„½)çtÎf Æ'£ÃØá)ÑOµ÷š¦¤í¯hЧ±ÖÐìµ¼nuÑ'!Hjå55Q°ŒlKgs­s¾Ò·óÏ¥W^"£å3„¿ù„5Ç)œ‰ô2:!dš—š¨¬»v”\ªŠN1AŸÔ¨ýüÑÊstýì$ùQfDØ ã¦_¾såÓeô›!ûI·¦ø¼³—aîÝ`¬•àHv U’n‹÷¿ûÑ©(XIÅd´b$àÒ¶èy'yL“w¥²ƒ4H´Â4‹ßŒ¹‘•I”HìmqdÕàLÄí#+±”K>ù{kZ~ ü…ך:;íœ8o¬øÚÈBŒ\„”&Nç¯ÉüY$tù›ë§$Á'¹’Íš!eµ±ó`¡ãÔ6ÊÝáù ðãVl°Æ㑧~ÄañßÇ&ËÎÅ%rŽX8ÈÛöÕê±?ê2 ª¿¾v1ã§1gG†Ó­ó˜mxÔöíQÕ$8Ž»§C«¥èA ìë/á¦Bžu•õ*¸«e´ÙÎ<)æCg ÀèªÅäœùû´¯)Êž7å I˜_'VÛƒ£eEîQàä«& pé¸rxÏ^ˆÿ";1÷Æ„Î0}6)Ùy«ÿëÊ©’7ÆÞzÒ°žÏUÀαdur;ü…“éÝ€«q(¨á^ˆÅL§ð=jÛûQ®Óêðü&la’ßȨÂb"Q¢Ë¿Zù.»’ûñø¡¦•MŠQà' eÎÅ¥ÔÇËéì}×ïeI%))ÍÞŸ_\|ú*Ávµ\•j¿S˜Zíëž&7œÜ¾¡³úd¥W@ÎìüºðYS0¹<"N…n¨Öäq¿P±ßaƒvS±Š¥8S•=;ÝVN§“|_”º´æZåý‰úéöùÅt6LBJ½¡"·B﯌m€÷•Ÿ){‰ 'ƒ–ú÷à¬KÚrú4í7"Ió¹î·‘~çÄ87æP™»$¥97‘n¿µc‡‘—@,9¸ú“ƒ=]uuÛÓ¸ë<‹ÝŠçäù<l†ž„b+zì²±Óz÷[ˆÇÚÍä÷ïQ¦ŒÂZþ™”ø¹Lö6Z™Ö]SòE¦¼O¿9âKßóño‹YÄ+pÛ!±.'meDö§­t‹uþ,Y…üÊÑ»ÌÐ ³òUöÓ46ÅÃC-Å!½WÙ; ÚM©Ëãí7-40)Ÿ½ý¶ROnq+€ÛR0×_¸ãU8qp‘EÛ*kl°»µf¼ÄÀÊéyùŒO/öûr"µvb ºcf tç)Âò-0{Å3ÚϱæY *uf:‰ÇIo=¸ËÉtÀtmåp{ºÖÉì<‚óïR2äxd¢7¤Ã'Ù]é`"j ÷Fä5RŒ&pÄ£¸¾Öw§¯øR×Æ_Æ]{½>Û»áòX9<ä®wùä<NÒBÀÏjƸq™|£˜½íÈ=ÞÆ$Ó´2jÂóêÏ·aŠþ¤þ$«É©:Sý=ñ “yž;¹¡Aî´kÉö‡ éì{ÜkmW“㓾iËT Ó²½õ•-2ÿÅIê­;·Ó,Kðƒ4ëûU™^áFó´“ZÎÖЗh㑯®c¯ã'ú’»J×fHƒç{¢ ÿ ƒ(^'³6ýÚƒËSžáY¹xG!¿“òàq·[aêPÏET^ !—.w¼´;zì}[ )Õ°™"„ù«£°EÖJe¬¦…* …· S„\ÅXË»ßêM3ž20åÚ1,Ƈ4­”)z[ë›y]E([@ðÖIwȇdï±ð‡3‰H»ñ¯÷Ò½Ê2$u{«änîãÈOTc>ÿµ£ ËÈwTÙ^ˆõ')ÿÃϼËß(ügŒ†«»JÚý. ¢žsvÕ<6 »}¬Cêå„â¶1¹ôÇîWï¹+Ïeå Un2ÞWW )Hý¾TX~B5圥ì‡G§s Œï48gâÚ•S‡|½Øj¼^¡7Ay׊Ü3=KÒ÷ ”cPõñ9·ÕÚl^*ñ¢TÑKG‡óÝhu4ü«ó§Œ­Y?ý˾º~øÙeŒ7"eKvûƒ¯2’ߟ½_‘Ü–²\ŸjÜ+G\§É Ð¶¤¾Üt2Ê ž>Æ ¿´/`‡jEÂ& ªÜÑË+4Ï7ÈhpVûÒdH/…˜¢Ü² D7ˆ37uN§eXãoÙ†“fÂJ8sT`䱘Fî·q «ßz0Q”“;[©Àp} {õ|d³^íçì@P;™Û[×”—_ÀîÄBÔ¸¬Ó¥sß.…™¨:˜b”ìH”.êˆóW%‰ÈÚÕ£XFcìò>ñÍROdªé¾žKÓ63.LÙKô~µâ*Zm4ÇŒ~¥qγ{}ñ ´Ä|Ã(®/¦ÿšºU÷‡_K¥’£7KUãbϵ3‘]£ánÆá¹È|ev¡ëôa¾ÎÞõÖù ïY· Üu#Ç°lR©³ì®ÅÒÚÏÅËga÷ÒƗݨ·v#ß«êt+kÖ(˜³ÍUÒxÖÆsž–Oa²¡Kn´¨ý\È(—ŘÓÔÊm¹X£–|ö¼¿âŠ^R¦ÔëEç/iÛ§¥^pfÆTFÀ´–®¢ë}b/žç:4ó3e».÷ yemôÑSÄhiQÁ°%¦¢óN]]ÏÙ¦<Õõó¬Î#b%ë›vÿø8“ª%ÆÓ1‹qV)ÑüJù¬àQw×ýîØiš²TâŸÂ3,ŸÞß? ºä¤ÎR/'³¶ ¿…@ï…,ez²p™‹º ¨Àö²U‰ž#ê²:–6ŸÊJ5ex•(uPÎE±©ñtfO.Uyâ÷ŽKg~ÿô%iëyóaóè„F%ÎHV…dUŸxB£ 'ë²×È—DXÞwŽ Œˆw‚ö¥]9³aAèéM‡úÔ’¿% ðÒö8ºîéHîÈXŠ=~¼O¤#,ˆðB°îðÆfmý†aºgîA3ËHݺ”ºŽ4s»J=žïAE6û²$; 5¾ŒôðÔêÏá²Êõ«å™ëÅ«’)x 6æEuOÛ2¸‡HX#†b֣K‚ç^µ”]$¾dì²?#Ö÷u j#lÏ,Ó~t 2…»!Ÿ@>Nß½.5ß¾î±ÙºÀA<÷©úÆ<…"Kû\ï¥Èbíf4:ÏŸ³È-?ñZ,˜‚™5)~áÇCïóâVåP†®ˆµÞäuù~Óþu³õÀSt¦5dqôI¹À¦Ç?#zÁ©6 eë_v6L[›ȥ„¥^c™D«ôÇø¾í Ë+Fµ¡¼J¿‰Oî- ôô6ŸÔÖÍ=[– ¸3Õ]÷§ÙžQG’ù—=™N~‡ß›³*¡+–J{Ûv 䥗}rŠ$–¬3¨{ñMm™Í3ªŽ<~yY¯-T¶~v·å&±Û6EZ@'ëï›?« å.á³é·XÙú•\ÎPš÷>o›M›£ÿÁµÛŒ0ÆÇ©ÐHÚƒA×{®¤ŒãÖOœ²;¾}dˆµóé½×–Ú­n µÕúÜš«°øÆ®¾çÌ·þ°r•„ö•@Å~6Ü?÷9?šam¦IŽÍXs_7ÌoW'eÇòujmª"U@dÛÙõ\ Y+„‰È¬QøÂI +`ˆlûJ9¶Í6l!EšGUãÙÛ ^Q'X\C ß}äû‰àåÖÆF=Õ²(‰§˜¡ D›%™-x½nã6]€ãX,ý¡\[0)‹ j&upqm/ÂqwÇ쀳^Ù¸}¨b¨±&WSQ3úÚ‹Ý“ÀC,9Ë,b'•Ltu"ìØîóõ׌†”´½tñÈêç„DüU¢¼–ã-²twÒßs•¦l†×ÁBmÚ ƒì7åb¢>ÑщpoèáRº=uSyêu' PP¢»92Q"F ÉÝ^Õó‰f>y`¥ {ƒnýѹ{lÞ•GÀ´þ¥õÂç_KT¶_ }@ë=™ôï‹à²/OAÒíyøÐ)³3<ØÐrÈG4èoÉìmk”Çp§x§I4; 7'þØ~­Ï3_ú`¸T-Â…¥…s`c:–Å‚žNÐûSÆ¡BÂ[>³ŸK™’v¾Ìv¼H +†ÆÂH½–09¸î( :øëèe7ˆ`š XÙ],u¸Ë˜Ymûý-¿79¾"n”€Ù6s#Íù"ÕI¾%¯­¶Åfûí¼j”áyÀž`å) ]ôªèœ±ÿ÷¶VŒ;@N¿nëɯˊæ_£ñyŽA7,^6Ž£ïžY?³}ÃÿÐë1þXàÒ·ƒP´3ók3,OÙŠ%ìê”sÏŠ"ò½Jrl%>J1t½óozzñtºE}ëãNï²e—ð ðsë‹Jè0V{/°»"|uª<âgpæU÷Ù³E^ó«Ø5yj鼘²M1ÌFŒVÉ+ÒÖG5åhñ8©’`ÎŒº$?ØZ†*_¶Ëþ¢dçl* ú¬“£©v1‘¡? ¿ Þê\p@Öãïa²……á€]l!‰ueÑe+ÚnG_Š <\Ç¥#R¿“X b:«¤ò uª§x8 M»É-⾉í *Ù-º¢%ì&ÐìøJyÚ†aÎb²hr4¦=äRVPEáŸ$þ³·n¯U2âì•ï{Èö/oo1 ¯ò˜ÞDþô¦’Ok’ÁÀøò7«”þˆ›™õM–Mž­œß-4ÔëÀº•›–l3v>—ʱyY\mÙÏ[ðWxoòå_iÈÚ»N 8ÚònˆÀö £|§ >Z峺+õrû<0ÊxkWtz"ÌY|¾{,`(€õ ô&µ|Q]C<¸VÓ&ýy¾‘G¤÷„Tª%H«…¾§˜¹¾'ÊáC¢ô¡5 %Ãx¯ èM·Ù°zî”tÈTIÉѳÞï"„ÆÂ/,ÜbÈŠ1²vÞ°&· æÁ¹+ÓÌV)6<[µ¢Fvp½9À·B‘ÓÜ°‚±ï~Q@˦h¦mLxEÒA³"œ â·d£x‘Ìò½½F>Wãn5+§éiyá©æI çš×âZX·/Ï0Çxóç¡c¸éçÞ]¬j¬)Ve¾ïõ·=ÂcØÆD(RfîLö‹+#‰çÉ7òÖ·¤<Y.ÐoqûìSåbo$@š7ºÊQøi¢È¡#ô÷q‡7êžö£WžNkJÀêÏŸ$ãÚäžõüé?èôZlëeOC•¿I‡¾iz°§#ó)˜ÒП#5Y¡úY ÑÔëR2ÒAlš¤³”+òãȬkKpбùŠ#~옓ßàâØÈ9>»áh,†®ùÇ Ý!½Nš®ùeÏ`„n-óЛgc÷Õ´8L!"Aµd«Ò’©¢y^Hê{ ˜9ˆ ÏRS¾Õ¦-'®ÑMr>áÒ_¹‰k´$µº6ÞųSQ›Ô8ªÂèÎÆIïðÁ-ÓÛVÃÃ7i¾cüVªÃì/Ý <Ø[|¶1¯B{V[hè6>„kó帀¿Aƒ½k˜®G9SA)Lã`÷.J¼œŒH{1>÷Ž|‡Ðtdüd5 'UyR9{µÚ0Þò«³ }âuúÞ;æi³ÇMÉÉFy®ÇÉË„¦W['ñìÙ‘\³H(q‰ë3¦Ly Gá'ÉvÝ•³õ_5†=Æ»LÎcΘ᭞­×ÄûWÃÄg–“Ù®(­:›ƒ¦cˆêªl6|U΢ÛÞ†dM„ŠZ¼Ç¬Þ©‡a%Xß­¬[ëݪkFT™qL+Êp|Ò1=óî–äÅxÑptè ¾YbY^3nžÞå¾Ð‘°¿æ××&uÜ /³‘мRz¾î¤òÊÈ›„U.ÔUr1ýJóTh÷Ñ`é{pùðâ<ª l›cóåŒ!‰½]ÈIi"•{åL/vUõR<å³’¨ì(Óú›}0X‚7ü_áñ/y9[,(?›ÃéyzïYÃÿf(!˜ endstream endobj 4638 0 obj << /Length1 1573 /Length2 9159 /Length3 0 /Length 10184 /Filter /FlateDecode >> stream xÚ·P›k×.ŒS¤¸kp(Ü]‹”â)%à$¸kq×ân¥8Å¡¸kqoÑÅ¡¸º÷~w¿÷ûÿ™s&3És-_ë¾Ö=OhÔ4Ù¥À0ˆ< êÄÎÅÁ) y%ýFÀÉÉÃÁÉÉÎÀ eédùGŒÎ qp´„A…ÿ‡Œäô$“9=Ù½‚AJÎ6.¿0—€0''€›“Sè?†0a€,ÈÅ xÅP‚A!Žè 20;wKs §§4ÿy0›²¸„„ØþrHÙB,MAPÀ+“Äö)£)È  3µ„8¹ÿWfQ '';a ÐÕÕ•dëÈs0ga¸Z:Y4 Žð»a€*Èòwgè - KÇ¿åš03'Wð$°±4…@Ÿ<œ¡`ˆà)9@SQðÚýÛXåo6À?³pqpýîïß,¡9ƒLMa¶v ¨»%Ô`fi¼–Wáprsb€ à߆ GØ“?Èdi2y2ø«r@^JzjðŸöM,íœ9-m~·üæiÊrP° ÌÖurDÿ]Ÿ¬¥ÄôiìîÀ¿OÖ s…zþÌ,¡`³ßM€í€ÚPK{gˆ¢ì?&O"ô?2sˆ€““S€_±@ÜL-€¿Ãk¹ÛAþRrý?uàíi³˜=5ñ¶4ƒ<ý {:‚\ 'gˆ·çÿTü7Bçâ€-M&sK(úŸèObˆÙßøéð,ÝœOÜãpþþüûôö‰^`ÔÆýù_ç ”VT“Õ{ÍúwÇÿꤥanOv>A;7'€‹Kˆ ðôàýßaÔ@–ÿ”ÁùÇWjý]íÓ˜þS±Ë?`þg9XÿKöÄZ€ùÉ 9ù8MŸ¾¸þŸ©þ—ËÿÃGù¿‘ü$ïlcó—šù/ýÿG ²µ´qÿÇà‰´ÎNO ð ö´Ðÿmª ù{i¥a6àÿ­St=­ÔÜæß!Z:Ê[ºAÀj–N¦såo¹öï³±„BÔ`Ž–¿/;'çÿÒ=-–©õÓÅáøDÈ¿T§½ùï”rPSø÷‚qóñ@ wô§#~B|O®§MCÜþ¢0È…9=¹žšó˜ÁП'?(õ[ô7ââÐ$Êþ‹x@Å?èÉRåz²Tý r€j¨þq€ÐSLÍ?è©í?è)曑úƒžt&ÿ".nÿ>etÿ þרLžîŠ¿¨ü4Çÿà¿.&Ä bŠ¾0 3 ´úøåªJŠÜ•ýǘØÃÝvχVç,Ô,•ïW.¤> vá,oÈ1ŸK.Rß{î5Õ¢†4'¨·Üzݽ‹Ó˜øÑ‚>?NÔ÷µ`Oª¦—‚]KrËëÞÞKÇß± ¾]‰!ÇÞYK-ÿʵGÁ­¦·di$xö‡úV%¿2Æ]É${”v¤¡ÿÇi†\“ÌZ'vÊg/ðŽÝ°§Ï/¦ð²¿>R+ű¢{ïGñzê¯rG_Ïx|+Óâvì ¥'Õ'¡D<Ç™`ô”ÞIR"žó,.ŠQ Ž(2£4šmoÅÙóVÓ´/ˆ– ]&ùùÎ_¦{c"8ÆT}Azð§fv ^NÀÇÉ{®wùèŽêmÛ÷DùÄËà %ˆR—Ôq·NDb函[Ô3½Ø•Cټ׶QÅÕdÑWøùfïÉ&|ŒÁäÚü¬†|ïíñä¥Å3fkpPS k¹ð;ŒDji˜tÔi²Ekóéù‹¬°µrgµuào¾ÂûÊÚûT¿±èׂsÕ._~¾½§‹·À/@o¡ÃàT5`…·r³ÎOYÙNîSkAüp-•Í—ÓÁïIöºøg!bŒvN~.™ÔdIIF3¥š–,’, @±LìÞ‡à`à©ð96YTÑ n^ \ê¡vHÏ`¸§Ï¶ÄP¼òI(ŠDö"|ç¹nˆ-ÍS<ò~ ÙíQïÍ÷âaÛ¯»(Õø/a 6ím,2ˆÊòpIÎчӵ6±Õz>D×¥¢lñ/àôéHŒÌn"Š)*ÜV™ø]ë¥áãŠuç«p}f/e9ȵJÔ²Äs•ÛaªÛ_5ùqNÅ ™™@ÆyEUµ&0!šà"Y%£B¤àÒ¢~¯“õ(Ö¾&bDîVa‰i Å_â½)=½Ìs…¼FÔÈy•Ï™”p¡»û¡ÈÆã¼sê)BA˜ƒ[;Æߨƒ°x`>›òÍöŸÒábàëEÂ<”ÈùpW[È8ˆN刺ïî÷Ôngûßàn½èKëQþX°‘œ2dDÅû40™k÷J(Ì0ÄÆ ëªñ F‹Å¹/QËÓºâå»cB¢X-%2 ô4EÃYWzÄË„^=ÂÿXÏ0šV°¾4WßåÔKgòUÔ”‘*›ìæ‰ÛÂô³=D’øV„ˆ›ˆG@l2¤¤íOÀ÷ÍÃ-)ú[…U’’ôµ¶ž'„nAÞÎQ²Ùa-E1IÓÎHv¦ÿË«®l“;Û"“»ýÅB \å0!–/…n½DþµWïÊöتšL!Jÿµ[ 5À/±l<–‘Ý…¼‹³^;I 1ŽfŸA€?Ö¶Óó¨Ç 1ßBº3÷"˜É‚«©CDu ,ÏÒµ¡v¡ýè`ÜZ  _ôhýMåzB,pQ¬´ÂG§… ýM]þ1z¿6¢ ¶æã{WAò¤× ×—ïØÊ|ºíK ©×¨«y† zmå¼+DŒ÷pôKY(Sk°^êãµ`­±üÚ1Ç»Ex\Ñ-.£éQ­€Ík@#¶wTTY_¨§IeR³Ú}¶›¤"»­×—ìÂj5,±M”Q)¢rbHŠ8³Ï¢§pÕÓ¶Dô|eÓy¿!³ gÙ-\Í}ÑiçZtg| <R=RœZ¢/ ì†í´~Ǻ¦‹‰«W©ã¢Œý9ù‹ëDîX²†E«ÒXzåÊŒ¡qüõcˆAûµ)Üò<Î……´°À+,·ëWrT\>Jç)[¶:±ÕYÔËÖ)-Ñ¡*N^¬ò cªiµ¾Ô2(ë$’u…µ|¾^X °l~PÐ.£L0¼V0Y^A¸:ãè ‹Å%÷RLüDnB>í x zköi«W•©H®ÏÃL……gˆÐÍœ8†û º]•œþ"C“ê›ô¬ÄÏR‡W¹M’ºêê;xÏ;ÚÞ<>Ò;< „iÙæ¹Â+ð³¶scÖ/€¦{‹~å|ØÀ]­"Écƒ6é˜ÝùI Çgá¼Èùê=,®˜oK0"¸žýFe!DE¾éd¨9j¥+)ÚúÌœÉ,ƒàÿaÊCÂÂ#Qvº–ÅÎÈ¥£\kSLç­B`ž8ö'ÚŸzà‹@¶ë eÛBQú¼þÍß8¼Á.‰ê`:­¦« <¹=³|ŠuWgþδ RöIRpñ-eâÚòŒ­´XíH%åè­lE\2C#ÁY]rQŸeL!^6»g!aj“Û ÷-'ëÕcÛЙ{*Ñ:;N9û“1‚8Ù+k®ˆ…á&ô‰–ÜÁu°—Ø=¤Tƒ"²b(œ(¯aÅGÙ"&?Lc×hè ›—·mtÍ1LàU6Ál|´õ¬ÊøÁNßyD{Jöæ1uÂËkû-Ö@XrB³‹ Çõ¼Å®cãŒØÖpÂÜuácÚTŽPn[^ë»$ÁXË¬Õ v0 ZϧÊêR2":™gA¯è0,6©ìªsc³NµŸÑºâsè"#è“ åôgl„¼6ň}FG’ÿ —aÏoËh&÷è†/—þqnåÜÚcˆj  *Ut‹ßÕÝ"Ù€¾Å¬ëØùsa–}À…?ûYh8†álï@É]Æ*]‰Ëի̪™0éä"7öÒsâ^s2LòO¬4ôÙÜ2ê{ÆÆäÕ"E™åÎŒ¿wú öë¶oÁ» 2ÐÙþd§”1µ‘ rŠŽnß šV³±ÚMÒR&¨J¤ dE‰OˆÑ=|)B|c”>üzó¡Ž|ú¶E±¹ŸÓ0»q…ÌH­¸y༔Hy5æaZ¡ü«F’{¨85gö.ÿWduH¨MãȈ.qÈA?%&&{ÚÐdžª,ÁL‡ó}©ïèZT@ú6ºÜ?ÈٱϫΉٯû$¿²9w…dç·AV~–%úÊÛ?”“G =5p™SÆ6;R÷­V<–%«ôÛî8Xo~W·£7 aÀúL€ã=´VñÙµaRå¤mèUTµ<êðÓ¦1?û—à:p®PK¥®ÓÜŠç²1²8Ögµ´,ôw?³]Åß®ìx~©D»z§¤teà•_u:ŠÅRÚ/‘µ½ŽidË^ £úÍw$lžFþˆÊlrÀs¾v !ºO“½Y“æIêÝúàØ-êý ߌF·ËŸ¿UÉJ–íUHÁüÔ£àS.÷éñsõº©òT“ªͨ'¹ÁȤ"q[C_݈)ñ3r s¤jXÛ¢Âmn·¯°óÄ:š@£¤o‹Ü÷_§Xl)pu?Ìí&¤Ú›©A¦ ßÜŒ‚© ñïѨ=2©Þ– –TQ¤¼©‹_}ßõª ÅTkNÛªïuü9‘£~Ë«¼ú¹Ó¶WÂM½Ç#Bõ'åGÜ9QÝ3¿4 c`©í'‡µfƒÐãT^x›·kZ×mªÉæ¾îÖ‹/4U‹'É]½KPѬî ËžOYd‹ƒ$ö”]ÂãɹEo¥TüÀêì5L›QÀ߃f ñjÝ*l?Ñõ§Üh®Ä7zª p=Û¥û<ÏÝìh³ŒC”C «¦üá4q(Ù…èóE'´Åƒ†5B… ˜ÕÔr#è.Ö”³´þ[AïGŠäˆˆËŠÒ‰#^­a°2‡g™j£h5s>™UzÝtòÁú«a¢#øðÓ§WòÏjdÐæð…•+•vÕm¾bë”ÿ|8-òj÷Ø)jYî ¤øŠ·š±j"8 Ï"º‡e0 çhˆZ9 ÎZ·à.W‹G¶Yr&BöÄt­ÇòÌUWŸsµ#3©¿\©ú\WÖ"ö”‘°^p Ö‡µê?Äz še¯ rs¥œœ…âè_]èµá"è)1hë†7¬<ب­£ü’nÕh~FÎázî´R~ðÕÔØ*Óÿ^öínñäþÕ‰(ÀŠnÿLó¦ÃúZò?ãíMP­WÿókÂl .¾ÇŒã¨àD¬=Ÿåu+¸¤Ó2¾„>+9+‚šÌ…ÖæøŒUÅ-L11éDòšâŽ²q U;âflrM’¬ÛÈšÂyJw°Â—²D“NOBònòz~àcÚü­ñ™ÿšÃÝN†g¬ã´çÛt´Óžoy´ùYR¶SŸ H>oë-É·rÒ3Ö¨anä"­=y×EÍñ,)=Ù©-é.ižyÓñ•ª™Axuóù·%gC~‚èó²¼±1Í­âCΛöÔ6YUg§È÷» 1ø¶eÃNû‘„èxúãÕø;ÊÕWñÈØÆ)¼“5º *ÏÁ,îúù¾Äà>CÛ‘Yáœý†ª!G¿`Î+ôzðè`t5¨ß aM2¬*•xF':­î‚^äXÿ€È²y·<é^vH/xŠÅºkhrÅ2¯,„”[Jñ‘µ‡A¢1,xU“þT£oª«Î>p­ýâìcs=…]Ï*oW¸A‘åxï‘÷K±„BcMí5Jgcë'Ó¤zÅ–î¼QY°SI×V±8yD1‡Ð‰j<2ÉEª‡Íà¶i À?ůe?±ùÐÿØ@,a8¸ø­àùùþ–ìÇŽxAZõjÀ¤+$ÖÚ˜XUCÈêj„/ˆ¡¯õ¿äz«¾~F_ŠÛ‰[ê¬eP¦É&úY=½áýØ´XRè‰äôêš=j™ÑˆïÎíð8lß@ß1Z+ÕÏ`OE}ƒBžWÞVFÚê2ØßLnV¼ )ûÊ—9ýè8I¹…ƒ£XÓÑRã#ÒI5‡ÅŽîæVöÿ\g½!”[íkט°9¶aC¤[ç­}ÝƲèÎ6†3#&‚4âŸ`QÜúõ„ú\Ã,žÇØ»ÉbÜíæàS‡S'ÃÑôÑidæƒX©Ø!¯ ·¶-°8PIå‹3é®x6*žÏçu£ z–Î#Ò•“ä¼ÜãGµŸž9¿ˆ·zïhÒ)9•%ð9ÎuR¢’ËóèÌ4 ¢n'‘Ûœêh‡ikšãvé¾ýØe6TÝâb^c]¼ÊM.*þ–ç¬8Ò°L>ÉãìÎkO ‚4ßøjîägUyö U–CùZxêJ»c­Ö=펿)8˜ïûJCßb ¡´òÝ|Üœè’ V èÊ1•±ÍnF… ‘Œ0&€›Ë÷̺ÆíeçÚfÓÙOWCË°œ‹mV<ÛKÞC¹È›wu &Aê%õÑ4Ó2–…ÿP1Y Ç ¿¢cS}î[z<¿-“9Ù#ÙùÆaj!ap¾{ê?ùÎj¨öäUÏ~­Á˱eTv3^:gøÛ•  Î'?Õ\wCºr7Tþ¦®¼# 3lÄDy NÅYvÙìQ± æ=”P)‡_µ:}ûª=Z ï×ëK šFö£5K$´E—z³|Òù†¢Ç_@£í g‹è,7ÔvD/ÀLé²ïlT‹*EÔ*U}¹1‰jbZjÛNuì>P|7ÎÕSó?)¨çé‘Ð Éçð<ÓMù<Œ'XÊuúŠÝ¬7_oÿü»a—&±âi,¨m±ª„bš¯’áí[Ê {#o¤±Ü†V+l ¼Ð^p~çÁ’Öœ2Q9^`…UB„—^ëqÑXÕÌZô¥’þvŠÈù•—ö\¡¥3åù+f’N•­8CÁA·xæHùбsúÞ`¤£ö2˯ƒ¥?L—iïh#`ltí̇䞧‰âp7ÉÀÛø¾ŽîÖ~ú'AJyá‰E'kõá9¹º] ð¤ÙK¹Z¸Ð  æý1äFz vAÙQGôÇþ0g¿ÉÄÛK‡sxãˆ-çâ‡Y,z˜¾èÄA“¡ã‡GRyZpzJõÊã~oqß:Ô\&UB£`Þ(šéÓÈWpiq»sÇo÷d®Dž_¥„£B;2 5ž;÷öVOà/¿ŸC¶Þ®ãcÌ_‚¿¶æìtQ`š ÜÏàÎÓ+gE¯áYÈŒ]©0woLj,ÐÕrؼ°`Nxü„УXÂdÅ3-艴_+÷X>)(礎Å4a°éècæ+µ¬$eYƒòòÀ¸Ùr'p榡™ø0ák@Æ»3¸IÑä¶Bvñ©Ìxq›Öo“2>muANHX@½,W²éëúrëY߆TY‚¢©öÙ!MYþ­wÂÔnÙ.UyV’"ÎÚj í©‘Ó½5–ù:%ÉŠï3ÎÍãÁ?ã6³‘Âõ¾–?“¹$tFT:ŠÓÞ±L}!Ÿ“..„îdÍ•X_(9šS£‡˜ƒ|Ó†j£»ùu„çƒÁê~£¸cÃã2ö>R¯Ý µÌˆrAAn_~Ír˜Ù2£j%ç}ÉÛ7uZyäváj˜z£‘¾mlîŸë¶«ò2b'|Yx±´k¦LZ 7¬PiÓÌJ-ätÁ=VNÙïNŠCКƒ§½ OïjýÓôbU'!IÓå³|û~e "^^=__È :r¥èѬ…ÖîüC5kƒËøÄ›{OC~–n–æ‹ÚI‡3¹ÈË[ͼvêŠáñZ¾Ud‹jGpt•¶Þf¯Rï‹f@]µÌüWiß±PMáy›«8¸ -pÞj¨k~%¬5LÙ«OðLƒ‹æ\¼‡êÆ¿ zTžq+þ­¾AùºÈºìûê{´;‹ìš¡ ¾L™ªôºš÷¼CÖ¢ó¡«Ýå`û ;È›Æ }MîWŽÔ§Ÿ(ö,Ä#D±áô¿n¹è@GÍ(½RèüÍÐ[ú¶¼º'ŠÏ)_©^¾*±ð§£ml‹%#㫱(“‘­i¶y½u8ªpš{Õ•ÕVÆ úÐÉ%ð‚ݹ€õ ³ÅkÔˆmC¢¥F|ç×ñ±žÉ‚\"V"µR¾”!_NËhÙÙtÐÖv¾TÖ‡EtœÄX±3àYrß‹üôΞsÙiÅ ’AŸŠ}­²xYa ¯-‡àõÖLæ +,Zã”EU[çg¯=‹_Ò}€öçÞê手 ð¸âÈÑYzÌv özcLï[õ“f½Bá£FôÙË­•æ¶ç’Îé•à’°¸æDY ^$€Yîú¨qã†ó4ƒ¢Ë£XZç×豑 +¥>¶æ4‚}¦ªrY“ü¦_¡-©oâ£iÃÐd:ÔŽà#Y‡H"iåõâUC×C’À´¶-“1ÞÎl×-!Ä!½.üà€ M#¥ç¹ *wí\«g!`•i`ldøâ·.¿eu‹mf¶Òabðw˜Û >‘Úý…yëœ6ú2®k¤d-ƒ$§\íE.fpo\˜ä•®}‘Xjå†ýÎHò%«h'±ŽøͶ"mÇ‚Há‚uõÊ>"°ˆ„TyI ±žg‹µ3wmôW¼öIÆpðmã§Z4ÊtÀa 6Í‘,ºWq݇ýÓM‹uÕâ=ß%ÇN†fÙ~š‡‘–>Žl3,p¥Ñ§ÇpÍP;~Ñ©:tôvd0‹äo³ ¦ª`¥4SRðüˆ_ÒË 'TcˆÒÏ‹•Ÿ±âíÁ|pÙkk®&ñP`¹½®ðª,qSŠŽDà`éãàyó¡ÆÙdW;ÿˆÄ 'ðoÎUÅ:Zó¢y°O1> ÿz §‚ÕO´ûÕ)zHƒÚ{”Añ[–9Z á x ÁÑ­Þ_ÄêR¥¢æ1€ã©#ú“9»®ŽZŸ#)]ìÕhÏê [½¯ChÊ >á©øëܤ­“)eU ½zÆQ¿-1|ç1-Lµfº4Y1PXÖ\mCøð“aÝßxºãTˆu;âǨ½WTQÐkÃ3x³D¤ösªé‡ÜƯ%ݶãׄq¿¶ô®[)–Ø(Ê›Bœp??Û5{_Ò‚/T®}£{Wé{Ö÷L8ÕV¸Äí«Åæ/ú¨ ‹¡×üuõÎ<úsHS–ï8†“á§Æ«4¤* õ6“©óp' Öôz¿SèÕ¶"²·7‹ØŠ—}Žòy‡F¬O ×Y˜q¤bg›Û*í#h…!ÑÁ)ÒÝäy¼4"ôu(mŒtWËé7¶ëgðãìY ¹»ËãgAd°è8s¦öÛ¬ ÙXè=³Õ«ªsS:ÀÞ-ß°­øeI‘úzS¢Ùi÷þÌé’Úþ%&£Æ*tl¡q:¿ßm)‹c"º“_¹Û*e>Fù%ÿšáƒsÑ©ý²Šƒemg¨mô6jjXây#v+3Qr„fgÀÉõ>Óëtëé¯|þ7/šLŠ`l3`­Íg°Â\HO¡¡Ïv?ž2 CMµL÷_ã‰1rm¿&¨L;Šw­ãí©_Í~!„mvõÒí>´'šš×¤ø‹ZÜ{ +±ã8‡oÚ‚P„cÞ è h‚XsYåNúG >?¦ð<ªËAU$ݦ¤4œM’ ã½CW\Ù3ë}È{Dc•‚+èíZÙZðüVïTóDwî$ˆõ·§#[?À¼užµ¼Xá-2ÅskFAEÚϧ$„"µŽttB¸ùùÇ槃U%êÜç‚ø¤áûÛkÛ}ËðÏòhF)0€Ð!F§g˜ÀB'ú w›‘ÐœÒÍ 5mö²ŒÇkßž’z~ÓŒ¬’úææíÂ-ËyQIkñ¼7$E)/Ž^!nô+´ß;Ð ᤞnÌ\-ÏFwïÄÙpà¯1…dN‡Y‡„Þ]ü—5–;÷‡•‡¶šdh QÏ/ÉÐ4á;¯…¢.Ï•Yu½ïÒ—‹³Ùˆ:3œ/(Wd2P­ØÐÝ‹áHøÍ¿FÃnŠiv»ç¼Ýðj:a-×£@,ãrhÖá^î‹V>A(‚\exËŽ‹£™Ç2ƒA)‘µj ­ÿ…ì隨‡•çø9Ìž,áEþkú£¡íýÀ{ªk"TŠ¿v.çó/ÝýT8 úÁ<=mEÕGñ;’çÝÎ.’8~÷þÏt³¨Í• Zz·r-%[(Þ";Ù„þ(ê^ú0>ѯ¸Õðeæ£nAœÝ‹©ã°8™ñ¦%ô[™·»Ò&;ø*U0„WåpEž›þ÷†“¾÷xn—©èõïƒáÁöG²)F{i×9Ódj£._i‡„‚™C¡li§}© Dûvqá NoiÚ±SG0ò»J惼År7ÆĶ!®âûÏcgz5¾¹Àz²;Z…z¹ä@GÓËcŠ…G±¢VÊú:‹ª¢°Ÿ(U!U/šÚ,Ÿ7*, )8"­BZ[;ÎgKªýX–WõhU«B&Š?x0(C*5ËÖD6áøMñß/E,à6Må›”Ä2-[‹¾¤‹ý<8µO¿†@Êñö5_·ýyUݶ-ºY_øÙöXkßí3;œˆI”qöi&&梑÷1Ñ{ ÆfT"<í)ú¤u:í¡¨êZûÓNQ[¬'IKä~¦†âi{?ÓwÕÅu!>%”LNðc¶ÑfÅ^/¤Ñü°`/Ùì'yñöÊ´.´žõ"¯Í›f2¹Î`òpÐ…º Š”‹1•HÂW48nÔ¥’ªÇ£\VÒå³=4ŸªH÷Ü!9û4F«$¾…™lþÙ­#sB¯uÇt)wv²áV1ÊŠ±!4“B%/>8ªâôÀ>åÁ[å ç.æõ2"—î½Ú®•„ÁÑîŠV å•¡ó†¢DI­&‘ Ýê[º2{ªG–aŠ—fʬc¹‹A82^~¡YüˆgÞa;„Š&·ü*©Y·£ìbu/;ç%K²K麆M}BŠ2·ƒâóÎÔ(‚uÂPH‘ÌùÙ.v‚Q𨡻å9ªTókä.S!s³leºhf·sÉŸÇÆkZ7=ŒÎÌd`÷Ľ„Åï†òhŽºh_ͦ¤øŒ! ׳i¶OÑpW·%ºhÑg8D5mñƕᵸ™¯6Ç`©ëZgÞ_fì™Ê“'MµÓØ]}žÝ§I €<0jŒsÈ¡á69E±£ “.îñ­~ÿ‘<¤ì'¹òþÙ´)im¿\*¾-#©ÅÙ9:þI§ éܼ¡iž GR’Ìž†¬×á5¤‰cz.+¡¿´¦þUÕ¤,¹LcšÁ`Ga“‹âq­À—Œ6“«`·…÷c«ÕÐ+ÑáØ8ÛߘéöÆô/˜ýp† »ɹ×oMT%ÚöÐmæ3*Òtòƒc•m<7ÏÄ ¦x“͇{gr‰Qp¸ÿ ò’0¨"Ò¬Aû~Ì&£gß1g´¦6žêm¸±Ê;ÛðÉú «ÌïgüÆóo2hFÜó‰”ã¬(2Dõ×»r·æ#9•u©8Ñ&bß‹¿ð8E ä¤õõŽqøgŠ½õRïy(ŒìêçÚ’W.X ƒû–’@¤sAcÑ4wñŸpÈ\;­vpè‰HJ t#7^eƒÓ g¨—E¿´³áû¬ëŽ† *m`÷_å`x‘Mc*n¥iJ¨QDb˜k¦çdá ÒýE³ê£ã÷¼b‡IÔW÷sm¯ ³¿¤oTË–@±³+1Š*y >'¿ 㵡¶¿9òËĈ­|'éO!¡ 9O8èg¨„ù>ç8'y©·8LS*»±Ú‘&ÃÏÉc”ô†´?qm²Y¨µøTÔ WžUãyj)ÙÃÝ€}{‚\O0ö3;ˆï3Ç[ÑËUùÅyú+¹¨¡*96þÓ¬9²ƒªiÃË­ÁSUsz<Ûæ7nÿ¶0´• endstream endobj 4640 0 obj << /Length1 1664 /Length2 7537 /Length3 0 /Length 8587 /Filter /FlateDecode >> stream xÚ´Tj-L7H—Ä"C—t·¤”0  1ÃÐJwK#- Ý¡„ -"))-!- )uÑsÎ÷y¾ÿ_ëÞ5kÍÌ»÷“ﻟ‡•IWŸGÎn Q†Ã<@^~ €‚–Ò ?€Ÿ_—Ÿ_•ÕŠt‚üƒã±AnP8Lâ „¼ÃAÈ;C-8  îî €"@Q ~~€?¿ø?†p„@äµhñÔá0ˆ«Üŵ³GÞåùç/€ÌŠ‹‹rÿvÈ9CP0Ð!í!ÎwÁ '€> … ½ÿ‚]ʉt‘àãóôôä9»ñÂvÒÜO(Ò qƒ < 6€_-´Aο[ãÅcØCÝþ"ôá¶HO¸œ `ÌíÎÅfAî²ôÕ4:.Ø_Æšpþ¾øŸp{ÿ …ývÁpgÌ ³ØB eM^¤’‚Ùü29¹ÁïüA ¨ÈúÎàwé €²Ücè®Ã¿ûs# .H7^7¨Ó¯ù~…¹»f%˜ÜÙCºáýªOŠ€€ïîÝ›ïïÇu„Á=a¾ÿœl¡0Û_mظ»ð ®î5Å¿mî ¼ÿbv$@˜_\@TDq@¼Àö|¿x»@~“À_ð]Ï}]à.Û»6 Ï¡¶»<_7€D¸CžûþIüû„l `$Àb…áý7ú ±ýë|÷þ¨ÀŒÿN~@ÿ¯ÏþYÜ)Ìsòþ¯ùï'æÓTz,/§ÇõwËÿ!ååá^_!€¸?($,<ÿw ]ôïBþpVƒÙÂâÕ{wQÿÔìñ·ØÿžÀ¿ciÃï¤ °ÿWéæüÂüà»/àÿ³Þ»üÿÉüW”ÿ«Òÿ·"ew'§ß<û_ÿä uòþÛâNºîÈ»1Ð‚ß ìM!Í®Äêîü¿¬t7r0;§ÿ\$ÔMê±Ñ…"Áö)æ/Üð׬9Aa]¸ô×vðùùÿ‡»0°ãÝq»“åo r7?ÿN©Ãm~ š€°„@€¼ñîžùî$ ðÞM¤ Äë·|¼08òÎp×Þs€-÷ëM|.w{æ±EÊCíì~Ñ¿ ØŒõŸŒˆÐŸ ò¿¸Èø]Úp¡?#!]þƒ þÿVÉ¿“‹ÿIý;»ð¿¨?Ò‹þIü™ÿ_Áþ(@ì€Û¸ƒ‘6P7'÷)~Ÿ›»³óïÅì¯4ÿºz°;â.&ò÷xܽË?çß ñ‚€ñf§à`ɇº¶ó¹ûž<ëÃ>³®§sðøÎ"Þ¹ÿ$ÂNá¨Î ZBœÊ¥ tϯ*±ŸÈ~a¼öÝinÀoIzÜzùìÊò…ÞØz+ÞÌ(eßHáŽ\}/=.ìƳk×gFŽèͨê¬y®îbDº¯ÈÎ={T¼ê{Ëæ>…M­?Þ¨ÑÀ¿*ç‰5Œ1,ž`ͷΞ¤fÆBòÐãp’xÝ›89ýLš;r˨þ‚ ïùn¬`‘¯é²@ÜŤÏB…€Û{š4¦Ôôè'¤ŸÆúÊo¦ªSMû–-L0ÅٺܪȘ"ݳ؄)utÀ£!3Þ*ùù”]y8òá'#8Ίd`Á‘gîÎý“ - l:ô°‡æ&¾,„΀6,%aÑ¿¥|® A³Þ¢Ð—¢1‚½Ù”ݵó-ä×pÕ!$ø…Ã7—]ì¤_#ÐDÕQÔˆ”uø0M9Ð^;&ù”gpŠ=q÷ð|ÙCS<vn÷p*ºÂðjŸœK±ÒX®¨wyi¢ža~­R7ÛK²€Õ‘M"[¸ŒŠ}—K’¯‚Rµ°·îgûS](dGlæÂ×#YYëøÕ¹ÿù×7Ì™~ß0·=_zT|퟿¡6îÜô쨡 8«?q¤ÅuĈ#ŸÜêR(æÄF,R÷™ Ã]œVŸ²ï}—¤÷ Z‘2¾Öy2OŒ[Bé`ò‚5Gé™ß?½"›„N+eS£ÛKþÙAúÊûM`m/Ç¢•»Z‰\ʶ|—û–ºÏÂzEÍ¡©[]%@ñÖºØr—Ú" fÄ=ñóŒŒ.øƒÙ…jÝD½Q¨V¢ƒµXÑŽÿŒòÄT~ý%ûù&t¥È6‹§-°ÑLW¥£3àü†%Þ÷Øe½±ö ¶ŒrÒDæÊXSǃj>gª¡¥5ÞÒ^=@`4ÜŸåå«õrÌ$Æ>™Û_‘ö‘¦ÝxwOüL{,˃çË‘GÁ2Ç•A"'}«šæóÜ&Wºš¯%sÖ^ÓÒg§ôîDÏß%T=Ü’Þyäd1É°›1—xó¦!|»P))º:W¼g/÷4uäú”0¢ß,ïÞº’Þä‡C½­XÉd"æ>öÞÒzû2 LCÒ’vöí“* æï¸â°Ç¥Œ 壟d©6²ÙÉ¥¾ FÄfÞÆÆñ|R·o0œ\àai­ Cª«3øj‰eUȾ®i³{]ù¢vÉ¡_AŸ3KÂ[ûöé™o˜1ÂÖÛ#Vˆ¿ê²kÇÂC'\æp!Ú”t$ò£6‹Ú~ª¹ø¼çÀew¨nºKüÌ«íwÐÊ] ö5AmLTÛ¢WGÕ1rm_˜É¼ð¿øxû<Íÿ³¨öG/ò„£ði¹’ûÓùD-³{K€ñwow lKÌÚw:îú,lùæÍã#ˆ¦ª:L~€¿*ôöcõV0T¢]Ø®_S]x Â* öí äífŸÚ¶„èWà‡· j,Ø}«‡ºlÎ$A¤ïŸ^h7‡&L§œ“V¼f¶²Vÿ°$’'neçÀ» õ¢ÐÉH¾ríê~|}@æ´ AU…ûzÀÊuoÂû;4÷‡¥NA;†èùW- ¦áv·mj[©Jü8­ªž‹¦;Òv Å=CªXE”ŒÚÑâLë’bø²_–2$F*nóij+óó¿9(9°uT Ç&7 Ì­J÷¢‰Y`{äÖiì¯zTŠõÃs#*Ž"¥¸®ð ¿ˆ-¨×)|`´] ÍœPÓ\¦þü“51…ÆwÒ{!M…æŠY¯jh6Óý=ûž!lÊ-’³bÁ£¸Î›z”žF>´LUè}³š­f¡8“ÞW^Æö*>äÅð÷SE•p}¬žÇÆ\Pï—M†t`‹HÝ~;¯ñÃ>`VÜ갛̒/SÂ'0ø¸Ä~T®HÏ›d¿ B£}’ÅU52º]Sy:ÚÙÞ)aKUþ„D«s~—(?ˆ´Ø‰åçÓ³y .á*³R¿Xó gÎâEgÚ°[C§w"¦–duÜn&d Šyé±ËŒô–uN«´ C.Qd*LÛ×?ôkKŠE,µâe•ä†´ÚN[ýFAߺ]SV¾‚>ts¦;n;ÚoGåDí.ÌóN¥7v½ªa¯Ð‹xfN ÕàÔf=ðÛ¡'*÷µh=›c‹¢[C =¸²ÕKHêïùY÷/ +?§C€‡ÏÂ÷¶ù1êd¼@ÙÖbÌOƒy-Ps™S/£«MõÆw¹oÝþ~nŸZÚ<‹´áû¦w}Õ,΃[Ù’T’&3 úÔ·7BŽ%+u]ŸšéŸ{0¯¶:FXº”îà ڨ÷4)*ä&«Ç×!-G*õ¨>{(‘¾Æ¦(ú@³µž&Ü'Ì%$!_>R4þ”°éx[ËiÖÊ šÞ«þXí¡‰a€ÿš†4¥Ãœd- Æ›ekþǶ‘ëÜØÇüÕOø9Óf†eKs½v#.ŽRbYÜ$¾‘KFÂΰócž5Ü•Á¼”ðØûkTJá 1•â “”µùWãHŸsó½bN®5žu²n#(Ì%µÕ£Ëþ(Fc#Ca e.ihÙ¹®™æß»‹ï`Ÿ µ£ÕƒÀÚç,|vÞÑæ€ûÒ.™ P2ÊÅîm»L¶ooªˆB€r`ØœÚÂÀ¼·ÑJà^mÃýÂM÷K‰-‡Ý¾lxšŠŽ†ÏI ^ÀÚÆûf\ýWO’Oƹõ&mv›n”ºÌ3«nó¡¨5Ì¥†iƒ’ëßÍê}^Ÿ¡sD±i»ð|ŸòÑâÔ“lŠæ«(P÷Ýu-‹Mº¶Í—ÆÁ÷2¢A5òÏÒ®¶S¿O y¶É¹»ö5èU´m¹Ý8°YÙõMº¨Ä§Y5FRk¹…åA¿²“åŸq™sSº˜Zˆ½éè~Õ\é v²T¢Ý¹zÿv8@åþÅôÄçÚή&ÒíÊ—,LDI9³â¦ÁoLÆç?‡ zOÊNíP—m´ÄÞ†Ñr¶êÖÚéâв–£¬—CÊ·ä[¼0îAˆ Nezö:˜ç¡”8¡ægéCòÞ`O¢tÊl¢¾bHcãçϪÓ2 ½[¤ ¸)†)8~ä.[Ÿ”‚èîm®½¦à­pôïWKªZ ÙIMmµR­ÍÉo·\˜î˜w ÉS0”‡ Ûe#šÂîÑ(ä…PØ<%ëõ,ëŠB›…6¾q¼’Ä>  f–éÝƳ°²¬¥,5Pc‹é2 šo {¦gqÒ‹³Šç‘PýÈ´ ÑñŸ y+ó<,†k5GsÀ¤D}ä©·,ðâã&#`‡ÝÞ×°ŽöjRGã\¾Ç­Ìg³–N5AϬ*J+Óå@eô<è4Uoà O§ÁÉš]ÙDlH…äçRížP o/!DŸ¥Î¢Dª¶.‘ÜZÖ÷Ó@¡#*¯~ိt üý©fA_¾Hß·Žäî^2Õ*ˆÜJa8Fÿñ0 ±„Ãþ:^ƒ(~Ñ{‘Æ{t&kïGŸêyÐ#¶d0¨´Ï§ŒÆÕÆf}€¯½žfëÊm OÞ.ùUlœçhd3bº#õo_X™/«èY1¤Ø îªv ­dO³A4ô­Êæ³¹Þ”/Ò¬,“8<[i‡/·ªjëb¹’F&¨Ûb ûïm-ø^0Ç|CÓÆ9Ä^Pÿþe†wëð&úñò(£ Üìԛ̣ö¯Z¶~WB¿81…ðaƒ¦ WDc’­{rÛ`QŸóãüZ[†n7•C­aëQŽm=•é*o›ÈGoƒ‡iZ ï¥bäCövf®ŽšQÄÂd9¥8e×6˜Nâxw½s-tí㨴§FËÇ€dŸ\º¿o LÈìöëj´âôú¿òE‘nwâ[>˜^kmßA¸³É-¹¸Cȸi­L°¥]ÃÆGOTÚDl¾Gœµ›'vR–A³ÖÉÂoq‚’Of4Ÿ¿ØûnÚåð4šgcŒÍ Vó¦Ð1-ÐY»™1ŒK.ó/Nhô‘TF€Vʈ1ŠŸ'ðYfò,*æ²Áë˜ètÖ³E¬Õ>•M'(áe2ô=ò»Ñsxdøh¸HÑu£VãõRâÃwñ­KŒ!×ÌaE)‰%@cu4ÉŠ¦õ;^Á¶Ã[ÿðÚ &ë/‹òéHIŒªÊÎt‚ªwë ½¦t=ï°\Â9Ó/“±ÝN/âÚOŸ^À¦}ˆ‰˜ùW†1¯Ñ&_ï qôÚë¼IÔÂÖ²é"nÞHô¿™"Ø 4ð=¹Œ|㪡ægÞÇ+ß©hì? 2VšâÐåµïEå!rŲÇjL¾ù!¼Å£í£{e¶Áö³9©L?CÁxä&ßbBubˆßÍý’žÌ?w½×.Œ™›–jÞô3•½Å{’‰2þúõÓ¯³;èìšÅMø@aÁYpŸcû¨qºÉ-ñ­7ÉUQi÷E§ÈLOLN±P×cëš?ét.—Ip3½I¼6$UxÀùÅÞL%°‹U(vS'츅«Ð;)U„yTZO‡D‚eà‰&k‡IÅ«„ÅH›òJn³E¬«ŠªªpåWÛy…vƒOÀA£µï$ iàâýá)æ¾û!•·mö¬â'lHJìCyò¢†¢Ç½)ƒ*ߺôNÍMp‹G¯ï¤5î(7(ç¦'½çy\¨dÜ6ª¨Tç3&ì–ÃÂk€¥$ÖãYˆª¨•¸|°ðœ+Á¹UiœìŸ“yŠ°XehÝ‘en¡Tâá†ý¬[FÓ^W§SU8qíWŽŒòJb‹ô®\PØwÿóÄÆåͦ=°`ΪaÕÀy íïTxvfA¯þm J(ßéÐÕýB!9ýCxr`ô^O%í„ #d3rÀ€ÈrDŽ»$Ë¢Ðb ³>Rªå?¬ìÌDÇ6”©6¬X›~~·~¦\èü1í„—´ßÊ‹æˆk†,(IÀÕTÃaµöõÒX‹ú]F™dŸXußk¹,·Ý‡®Wæp×’–8#ÌÇVh• c`"ÊØÉj6òîG1J,œÝxÆFFïòÔ–u‹íP¯^£KO,ûC &…¨­q»H ¡—þë/?¶ñêZÕó± üãߘšGö¸ôtâµ€D;eŒùïÑ_,Ð÷2U™¤¥ùdN1^+/9ê e4M¯sW¾´r\aNWs·]ÁÌoô¾„»SÛÐ,bI çeÞÔìš¼Öûy™ÏgüĉRg+ž¨Ê¢Ó·Ä!ï}­mZJ„e¤Ë³äõíG¦:™ýì߹ʮ­vTqñZ„ ý^f1„‹ÚØã|@ë˜*·0š6LN„ìf ¼"Ud66ëæ#Gªà’Ù w}òr5Î1ª§b7;IÊM™¢é¥ã4‹£—Œ§ADÊÅ’UAž¯ø×Àõ›ôr©5ÉóA»Cóš$àÀV%äj bFÿ)QF)ÞüˆÛª>-²‡$=L¼Ð|·©«Œl#“v-¯9ú‘‡ÿ0ÏÛ–¢2±õ#'š—:t¸ž}$ã¥4ö^?yŠ7êGôõa¼‰ê_?C9ÓMÔMŸ»òÈnÙjê{uþfŒC½øj±#òñ7F–¯ßÇŠ:ŸÎ>3TŒZÌ|=îõs+?ÞoÌŒY¬Zù½‘p|pÞêÐÆ… 7¢iƒ`¬¸’9 ÏÄ'7TÍ5<¾©mÆ9†íózµïFÁ-¨iÃr¦œŸ±i²}ÓäpfCYG÷mñL’3O+ü¸u…ŠºÑÁ·Ì[‰o‡EvÌo!—Nv©A‰‘»\ÎûAÝœÞÔ9 â£<ßòìËt‚iI‰VtE2ÚüŬoG„ QXs>¼½È_³šmíï5’áÕ¼{xÐÄN†R²‘\£ ~)e¶­>ùµÒˆq?6naöee ¹ä¦+x·*¾¾'R°(ʳ^öŽð¼ž‘ÿÝÌÇðEQ¡6Í­ïiË4@NiÎ@E•FáUâ'ãûÜÞ¾ öüÀyxž–ŸØ5¸&y{ͽ2–EW~¶`×A²F©Ç·vãvS»¡œ-òJ\§FÌÞ>„¬®»1¸U+ö­ ‚>¥pfÜèngz$s9ZàŸ¢(^ŠlÄÊTxm.ûα¾­VúQÒ5º}ŸwëÐ÷¹¤º¹8Y· ˜AÛËìå)þ÷ÑRر?‰îô =‹1ö¨GQ¦œØb‡H¾OÒÛlͽC¤Ê¾µ°îU¶'7oö»x»V¬òИ›Qe‰Ù÷ûèB×îdòFg² :õt‹§tÑ~Ü_Æküè«,ÏZ s%ɧ<:iç ÷ZºoY|lMêõ,cQ‰‡iK2|[š›ò ɾø`o‘’6s%õ¶ÃØB™‡ÒÜÙÍ?ÉùïÐÕƒõ=­³*ã q%ØÅêBÁ˜„ø¹n‹’¦À³æ,ž*¡5÷îªF§Ô±´ø~ÈËÖM…I#PŽÆ:WŠ$Ù+dlu6¡سʜür ]T17Ëp> ìC¼9ãa á¼J›²öö,Ç­ÜRÖSO¶_hG¤bThm¯O½O#²œ«QõìòãsÊ]– ?ˆÙò:¹9&"ºÔí2 ›ˆ‚^ œÍ%#¹§–Ñ‹::܃¬‡XŸ°E}"iª´:S¸Ù3Šcï›:;%7œ_üäÿ vðÞ7žúBg“]Å37}%mû“@|røþÅyqënöRZpwÚ“#fià$•q„`öÑ`š]¨²ÇÏÞ´Vê&݆8ËËXIÚ¤‰Ç 3C;nƒNï½ì±> ïú92`{¾8çU•AU;´i×e:7•'ÚKWuz±››¼ÐEéîÈ£)O†9‚ö£±MfP>7•ÄòÔ/ëA¥–f7©™FizØ øØ40{\ÓÓìY\Cª€Éµ\ I±hœ˜¶ µFíD iKiv“{Í^± 8ùèºùÌât„ŸóÖuPS ð3w‡°Ó¿Ö9׶ÚιªéÃ¥Oº£Œ;l†S$lM¯c°¨ •Ö>ÑÀ뙀V&Ë™ÝK¹î&IÐXL°ó­Ôý°pk+·pèxF%ZQRÅaäÖYß¹¸h8ª’dLìQƒY:KËa©}íaÓ'âfæÏØNÁ¯èSÿ¬‘‡P¡Ç‹b“Œ!½©²ñŽø42¿]yÒSb=P%ßkLGì“Ј~µ‹f€``ò§5Tÿ «m‰Lr(%{)]IìðàåÿM žÆ°Ö‡VDåKãô‚Yó§ uÊü²X›0;³ŠíÝbñ²£R’ß(ñ°¤»‰ÇÜC%Fc#Î(§‚æRbéÉ’Ç×ûÚJsþ"ÊAŒ)bbFt+R#^[~˜è¤~BL‹é©6E‡áóT;Ú¦Üå»*¦üIº?´ðxö ówÙ¯ïüÁÆKƒŒ¼îfÌ•_is™ÞúNN»ó _´ÎîÝ¿ŽÈ¦H)« ¶@+-$_9,Ï°îÓþpÐ}¿•ê«/½ny¿§óewH sW¿y‡±lÑÕ~ì>.î˜ì»Ð0 ŽO»E¥ñSCouƒ²dP¿ƒ5£'‹_ËdHzì·¨‹ÄzGæj`ÔÞèi|Qaõ7 ňE¼ÒE0^{»|éÒ(li˜óBÝ|ëJÔë¿û´I‹„%b#8Ð]IÛxr¨×¥” ú(oÞÀY©n^©÷ÞÀ“Ÿ¡cîtîëlD5êŠê;P?c¼1ëÛQÔÛÅn‡C‰ô‹ì”"CÕþ¤éÁæ`‘Ã…šDo½iÛ7ô¨²¥ãŸˆ ið$Þ[í%>_nv¾IüÞ“)O°)‘d dÓv˜máXéyi£™hi)a/@ÑÅ9êâ'9Ê9LËg“aRn(ptçþtò-j¹ùÜO§I§õaâ` ÖMïÜa¶vZX+Ú•‡¯˜ðH8ˆI|ƒ òCJĉ]^ÖNe¯ÃÊtÁ—Å‚ÜË€“MòðŸ>VƪüÐìíHKa›A(¥Àh%¿¿½VÚeÃìvî{?¬ã0ï:•G·4ù%5u® Ý‹BB4¸8ÆÙ•ç,Hwüþ¤w¿Ø^³ë[³ø.Ë ß8wÓæ#¶)ÑHËL×Q9#Å`Å„©’‚•Z‚,jg톉ÁcšÙëªÁ¯ØøF*e9iŽ@›)¦®e†kÖ[ßsË9/˜ïÚõëê}…I°¡ëá êj€fFaJ¶û?voYüVªkøCôë‘A ßçÉ¥AÂõao”ªÌFÍ=ªEsò¹U:BüŸ^*íIá0ûÆ ¥¥f†•/y­s^Ö7áù^¯H2chUtŸ’àÉž–·—y†äGk®R ;Gy(>Óßòo~-U¦åäV'O+³]¯ŸÚn…›„2ú¢ç }„ß3ü~“øCjà•Q»ŸL‚8˜Â~˜\Èü/îëÒ nu+tÓ>Ú5|&Í©¸FU’aîµ ‰YM³üªšæÛUÆuPhqIŽ×»Â…Äs4‰‚Ç ÉPsÚËÌõGÏA„Èj¥]•Au9Þ"|t=Î]+œYËÖ,ᆆJ¶ço,èìåì:¿-ûÕL}³¬f$rÒZëøüÆúi]ž|«‘(ä)0Z·½ŠCañ! ³ÛÏ&óÂÄ*5,qJØ6»G‚þ“vƒ…mQ¥¦ù(Ûó¯Å{ðÕ‚[>ORÜôšZ\*•ð}¥GÛ0ÜUS«Xøü(BçúȽk ÛŽ¸Žu‰Ê³Àþ^ºkÖ0¼Ô'kÜ!VÌëV> stream xÚ·XÓí>ŽtHŠH3$¤7º»[Z$Ç0jc›twŠ€4ÒÒ-Š4‚¤Ò !¡‚tó›¾ïû­ÿÿº~¿k×µ}Î9÷9ϹŸç>Ï6Ö‡FüŠöp;¨ÜÍ/(’(ëêj ‚ °$DÌÁa C»Bÿñs˜B‘(Ü]ê?ÊH(ñ©€Ñ .Ü õÄ ( “—B ä?@8R  ö„ÙtZpw(Š˜CŽðAÂИuþypA¸‚’’â|ÒŠnP$ vè‚ÑNP7ÌŠ°+ÀAÑ>ÿU‚KÆ FH^^^`7”é(ÇÍð‚¡†Pé µü¦ лAÿ¦&@Ì0v‚¡þ ÁÐ^`$€q¸Â Pw&剻= À¬0ÒÔè# îuþðþÞ€ €à¿Êýý»ÌýO2»!Àî>0wG€Ì ÐWÓ@{£ù`wûß@°+ ŽÉ{‚a®`; àOë`€š¢Œaø7? C Q(˜ëoŽÀße0Û¬ên¯ wsƒº£QÄ¿ûS!¡̾ûÿ>\w¸—»ß?–ÌÝÞá7 û' ‰;Ìã TSåo ÆEüoŸ# Iˆ Kˆ ¨7Ä ø{côOPð·Ã!ÀG04 0(æƒØö„ÐÈ'пÿ ü·E,(°‡AÐ;¨#ÌøßÕ1n¨Ã_6æü‘0o€#?Aè÷ë_OV…ÙÃÝ]}þ ÿsÄ@]U#ÇF¼SþWPI î ðã𠉂‚  €8æ!à¿ë<Ãþîã?r5Ýà€ßÅ~÷‹Ù¨zöü[\O7à¿‹éÁ1Ò…¸þ­tK(‚yüÖûŸ”ÿ?™ÿ®òUúÿv¤öÄÕõOœë/Àÿ'vƒ¹úüÀH÷ 3ºpÌ0¸ÿ/Ô ú×ìêBíaOÜþ7ª‰cÆAÑÝ#i~AÈ_~J æ µCCœþ’Í_~“ßç s‡>„£`¿¯Lô?1Ì”A\0× £Í¿B`fäÐò· Å Õ÷¡êÛÿž>!Q1‰ûcc‰ü1cjõþ£nPÀŽÆ¤0œp$ñþXÉÁ®'ð¿<’ Ý¿,1!Ðñ÷͇ٴå€0%`ÿ†€@×ß þq €p7¨#ø?Vÿ£€&Åûù_Ô OH ÷?šÄðþÇþsË@¡ÞPñÌ4"î\Þ~Z£ÈàÅ¿>"ƒ·›qúHˆ¤ØšÝ£:n³’lô"gVû•ÚÌA5kçN=%ÓÜÅÏ~kõ, >"Çü,j›Ž,vϦoŽoM¦ø0ÞŸ&oÁ*0KSb–*Eö`=dŠ£è"’·wì1â ÷P×ý%Å‹“ºLM\+¢]¯£«¦,G‡†QÒôûWCt«]¿ñºè!탼¯n‰a«ñ–1ézY÷µe:Έ“½ª)–ûûç)?0½‹ Ñò ]ßcDSªJ÷3ªˆT›Î’]æ•zîdQùÙ©ßQرï©XâN;­ÓÛwZÛß±båzÞ%îdûÜ!^ð»ï%bžZ)™_´k?—Å‚ÓÜ'—r‚2í΄i¼_|ý•ÉE+*BÛgv²{lùò‰vº¦Åho8Ÿn²ìuåÚ÷€FŽ· ž‘ØmjÒ(×Tyir¸· {Ù]_ÌsELš YHd8µ˽œ— o ~D),Lê ˨2!6~ë#(1?öó¹.<èèPâœõ¨ŽsO Š÷]®Ÿ÷Ï*.8ß4@2kã•}½ÜVŽý«½W¬túÜà%¯}ÛÝD,¦|—°ä–owƆ'Ð ´ÅÜ=·ú!úˆ¹û™=V™^~ÅùaÍÇ^x;–0±gYHüùŽïÕv@Ñà‹÷êá]iÓñNG±¾Âl¹¾›_rméúÁZ"nŠ á+Cá¦éVê~¿ÞBš¶5*IÊ•Ø“õQÝçkú äNüw渞’†Rô‡m%'Æ·+.¶æÅqOÔ2Lþ¸Ý^&B( Yþ-gçPØ‘þ G–ŒÅ¢Ã†åÆînswO‰Ñ´xé¼7tˆ ißì>Ë:쵦Ùï—Áû[ðÇj(ý$îðçÅ»öBû­^ñzo^OhÈ©íνHê1O%kÿÑP+èü¸*̱Œ ¿SЮ£5GëØ߶Ã)¡Ô.ˆû—yØ.Ä‚äü|¯î–¸Ï©#ñ ':£æˆBN¼ *Ä5ÿø¶Ã´5|1mCÜÃà*âkºu°énx°ÜÉd“U¨®çÁöõOKJ5ƒ 4Ks?íËÌVŠ4zº„MLtÉ糎·KÎÚój%“ EˆØ(á¯nßÁ£š¿è9Ü囥œ¸Eþݬ±NhÏQ¹È©ˆÁéð–tø¬QnÁbe¬züÎ9Ë°?6È{A²¶F³ ÈÊ Xp•Xó}4ŸŒ¨;ÌË~¡Ájz2bßÄÚ,m/RXd\B>#*Å·zîIÍÑN䙟–æõ½Kð(¾šÊ—Ôp¯Ø`bÉ«GìÑk'¶.˜ yÞ:¢MÁ!ý4u’$½íÐÚ$³ç¬}ùt‚Ý¥Åõx‘ÃæÐÝŠ"Sr•ÿCXþú=°ÎPýüY†ñèCA¿O!wè©ÝócžNåªÍúÙ¿nwÀüú#ÿµ_ŒÎøgtWñ࣒«ƒ/—ÏO~6.Éɇܙ]k0ÎÿÒÿiè•5±"EÅœ mÝ%îÅ´m21¾£¥ñ¹øÑBž…Þ˜}TÖv_&[ÌÃx§e`èܧ8x† qŸ=Ód„ü2¸.ø…¨Ðca)ÚÍ ý2æêc~‚§7SMº1.¤îýÓt„}ppØÂ+½H!+ ¼r,rp#»Ëô™ùÆÓg®ÚÉšç†öL­¿åáó¯;ôº;EÂ|<b=E^•H¾¼W“w_ ÜÞ@I5ßÊ x†#V. úicZC3ò&ž`nX*Ö8ÚwQJŽî½vý)畼øh[櫆yBM/®·'ÕÛ;ÁkjüìÙ÷³í¨Y¹}]T íÐÒõ}d[ÎÅ-^¸¬éÑ‹¼žÀ9Ë<\ªŸ¿qVäɶu2xU[GÄõò›ôPH© K¸2Ânó£‚ôi·2–$t‹SÍ‚+Ž¸ð2âìÙÙKùÚ$VìŒö6›ÃªÊq}B³ÅOØ«eyeOÎ@ 'I .Àä*ÎjÑ£ÛãegS_ˆBjù—tÌM¿²û.ò(×bôdØ™FNuÒ¥.¸ŽõQO—γŽ¦Ó‚¾$“ôšãìU€n”ë¹±c¿ûøµOö¨IoïÍ%*Bw>'!Ì2âoŨ¶Ê\Û`ðm YЫâL¥®>e"¨Ð)”Ä–îÓ¼µ=ªæûœýeG°É 66Žëg1oå|&"â:¯€ÚP `=Çùœ]ªKJõ¥y­ÜûS“sÕÏtï¢:£·8–>Üî÷äÛrM7Cµšè˜ÏðyYú\Àù4¾óõÁTéŸ4y,èd±u©h„'¸9Ú•WQ¤x¼ªjÒçÂë´äÌOÇœ»£ÕM¬Á͈48~ÖÈd z\dLk§”u¡úN{"kàU¨-N#zÍÆ •ú™¯ÐĆFç¡|Rcßà==åª #Ýã)Øîé¬\*eïèIôúíõ_Â<ŸÙ̺_¨lKlƱïOøïç²6«Å. Ƕ\ÓoÍê¤HÛÛ¤ii²7µ¥u›÷s}¡¥q3ôؼsR¤eA›è0M#É—V!VÿõžàyÑD €äÍN9£ž¼`¢|!ÉÁ´âdÏ’+WèªÎ­ÖQô›|œ]“gT?¿ouÑU¸)ŒóÐ\<3¦–|6§ÚŠ]b¦ïÈ?›6ý.ž¼Fc ±AKÖÀg¾Ohé[|õž8>Á®êlŠç÷B0æ@p8̸6ÕTçj\ÔÇLÛß7xü`5}϶ MPì¬d¿a*[å;#<Ûe<­ؾaQ×Ñx=%l{å™pG†™ÜÖ55{•},ðíŽ9?z33c«æuï‹©_Iá%XQÄ2FbhÁF× ¶oì²6b±òÚ°4whƘl¸_<Î<˜´R¨’¡IKL ¢ß?*¯(Ä…Â{D)ú¼uT>v*fÄ6]õè½dúdHЉû‘ãÐë½!¤Â•:ìž_7;3›Ox5:V"ížiOûz.€\$¬Áa>Pµ(çÇ©¼jþ~D¶Vâû6m=Y…G¾½<Î^¢ôŠDûì›T‹Í`zñ3g°:Cîøˆà1Ê6„8ù0Õ?«-…«–F$o©”kkO©îŠŸÒ¥ýMknošKÉÊáÅmæ*·¸…E›bÅŸ»·MtQò±B‰Ü&U,p^'t% ‡öªöbHðͧ(^I¸)úÎ}ËÁµïГ¾¿–H‹?–\ÖXj?N¿ÛB§¬þ’,8EïS^ÍÓKþÒm‚Ÿb]ŠK'“}¶¶kÎR@ì{Xëƒo®M^rðœ‹1X~9hRÚXI™M’Ü^ÏŽÀq~ÜÕ»åÕŽà…•-ªŠµ^Mæ6_NÞš”ô í¡6ÍÛ^8G[¾Gk(oìž1g‰UVÖo‰ü`Ы·3q*e ª:¶G¯üß ø¥Cj¢\OAO‹¢¹Jifƒ” 3x~dlaœyÜr`pþ¢—’7°«¾JVÓHpÃâ^º·X,ŒW‰^2\‡e»²ƒ8¼]X¯”3¥‚%·¾ÙŒð¿ p ÔSøö£ò=éºìë §/ÛÜ.ÕÙ­0" »‰¤S”õ½Soõ¤HBòZý“ȬÇq?«WÕ¨çÛ?‘ò±ƒwÃè çjÎQÏŠŠ¿XºC\áµ¼A„QÃK¸ÁïT·£ìvãø”«<º9#¯ÝÙÑ,ÊîÌÀE¾µœkz:póõ ·õL^iCÚßCȬªÎq˜R¹‹_[>Ýj†wŒˆœ±T¯pw’b¿Ãegùƒý²÷;M'UÙ¾°Òè«d+$À8¹+€´í§fèÅl¡º*6Ò’(ÜÌëí ¢štâ©dÈ“+ŸV×eœg˜_$ƒ1 C:#ÃýÛ=œÌ7}Ûõå»8¶íæçùöi·š'oøW„K%³v˜>™ÄFí2¹ÈŸýb[„‰£´´ O­ìl7“îöéÂ:ú[8Šúy\U‘¨‡Z®ù ĈʜÆ}!N¼ ~D,‰ön`MŒÝê¡0«ìÕƒ­çé„\;*2ÒõÎ5›Ï—f4×Ï„PÔL…MKŠ Ž‘ê)õŒúb!½B“—mŸ‘T‘ «âSÊO­••òWâ6k¨eÏÆlÓö©s\=^s Y-tfêA^ho>Õ3}—/G¦ü"±NÈØ'£¾Kiû0Ðè†EV{áF^õlC›!;›³ž÷ ¦iÉ.DÄnñ9è=îÀÚùjnRPé†×ȃm›”Ÿ(’¼N1‘èíë?ãA n3ž‘ª–»º”Ú)¸ð K&Å»ç&ÇùŒFVÓ„Ï40¿ÙÔÞú¢mjÆV!A¿Ÿ›ŠP•êð|‘;F£ ¡"IÉë®ì–Õ<ÚŠ)Õê³ÝxþˆÛÐ{w1yëÎo"Ñ1Y§26Â6 ºí¼P?6¤1ð]+VÉíÕÈ–Ý)\šÞ~'í…†k5ió›¼O—ÝþûÍKD“”wÈΫ—,Õ»Šì¶ÛûŠ.Ö\+9\}AYà@Ô·•‡Êz"Ú–M ûòªl¿ ÝÇORïo¯¸°-ä&+åŸûk‘pßjXâ2àSð=÷4‘W‘áJÛµ*ξ*þ™úf/¹òëâ–ú§>Êw)xXÍYÆ웚ºÇ+>qXY4"@]&ÿšæN¶JPcÞúÓ’9yX=ÊÏ Ãþåf:½ÄU©“•¶jæW~ë9" ¬%ïäT3PµúÕ.\°TjÄÁÈ©Ûâ“Pd®\üœÈîlµåe/‘¢×]í"â“·Æ×I9DEªbkL®fÈ(|‘ëSÝAz+ãèÌÀžÕLò>ÄÎËŸr‹Wž½#Éðç¯èPà†6ãRæýô 짤ÄιaÐ9§Ÿ,y­Îû¸k(O)¾v)¶s[¶…‡s8ÄX¼B"0(ê[Æøro§kê{ –»M,u=o[œ´.š_¾Ëg,ärN¸±[ç¡‘õGÇ3ðAÆS@T= ×æÝš†(Ó6/¬Ê>Áñç',<,‰jtaûéüeÝsõg”A¾pÑ°þ’ùŠzûJ Õ ”‹AÎnêÐ/ø½¥Å§A:­ò †þ©ÕY#[åÛX¡âPã¬bšR»]×¼8^ƒ66Ó·dßÐ÷f÷NöþFùëé飺üÊ!G muj›Ÿ zÖiø¡ïK³°½á!˜T¾Y;ï>nºv}{çå´1®×·r”G”qe‡S¨rv{_'…SÊÌ<öC{f`ÕñUq£Ž½\|L¶6A6©Â…ð”åO#=)‰‚"šŽ¸[/—Mä¹×& í8Æ.fáñÍÁ›r±b¤«ú¹3ˆô“‰+Êûy‰~ÞZñwÉ,ã‚Ò±iµ*:ÔIZ–S˜ûŽÞå2‚tàlNˆ1ã-Žûë·ø ó¹äJxFΉÆ˾÷ ‰F;µoî¶ùk ˆ>ygkð°èd:”ÛöWyºA_Ó×%Á‰HŠ(mj½uiØbx(µîR5<š‰PTÇVþ£¡šnérwðõÔ°ãêÓmD—Ãì¶;Î5V‡h¯ ¹}eqkÒí;T:Ä>-D J]MìÝ è¢ŶXÍv–‰Gž«ÞmêÕlÝ;å»Ð4~Ç•p=â“=õ3å–FÖºqc qʵ¢uåœ[*Pë^j}O¡_¼ÅÎÖKȪ"U†G‰ÁÁM@ ¦]ÍÖõN¹êï»o£“~.ÏøÞžŠç\*j´+d%îÍõ½MARõP¢‡Q×S”)5d'sô´ÞJÇ ´ËsÚ¤ý#õ3o³‚T€þj"qóZ™®ŠŽ7­ 7Øub·wÌ2Î÷.»g7¢EåXl}ª:¯ƒ{ÙòKø¿·ƒ= ß“ïAd Ìi>Þ‹ÏrßßY˜°côàud˜çe™I 8Ü=›}¡f¨÷¥ÿ©&ÎÌÍÝ;ÀÆ…Á ÆVŸ›¼y㥅ÒhóзŒž7÷ì&f¯¶É=¥mºšÐgãq ]±Š“MQS€N9d4xÜžj7ñK7‚®ÿüŽà¯ ¡bjÓpT]6îaFÖÓ ©ŠÞw.‰v3¬ìÚzf¿*´UŽ$'<)¿ð¡žÍL_zTàîtÔ?~ ÝÏ‹·ïq¹#ÿ•âJ”N8ØJî†WŸ47!Õ[Üw…ß®îãÁ„YŒâØFËZ°‡ÞôR ‚Es´¤É‡‹[ o­m#%…ßàåMÉÕƒß9_\ªÄн®ç½*®Šï¤Nÿ¨]’vµ Ñ˜j±Nh¶§ÐuEð¥c`øÊy;ÆÃÖw[ŠVB©Ý«4eŠïpi.Ñ`xKç÷qºäÛ,–“Œ×Àjù²©¿vþùÐe„Î#iª´l:«LÛîõ¨J"¤«’bÜÍ2²M˜úlÒ¬ß6Ä>AZÒׯéÅ™x÷3û!"œ¼¾€ÓxŽ錟Ǔƒ#£¤Í¡}×gwŒ\oŒ|l¯ÙEôîa›ì¶´ÈS¾‚¯2£>Ò‰…÷¾3:<áLžîé•¢éPÃ@DGS«–$RéXå–y‘0ºña+ßÝ0Þ‹ôÛ¦„»¹Š8<Á‹ý—›CªýŽ¨ƒÌª¹,»®HE¢w.d«Ñ$Ûáõ\yÊT”ÑÊ–µ•„Ë, Äý@‹™Ç fâY>Ñ“°Õ½Ðä+3çrÉ`ÕÉÅua€G5»IÏÁ0/ñ Wî%E=V¹<Ž.£:”wTëq1b=/—Ø"ƒÔMÌR&ÒÀr¨²"í|IÅ÷—cL‡db”¸õÈ+ÿS“þÚÂs' «y"Šxc—»Oây~þšyÚÚ|\j”N„µb©¦Å#'Í[j—@}³j?¦’øJ"¸vºVDß¿ê^=˜Ë\š`2°¤zz7B=Ž?íM÷ ¬Z¿iÊÃ)¼j>¨á¾æ'”ØüEù-ª“œ1Üm.|)1àƒ´Òðãd‹ù:YXŸ’Ò€S {Y­Ó–­¥Ø~¨éÂ+> I§Ç¾L=PS¹Ü£ÄÖC‡ÜRkrªeëÔíÜ­Ïq¼è;åÔ€]QL,Ððks2êO,eSÅ ´wî³S}Ò5{u-¹xÝr»`úÉMÖTÍñe[H^fml³yM·¦Ø åX^N"sµÃiócx˜Ø'ð2Bû^AíCqQÚ¯ös {¯C»¶¶ÃO•@k^ûáÓÍ£,p šûYd8"–lŠ"öTC#; üEd•2ï¦I"¦Bf~u„ åôveõãúl¸­…Ý¢×ÝŠ®”s sôP-Ò.5üåÑÙ»ï%}Ó)où}Ÿºµèèxe²ðCÁ¾DYÌ“¦*§ 2pßšû4XÕõÑÐ2gô÷ ¥¸Úk¬Û£RÙqÜ8á³ëŒ•M¢“mt)ÂÿTþa!‚5WcË#}òŽ ±Ó=õŠ´¡C~•û™$e¼²¬!Ã.ƒý‡4©IØGz·Í7áC Ó»¾ê#üZ±#ò ”Ëc‰R×ÎÙ³§Ú+’]xƒ^Ú@èù­HÕêðÖ¸s›}ð™‚(]¬¾XŒ®æ¸ÍºQ’—Æüm%M# dr§„> stream xÚuTÓýû6(R * £”†Ñ%Ò-HÉcÂÛ(éénH‡ð"H*HH§”t#ÂÆó{þÏï}Ïyß³s¶ï}ß×]ŸÏu}Çɪoįh‡´…¨!~ €4@YGG( &åä4†c!ûI9BPh8!ý¿Ê(ƒó©€08 ÐtuE@qi „´@XHHêo % P¹Áí:M$‚&åTF:{¢àP×çïG˜”’’àû•Pt‚ à` ÂÀ N¸Ž`#À †C0žÿ*Á% Ã`œ¥ÝÝÝ@Nh$ *ÇÍp‡c`C‚rƒØ~® Ð9Aþ¬&@Ê 0†ÁÑ¿FH{Œ;àŽp0Æ¥¸"ì (®;ÀHC ç Aükÿðþ(üO¹?Ù? Á¿’A`0ÒÉ„ð„# {¸# §¦-€ñÀð@»Ÿ@#‰Ë¹àŽ [à×è €š¢„ÛðÏ~h0 îŒA  áŽ?wüYw̪;e¤“A“þœOŽ‚€qçî)øçrŸ -{8ÂÎþçv®Î‚&¸‹+DCåç"ýÇ…`bB’"’∠↠þl`ìé ùþtãvðñrF:ìqk@|àöÜ©ä`P®¯ÿø·E ìà` À…#Hÿ©ŽsCìÛ¸ûGÁ=B8úB??ÿy²Â1̉pôüþëŠ5Íu”Tyÿ¬üŸ ’ÒàÅ/ð ‹ €BÂâ ܃Ͽëèƒàæú'WaÄeüžwPÏìö‡\ øw1]$Žº×?L·ã¾€ÿß|ÿ•ò£ùÏ*ÿO¦ÿ÷Dj®ŽŽ¿â\¿ÿGäwôüƒÀQ׃“'ÄCM!¿µ«±ƒ»:ýwTÂÉAÅQš(* $úÛG«Á= vúp ö›6¿ý&?çG@ô‘høÏW .KHè¿b8•Ÿà^#h7‡@hœä0¿.ò§ Á‰êßs¨"ÀH»Ÿê€P(')îòq–À ˆ“©Ä㻂$—Àíì°G¢H^´¸@Pñ§‹ô_eÁ®(®ï/>àzþmÿR8â“NŒ"Á2AÕAMß+Üù—ûe¯í$7æïÏ·&Æt¨=þk”‘>©U¬6ñ¨fíðVWÉå{æìØ×R ËkOÑoü,j«PÛ—£—ßð?Çy3²Þ¬ÇË1MTb–.Duàé3EP´’ÈÛA;Œ8ozß«ns¿{«HMB3¸I·¥µ²(]û£ÔÃÍCLƒm·ñ²Ø!í½¬§èÀÅ–áIº©lZ²-'¤±îó]½ÝÓ”ï™ÞEøkº,ïr„`(UeºUD‰*Nç’Ÿgºm¤RyÙªS+ß1ÒÉa5¤%íVÎoØ¡µ÷²“Q3ôki í¢9ž¸6ß»äx½uà W:»7¬´hß÷ÙE£‡är°9¿€i6d”:ç=;Xèúqƒ:0IÖ#³#?¹%XÚ>4'ÃÑúWe;ÃêiSsÍŽÁ8hûégËšCÀK•ã“®$R¨É²‚Ëséþ‰7h©x¢ø„xš…íhoAë:ù¸hIfúuâA4]Ø÷•õ} 7 Å %ϯsK_Mk—†Èìç—n_®~:€IzÖ2ÐÞe±ñ=E²‘ÊøH1LÔ¾bÅŸº!3¿oˆ®—6kJ+Ââ>G¨¨*‰v#öîúÙ4ed9(讄øí»rûµ§*\©$>±’LìV»ùrLÏ”й±M6 Ê#&¤*ÕÎ5°žÜ0«óZaµ†z—¹Î½š}ÉÙ+$ë]fl;›v0üp‹-‚"â ¬5Ô7ázH4b˜<þ`Hx=O…©ârÒ!;‚`äÖYw¹–>Ó_ri¹m­ó ”Ç¥à“Wí”|PØ?Ü":¸Š%ÞïÇç±"°ë‡bÔi³Þ,wÌB¡RÄ'Â#ƒÂáäA¦ÅÛ:éôó]•Lç¬òL¹å7;(_ùt„YËAÙ&k¦»>¸`4HÌG隶¨ƒÈèV4V 9ò¹"ÚºØ2B¨Š*¹/è/Š&ÃR*- Š‰ŒÍ_Ä.®.2dµœ'4ÝDÚÕɹ”(”ܧוnßbß•™;¿F4>m7¢ý}¡-‹\ŠPËÉ¿Ä]}‘nÓø3qcQ*Ó®ê¶:!C/}ï´zæ>‰ÐüöÁéŒûÔ$˜E¢¸ÂûUUr/d›¥§“êšh©ò#Â[-üºÓ§‡«½iÕ*7&8džö®3“íå¥a§¥šÆßúO<Ù{óh—ªŒ÷*1a ùžË~fzºÚ[Š P³ãáWœjxÞŠää.3W¢I›^©÷~Ãáz?=‰Ïi š>Íi}ÊŸ÷l„k A')™¢jbEªXâI¯#3©åˆã' Ÿh¡OŸ불=зXê3uNÆ0–ù-º_òŠÛÖï´1vTîùöõdöY”ò÷pÖY݇ 6Òb­Ä¾µ+ŠhK6š3í¯9w¹T ©î £¦QÙ"þ/‚«|#ßÕ÷ßsÆ ‘–™í o°Ð¹âJƒÉ<Ó¹0ˆôe<—Pb9YÑÜ\»{¡ïåYÍ  ^_{Gý1Í-ã—‹M<<ؽý†©:ZÆå ®@Ò¼ú´hQp½I~eÚL§“Ùu8•a˜Þ¶©k¡ #üU•–Þw–Í[b5èY˶Ulß %bðR[N鲈SéLEš1möäM꬀§Ñ®æ0>2“ý>C"S½PLE“ì‹÷¸¿:¤8n–ûeÚö­•ãgVTMu'rƒVõv—ÆÕD×K8ö±„ßç®!t°%Ç–uEFí°®0hjùAÉú»E hÀ½ÎÇ!›+unTÀK5Æûq°4("û²v3·¿‘‰s&è‰.œo(ø P|ÿ³Íˆ*ÞêÁ”\zEë¤çɹÁƨ«7EnÞ¶Éä°ì -ˆíí¬:¬ÕÜ$ö¹Ø ½é²@¤ðð½mÆÂs $7ß—JÅL¯S’G Âr,¥þ*î¡)ˆ×,ªÎbŽÀ$ßѸÇ33 Ýü6“dÞ`ÙÔô³ÖèÖÉÚÑ»˜HH@C75!®)Yä;XsHç>’àDÇî?¥‰‘:âÙ7%Ÿ ÉÚ_¿­“b[øî|#”ý»ê‚§áSñ6‰9š8†£"ÏH¾xÑ;Ëm$¦¢;“Ò¯ôc=Ì3¢?Åž(-üUÙêô–DmØï3g¾z ¦)Ì §d˜5iJÞ;U¸ƒ¥JyE¨æøEðÐ)ñÆ-m2±)âÚ·œíýظ۲‡óꉗÚZÚÕ'n‡S|"?Öø•©©Òõ>z4Brðþ!Ÿ7¼ÿbi8 Ëx˜íG2»•r\ýè¸ã²+°eÃR©Ùn’|¶LÑHÈkhaîRཨ-íŠm(˨¿ç… 2Žˆ×ÐúÎuSÏ#–, *~?Í•„ðkÞé„ߦ“¡Bç‚‚­±C¥cJãJð‡ÑW ç žGÈ(¾ôn™êLh´r^yóù߆DkÞãFîr¡ ÇI76á¨ëëó¶GÒϸùuìÚP§__’¾ƒí_µ¾ ¬[ÎW¡ö¤Ñ>æ½ó±_ÀC –e9G‚ÉÙfÕŠ;¢ ÊøšŸÅÃÙR¼ ­7ÈÈýã‚/GAÒ¬ bä*Ñmþ©øÅ`'ëm+L8óNcû¨BUS•¥#~žôJð"‡-öÛkÒ]fo|}‹wÒ“ô»Í‚‹‚d¦Št]UbÑEAí™Ò¢ºjÖíªÆ©?£‡àtÖKQ#&ùÌV‘Øm¿Ï/Øi>×Ö¹tFó­>iŽî)k³^Ú8R¡¶=×ÊËšåJÎ ¥­ÒÉÁ²¯´d£ß’±5ä _4³ž½x?AÌDi·WéÕK¸VÇæ/nœ/ÿ [tÅŒÈ@Áð£«-¾Á Šû=D^CW\o/‘Mõ[QE…);ö‘²ú”åIh¬§ÒB¸R,F|“B9fMRBô4éŽÈF™Éz]7x`VžR¡!M·ýÛrÕª1éÝÜ-ä©ÊÙIÏOÏÆÆtòÙf'Èj2ˆSª—W×Q¼è£¿ÁáöCTL˜HËçÍ6ïQ|вGQv-oï¤â(EÆB>áøá6Þ@÷‡3y€»a{ÃG-¡^ºU0–PqûpéÁÐäS8f'Ilªq«a¬©?¦ÔÿÖÕPNuçÁw¯n™ú49j:Ïý |îg;•æò§W¨¥Vû~|çÒ®¢H  Ü#Ý7ãˆ\¿x3„ÆÎwõÈ ‘Uå»ÕÊÁ‘îI7Z+|g¾¸÷h„ó™/Ѷ½]Æ`àB÷iÒf«%l¶VZ™N†æ'ÃwUN'–«<òŸÆW·-k€ƒhD|û[5Ö!;vM,_ ¦ì%Ïr\Þže×Ö5a`ú´eùÓ|ÕoäR>‚;;aAdÝ(Cxp|%ëûõ÷Jꆽ,wÞŽо¦1Þ,Eù]8 îu|z4æµi>…·ú”0ŠÅ_úÞ4aö¸l¢ÄÁ™Á›ü{d.ƒ£ ;…Ô£ö®Wò<º»pŸ¿Š}D8!/nMôù•ØïžÐª²cm$î¶Íî1›çFÊ>ê¡H»Ïø°Ê^µ÷moOP._}ŒÌê˜R¬*¬QÆfhÞ“Â’êHjU:¶x­mËñ±Ÿ²_aä *–µºsZµð19¹xzÇd³ko>_~Æ…êŒÜÎÒ9œXɯ/äX<|¡l8÷c¢¸MŒ¶Ò¸›Ò«É»yiåÿ Aà"½køH@M³}ÿ” ÃFë¬CNØKµ-NßIêR±£:Üò¤Eª^Kk㳄ö\ŽÌž‡š*IûNo†&…¶'¥¡BÝŽ¢«­:(E´ëKÙÖåÅLöåÕ½1Ô‘S†§Â,üꬬ^{<ä )úHÖF°Åòœ,pFzO]<Ù oþ½uÄTxø¦ù}ÒˆW8}¶(·ðéù±¡nmÌæV¾7Cì¬ðõã+Ú¡ùŇÚîz ´î­õÁißM‡²‚lj¨C"ƒ$QdO|ˆløu‹åÎû" ^^ûzg"ñ%l2FS¨@·_/½ªããU|ÎÇxÁï/â‰ÕrŸÍ;ŒÇ,[ïRèÒì/J˜íOÝa£ñÂ×8DõÁÛ•g é„w`ç‘š<ÒkëŠFV ° æ¡Y‘Ç•%óé…ëqQbî'T ÊO{FK}W¤Y\.Ô&­ñp°¼ø1 ½t¨ .@hUj0$lZ™Ö@ºhŽ² ýÙY?Ô&ñ²Å-ù9úÂ$ÊWBÈOwĬ·Y ðg”M†HJ_kc‹eǸ ºÛ.Kh§}™uø$ÆãßçÞ;QË•÷T‘¹/¡É¼_5ç°Ã£Do‰Yeµ^¼TÔàoê<çSLaýV±qlØÿt73µKg(—L²…Æl07ƒ[‡ixªêí=?¿R*Èê"V\[–|)¢hÁ–uˆ 󣛀¾ŸLÊ_8òÈ…J"È})7 f‚Å%JýËcw‰O¸øá‚_SÚ¡H¥æººù—Å7T-æ¼ýcâz¨‚<aµboŒÏúšˆ›h.DÓ‡d¿èG×\¿}æÁz1XöÜã™ü6}õ[zxªÞžO_j (ež%lq$EÏ{a7÷;¤BîRχʉkÔgs_®é;œNenì†+5p(±3N¼#GŽ†Ý·þ1Ç”±’íÜĪ¯¤'—RÜÛ&Ÿy®I /´CkÔ%“CmËé_õzØ3žPÊíb鿉˄÷˜ã…ç8™ðOôq]t¼Tø|‡>$3,8óNÍ#†Î¼¡®Ò ¦«#oVŽö3#*˜7â-|¹$ŸÜMnTá;&<Û¦úÂ]árÄ6YÈd—µiŽWÑœ%o)"Ã.(bÈ¡ë’àI‡^`zUWÒãÍk#Ê’–‰•&õ¤ŠÚ6ïJá Y5—çÃéw@ð>Þ2aƒ©Uñ ë²Ý5 ¿Â¯øE›«¦ï¬yŸ0€Ð·Š®; =C·•‰o1áéÁDÛÚne:¼ŽkÕÔÍv‹ì,4“µl‘æÕ¼’k“½ê±1aÊ?ºÁÎYYªµ†-£«(!)$‚ßsÛ16ìVòòz‡W¨ïü…xLG!øI;Ù©IËžì®[î·«ž§Û˜Q™›OG_ ÜågæMžâ¼ùY]ν5Åœ‹ÇrFš•†Î³kÇ™†3Diì Vt¹cwRßܵ žO;í¤ñ ‹2@3ÈNXª«¾5[3éxte¿©xC-ýn†©O·ª,¤l£rì0QŸÈpv¥1‚Y”ڣëi;Çм!10Qƒr-Ù;º&©\(~½+B>Ò‚—:îöæ9Øÿžû±ôÁÕ•ÖjõýÒΑf~fQƒu“$M‹Tüú–ÇsíÕè¯c÷FTd¾ ï§ÂCª\‹¿¢Fð~ð³±³Ú7RDÎã}+Újº:µS,Ijñéq¨õP€#å :.+‚—ÊöMúK„¿*­BOðy ûÖØᯖÑ{ ”x—œ¼TÙó·RcñB'Tà á{‘»DS™Í m÷W¯KfvÕð&ŽŒLÎÖu¯Oñ™Õê,Ý(khañ£¯ôááµ…¨Lû } ¯fßrû\zI/¶çõ†JÖpÂÔºŸa©™0 òàëÎŒïsgÜ𢭒&¦šh7\ùƒµA* ù“)“Ä*ç1_îÍä®…gLžlÃËãôé»Þè–¶¼‚b>Ó×-K¦ñ×Ì#ÿR[|C sä@Rzã×µGå-é[WFLšYò*ÝËF¸w²ù(ÈòûMÐÂ}ùÖ‹—Ë ¤´º‰M´¾\y̤š¿4ÝL°XÕògS,XSº†ÛÝ„p†ÿA¤Y·áÁ×È"ßÕ—Q@Àg›ŽçÐË4Ð+ÓÝSõöún…t¦—äy²„|Ó¦<ôóÈ•V™1ÕÊè~1r¦Tþ³ÄJöØÔGGÑ7>›°!‘›9i“ýÎÁ;›í'”V•òÔ.Çlñ›¬Õ —Ÿì¿Óç5Í|XŽMÁ“_˨1ÛJB½-H*O!¼òH_òÅáêù½ÝI  üpì‚Ó׫œ4oã¿R²yª\<¶ÿ|Áë¹Æô:ß•é~]öÅêÌ•£û-f>%ÇÚávÏçG½’½Z]ä:>”¬ ²sZù[lð9Y¢W2]ŸºøzŒŠ$rtæÑ2S³·h³%w˜ž{Ú—iß´|*ͧ[˦ýb62ë4t(b]%’dËÚmq>nv¹••½ÐÆ´MûÁ/ƋжÜÙƒŸ‹§óëÃãi»:Ö:?;Ñlì¤9§_ï«øû?ÀŽE3Sº™õÝ3—71ó¾ïèÏemñoŸÅpC6ÓÊN^±’g„$*ÔÁ•×Ÿ<³èC˜¤ÝîÌáH¡®G¢ïx¿Þ+my$؉hÙܯü8ï>ÍCï—¹ÕºÒÃT»é…W|=%wk>ùraÔ;KçÅx0ÅãŽliÈMXJìô~›8¹o »@åI`Khr{'óÌ|ºð®>Iz© «c`TŠžÐÐͨB_;ÞÜŸ~ÚÑYÿ7ã1.Ù’ÒÅÈá×ÆFÒÉâÚvój±ÑO?Íæh²ÓnïZ¾XÂ÷ž=éç ªí)˹_™9ÇÚµ…&®ªêdò¥æÓ0ÓrûoIÙ=u_t¼J Í™0HÙótþ„¹ùH]ã¢S÷»£WÂÖ<!yJX*á|’[tšètõ¼?´tMR¦v®ÀÅ|AØî2˜òõ±wíÞÁ©LW$ýöZ†º^[ÿ‰NùC©0Tt¶†ý¥µ[,Äø“…¶¿LWï6ÉcûT4üÐ`‰àîŽöt#¼æÊCnbÁ‡ôûö¼×ßE·*Ç‘}’‘¯¡æƒÄ$›&ä=[¯Ð Ú@9Z¦Ïå銷ÔÛØ(n=îº}uý¹f#”þU™õqŸØ^ÖFHƒZül(ªâ{þ ——óð4ç=(4ly´EI0™Ýb¯¥›?H‡ß`ð¡{v+mµ¨b±Ù…²Ñ‹j¢¼Á‡wf  {ª}+½½$Î'9] æ73ΞTÀw½¦ì3œÂ‰gÅÓ,?·n-“þ•™’©Yžð ±Ý[MjàB6š×lœšàÝRZ VWG!s%û^ÞPãY@í¤= £œC<ËŠ©ÖRÓŸåº$Ñ3Û&;vdT€x~×+éæÚôwÞ>´`â›ÖƒåT=sÆ9`˜áJ¬¹ôU«„þ.žW|NdjÊ­LK–­ï~Pp#‘¾¡ÊcŠª€×2× Ähša˜/¾äCˆ¶ËËçd?žDæ[ÞP|ðú½"6¦Eö½i¹”HÉ"Ì8ËÞ¶ŠI‘OàÚš~årqÞ¦»¦hûË»võ¼¦œle"•ï¾0;#ŒË»¦šù"V4üz{àÉ1¯Ûz˜þU¹t endstream endobj 4646 0 obj << /Length1 1699 /Length2 10433 /Length3 0 /Length 11525 /Filter /FlateDecode >> stream xÚ´PœÙ-ŒMp'Ð8ww×à¼kÜ îÁ‚\ƒ nÁƒwwydfîÌÜûÿUïUW}}Öö}öÚ‡ŠLYQÔb ’‚Ø:1²2±ðÄe¹,,ìL,,lÈTTê`'kÐ_bd*Mƒ#bË÷/qÐéE&tz±S„Ø䜭¬ìV.>Vn> ï !|   ؠȃ؂‘©Ä!vî`s §—4ÿ9hM謼¼Ü ¸Dm@` -@èd²yÉh´¨ALÀ '÷ÿ A+`áädÇÇÌìêêÊ´qd‚8˜ Ñ1\ÁNU#ÈÁd øÝ0@ hú³3&d*€ºØñO¹ÄÌÉ輬Á& [Çg[Sà%9@MVðÞdû§±ÂŸ €¿îÀÊÄúw¸¿¼Ûþá 41ØØmÝÁ¶æ3°5ð^JÉÉ͉´5ým´v„¼ø]€`k ñ‹Á•R¢*àKƒµçhâ¶srdr[ÿn‘ùw˜—[–´5‡ØØ€l‘×'v™¼\»;󟓵²…¸ÚzþÌÀ¶¦f¿›0u¶cÖ°Û;ƒd%þ2y!ÿ#398Yx¸ÙyX {ÈÍÄ‚ùwxuw;ÐÊ?Ä/x{ÚAìf/M€¼Áf —?dOG  àäà òöü·â¿2++Àlâ0™ƒm‘ÿ‰þ"™ý‰_†ïvè²¼pÀòû÷÷Iÿ…^¦[k÷Ìÿ˜/³¨¦–ŠºýŸÿ­ƒ¸<_r2²q²XÙ8XÜ/ïÿŽ¢ ÿUË?®²¶f+ËŸÕ¾\Ó*vù‹´-࿃)A^X ÐþCr=N“—ëÿ3Õÿpùÿcøï(ÿ7’ÿoARÎÖÖ¨iÿÐÿÔ@°µû_/¤uvzYEÈËØþ¯©èÏ¥U™‚mþW+ë|YQ[ó23²r0±pü);JÝ@¦Ê`'‹?)ó§\ã÷ªYƒmAÊGðï·åÅ‹…åt/ûebõò~8¾ðòOÐñeÙœþão zY§ÿ®CÒÖbú{ïØ8¹@ ;òËè_ç ^Ôäö³ÌL¶§ÀKÏÞ3ˆòï1sq¾é·èOÄ `–üqs˜þA<f¥¿€YýoÄû¢3þ½D1ùqþF/Û ü[Âúâk ²vú—ä…ïÌ Á ‹Á—"Áÿ‚/uYþ r˜­þ_j±þ|Ioó|¡8³í¿ €Ùî_ð%¯Ã¿àK^ÇÁ—¼Nÿ@¶—PnÀÿšˆ‰³ƒÃËÈþX¤—qýÿñ,‚@n äùˆ  eM`ëM•(‘+ãæ¨üqÊ6ãègD§^ÉIõxµÌŒùR©ùV)Ë%1û›¬åÙsÏZÒ:wŽ+FR©sRãØ™ç+è©Ïkbò´&¨\­$1¾"‡^(å·èß„MÍ{ըмhjºç\©±‹¥¸å‚Z•Ú¿Ug(àój¬«:5÷«or^àÓd¯ÛÄüŠÔ KVJ#—h¿EŽw­D_ý>Ø¿ˆÑó¶3ÂOÎÅó„2Ø C’¿ŸX‚¡Rs1ïÍCv‘Ë~¦§±4–8®šb.™*>r¿xÞ§æc|½ mËŒ0‹ä}|´¶¼´í ˆoò-;gWOröyˆy¸§©À’”ªo{ólÈà$Þõ<üêà†5Ê·ñÚ /‹òâ3ŸC¢j–)&:ŒLZ9 ¬ÜÌw®&,(×ÍÒ¬ÉnY½ŸÏRÚƒø4,hôž³KI›±UÁoß.@ŒQc§uign·qm°~©ÓìÉNš­¥>í3ˆÀ‚G‚7ÎgM$V$°"xü_ Ï ÏÙ“P_ÝáØe£èŽïÀ¸êbvù¬8ì·IДD¾ƒÙU9kù‰¸H)yŠT°TPåÛ8ÊrÝÁùE¹4ýgŠ­ª‰ñrz—AÙ$bDe; !¥.€fP—UNL¿Ž|>–=@¦X õ‹–Û× 5/ØewzVÅET’T­™õ;Áœ¸'uÒÊIùÂP ÞB53²¨ÌÀ13Dý÷¬¥%"š yƒóëV'¾Š6#‰šÛ¨c*´ M¨“þs}½|Ò«æû•8¦Èt·ï2 ³ç«$–ìÞK¡†Å |)øº”ú"™ô,HZÁo¸¡mŽtÔïö$vR [|>Ýœ}ŒŸ\V¤1%Z<Ìç‹brE¡ 2 ûF‹–ìJ‡Cÿõl ¢ìh*E¼–ŠÛ@"‘4´áôû™±õ™k—Üýï™™ÌÔÀ¶ ،֨¨Ëœ¤¯÷AŒñ.tQŸ/·š¾ß¡TÊšþófŸç÷ëvÛÍê&8ÑïÑ;=½_m;b„¤ÚîÃHùvLõ¼K"Gû+9ªx“e$(ˆI§#„£c¢j¢B¦‡ +äˆ;39®|/G Ž&%’⿨®h “^ mŠÖáÂ= £dÄbóvççÅë9°ë‡JçvÈí¤ó ×}CÏŠÙEY:„-(ÞòѿØXž_”œïfàà'³Ì‚ —=ÂTÏX& g4ºVÓ?íÈ¥ô©~‹WÆÉßd¡'å7jÍ]À~¨n3H°îÊÖàJ©â¨Ø³A¹8¥ò)N¥‰œ‡¯0ÒðÆ¥;ßo˜,6Ëéh‚Mc½ §‘YtÙâ9ÔMÙU!×c'2¸ó©‡2eôýÞÃŒˆ?ãVåœ=›fÍÍ艥kàÈQž?´²Ž¶0çq$ù^Øc«Zóc‡[ü¶«ƒJú\Q x•èû3ônhïêÖA…>Éš;mJ¿†žËœaŒYf(' ݬ °.[ÿ3¯wËzŠM%¢å É»_Ü4w$%¬pq¨fˆÜÝÁÒŸ"p¶ebf (è&Ú‹bµ÷IòíV ×êüDEy À D5Î÷M|Œ’ʤ8â¶ÀÚ/E1Ng9Š)?ÞVœÙ{Ë¿åj[°rr­ÜÝfòêæŒR*¿Ëˆ·>¹$q·~?i©‡7\.s½¦Py{f’¶ß×{< ó ŠExy—H•‰*TZ?Išªà÷HxØLäìSg¶åŒ9§ñ´Ok%6ͲT[äš4üš¤e%Ûc´5è9Í)nHÄK§4¼½8$,˜IÕª>SÔñ³¸§ª‘Éû¤ð‘Yšm ÃÇô«9gᥒ³­MËw,2‚×FÉûJ¬‚͆§™è!Ù}V_yOjî㞥^7S²‰ô»Z=CÁ™Hœbf+‚*ÜMîýá§G¾K…“¡Ô¦9?RŽ©ï°´³>p%ïm!?tÖ¯D¿¥î]¸ÎëŸxVà¤"º³ ´Äãè[¥h!Ðx—ÿHc:Ðr1hN”vU”U“wDjA¡¹úU/ÝfE×^ié Ùsæ[™ÐG3R]˜SFݹô•ƒHW«U»dGÞÆÜiq)µË ž¯›×öýjÝ…h±…oÌá0<)2HÌrŒ›¶~L}ÔŽ”M¤*ç3zk³Úå È<'»j9úö ä[t_kħÁ÷;…3› Ùñz¸Xfí]™ám¶¶­«Ôd•'õt=º "Æš“µ_w‹(…g×(!8š‡âæwj1ïS¤/,T¼ïãàT«s¹±¶#Q+â%zíÝ"ˆÔÎîÔmN6•Ï¸ndÂòé/æzfbp‹rÃ0eVպƩñÏ'D™üfâC(¾ J¯¸äC'„¤KÕÆðëËPÒ×;Á •«ËïzªaS,Ú܇b[Uϱ6ê7Ö ˆ‹ÌMÄcGªÿäŸníòÔ/eJ•½¸Ý(Ѫ%ÿU9mÜËg†W¦¡ØÙ‡s!)ô0¯dèÇËœÖG†U‰ü~õ yªâ’¯m½\rÒÄ9?Q/ƒÎZÖëðò…V4œ×¢…1þ±Ÿ#%œhdÓÚ»…Ld¦ʯ'ûV;>mâ|N[/ôôÇ~ÿ•øc"l«éøcB§(…Xé$f©}Ó ‡˜Þ÷Ü·p0ÍŸº§õ  6gNU7…†¿£êΤi Åm¿:Ë–{`}‰{k‡§é·EênR½ô= Qü2Üãv»oðÇÔaA#©/³p–é%ãGC¤‡sVM?å¶Â°ô1¼@ì1}˜FqñÄ9ªN5ßÓAo®œ÷(¾!ŸnI³èz^Ó´µkU×­‚j íqçRL1oݺ»”.+¹ä§ÌŽ¥‘(@KZ>”£ìŠMvâX,Gúd•-l店è0ÑÓƒ0}ß_aYHÎ…·*&Ʀ®^,½žf0’AÞŽsÛ†ïÐe«6)TȤƒø³ 'ÚêD{£Š¶P8,CBI4­Ð< ²êíæ¯$4Íü,%x ¯/¹íÃÃA VrŠæwù8IÌ ÝÜ“óâ |„ÒZïvÊâ __¤Ü’BãL »âLéiÆ|[ß<ÅoÑN7ÝÖ¿ÑÍŽyR|¾ù¡’Þëgÿ㶼£}ß%Å£‰l1,".kt¤’üö)§[tg«0]k˜þ•“”9¯•cö<³Ra’˜Qy4úž(˜7~Þ&>”Ú¸#º€P+/Í3®@ƒˆ*ïZÃÎg«D<ÕøQÚÃ_`‹‘_ÊT›þG>ÒN<žè,†ag¤,Äß­AÜ€ÛtIyOÄ…3lLÒ¥÷Ö¡nÁ9ßt\@r@®ÿ#çr"+œ&UFû6‚Že\³ÄHeùU©“²]OøÃâ'k‹Aç¹n@>4 Ž¼ÉÏ’¬¨@†ÃLu¶»ôc}h%–VÉX¤žþË–—×£yW£”Ï(n«…¯ÿ«ö¼¸W©5@̗逨yÕó9LöNámÚt1×Z², 9üu(î•õÅë[èÈÚ:Ò·º±ï¤¢“DEßR2EJ/7ŹwQ˜Ë`ꔥ•c10Á:ݦcÍj]³1U~URVµ,X~تFcL²3’gƒ*å7æL¶Ý-â"æd%>çƒ.#Ïr’ØŽ] 5$kRÒYNÚþ£ô¦†õþ[jc.’ºÔ}ÙTô¯µÖÎV.ßF_òø)‡_yäуôG´$3t†|!f\½Hü¯ú‘û™\º³šáDn‡¯•ˆ4a·Ý|)3Ý®ÀOP8>Óû’øáuÝâÅÒ¤:$î×=¤ã­)íYî018/XkudmÛµ³]—ê5ÿh³ú’¸]ýáÿè«/(­'ó“Š&bcšÏ—$cYý¯ò(â݄ϪNtü£„¾0šº‹¢ÝLuzí"“:i¡D4›Š¯€çš²¥Eã`Ô¡{ⶽ‡f Å›!Ö¡ÕQà¹ÙåSvÃÀ@µÉ¼}ÛRLý µ†N2>©'ZÏQÜë£yså=»œÑ,Ó!º¾‡ ¸ˆŽQµPY´‡ñZ¬à𦠷ÒÛJè=ô¨€º|ï·¼ÒÞÊz >L>‚ãqe¤Ò?%K4ñ$%ôÄpÜ߇töÿâ!GgÜâ×¹XT Åt=Õ5¾ê™Ûá¹#çIäϯ±™2~QÙXÚƒ;€:¦z›âSÍK´ãB†;2ʽV:óîÓÚsg¶Q ƒ7íœÐ}?ñ&G1uJ€çê™Êä‚òçëûˆ‚_ø:ãíÉ|0· ã$V™¶v\]š„j 蛽üc&P^.B>18™‰*§gLÃ_ƒ ¬­oïšž”‡3^1?|zÛ,&×pUæÙÎùz;‚×ö¶v¥Ž¯Õ4jú^|‘§Âª€iÇ“óùm_dƒÅý£L^Ú}j¼ó›†-\%eÊP'ÖÍÀˆJIo´¡j@Ó×ðê‚M¨>8­;õÆ.ì%Kæ$ ëÊE¸*¹çÛ嬄C|ZÉaTK8¶ ,ŸG–©Ç5ýZ/šJoÌœ¯jXbJZ­@°&‰²pKn‚;è‰ s@–—í E$£þ ;0 ø R’Fšõdô!ïß©×ÂOæ‰iJ§÷ö›ŸÏ9 ¤q4ŠbD ÝÕQ€ïÐÇ:àÐåª,8ô@ÄNëU=óQöjá± s6J¿/D…smªG‰y¬meªh¢Ö9<¹0ü&óäÂÜUgw[³ö… ³áëBÇ÷ÑhêIºRzH.øÑñ²œT.ÝékèôÇW&™±ù)œÏqtjEyvžP7-HW F÷PÆnåLFTuß܇I¡ï#Ü×Òúmë7eL6;ál¢f3Þ µ-é.4ô5³€ /Òʧ•m~i9Rßݹ:5ª)ûR ú2پپˆÉåˆG±IG3ÑÏ*…Ñ„¥ýÿAps3"3Ê¡¾)æµÜGZ/ƸB*ØâäÅ—l– ÄÊä¼’Ò7Q®FÑ–%Z“,aU oòbƒ3v Heo¼×bøØ~ÕDf«Ÿ3E!9ÍñSþܘ0®h´zSíì_3C Xá¿ Ù.N…Ï5)ÇÍlrì—Z«“]CÇÎôð£2ÈQo"rüÚ2#vQbX1“ ت–ëÁǧZ©kæ0õ(‘êEc0˜ÖvùCvƒéä5"ŽN+l‡.K[{d§æ(—tDÚŽÊ ,böH×8¬ˆ$A@¥6õ4±Ø $ÌâpF–Óô(R32ù4žqñ×vF0õÆg+)NŒù+4¬:]yvÁHH¡ ‰&"?£nÍ°BïÙ Çh#ú|F¢} TíÎÃQjmÀ¥$…Jë@…'ÄšµJR⚊gøK“(‡øZ>öÆüR2E^Sæ«ó« ±zˆ.-GŠ”5±^ÉÎX×XÚ ’ì6^î7ˆFB‹»hç´‹e ûŽ[È 1ëe ¸7ƒÙÞ/ÚðŠ•ÆP\±Æ HuMê%K®ÞbŸrYÞ(Êëì“ûQÈçÄ JŠ¢‹½÷+ewxßw“×>¬#$å’ñ¸6:dæÚ# Ô¦ vw` q€;tîH‹Ø/ðZ&j´ÑЮTeS{RDý’Ûž3_øœŸµ+*ž£¤ÄÑêÍú•ÑBšn°n´NÔó3lGË´ùÇH&$“õÏ$ô0þ q“IOqFód²ùÝéCÃ趃x÷%§L…C³%ê$R2Qªø˜˜ :¿>óstÛ.0ˆ‡c|e£ížòÃëGØù¼vÇ!8¥„JŒÉбTdW†cŸ¤Å½å(iè7Ry:ÚGn)ºö4|°kJÒ¢)_úüuÙ *#¯$é~/²Ò~K@ØKmi•—²lor¼†¯Gx–Ϧq"ò gß$L–YãÒV|ï„ug’µ²wö£5ŠŠ c^ø2{c^v*Áû ß•øår vb×Ì–Yh ù§izJôñ÷[kÝœ$¨Î«ÛËÎ_o‡ÄpåC4ªXVüATõ͵\|¸hPg¸Âi ð»UÊ«Ç)š8&bkÏmEÞt첫Á}Âç žGÅöï鹿/ñ¨­'c²>ÿ ×FC/íZº"ó¶(ì;¯©6ýÏÓ˜OœÊ$ˆ×ï’ŸÓ¹¥æª¤CVáÖ­ùF<Ìq{‡FD=áÍØÃ÷U §ŽŠ:'ƒ`à>ˆ©Æ_²ÑÊ£ÈSÚ[“Üiˆüôë×OÀº÷„°Vš£CÒO•9þ´}‚á[·n@ê¾H©Zb0aj®m1ÌÕ÷ ÂÛIŸáašrRçbJÆSÜËÄæ: )OLfYîAÕôžp”_G”ÎæáÿþŒ®qjVúѶò¦Æ‰dÊ;”Ñ¡Ytj†þ‚³ñ¹QkŠ'PQÆý„–tã’T©åå ¥^Hý6¾£®Dï^gHsìùà7~A °ø6h„ÜÝà'ÞÍ·Ï'ûÌlôDNªé¯^‹H—«)Á íø™ªS‡17‹ù…O˜ÔÈ/“De#˜zC~yƒîh83Õ'q×€{0«gi]‰¶Ý×}“üÅ'Ô\˜œ³k•q˜Z+™þ!’Ç“fÏ8}öf,*s¾Ùÿ›ÊWÇ“^£bªö…J#iæ´¢D–Yžo`BÚÒ“k—4‡7ƒ'â«{ªŽÔikmÞôÐÑ]È\ßµ"š‚²̈bÈŒÅu¬‡ìç g7Tüœž¾m™,ø>I²vF%¦t“Z!uŒ+o_]Ã$3K¹*;¡–LñÑí{>×–ðLé†öÒu@‡üÒ4oNKÈn줨ÂÆ8°Ô±¾?±ôbw%vúÙÕ1»Œi•ÜedË»¼µêµ8:hžn@¤jë`«¥(ÑÑY.e—ËmLÃCæ÷¹/ÇWr) ½Ùúú®Õæ,–adÊXâèJ´»¥ÅXà÷A.“øª’îØæáU º<^›HTmWßsá¼Óhô0¿•|îQÛM÷ÆîG™©Pò(ü°€.DjÇ*†ÌÍWû¹¥ú ŠsÈ{zÐrœ]ˆ!ÅRÍgÃׯPüàdHØÝT@AÐFNˆ=kçÒâÉð§<,LRˆ-ë¥öHW]²ùé»óPÙ;‘¯dážÏ ®ŒÁ1æÁ-ŒO ùV<ˉ̀ݱ+ÃL† {2×ÅÐ*i­Ø ¬?›`#Ô•d:¹Þe¢2'Ðèo25hS jôÉzÉ&$ÑÛé„ÝlY4cd¶š~VE‹¥«Ø ­/§“ÑabBäç ÕoÅuÁXßé¶î°½Á÷R·Óv$Òf'uDÖ q=|ÚªÖÊðÊ–M¥¹|ë˜c *‚ó4ÍYá!ßKB^Dz1Zr¸Ù|:^›æ é¦Rv¼N³>Ó9ÐP©MS‘êý”!UaÒ~‰èØ#LUØå_°ò–œIä›3üÓe’ݸ“±´A£Ã”êÎ¥¤¾ÓTƒd¶úsè‘ ÷.솖ݾïuœ„Øö•…Ц)‰ä–X·Ú[TaäU­aS¦7JyÖ‹À>«ª«1–·Æ‘S˜4ÍC†¬ù>téÁÏuõ¾G±ëÈèÓŒ vÃó€¯]gU¹³atÖÔ1ÞôE·óañW¥Q2‹dŸéeÚ!ǾkjÍ™OwGíî~m’ìMÈÁQD ‰ÝŸå}æÑÌ$Q?¤ì%žÀJAæÓÞ *”-šy¼;¢¿'cijØÌØx¬/1÷z—â•2C7` ''ŸÂßX ä^³™ÿ\3:¹²^Ô%xà¢;y§CHíu Ÿ’¸§Ÿ#XgúÿêÝx¶+öèp§¿Ô¬Sµq–iËâm{Ù£ëÝ8>n=·£{~;LVc¤”½¾fÆ¡g3ñJkëF´ ”™šq»Iaö–Wfùhb;œ€¸×Œ—§±ê3©ôu^ê¡Â<{nÒ{ÞÏ+-îùoc)y!ò´‘©R¸[í‘_P]SÚñ+PàR?ž æH°î‘˜'¢b*Ø”ØLÉ ¦“lô Á¤&«Ø’ðèÛ_±öXÙ%Dùk*1Å”K³üÚÍV/öM¬¿.#–ã6u±MJ¸T>ÒÐÑ4Æ+ÓÛ›¥|õl1^ÄCªù¥´¬Åºâ7}ö$Ô——äÙ‡±–Ãfˆýn>ÅG' êlÍ©¦VæÑK&‰«‘öõFõµ•ï/Y3›ÓÆU\üXµÅ-áEezž¥nÁ¸3«ðÝ·kdž“› ¼AC5bx£‰º6ÁwqgG+aæÓp­XÆ/t_Û˜5›Ïž¸ùfœÍ=xçƒ.<„o6ò.û~íÛvL‹ ¾§Ú¥‰o1úX{0Sfhm  ?Z0‹°wØKt+ïp^Gð­r ›ëöY—ô½G±ºÆ£@Ú¡*.R†Ã>ºH?1FN´7çð]—ú×:y<ÆÆz‹Íòî×ï.=–W (€ ·!i'sÃOû(º:&‹ß8#Gn0v¦¦¢o©®¨&²}ôÆî!åÝ™ò{nšÕJwK¤^²o­­*É(žÛîxìóN—ªJ²ïÎl¸+DÂ'¹—›Þ§]«B]åÞ”·õN× #§›²ÚÄ¢Ö‰7 zÅ«ö¤-T!ˆE‹Œà÷¥áÙÛ[‡_˜ØÚÆ6¯…Çž`qØeŠ eÕQb¤Ï>owv`ÈæÞ¨óòàÑBB-Ïm)ö¥?ù*R÷cÏ«I+NÝìzôeI¾ 6?³NÛúv@}nE‰±¯jÐcÝÑj¤!ÂÇgšìá0C4CR:ëÐä͵ØJ5äŒdÊ6D¡Ýjö›Œ‘´ê|ËCÌǼ+é(’Ëzíi®ÒˆÉh ˜spÝ©}…Ú–Öc/üŠ²oºn8GÐÕNtW×ÆìŠl$¶Ý ¬Èá„ l8^¯Ã1ï5zDo¹cõ¡3°˜þÇÁ>=·ÎÁ—eyw1ÞŸO(ÜŽ¢#ÃíOS‡`¹ÝŽdª5êT®«®K¥_JókÚR°c@x$%œ\¤Ó£1¨°oŒä0§Ž{{ᓇÝ~½Ödj,(Óüãn)`Ìsàü Á'õ0ø€Õðy–ÎìWh{« ‡»¥±Tñ­]z‚vZ¸Ç •ÉȼïÑÞð~òíP°i™SÁ«x||’©™%Ô€ZLõÝkƶy†žM?PlabÕžJŽ)Úýebÿ*Q!Æÿéx.¿eܾ!î…]µIßûÚNqòÊte8žpb”"¶lÄuG¡ëŠÒ ª õu¯©¡“^HžÂ£\-ï‡Q8¼vç$…´Hš^ZYÀ-ôÖk¦Hõä/¡TØ…®—©ë‚ƒ.ò?œÛÈI´)Qq B•Ã+O_ÃL:RÔ¦-Ž5Œ¿:ÁÆ~³ŸaIÆÞ¿òpÞÁÓÐÙºuŸ²¿†\øUeu釤NO7â¹bð+A|ÀBÏ/_mó7øôsˆÿÛ*{ƒy;dn$^J®â·…wD¡›×WR,y¿â‹w«DÑ¢<ŸýNn].¥åOrªcJuAâò£„®u `îs«@K—ö±Éüéþ=ïÓý„ˆZ9ï ä›â$Æ´ ^%×°¦ö ½v6‰ª†xʾ¦H#å]¦ý=Ï ‚ýX]ßU«rõÆ)ø|WÿJXÐÚ¸‚u©y½Äÿ/NÄ–µët’©ÿ2Æu±/¹p“¤þæ.·±WMUŒe~îf—]…Nuø¾–{P`pƒÑr´,ŠzÏ’^¨v¯9U•„­jœ´¸Ìêý.ÎÌ¥Y¦Ã}_.Ir~ÿ½KÂç£í5³¾ ê¸WYs°¾#…€wP;¶±Ú+8ì•€Î5ž±lrÈêÍù·é šG¿ ¹ªî¹ÔðkÓMIÓºæõÈóØ€n¤¢B2Ì€â³'^ïÏ1Ø„Ø !›ïl܇óåW¿‘ ñºÄ0·jý¸RÙû0(óä§ÀÆwgôz_û°N]¼³³¨xT8².s;Ã¥8[jG6óyPq¡éµ›UãLa';OB81d úk£õyx+•›^:rVÏyI¸*Ð:¾"*â7dÜvÔ¯‡¶v¤?'^ÿ$’ÄaèV:÷Ä'·QàTÜF’IUNE_ gàK¤-ù‰ÎÒi9ö)˜$/ð¬0ôɇ¤\ÔŽ+  <ŠLökßõóןRøŽà}\‹ÍñOÛL°·Þ ànJ6dÄŽt°i…é0T‚~¸ØÃ+aø„ÅÍX¬Ñ6Š‰ÓdcKX{£2à÷Sœ€JÇ''@ÖE§DÑý3šoö©Ð«:™º ëجaý—ñ÷“ÔË}²SRB "rgÝ«PÛaà­»)'ä¿«Ž^ÁÞU’•ZTç3#]›Pmªƒ‹›,¬^©Fuvò̼U1RWá†:ânpk*°×Ê5*¦ûúuq¶NAMÿK½Äk’DåM Z+Ö> stream xÚtTÔßÚ.)ˆ„H— ]3t7HwJÃà 14ˆ „ 4"ÝÝH(-)ˆ´R’"Í7Æ9çûŸ{׺wÍZ¿ÙïóÆ~ß½Ÿg³2éðÊÛ!m¡*HŠÄ”(ji©‰€@A> P€€•Õ†‚Cÿ¬ÆPw!ñ¿Ý¡`S£ÐqZH@Ý @" Q  Šÿ+é.P{ÁìZ|u$êAÀªˆtõu‡98¢ÐÛük à€p@ââ¢<¿Óò.PwŒhQŽPôŽ0`€„À (ß”àrD¡\%øù½½½ùÀ.|HwN€7 åЇz@ݽ v€_´Á.Ð?“ñ° ap¤=Êì 8 Ex 3<vPwzs€š&@ÇŠø¬ù'€ð÷l >пËýÍþU†ø †@.®`„/ á°‡Á¡M>”ŠFØý Ã=è|°Û¢~w¨ÈëÀèÿŽçq‡¹¢<ø<`ð_#òÿ*ƒ>ee„"ÒÅŠ@yüêO æ… Ý—ÿÏÍ:#Þÿ¿†= agÿk;OW~#Ìͪ¦ô7 üs€¢Â@1QA1Ô õ8òÿ*oèë ýíý‚Ñú»"]öè! 0{(úÀßì Ü=¡þÿÛñO‹ØÁ (€-Ô† øOu4 µÿc£/ßæ0¢¹ýþ½²DÓˉ€ûþ'ü÷ýò Ðæ¡óÚéÂPÇ?”ùƒý’†€ê"=`¿Þtø_>´¾ Îè÷ÃÍË?.°Zl¨ß×øˆ¢åôÏ>”¤Ý/Ý ‹Àîî`_ôÕ£-a€?-P;¨ÏoføùH:€ž9`t'øuÍ"~‡_úÐŽ?ÀÿÕÄ/à»A<ÝÝÑíü& º•Ù¿%…ú@!³SHˆd¨SmhÛiµ<7ïÚ¨î^ê©©ïh¾>ªWyÂz9Ñ +sN£Te¶¤båÔ©­àvúêËô‘ÿjc½¯Ð /£Ê7FÛ„©›ÌÉ$ÿŸôÌS$Í9&É ÷%ŠÜ{1tbî¾½-kçÐkÀJÀ^Û=“äÍF^¬"ªÖ¦Ýñ¶º8S“’^ÜxgEÕb;`¸&|LÍž½âÿôë3‹¨ítf ©Ž3‚D請Kýƒ ¤= ïb‚Õ½BÖö„£H•%è•„ðªŒr‰/³‹¼¶ÓïùÛ>$SPå4ŸàL*NXËè5ÙÆ Š¨tY]÷Ì“ìzâ´]z™)ÿ9´žA„Ä5ÓFo¸oí{]ÍQð‚ú1ãÍ 5vð­¶øJÁ}¹W÷wòUÛ€ôUðž2b€Ñ ½´Á9$qœ~{šÑÏH Ž©|z°Š`m¸…¡³`‡Tdam×”Éî…yéã˜n‡¤ÏÕgÑ)Û® í¨d빨£.?°Ê<W‚„ óFÊçjiÍ´æ‹Ý²Ž%oá×ÅÍÒob¼?°Ï«á=¶³ !¾]~µX¡lÔKwÕc=NõØþ3cÖ6×¹ÓOòŠ³çD¯£Û´r8?÷ûÆŸž`¦Úø­¤!²Ã³Dæ­ÇäLq~¶xÝ—Ÿc)zì/X»ò­žÝ+iˆb¯¸·†íöÊâö¤æ…ç¬aÕx‘°8Å^»$O_¾¦T®5€rRš$ú~UøÈÙ+ 8," ·äÛ;SQF]ý| ö=d;R‹]Q‰ÒÉÄ*¶ÄËåBÙøÚýþj€±9åàw} B!*³g•j 1Ü5äD‹BŒž>²¼94È®¼Ô"íiâ¿R³‡3/—è $÷6ámûvíÜÃ6Žü¼!qüuìKN[?fËGGâU¢ l?õð)hÙ°®×ǼèO/ù­“°ü/èçž”ì}nŠ 'åcï¶IDŠEŒ=Ýí¼±à”:X¾P*x¨„#!´b|QÝíý`Þ-K7ÛÒÔµ¹™Q”ͪ\\æ@¯ðÝOÀý3ƒÞÔêG…nȹCê„ô«Ä¹¯÷â¬7£ôÊBGÅ©×Òç0™ä?ÎÔCÕ’1D0½…釸l´i/J¤î»ùϬö=9,Š ÞåOŽ¤¿G“JþRãâj[¬Çwpk†y®Ï(çú6wFÿË9‰ŠöР\srYŒKÒÌ€÷.’R‹ZüsSàç;{DHÇL‚4 ¯áú÷ Ì7åµ$œN©9zm›±—%“Þ é9LЖ¨É:¼]rÕZ-¼X—‡LoÄõ¼°ìÜ®7DÍK„2_™X2çÚ&¢3!Ú—ÑjWü¬¼ß_Ñ/b\È×µd° 4¶µfš$]`kb×›¼ËÔI¢É×A¬¼ µÎU|5à9Rcžcv…‡? n[}ÁbrÙM±}u<Ý[™kÌEF›iÅûHÕÑ2áì*R«ÛnŒ­ÚÛùtµáQµOZ£NnÃÇÓ‡Hã¤eVØ´˜ŸÍ+r©þð¶p2ƒ%ªþ}§1> }³g?:/)X<ÿ¿léúú¢0¡?úiêEd&´Ñg»óÓFö5~hÎ]Fºví®; Í.”7ÿ•§fî[î*o«ì‹±~æNrU Û …I ´>8 §¢î"%ÀV¤p£¤°úhƒñ ׸ÞÇšw!g1ÅÕ¢w®à&6î<ìþ½ÈÀ'çf’Ê5±&ËsÛXE­ QŸcÄ"íÛ´?Ï)ŠT¶¢0_¾ü:õGë6õ¾¶wuÛ²(Jˆ×ç…ŽFm—ºj ëHšŸÓÏ0UNéÕ~Ž Üá;Ûõ¬wuá^dØd@¸°¢ gî³”‚àóÃÈ‘i‘4¯ÀcòB!…Hb¬Þâ‰á#·rÖƒÇ_¥**|F„lå‘Ý£9ðªÎ—ú3Ú·¦³¨h¾5t«^qS¾cå-L Oysbœ5áNS’cÂe‡ƒ(Ae~ªX^§¥Vr -1`g´o»_SÏK#ˆj*ÒøHK´ZÛ0ñ_V=ˆS7H+IÐvÌ]¾¬"ê³›íOÇJ90Uä‰â@ÏȸïLÝN8&®"<ÚÃJ'¿öv)äKDghQëû¥É¦Wâ5¹œå²ÔÍîɸ¢¸¨²ÇGÄ_­„ˆÞðP¥Ž2‡²¤"˜Ú º©u(>àª#½r?ej¡m¢¡3ΗkÔºtJm3lé4 kìE°ŠÀ˜=ZuA]dW ‚HŠ¬¾-[·nabŸÏX¾F”³2òä‹:|X¶ÍQ LvZÝíÓØ9LõúSg¹wyOÄ·)3$ÂJ0ûõH¼[B"5Yª¤–í±'\P´<©Ó’ôû !ºÒƒ…‡'…ä_H£Õ¥‘a:•Ýy¸`Gå…=Çñ–ÞvÒ=âIíy½U,Y´øi34Dk‡3’åz)¾â^×êäáw™‹ÇºDéz(0ÝȈ »½?Œž¯%1:`^ÞªA†)Œ¨{>Ô㪠^4ëK ðnJáŒiäO„õî°i` Ȇ¬›¯ªKæâVÛ¨Bºš¤w{\µg *ð$šMp¥º'%¢I$牠[bÑSZ©¯/`ì ?ÛEPorb>Ú,5]:sÉZØJ7c%Ræ®|#¥+xsíÌÃ)–{ñcÿàáF½·µb.v¼ÄĺÙã(V;»Â ÉÉÝð¹µL2PÝS‘½£ÊSñaýê²™;Ÿ¼Ü<ïÈ7M·øµök¯+U“ SÐY‘_œŒ¨µ„`=|¾1}Oß]¿ôÔ&¹j:uŒ:«v"QÀpÜ>ï'‚-ÜùbýY þHé‡&©#,g¢ìi}’}‰Ý7IßÀêNÒMa£Y3Š¤.ãtvêºø“.§…Æ?¯ô¾„HÂ0KaŽ<=îwQ™mó‹R†bœ›#Ée˜U'2¯G“Þ?†ÐǬníÌ°¼±M‹9w­q§q uº¯rŸ=˜\ªS2Ù0kn¥'‰îé+ÞqÓBÔUД Ó³°Œ9ÙÛC¹æŒ}ܼºw/~lîh΋«¬ßïÃ^±7þ÷3¿C¨ïý¡À4¨3¡š³îÃ7ž/ÎÐ,õÐl W”Ër G¢q­Ž1³žçFVïe¸ß¨ßW±K¢cí¨‹.cÞøæ ¬³ŠQãy£—èjLéÊ&j.î6Oª‡Tû~uÙ`œŒ¯%` î‰?¼ãÀ`¬¸\~rPc?Ë¿¢ï^z†ÿ‚DßØëò¹ÕñÎ~åm̓သÞ®3>w¯ö°ËHb³ð‚dÙñ6b:ýf(áµÅI§û[<¯×èFëXš Ó[äU*Ò’Í\^…YÝÙ‘{ÆGV8ã1Õš°'CgÏdI?3­Núzâ£â݇WÕžÔ­›Ÿô(ã&|ãÛ*M0~=æÌJU{»gr7Ù ÎrÂ.rq'¦Nì4)†Hu±C>dF4#ϲ6I*5ßó^]‹ä÷¥±·Ü'Ø’9Åt³Z³I< >¯í ]Ì^—ˆms$xónóp’c}T65Ïø¸kÓoRßIÞûÔ³,Æ‚Ò¬vËÙÃ'. ÉpóË˧äÏ t2?èPänÉ=¯èŒixC·êKÊàÚUé-ÆKî~Êm¥¢ü$PïôƒàÉâ¨ãÅW%ÁXÎ4<ÁÀýBŠw jà)1œœ2šè³*zúçᮺŸõÜ»`åi3Ζn Ù ž’GV^½zaѤkhbÈÞ*LÜ·uÐ?§˜í—•ÚãhùLñ—ÞÃ97ÿò¯^œ)ôtF–Ü'tugéÅ#¬·þµ­ÛJ¼®:ï¥âÆ[ÃÂ>¦}Р¿Ðc3"Ì_ ¼ÅOØòIÒ7ÿeÞUÏ8”ÖOE3Õ—õÅñÆ3ͽ3‡Jí¹¬7T\j œÂv ê–­Ž²³ã)ëN ²Hâ‡V5œ¸+¤÷ÄÚ±”ÔË;rÖlIÑVZLQÅЬ[ä±%Î%xµž\³Òi¤èmE¯°Öó‚jð®h…Äc´Š¥PÅWz4óuääÜ<0—L.Nm©¿œ$ÝðåQ^:8[úd|Ñûa@=(ŠxägïÞùªï7Œ ~ u†Š0S;zv›Ž:‡r’'2pý VjéÜ|lõ/Cö\ w 'G"®PãÇjðfÏÕÂøt;ª"ê5*#)¡°ù.?*”_+8©bêÞ÷›¹gÐ÷ ¢Üv8ô&ŒsØrˆŒõGÊÎB¬GrÏ ,çÛ?9Jóæ†p\Z÷[•>c”°ñ‘-¼Qè4ºÀ›ÆcËiżµ¶p|2y}{V\µÇÍHàðŒw”)|Òf·¯Ôx'ŸFqí­þ©°—ƺò9Ìø ÓyóÆYK}¤ÛK’Äû$ø먄KVQ¿¤£”]§Ç5]{Ffnm¡k»ñqïè“ë÷MFÈ¥ì?mÀtÚ†we L5â4÷˜{eÄ«De1H|Þ¯üt+ `“àL ,L¤Rý“žZÁ žA <}.UêYß¡1G·G³Ã,}‰)&ÆÍ'Huõ¦Õj†”o[èÃO*›LšõŠ~‰Ç£VnÑFOž–Ï vaû?xOfÔúø¢8 ¶ö‰Oˆe$|¯´‘MšÖ%áö˜aíÏyÜýgãÒ#]Åeé÷³(­rWœˆ.Ö—TVjšýÍÏà Ð)/~ïE×Þpÿû£Û6coßd¤ 60ª¼«íä˜Äá%Ñ©1–ÉfçIƒ÷åÂëíú•é3bu£ô¸ô¹LOBÊ/ßÍÍ‘v©EÌò&ôd<Ù=ÒfÆE1¿“šÎ~©Þâûr£ÏJ+•àÌf¾êxR.þ 7Ì6¿ŽÖíMŒ½³/J³rÇÖô†$f¯Jq0Àw?š0­¸‰¤Ÿ•B3æKÀù}7¸wAvø$å¡'/ëȇl\J8³’3˜§þä-SyyÁ÷<ŒÌùÛ¤„WªéqC-Gzyï_1~N}oRúZYÑèÅã–¾ä8ž‰Ü 5ýy—¨¬¾Fðë ¯L˜^XÝž.xc÷ÓêÊÝÅ?sîµzhÝ `@xÇÌM*ËÊž6ˆùÇgp}ëŽ6%ªÍ*$Oy±N áYTï:,‰Ô9ׯ/?Šm*h+’~8¤'¦>” îx °Éß¼å„i,ø5§ÑÌå€Å“¥%ZÓf¡I³H¾Tæ*AÀ0"ï|£=(DµÛX¢=B¹OÝê Ñq;}Æ"FWÄÆ©6·•(—XþúY ‡t±¹[SÛ£ûžƒk@]kþç³EÛ²sÌžI-»aíù’rÏêU£ŸfÖ³£“£˜mE8´ãníŒÙ`'tË´¬\¬Âeäy<|kA1ÅCƉHû“0Ÿdþ»ß›£ïЃÏøcª\Y6‚àůoæosy2Sk ;ž‰¤ò¬^ÒE‘‹ô~)Гq²?Ö'-úAkøî»æÆnoÑq=Ù¤?¾1c/V‘S<Ç»õ’²$ªFÖÍ=`oÍsd¿vç tßÓ¬ñe|’û Õ¹-S(§Trh“Ü—8à<–'…€„Wø\ ¯Ê?ÔÏýíË kêP¶GÌ'Þ# \©eù…ïýïçÅÞX‹&•SB¹¶XŽ~êî»VØòª&Y? ö9ªï¸& ‰ÜçaÉ°8|X9<&ˆX[fá%Þ¨ éæ˜}؃»ÙLd)=Íû9"e=ïG iòX‰x™~ÍÉœ5^X#)I±vB– x]ªÊçô¤~ý'Èÿû¥Ú+éIœ+ } D¦;¯ƒc¦™LjåZ ­Ì/¿µ¡à3Q/çË#4ŠÁÂÅÕ¦k&p»t%+­ràÉè‰ïŠÃŒ¡LÙñéƒSóŠä{¦IþJ Mž¬F¥× fÈÿ:wºuÂéKfÚõ&Eó{!VÅm¬#‡ÞR]êØ”ä=Ã-fk),>Um#•Ô™¤ˆƒ±ÈžžÈ— @í4Mn~x˽¯zC;n¦äÓµ{ÞÇã#V&ÛÞ=—û¥zJ–ÔÝåÄs¼`¾~4qe”E!ü.]ƒsBXÉðúˆ–’êIëÎWáqÚ—ª 2¥Ö³÷QüÚöÒTâÎQ&ëGø“—ï߸ 5Ï^ï rî&Ðmu4w‚¥ì:{¬ÆvÜàÑ´6;Ò˜÷Æ¥¦Š¾ À?Ç lŽc5Ëý6ûd¹`Û—ðHç²ÿ‰1ÖèaˆíDhwÛR<0ï"÷ èN¸À ådY‚¡Î\0%½Ž¿?'gÉÜÊŧLRx¢åÔnü6hKp¢b®zàd¡LÓdc¸íQlÞÐH62—ý¿V»jñS Ôi…OéÛÐ=Ï"¢;:z¡£`šìc'ˆAªKqýÒÜr—ùÝþv`bCp÷s\‰í°=®]Jò_ Ñvgà÷ÔíÝ[×%J–<è̶¯K)VÊ»Z.¦¢ôýFl•ôdkOŠ2°wDWO»ìŸ&DµÓʹôÖyBÍ«»‰£@A|¦Uk‘rû¯7¾;ë©Nh“·íèw>ÚŠa®i5W¨º2¸õß}³ÍÍM_@Û4Xí4p:—ŸJ³øì@~$:Ÿ¢y¾'3E•.C‡þˆèb¬”º7SÓ0'ç7ƒ“á6)ðaæ¬æYrçdŠ¸¿ñOçw6¼'ƒu®ý(“/f`Ÿ“¬dWxÃâØ]ö;MÖYöÌ £?ö[nWP²†%ÕJ_Ö_ÑDtÅÞî ]JžS¿q3(j˜TŠt«Õ~ëÓ «]“BDKèæl”žtZBõ¹èä‹Ñ+²©‡îY81uƒ­mÃV_c¿§Ö×èjÁ0°É¸¨’=õC?«Y2ƒ–˜*gø¹5AEÄ•«:M ÞùOf…È–•2›¶W<¦ oÒtRÃ?H•ú$[ÍषP>œàjâ©Ãkz±dÑéÍ&Éqø¸¾ü‚SÕ)hç¸K#Vî^~î«vûSÖ۷D9ã„òºéW4E¡OË-Ú¦+ÈLªÌq;ãó 5‰zÒç(ãîKê\ŠŒ÷…qÍ㯠æÝIi®)ùj(½¿é[·…s ¯ÒJ9ب‡*!µMtUð_Âì#žmL2ÇÛ6w;Ťd‹ÑÔ!cФóŸÕ³TÍ3Y'97á«2tCp¨­êP~Ü“Š«H¥dªˆU¸{H$a5œyŠ0ºjn„²7ùzwÓ.éÂ]t/{Ô¹& ¼Hcã›F²uà Ä&¼¿lõµÞÙÓ·HÑíÒ{ Mê´&ËÏóè|/Ó~”'òª†øXÎ1£õûByšÿŒ@— endstream endobj 4650 0 obj << /Length1 2091 /Length2 15519 /Length3 0 /Length 16801 /Filter /FlateDecode >> stream xÚŒ÷PœÛ¶ ã.Á îîîî 4î®Á ®‚ .ÁÝ@p îîîðØ{Ÿ{²ïýÿª÷ª«èoLkŽµæ\_CIª¬Æ bæ`’t°we`adæˆ)(Èð˜™Ù™™Y()Õ­\mAÿ1#Pj‚œ]¬ìyÿ æ º¾ÛÄ®ïq öY7[ €…“—…‹—™ÀÊÌÌó?μq »•@ ë`rA spôr¶²°t}_æÔ¦4.ú¿Ó"v g+S =@èj ²{_Ñh Ps0µ¹zý/ j~KWWG^&&F  £ƒ³… =ÀÃÊÕ  r9»ƒÌ (í@ÿ(cD ¨[Z¹ücWs0wõ:ƒï[+S½Ë{†›½Èð¾8@MF ä²ÿ'XþŸzÀöÀÂÈò_ºÿdÿEdeÿw2ÐÔÔÁÎhïeeo0·²”$å]=]é@{³¿¶.ïù@w •-Ðä=àïÊIð]à乘:[9ºº0ºXÙþ%‘é/š÷]–°7s°³Ù»º üUŸ¸•3Èô}Û½˜þ9Y{{Ÿÿs+{3ó¿D˜¹92iØ[9¹dÄÿònBøc³¹8˜¹¹Ø¸Ù 'ÈÓÔ’é/zu/GÐßN–¿Ìï ü|æï"@~Væ ÷/ ;àêìòóù·ã#€™•©+Àdaeð‡ýÝ 2ÿ¿¾³•'@ù½÷XÌ}þûdðÞ^fö¶^Âÿ>_&mUU Eºÿ×'*êà ða`å0°r0X˜¹8\ï~ÿ›FhõŸ2˜ÿäÊØ›;¼güSîû>ýOÉîÿéêÿL à“):¼·-@ý§Ëõ™9˜Mßÿ°üîõ¿Sþÿµø_,ÿo]þ ’t³µýÛMý·ÿÿÇ ´³²õúOÀ{׺¹¾O€‚ÃûØÿßP-Ð?S«2³r³û¿^Wàû$ˆØ[¼w3 ;#3û?v+I+O™²•«©å?=ó]ã¯Y³µ²);¸Xýu¹¼g13ÿßû€™Ú¼_ .ïù èò>m®ã_ô>Oÿ» {S³¿•ƒtvz!¼ý;âø°¼O¨ÈóïÖ01Ú;¸¾§Þ5ûÌœþ:fN“È_¦'€Iôâ0‰ýAÜ&ñ?ˆÀ$ñ_ÄÅ `’þƒÞ9åþ wNù?èEñ¿ˆ›À¤ü½³¨þAl&µ?ˆÀ¤þ½¯ ñ½sjÿñ¼sêþAï€Ð{¤Éô®Áô¿ˆã/ô~Íü‰þë|˜ÌþÀ÷Ì@¶®ÿ`0þ ÙÞ@Žï—×ûáþ7„ã¿6–å½k³ø³—ïº-þz“¼·âŸw2ËÁw«Á÷Mµþ|Wió/ø.Óöý» Û¿zê¿þ÷9gúW‰ï·“Ãïµ9Ø,þ%“å½@Ç?õÎîø>ÎÿÚš¿öæ_Åÿ¥úÏzœïü.¶@—Éay¯ßõ_ð½~·Á÷Üÿ@Ö÷r=ÿßé¼þß‹óþþ¯Á0usv~Ÿœ¿ï³÷©ùü÷ë ò™",Ì9˜ò…Xׄ´ÝW‰x0ìŒñCŸ}½×feË7„sí—˜2ÚHTû–¹(W*¹ÐÇ"ihÝ©(êtŸµ:å³]KRçÅ~Ë@"¹oAb?÷v >“äsGH6‡Ú–«•"JÌ[äܦLõ¡ ^ÈÌ¢_Õ÷cMïï$*ÌbI.ÙÐ6ÅŽ®ªâLylBÍãMU×f“Ÿê;׸³7íâ‚·¢õ#RÓÉäø;=*?¬ÿ\Fë#êŽ ”uÚ9§sE“àûI(Î[©¹üå9»Èý(ÝÇD CøȬ¿l&å¾FñÒrûòÈ€”Ö©/«·î¸@^*ñSznìp¢ðhBÕU‚þ\ùgûULO–±N!›ÜÏJ¼õÈ؇°‚áPQ69–¶mæ§*lŠ£…ŠSŽŒ"([ª*ÖKÏþàòNm ÎU˯jú4’¿}© _! Õhhès¢‚¦àÕ•9V*fWäá³À`£â•EüMÊÍafJp$À”./·SiKÖ惞 ÙéÌ\ÂO†ˆ°¢/}~ínÜ0³&úö×¼°UVÁ4€||5åD…ztú­3„ü»PÝ–Á‰Ù»MQ\jµza4ñã ™× „lF5ѧýUv¬R‚IžG¬ö ©Ñ”M¢=F£À»°Sne§òÙ·yJ)|-ZA—.ñF.I“H~`¸tîËaUit´¡+>›Í‘èÿüõCUjühV?KÔ?>ü 4µã‚B#)Ý÷ŠHÛôI$!ƒÿ!Ê3f;)Z»~É«$\®‚82y]¤œà@x¿÷ ý‡êLJEd!aJÝæoiß°VG ˜Ú+À~ÞRùËà˜KV2éÌ(§OóÐØÂœeì)íãù‚t~}\eüTrEfzn:L€Œªy›;ÎÄtf…xYM]–ÀùDKëX*PPpÓfµó©)¹æDæÊèof‚•OåJKM]b'~rQo72Xòâ–³éÔ>„¹ïž¦Nc\÷Ý1ð‡q0wßÒûq^Ø·FJñ G”ïh“ç_ÖJ!¬ø‘. FØwñIƒVo£5'VË[l£„¡v›Ã­ÇæÇ ¦Ùù•ì,mðMbÒnIÖ¥C(Ó^æfOîÙϘþ•DWá²v4Qp¹1Y1è_Mœi0ý‡P0>ˬ¤d‹fH¦ibt¬¢ÛŸËš„5ñ›?Ž÷Fï1Þ›Aà¨##¨vÛF@ž¾:nÝÛÅK®ì·£RtCÅ€VCóø©¢µHû°].fB*w![À½ØÔk¥•‰µ13’‚úûRi˜má,e ™XÏ5Œjêg¨Â_ü$¸:Îìñ÷ÀÀ—¿óª8_ ’}HÔL:ztsk§úŠÂLÀeœM‰|ñ¬ñ;Žkè6Z=ú¦>{3´æ…2-ÑB-Ñ_ö¶j÷E㱃n?43¾³›’Ã+ÔöŽ¼~@t±ËU]-TyZ½í0€z½æ<‹4ŸIxGáW¯â£³ ¤¾™ JØŠv-¨]K¹mLP;$kÌu ±ºä7sˆîf)8—&Ž\ìøÐ 7@Ê\ÕùWYã6ËèÄj®‘·õºÚ7K²Ÿ²æÙ.jÜnÖÄÖ§Ë+#6«‚Y¹nÂnB± àúQåÞ[ ]r¯õ±7ö³•L¥’}2j)cêHP§ó±?´Çr¸ÊýBŒö¢A¨¯—në”}Bñ_ËL©æÚ öÓSåŃ[{mÞ¡a]èS³ ìÞ B{1&ðK5äí÷Ùkßü[wÐ︟Œýýòåd^‹²³Iiº¥ašév‹ ÍA]Ýü×ä%›¬uu×2U>sÔ-#j’ZþrÒˆAUþZ ¡ùÍ æ, r§fÏzÏŠe¹ÚýÁx&SfãFºò×çÝ2þƒ=måÛ ™1ÔÊu37ŠÇîtI@ð‘*c§Èþ²ÕÍéHŸìÑ… 6ž@±ð*ÑíÅ!sÂã=m ­/b!|¥H°ù –>Ù÷MƒæX¿Šá?™µ0…~Û¢ìe^? >ÒJ)'=—Ç<óÔ6²ðÊ:ááö+Øgܜʻ €T¡Ec$8æ¡B¸pʆoB‡_ :°øF®·‰¾ÃÛvnN¹D›{ NHœ›Ò„GmuW„„ÇÁ£ Þ‚rb øºÊ!^¼½(*g1ÁP Q6›òm»»×ÄÖF„!—À˜ ¨Guçç ´O‰šÎ»bŸd4¥žÿN„zHàµ"¡ ÄV}^m<¾Ç#F+nr¿ÊWä&2Îy¼} ›ûämråæÆüÀvWÁËØËWÂ+SȈ{è+"¹hÂ`ìë÷£/~UO”ªerˆ¶)¥‘£NŠh#FҲΖ?@~ É”=O7 #0;ô÷ªÅVM-êtižJ$˜7;¶N/—¾iU۳ѣ³ŠðÓ«6kÝ,ë9E¶(*¢*ƒŠöÝéR¯û)|Ðg·pú3èQÇH¸»À›bÌ,Ç&UD©Š´’©uÂÖõ=AÖ|{å l1Bèp +'Dp°3p°ö+o ¶zÌ‘ÂÓ‰¡?Uf»¯òí׆‘û{(AB(¼©gïÀXx[—sÛCƒŸŽH×®S{<ª¼tFt½øñÙ°¼>®r¥¯3[Q𿨌• ùÅ°ÅY«#ÛÌÁÉêÏ7Àà¾zv#¥åÒY3m ù‹Å®ˆl0m¹åº+p+A¼ÒÕÉüÐkö&H›¥a…XûÉí®6åËߊBÌ¿:{ªŽ[ˆ×9¤@¨c¼ž\ΤÉcqù¼ï,`wwð%é-n£ûÔÛ(æïˆÊ‹¬qBEÓÛ¼€ÅI7rÕrc,—}Œ`Οc“ϱH¬ù4$0ªÇÈÆœZ2Ézظ’0ä€[ZùÕ$^nÒ(Ðì6-ñ¿$Ÿ6ÂbÀzq¹E£+`‚”-ˆyªfÄÞKòÊÏ|bf‡&&ò–ã…ÝÃm/û˜c ¡92ߦˆm3ÕlŽ³Ð6ý± w¬U?S\S˜½†˜oC3û,ñܸp#Þö¥¡€MD÷¾¤°ÌlPòTÁ;Ç ¥‡à;¨<ˆ—¤!í¾ÛT¶> ZC÷v;ýËw3Ÿb¤Ö#¨¡Ìã —ÏhÛÑ<£z¸Õç,•%è»Ø †W4öil˜P\ÓsÀ½ºq¢´>VR^Îüþ¬çx²I •Ý£Y ƒ¦Ä‡ÝáC,c¦-‘m9Y™üO?…´Â°:+Eä1¯á}¾XÅÅ$-±¤ª ¬ð‚>ãu—ÙLåG uฆ"(“ F}¿¨@#nÀýŠ¹÷[ %A¸†5‰¼–º8Jj³³ 9Ðò4½Ò.»êŠÒZC¦ ¨p5¯ò2‹ƒ \Z‡±SXÙ3}!°;o†*®}®·8+¶ígµÜOÃß©K2¦A ¾î±Ù“Iõ;tX Z<,³™Îu3'èa'é_WÈqÔÚס Ão“VëŒq¡CgÏÊg\CG¿ݨ}²âÏÛ¾ïon#S–¥Kd¾7‰×x$†(öþô3£$8…za® Àj{¡­°®ÄÄœû†‹Še£Ž£èp÷Š"Àû5²¸KŽRâÎjEæ4âÃ’ôEÆÙ±ïSºwÛ¿ gïsh‡A†ùÑ×P]Bvä„<ÃahÓ-‘¬?ÇDÚ4Ô’»¡a‘ º<ÍM±püêE*À¨ê¢ì]\f7’·{¤V»m—h¢“+öŽÐŽÝ^v´BZbDª…_ø5äñS Ñ®¦a™H‹R_, û‰«l%F>­}\„£»,õüŠBÿPÈ>— ´j‹6bšû•‡ã^Àêù}(ÌÌʉ]±£ò ûû—ygz)?Þ´*å§,+BÌʬ|{?.¦DrÝžæœNWéÎ+IëíxöµÇ§{-¼u‘Gºq…CºëˆÓ˜‚¿ýå¦C3éˆB‘i·‘뽬cX…ýfÛ!îDÉ©„C0&²;c*ˆÓpÚß{BÉÿ‡^zš¸ðQÞNH`h˜‘‚1èKÓ5>]‹EÄ|↺°.€üN©«yb>µäÁ¼žcâtTåWÛ]ÓÜízdŒñn9(ȼ¬2†E“ ]îÆcY2}§îôó˜‚j3ÿê/,€ "9_(PòÔhGðò’vq‹ ÅH'š´ Û¶”)y´?wi‰u+•ópŸµ¢­è „Œã:;j5ñrœù¼Dˆàà+x\¡´^¼_­:™¨Àðá A„¹“fjô¥þíËQ·úHd:j'♎kÑûu[ºþ ¶qÓc„}Âú©OÈYÄÞÚ6z¬§¨³ØéEi3SÖ°{ÃȧPô´*2ì’ s‰’;ƒ¦ÂºJÙ=ÉoN.0é‚nÜrÇã…co§F”‡4·òܳe4âûh 0[‹¿úÝn/r¨J¥Ä[½êè ~.?“§z!zp&¨Äש2ŽpP¦×¼WøTnW ƒÍ2¨k> ÚHÄó ‰YîÇÅYÇs×y«x xî‹­m\j1; ë÷RIgº`àêwÔ3üÔV¿ø|Õ¼¼ØEu#\aß¹HÁؽ½¼z‚ýúJ¨ÝÅ$DzXÕ!éœøZv9±W2Àèƒ4X•¶<,‘‘¿iæ¦{ÕÄ)]¡ ™êé΂2®_6CóMmßÏ> %øÒ°ÏCç?Ó–zó&†OÏzÖR²ÉõG76i ÌKÏK;²X€ÑŠ¾Äã[ÿ,Âr9ÖYý$æ Ê·ô0óc-°ÊÍ%Ð4|fHLję{ôqØ©ÝCgyØ)NC>HÛéÃ:cõ1[nëa×o’ÇÑÙÀŽ‹Êm\Œ\‹¬É3*j°@n±]ö{ªÌð’‘ÔLÏÕv8ÌêH`’”ŸÎÑ£ÐyÝ×á¬,Ñ©­îšpij€Í$°Gv916v1Äݸé²Fˆj îaßØÜ¢pÆÜb®lo«p3Û *žVF¹&úÏä&ƒ$³dŒŠ2E¥ïz5U'{7Ð|¤=„θ6ñW¸,L ö¯ªÜz RŒnÃx+>ÒõÞ^Ϫé#÷ÖîÀñÂêï·.­øTÿ%ÚŒ¹{EøŒÍcx(ÃÛ ™e%z'ȉ.FN+O˜LöF‹Ê‘!Ó£¸êø†´¯¶’xÚð¦v(°¾Û„|e-ChÎl¨)Úz4¨+]‹¾?—\ÉùKB¹!õLH"‚}ò<Û¯Ï÷ˆÓ‹+„Å ¹diÀ°•Ë~‘@c®÷PVoL¶*ÇmÃaÄÿš~~ž¬9¡•I^6I™uÍÞ\z0y š†„1Ž\¡ûP{× >e4¹ä^¬%¾©·B1µŽF+¹V`¶øÒSx+F#‰ŽàI’y¶)òHyÿ“©íGn÷àѸh™ê9ÅvėPy¸`lî0^ƒ2ˆ]ž6bm@d9sèe°\/$ò“’3ø´+=Ï­]49”R€9\˜µ,z`OgNh§©¥ÊúM91ç—eÓù;M&¯„»×z•€;¦˜ÜÂàî   óѬ£B›†¯ß‚ë§g".6þ¶É¡‚'ý¦/p×LÛùÑæàqÏÈóŽ„ù;Ueì©>Ú¬ ¤ÁeÀ˜ƒHö«„«¼xÄFAK€ËÈQϸ˜ºº  -U®5¶ØÔD¿êÅö×ìã6âé/UÞw·{ü5†åw¡‚5W”)ÏHë—ß«-ᙺTkÞ°‹µ}”Éf å‚ç·÷ù‰lø{ñMÔ Ér-%©,?—¯4Jîfë£[l’õºÚ5TÍP/¥mœ¹¥ € ½Aôœñù‹ù½#EA  ´^vžV18YÌ Brøÿ…$—ßâÂÞð–Æ„Kø*!‡¤Ë~•®®YIáÀ„#9»˜Œ!Í–Ð×à{jðX<³ßçøNd£4$­œZÏV8þ ˜¸4ঋ 7)Éè[€óôŸå¿c<-|û'ŸÙØŠ6šàŬ÷.L•˜8­ç”l1GNÀ!÷çyÆzž<3gä§Sò7Ö+Q’ñæìúo“Ó¯‚cñÝ”Ÿ(låïàèU!Õ`Nët²º+…VGWûE«¨<°„œ˜ÑhFCœRm:a@žO· ‹ƒûÈøŠÎéö‘â»Õ§Ïg×])ížÇ…n½ÔèRŠ#ÄK$ZM±ðÌcÁ„Â6ºîQÍÚÆO¿°}Ãû;Pb-ˆWóû¡¨âã½}CãÆS÷Á™Žäü'‡*¡ÖJ”•9Ý®™¦sÐfÌÚz7ÍÝÐLÕ­]õ .gÕÇhd¦2Q„öV\Óún¦2«…wŽ¬¡u§0·$97ñdÛ;ÄìH~þ’Ùóâø@œ`ðýsÁ÷-÷d³ã Ñ°›¸ÉÂk[”Ïߟ±iaçPûp¹£Luw¼%è?L[(9o=;À±·giV«G«e-C]Ñ1 Éønê—y0­Ó¬ §Ï6 Ò¼ Âöû)Õº;¶U” –6%))Gþæ#Ÿ6=ý¸\–Òë&›‹‘.ªÝŽ7¨lÉd'û„±åŸtÂ@„?¡£|ßGôÙÌ$OšlJºŽü ¡š1Ø=Á™ŠWÕ4xÙ0Èk„›ÊsÖxfÝf÷IaúáÒa#ÐCÓãDÄJèé¾ilµv쎠™)öe 0½oóXÌCS(pÀ¼ö´øéx°[Ÿ†‰¡ƒs¸Vjú–Ù«OóÂîkjð‡¡V©¾C&TÚü½Oî¯>ŠÎ·n3ED/ÞšÞŠ „qŠ™Š)$C7.ö 0Ä7öìdþpl›Ÿ}³ii§„ò“VÅŽ_7°}átè”<0h K5£B©ÜÇ–Q‰ƒ¼® UVgKx3Íí}S%§hÆ-m´Ç®ôÉÉPgá(¥’n |î_É ü?Çë\²*%£e$BLÄ°×y¢éµ–2E+>Ýö|f{=©Ë¨uSžVÊvÞ¢ìÆ~ì63¡É‚íþ"Ш½Cï2Úí¯0­JqWW}úU§*¸O ‰Øÿ»à:§cžârôX9Ö‡·L¡µQŒ§Âæ v(¿_ Ú}¾è ­'·6rÙû~ ‹WO\£<ž=Û ÝÂÅEíÜùi­6€1ˆÐ=•ã)ìÀsN½6úögßæÖ5yOõŸŒ½!˜`Ù†,khú¾6oS¸g¾¼%a™¬{]Ž%éÁ츭¹^5ÈlF«šÖ_Š¾lˆh\SÃf§æ–(nE>šÏDTÒþJ ­œsD?)À “xö;2.WžæÈãì Ϭm%÷BÚĮ̂»Gμ•Oa$#PüÛáéÇh9ðœ4a`ÿÐé¥Aì¦óvÁˆ¦iœÓo£uupl§ÂD¬—¢ÐP¶º¸€ÞdÍhn€ÕígÒv÷¯kí°p$bEÈm`xH ´s5VíÉÅ*œˆ>ACÜ~ù0éUíÚ4裎7þ+ó¸ø•£uÉFGÅ2)ÞvzDÒó=ûéí:w¶{XâÜ|d(Á*o:ÏÌô¥Aâ¾®ÊBi§u˜Gœ>…±§—…šçC_†QVÔ—.ç˜5:קêÎçšåÇ+òp•sä“ ŒOëÄêÁKü-Zšú9ww ÖÞn­)VE¼± Bó‘UA8‘n6Êþ‚¡ÔÖWGª‹²uÂY”i‘­ö”?”‹#ø8‚]X(¢ÚF6lú%7íšL¿ÙMzºkÐÈ2N¨eÃ:;f‰¸, Ý6ç¼þð¬-RqçëúþUîé@ôÅR<ÙÈñCC÷§-]¶Œ¸œjª`˜ÒÀy(è„Í8v0X!?#ÉÆ-DvÀ,;¨Ž›[¤¼jáäO1æëRô…AJâQŸ¦IæêQàGÿìw¿Î1Ãe¯Ùd ì1oŒ(ÆÙ<>¢Î"é’'ó$wÙ2B;‡HaëóIŶ†±ûšØ R¾sy„fˆº¡¨:<€îÍXÈ5zí~I=¾ÆdHá¸÷TeŒ_=t¯iuù&¿xaLÚk ÞèÞ áCYœ×ëïí(ÕÆuNgEÅjߏÝì$’¸!cßÀz2œcbÛö9Hk‡Ð~kGâB’Û7÷öñåç#º¸€²¦õD¶b©|ˆ ›Â÷ßF”,ú é;Zcoh9L|ÐÚ“¨>^³‚½ƒÅ›¬¨P¡tf~~sÖ9 åŸC ªmü°Aã ÷=0Z@ßµ0œV¥;¯¬üï) Ã<ñ9”„Nr²«jݼ‡ÿE¿R³Ö‚«8K3“F2Wa¨™:Aœ8½¤{ù`N[ >uÔ;¥ý#Ž*‹¨®ï5>¦1KF§NÜ°èÜq#0v¸¼Ü½ðÂðr}cB(ã˜M-่a[¹ÏÎñntÆ%÷‹³?à±öÙps]$©· J¢;NÉé½ÑU4±Õ»›Ø)r™ù^…=JiŠ(-gÆaD4PKëâÅè ±^iq‚Òì_4ÊÿˆŸ36s áµUHC#“e¨pÙ½›gÃþ^ël·¼hß ]ìÿSõ™T¦àk¼Êl‹cj¼ßaʇyjod»c®°ø×¢ý§ê7SûPÅs_­(£i2Wõ~Ì|í aË» ¸¶³6ÏÒn±_¬÷±r§`Tðâéßô5bÏ×zq?Þ„ƒ˜Õ WÖDRdêD5fé0ª(tÑ žF#ÔöºP®oD<ÝJ>Ž ”A¦— +hXÁÿ¬ü¡.yÿ·á0ÊÄvµO|“BâlMÐÐI6ÌrT¦T©”õ ÃcÆ°Š&8‹÷ñGG1 2¢§vØùlùµškfÎÁû(Á ß ‡9[ç0@H|ù"-’$e—à”Ԧ̑ ›Ýk~PýYäïÏHñ'€¤zPÀnì’Mš©êÓôЃŒù¢„»ÆÀô÷=—a5Ûéš2îò©Öý)Ü91:¥K;_µFu¦4ÁâSb\< `ëêdrrD|ò0êúK`tê9I«}%á¾Rÿ®E¸X9ÿL ­7§t¢@äpáw“X `w©JJfÔ M§ëQùÐo³ð‰ù÷^»†¨hцïSÑÅÕP¹z5O0“¬aÍŒ?_v³˜°(GœP\O<‹Kð¤û}/U†}¨Ã™Ú×g¦žðŸ¨-u—¾¥“âªKÙ†.yrGº>fná>¤á2=ݶÚ62Йò$è°·/Ÿ§†•(Å—>ùGo”™=Ô‘œ½¾QIˆxM£˜ ËY/¯Z†±)‰æƒQÍ ñÐç#•ÓÝÿ¨NpÝL‰`½FvÑú 1‰<~;/÷Vó(1p ={[kÙ`ePŸH´³í‰yÜ)…Gõ5µ LÉ]SBÌ5x¿èÌZ« ŽÓgþ2AS±”ÝÅ”ß\y‘¤á 1B>àS Óæ®îTñ&žZ·E„v'ZÛŽÎDêín6Ú¹ƒ‚MÕT+F]ýž7ᵇlÔSTb_7ÆcêE‚§‰á@ÝÉT•³¶[9¿½.p^âÑNKЧ€—y—jí}¨ÎáãA†\¹‰2qòb¥lgØdãÊ~Óø/Æ[¢Ø6)ã&ÁýlÊ0“ÆU‚NL©[½üNgÁoPqˆt{?Ó1ç>pí»¹h«FøJÛ7|€K1Д‡Ï9Lí>51 ±êfˆÝ{Z•Ö˺Ö`kU-I°?u2ÀÌ[JA³'ĸ®N´”ðŒ¯ ¶ù©7ÚÍ]ÎÎxBN{м™NÊ™W#>—ò™We´\ò÷“òøtÏД¾ùÌ #K†$Íñ/M¬©™}/l3ºÏ—í1,íª3'…vWT<{,8íXÇ-³E´Gâ2Ç£RMp,OŒoêX[.ÉUñ 3êjÜZáÆ!TÅK?áþa´qeºøÕµ ÅˆÕ§‘O´äêíÉþËD”Ç.1ëËgM÷ØÞôý© wÑ.„þ!qŸfqÀ3-qa²™“q©·ÆÂëµ®Ø ü °å)Ž!ú;ºþt¡Y•%÷³¯:õ®³/2¸ïVwãVŸÐA¹YZã Ò1_1vÛî°4T¤ @ªbù’k$Ãòëvnm,%—¼n²Ö3b /™“´Àëòäräã‡5î„–Ëý¼¢ÓŸðÔN:^m^Ì·k£u>S¥@X…!Ñøîý³Ç¾¡‹±³ƒ Lœ"7©µe[H6–¸Ú5k×lmåô¾2²x‰Dîvàâ0œ^n7ÛöÃGCÌÊà¡/]ÜS­…±ÉÑ­¢’r£¬ˆ•Tš&e‡ˆWG’ Vø`&“Ó˜ éBô™±¿ñL§M&‚ÇÓÙâ〲ýñQßžh%ѯ ƒ¢ç’QÂÈ4½`Ì ¾(œº)<‹ìf×–8…¹?Z„=m6lÚвs‡Éì¼%ÔšiÕƹhh‚HjÇ~ü¥ï9Žæ›ø[iĶB)ï¦Æc…þ†dÉaîBæ5¥³ª¡ñÒ#K÷Dß·RbHÖuN,L[&#ð‡§‰zþK®la4“°ÏT\Öc¬“F¡‡—ªmr—ƒm;7&¥6"=1óìK³MêG -ÖYAŠr„!¬~Z#>¯× –»Æ5ÌÝS ." z£tÒ€Á&RÓ§à¤PÁòÃlÖë¡8MWYÄ©ä¦ZRþjŽâFS†£ÿÑ„ýdª'Mb¥ ’¾*ÿ©»‚° û§ðÖ,Z„n®,´Á)»fÅ"¡OŽ6gvWn;š¥ŸàaSfx„l~™Èþò-TÁÖÖ±•ËFB_Ã/» Ç‚hЗ&©ŒJÈü‰«¬†«›c73k²JfÖw[x÷àêá~SdšÏÛ§Ï7{y³Hó‚‡04iD/â—#Õ¾Á¥ߨ°<U A’Ö¶…¿Y·ª>²#ëiÿ!e.&ãE6‚ûpHÅšîŒÊôµÜ~Ö`ÏÇ”7A í²™‘dM¾»©<—d~„EŒoà2Jbî Wì3¡Ô²êP˜ìŒ£Ý k•\H«„÷Š]O4¸ÖôçÑNÈl¼âsMb¿ý–ñτènf ¯¢EͨQ¤K9[$ßÊ @µªm=ìt%¯A*¼“Ø;T£n8mŽ}î tAõòóî½ñݵ®1%UçÕz ¯EÉEa*XÑ *ó“…B› ‰BíXQánøfº*ä\ÈãP³‡ôŒ¸h¥Ÿ·^õÚuàGÁHÒÅ£XØËMÖV32ún[lYù~§wl±×«´ŸÏæ”Ãdã2ñ`±…Ùì[:ååkJò`i§žÃ>ÆýcL:‰3.%e͑鄙þŠn›Ë°GäûÊ‚Ì&d7‚:Ï‚!Øü¨úBñÕ5½›1pÖÖ@‰9~oHlÊL6ln ‡ÆwJïnc˜qßW,ñ%ioÑ•×ìݨM_°øeÔdï¹JƒõE©6e.òäS˜zq-=»(3µþZ[G"Yà â¬huéEõ.¦%ÛàrÞî+†L¼š°9 5 š‡@^0玉ûêß\d¦Ê¥)3YHR€2yÄ®…´,ùn9ãåZè_⮽ŸÜ­=왥3.ÅG~U¯n 4y5`ovt»saQ‡Qü½sTnq7TŽ\¢3†y:]@!´D§âÛ€‰#\,†ëMVAˆ–œsk“~Ý®AÊLXVÿLóvo¨¢ïYôñFõl`ÚToî­{ÕF:e¤/?„û&}.í"Üý/‡ûu„ ú`̱¡ö<&¢!¥¦DaER¯‚_Y6gé³öQ)š¼±Ç*f­¾w:q¼ºt÷žÝÞS³¨ñûT-ª—}DP$ Û®}ârÖLzo ùI†?Þ\ÏgM@wæ°‹­+îÓ(âEý+gÆM#5YZ㧡ÕÓÄ©ÔŸ®Öï+¡QnœË@1v­³'ì×Ê0KÒw9\þ½‹›Å«ÓË`ðkåyWÄÄs|B38>t¯}¤ˆÊµ&—/yj-D>©N÷#²k€ªâ#abxPS‰µK µk‰ÓdcPòç¼4="¶cy Êm-¼Áˆm‰wœ\ú1[Å:ŒÞŽ›Æ¿,/†iòBlb‰7Ú™Ú†&hšP Í¥!êc[©Ù†¬§ÐÒZyÚ:½¿–CÆ»$ˆsTqíLÃYŸG’ᜳ“A"~ùéÓÉ5YK©i‰éÖ5„íY—8 vE-CT¯‘à HŽc·«´ÄPj2 ªá™˜ÖÒÙÿ”ž»ÜÇ<ü[·ùöµÆÅ­úÞœöŽ3™ËyoBìô›­èK‹µ­벓ÆÊD 1d+mÓ‰z&”Cã“Ä8RøÆË H&_2m-[ÔnYe8§!!TÎ)L|¨ÕTï’+*Û*0³Á‚«ŽVÈÐ5 ;BÒ^&T¡}ÛŠñŽ‡(º‡¹><"|‚›íÁ‘;ƒ\QU]ÉJúæpÒíèä+Òû[Ɇ54×7ŒkÈù.¤#úŒØØ–ó¼OH%¨—°R1F(gf›dÈ—ÔŒ¹îN°â~Î÷ÃU_¾Ð¬À™_Wt“r»uš'ߥ„ž×:žúУ%\¬ox·’§`ÚFWÎê/¥“RfzÜ´0°™ž<’¼üfØ÷S¨3aöÔÛW áÔ;a¤µ˜^¶n‰@¡ùüëŒXGuHÑÁ@)ª‘ä>+pÞJ‰^ 9¶gKâ·×rçr% €œ-ч0†®1É}ܨvjˆEÜ]¿æÊxò l›Ä÷À;t:b(‘`ÿÒ„ŒX3‰¥Ùö®8’¾¯? Α…¾•žë|Iåƒmâ2z¯mÆÚ_<¢°bÐÈ!f·$¾‰¼Mœ$Èwâ<ÌÙ0E9¯mDLkSMͨÉ’ 9P[ñv?¥8{1#ìæ7 ˜ÖêKБPaÜpš¼Ùÿù4N€ƒœWžÂf ®„nÝšJå‹O+^XÙá|áõ h&]µ ßþ[ ØY¡ÏJÿ!Úƒ.Á»ü¤ä{QéQA¿šzv«˜Ñ˜PGï¬h060â÷®)¾bîÊÆ» ì’ ã€Æ€ñû2õK:$_ÃL6,¹õ·ÇÁçÍŽî|sr0ÃpßþÙ¸³™ ᯠPôÛëªÐ¿pŒ²[.U{ÂcÔÌv#ð¢ UãÇj]e>¤úú‰esé ™ríœ dâ lqŒX'ȉ Í¡Äö›²ƒìù^Ÿuü”ĉg8ÿx•wX”{­km©¡‡Ãì™pÊG¿OQÈg“ð…BL‡§Jýn¼F{«´TÊ:1lukÞ')¨“Í´—Xð1¶@«î{E,9D2¦ZôØæ÷¿+Ï¿ð`ýèæa½r}”ÑšrMâi­Œû½â’³MaýèIêGVý4.¤‰~`ùÕ,:çgׇ±²K”–[IsÒF×耜G}/W#Й]àÑAgG§á¨ç1….ëèA]o>»Ú„øƒ‚N2²§KôÐÖ†PÕéÑÔ^)c,N¸v×"yà¤s2|_6âEž¬ìw ¬Fhȸþh–ŠM‚åÑÙm«ÀJHOU®5a®9M×&TB!Ùš9;3¤[tlo†®û«Ô`üœÛ E0<Žå]–Þ´dׇùI¨˜Ÿ~ÙQiÖ•ÚÔIÜ[‡•¹ˆXL?$`?²1 ¥à$Ž¶6m-ïCR"ü"ý’p³I€årŠK„‡r°È¬®ä°IéQxÙܤ ÅFü¦ˆ•)!ïÈHIƒKåþ4á xÚœ•záf\4tï× Ûrèw\ ‹ÑaŠ©-ÍM™CÓïKÍ•²?Þ­-1€¹sN—[m«öÕᣤ)€¡‹êŠK‹|o9snÊÅ/Gh§8Q¥È¹»;½¥o9O Ž¤¤K« Õ?~Jdà¦X訵ëG!U¨'î°¸‰ßúcêFD %+ÜV² yïÿ|¨ä1,뜜‡å \qAÌÙøv#[+|9C(µÁxFpÙÜ?ˆ¾!zc9‘HuW‘PLÐ)m§ìp=Â+I¼(MÔ£Ô ¯¶“˜ÿˆp¤ð5L6yÓ¦øö§! xÝLŠìb8<ÐBýÇäg­LŸä°ÅG|X•ØÛIë!%”™”¥W$­K(øåTí’ÛÂÁ‘¿›®‹ÏŒÁßÞ²Ÿˆ´:ØKƨ§ƒ}`~´z ëæ>rgùh²<~ë-šöš3ã.±`©Ñ¥€<ˆÓ?–4.Ò›Bù8¤åø©{ “W)«›µùÞà˜æ1½vPi´ê÷Ýä5ØýâÛy“+×° ¨+¹”®û¨|õšJêóéjáwì±ÅmãRÊ™{$3Çmâì@'?!(²ƒ#þöRO»¶;Ãà5x®³²NšÀM+JQ â÷ÀXHº;zènµÃ $cåè¤þMÛ¤ÝÝà)u=±ìÉs¨´«”˜æ´¤©Wur9èVæqÖ]8JSº?ç ;)šDSF°̯¡æ»'ë±:€Ý^«Gö[¾d6¹èy_·¼†¾Ÿè´Þ8äÊãIóAùdÚ-¦_=ßáôCNj¡ö£¹µic;fZ91 ¬Ÿ …-Ú¥8G ¡H쮌}Iv»ë:ê”`½p'Éô †=Lð*÷ÎgáqMñ± üïmÏ¿–²âø‹µ#å&kÑôcàË?¼ÙÁp’ÐÃ.;Ü}e© ]ÙÚWüú«UÒfªú '"¼ãó¼–óš—…ÞЧ×z(‰¤¬ys1§(¶TœØ} ItXÐØcõñÖ¼^Fµ;¶‚ýq{XÿÇPy½·¹¬PJE£ùMžK#KßÐuïr[+7Â9TÄüTvÊÈšãCvpjçk•?æª^¹Q‚Ï©ÆcDÌèJ’~¡y‚ËVb¿söû+·qìgý÷w@v­qç"£®ÒPƒ2Dm¡õÞÌœP89ZD^ŠV‡¸]L#a¶À7'­ñU&šÅŸÓfºŠ—!üx„v!æ쪟#1Wµñ ƒŠN“zÂûë5OTúë0O2?N<³c¬èOˆÄþ¢øÜzã?ÚBâ¹9:Zœj‘2¾ñ¨‡m±wözbrÿÏ6ùÉ7Ÿ±Ãò[þÊ9¿&¯ŸîÓX¼YXà^_NŠ5ë³õ endstream endobj 4652 0 obj << /Length1 1495 /Length2 7351 /Length3 0 /Length 8360 /Filter /FlateDecode >> stream xÚt4Ü[û.чè=Êè-˜Ñ[ôÞ{‰:ŒŒÁè)Z”„ˆ"„ÑBˆ.ʈ„(щžèDoIÎwÎÿ|÷®uïšµ~³ßç-{?û}ÞÍÅfh"¨äìéU÷D ÁB  Šž1D…@ —) ‡þ¸Ì¡H˜'Bæ¨ ¡Ô5¦ A]Çéy"€Ú¾p X–KÊ€@@Hú?žH *Äæ Ôj{" >.O¯@$ÌÕ u½Í–@^'> XZZòöït ’ s‚ €z”ÔãzG'hâ郢ÿU‚WÎ …ò’ö÷÷‚xøy"]åùnýa(7 1ÔŠôƒ:êC< ˜ ¸€¦n0Ÿ?¸‰§ Ê‚„¯8Ì Šð¹ÎðE8C‘ÀëÍ&Zº@/(âO°îŸ€ÛÀ¿îÿ]î¯ì_…`ˆßÉ''O/"†pºÀàP º®*uA8ÿ „À}<¯ó!~âxðûä º’rMð/z>NH˜ÊGÈÿEQøW™ë[VC8«xzx@(À¯ó©ÂP§ëkþÓÙ{ODð_† áìò‹„³¯—°æí ÕRý+äüƒ¹BQ@q$)- „z¡Nn¿ʛzA;Á¿àk¡Á^ž^@—kÐP˜ ôúìñƒQH_hhðÿvüÛ€Á@g˜ èu…!ÿT¿†¡.ìëæ#a@kеöÀ@Яßß+Ûky9{"àÿ„ÿ…º¥±±ÀÆû”•=€Á‚b   ˆ8þ%2ÉëEè¿ËB`ãåj!\<ÒN{}Mÿ9±ß_àýk8ø€ÿ®¥ïy­Z(÷‘Û€ÄAN×ðÿ·Ô§üßþ«ÊÿKäÿ} u_8ü·›÷·ÿÿpC<`ðÀ¿®E닺=Ïë1@üw¨ôÏÐêAa¾ÿíÕBA®A á ÿûa>ê°¨³! åäöG-p³_S‡! †ž>°_Ï Pðº5ÿå»-§{×O‡Ïµ$» ×“óï-ÕNžÎ¿FLD\A"!€ë&_[âÀ`ðõ,:C~‹(,„ðD]§¯é…]<‘€_…U¡päú¸F Þ¾×ø"& ¾~¿þ±A@a¯ëG‡º þAÁ¡þ7,z Ã}}þ®‰£ü=ÿ  A‘€QsòE^—Cýß5ïÿØ¿Ÿ(4ê˜ót’v¯Šn:~«tË_pyàÎ0ײÅs>Áà d³ï))Á3¾Š¬È9ä¡Ò³žvòéE5ÞÅIÖ‹àõúj‚‡ ©Fg!çöÉÆCË€ñAÚŸ_¯+½ëd&b4U\ ¹ð1¸‡SýA›+×ÛWŠÔðÕ±?F#à]'zªïÁزÑJ…„ñ9ú‹`‚Y¼MÄ›®<ÇìQzv|” 3!?åNÙÈÁá0åËÏW¬ÚÉ€ÐÑ‚à»ó"‰'£A3¥¦">­ œ wé™q(û†¸ƒ•×Ò´é¾L¨—+`}yóvú´ ¹ÐšHfÌ8QÛQé×7Ñ^Ê}Œæ¹õ‘j)µ²¸–ÚÉn@SÑhG…ª½e^kqQži:4osqOgš”þòî 8rÓÊm=¼®-ø¬Ú{¦§÷£àуô†ãžÚÞŶP‹7 L®þ`~57ëØé)™Læt<4ªÿF«T‹šüö¤ß3©s“È•µ2…ÃaßÜSk¾{ɨ|ËÄôøGÐBç6ºûp•9šEAÔòšÀ×ÅkbM’Ý”•È¨¯ Eêø‚¿‹ž½0SÁƒ½ ­ÖD•U ‡Ò³Œ]Þwbá²™óÞ·ihX3óc³Î´?Òjxõvû]Å9Íǧ8FÐsÉžžö‰ÞK+Piß¿`‰9ú§c6ÇÀÈ—Þ=/ØEîá<Í6ýb¥#4­Cÿ£‡¯í6F¯N0ä‘Ê]eœf sà/i¬σаyz¹„–!''üìûii`*ݼu+ýú´¿'‘A§ï+·—ëSÇŠ ‡GÚ} ·}=ïë•Š`èƒf}S2rŽHð¿hä/¼ÙÙ~³dèJúÃ@Ñœ&_ç)­ý§ÏGßlv\_¢Ê¸Š?c~ž!ðM×ý›SWš8sõmTê2_LŽ}V,° `]“òfÓuþR¾xËsýþØ\8¾[ùŽbåÏÓM6PJ›UžgÐ çæÉàQW8¦ìÃPÿ·Ùo"¶žèŽ9`¹ý…‚–Û'2ßµe]á94í–8Z%G)î(.[ü©•˜—£aÜ¡ŽŸÂN‡õ+Z*ØxÜ3…¢ cJÇ»do±sÃQé2L'ÄSØžjl8Ý‚bî’)¹ùfà’ÞÚ•DxIn¥]ó•ÃJ¨h^ÏÎÆRße}ú^4…#cщLOïë FçÝ‹kÒ«† ÏñêaøD”pôI {»¶|9wÜ\ù‰…2Sèª9_î´I÷ŒávÞvÄì›mcJÚ:Ú‚æFõ„.t³a¶ÐZ³.îPxÀ1n!½½õ€¥ù# º®ýŸF¹7M ¯ü¢rOÐÞÛ)^—“ŒQÈ0·ÔÓºT_Úݤèxx0#áÔèh,É^Ñ…NB”QsÎâ7Ä`ÖOcÿöe?õÇ»%`~ôRWeÅ=.G¯ð²Á3è>¢ˆ2#QÚ5ssÙñ¼¦þGä7)Ë „ ræa·›¤¤JÆX¢6:ĸ¾¼csg^‘]}þTGýØ4Ïñìyr‹yD"œîZÞ–=éø¥,a†­n =š6úÉæÛÅ DÌL÷¶ï>°DzÁÛ¼ îM_0ÅÇîÞæ+çÄLiPr!AYþêk™1&Ýœ ÛDŠ4’8¶à:ÊO_µ%NOCRšSKvɪ4îzë.ˆýP›è‰ºAÍžœÑòºaÿkƒD%%ú^¿©a³_௸WkŽ­–¿VóL `YL.Gq·¾Eè/h^È`_|‰sÛUR]˜ %Í‚Ñ—¢Ø€@¡=ëÜ€ú…XÉ· Mâ¥ôYÈZ,ßd\ÄÑÿ©€UüzKÊHïƤÚW5CÜÉžÁÆr©DV@ÒËæµ¥Õ‚ÀnF\­¼z-•†’é¥ýt}šFÍÑ·ïá¼,J$ðZª¡-°Ã´”¯Ð¾¯ÀÖâûé¾¼ìÎí° žê!.€gcÅ\nN7è¹O$ÅX7¥X=àóÖÈZúÐõÒ#9¡&À<ð f’b(›Ý–#è>}ú/¿½¶›ÙÌ’3Ç;‹„ÊÒ9iuV*e*àS í¬ÈqT$…5xOÿáHœÎ[ìÜaÙüÖ#©ðõS^|âñxýýØBlÙùoΗ¥íg›Ø)eäçsüM±r óž-vRES¡q|Z ¥åj4žÜTQsˆ1ÿþÊm¾¹ÃEc”: ^àiØŒY¢ˆ ãD'5³‰Š6J•Þ¸›à#ý›Ça±ŒåærÒâDFÿiÁF·ÏðA×ÓZVE|—(’,;f‹™n1Êbxñ 爈Å6U•ÿLÌÇ iÇ«üevƒÂ—T½ýüꔶ3Â…èx£J¢G=OmŒžµßRçGOÃLiwÖìô‡ÎöùzQ¯˜p™¾ÓoБ|RA(`œ1¶a,È<ï¶:è¤Ú´ò††6UŽ3‘Ä[=4<ý PÇ6S{µ±¿3¬Õ:J¦ÏSU#}×Hq€LkbÅ•¿t•–Õj]Ä'‰án9Ïu@d“T2|·â™‚´¿7íØå±D†Ìe#ìÏp´uóh‰ yÓU«¹Ÿ_Êjô™ƒuÔkæ¦vìîe:ζ#~ܧÝtЭȷ%œ‚¼6Ëîï >Dé·°­;7Ý°òJ,õ'ø9gÒCéjËçuûÇý=ÄÝ9þŒÆ;ÅG½>;ž™ÔŽŠÁÉcÄ„l**¬qÁtN„Bawßol³¬€èÄóŽ^1®>†Ï9‡l+F2¹uå¼>àRÖ‘Á©HBêïgVK­ õ`ÒÞ ¸ tùE±~³¯R*ï}øòÁO¿‘&Bü?ö›¾>ì°Ä†ä³I1Œ¾ö¤M=¤wõŸ`#K.«Y)šØÞßyy#£ìî©<ö½4•ˆ5-Û t²V«þ4’dfît«Xmbý(ÒåØ0@,\3&—&äÅyµì”Ë5¹»¨òOñ‰ýó•ãoš6ìÃ%ÖøÇà´ŒM'qýci´—¼ˆ¤v£òÅ~0ÎVì{WÞŸÅ4F·IQòÖå Rý©>u2¬ÆœÒ¶ÔÜN=Ëù`5 ±~=ßÝÛ-Šât1ÆÊvÌÆÊø‡õ€wö¹_­²eªÄõÞTàέlMQoÇP%6–‘ÕÜ +:v3ß9‘Ç:ëðtk]•Û‚)¼½4fdYω¯9÷f•¬¥õº¬‰(¬{ThŠiWqAS‚L#·ÿ¹˜Žh'¼Ùbp¾ˆRÒÇÔ½‰H‹KWÀ³Ÿ¥µ³™r¥N©¹ŸCûñ‰l‚ËÛÁÍ"凳;PÌû¶iÖŠä:€üÓ5ø#¯äŒ%¯Â†ùZ¼Ï>©)ØN%0aà!±«?YBájWº+þ (y¥Æ Òè•h ™2ò¾‘XÜõôž)OýN¹lŽ\’÷-Äø’o ®«NµÄÅûÓÞÉ_1Þ_ "–âƒÀ*&­Lù†àŽû,О&"ýÄ¢%Úiz“½ÑÏ༻Ã5œ„, Уea/}qIl‹ hl_ÇÔø,$V3­lþnýp…˜o‚Yè‡NÌjÇÏ"|j3àÛ§4«g?°NØF°µG¬–‹†_2èp­9¨UÔm°œeÞQžèÓ²½n‚>rì7P¸‘öY=ÐuC[ .GÞ7A^BÄz†VÅ£ƒ²,Ò¸ L¶¸ÅCtVX´q1Šâá)3sC¼Œ€ã¬dyâ쎨ÚUM÷‡¯È}h4‘Ói€¡vùÉÁ±ŠŠ¼Ï÷ÒË'áYî´ ¹ÕÉo÷ I|.CKêA™µ]µ ¯µœ°M4¹Óä®ðšR¶p¡~,)ªˆlõH&›EóJ´hç>¤L‰-0°iQfwX€:lj-?`/-Òñ³ÞåØãoÂ.¡¢si™ëŸ »Ù5ŠÓ(ÊVy\ô|†FX--Ì.BÏkjë¬05 vÄá#_¹Üû»Ø4[¶ã 4¯{úYíOÞÇÉ®=¬Ø K^ЮóË#­Š°æpN É¦xTÜ"Ä3ä¢Mè/˜7?½mÛUL-£Ï&z)­¤ÎP sŠ}ðîi]­Ç»÷‰Uû†cÊáë Â*Ø}ÊA4~ùܡG ž{6_ɶ\}žw0lØÞ»üô¾ZÅóí;^5;âˆq·uƒ{8Ùµ[™‹^ǧ$eR¾ÓœÈ½´™ýg¾—P'ïñ¶Àûl3¶£Ù§·Ž[7HÍn—a· rùV`2š{¹-1˜)Þr{¨AÄwfuó–KïA|ZùRßµyŒ †Ì£o»˜ ¨œ˜LÍ»6\OÌ6ýÆ[±Xn-ÚÑÏRNä ×7]¨{/z‡¾Ür}^¡ÉƒZ;å˜VpX4úˆ¶øUSq:)ÂåsÔŽ:c¡õ̃ ?žð.!Jž~“ÅvÕƾ xà9+½d*í+«ƒ1•weßkìÞWhøŠÛkd×L€ ÏÈPÂñ#Ä—ó } ;€y±Ç•à2Ä#û3UùP/|´«´'óiQ'¶­â¶Þ‰Ã¸Ý—z CYñü×þ]ë¸KZHïm¥"Q¥È9+ ˜oixûÌRÇ^óÐöÆJ+$ùwfÕƒC™' “Î,Æ83ÀT%ɺ :é65ßBýº§Ámá³´õÈß+B“Uzi†h Œ©N1Ä’sÉßµ'õ½A”õ€¸[Þ]Qù¸Z¼iWMîäâºoÐZ­N5¡!n,­œÉAª TfŸÛ“ü­š/JïÊ l¯b>¿îÌØ«‡M@[oua;ø+Þ` Á-Ý`¥›~´Výâ£Ý¤Ä­-áœÀ¡3ÈNea÷ÍXëŠXr‡/-}j9ùíþŒmx–[$yA+°=]H4e¨{ïÛÕųüØåÐಕm‹÷xˈ‡>‰ÏA~Ò`Ò ¸ÂÝâ ý¸g½”qòu«R›¬^‚ºCÜÝùg8Û:ò@‡ê"®v‡´W[3z|Ð ~Ÿ?ÚÙœ?æO¡»0êýV¤ïè#0ÕÔ2ãÉN”0ñÆŒ¨)hhßõ‡k?d)1É·Z=w(C®ƒÊò4p¦]:x㔿éF·ëᕘ‚¥ˆm{’X‘æ‹þW™_÷^ص zëB=«²ž›mîß'9*HI””ßàûøz?C‘”s£¡¨LI’ý{°êc9aÔ…^g×ÏŸåÂð³{ÒZ–?S\ò‹³†p®>_œ PMZªm¼I#ïúñ­u°ƒ_{ÊD’´uÒŠ¥‚i oÛ}ê&3÷— ¥5m’•Gê )')ï¤éç-sJøU™0šZQ<昢/×M¿x³µª‰õ™çpã¨ã$LÎÙ\Cwì¶À*­M©Æåëy;áºbïêÜžCl·øN²Ò““»,¥AѪÅ(EÑ#(å‹Ì—kzãŠòî|rnKzM䯾¾ê¹ºÿ :¿i®ª=’ÞÐ`I:ôFÛM÷Ñ´[©{Ø…þâÆóü”§†¡²x±ìÃM:‡Ãɦ¹µ¤êG§6«ŒGv#©8ÌŒ8IJD­!?Œª6˜È›š¾#WFƒÏy²D»e8êYE÷YMúdÐS\u(ídaùÞ<ƒ«­,f¤ùlD;C€íÛzü&y¾…í—m5¶áðìqÏrëÕ¼AuYòÛúÜEr¸#ÚôÅð~µyyiõMÜá ú}ûÌ€¶„(³œ8Ë”š®‡ÑŠdfcäZÄ6¬Ñ«Ó‡òç2=æög7zäG ¥ùµ@¡´Ã56ìÁã4„Û¢f“Aw{|—Ô³\pú&^ÇÎõò©%=’"‹<7+È:õç+ßq¥ŠýDã="3ïìÎQP_1MóÈÀ»‹¸ «ÉÇó¦`½b @GCòÉ"{YˆÑàÃ+èÓeàݽ Ÿ˜ÈÐ|Œîhµ UlL¸ zÔ£éM»’èö“±b̆ä1ëwεã©çÚY6ÓïhYʘöh6&éÃÏOÈBð?¡ZÜÁC3•V‘—±4å­Cå— }Ú~í·uXC°‰öªc>?3ŸMJÊIœ4,9ѫ߬4.\ð0ni—cƒ½@“Y¡ÑÍûŸ€y[,#£V¦,FÅûR »¢JÕr †wB“²^°.Xß̱žo vÊ•B§÷Jü˜ÊÐÒ|Qûš‘u" sïݧgOœp­ ø7ÕÅ·W")“iu¨')Îh[W¼ É#Ÿ/¥ÆzIƆ•k‰ÄÜ6l²-þÆ䇀áÇ 9™¢rµ—+Ò÷\QÍØ©Ü”-Vk˜:ùÙÙ>?Ò.÷¢ßä®’ÚÌŸ©¬ÑŸC«ÜöüÈ$Nû%ÚÔú¸Ž-uà^0[3œÞ­OÝÚÓˆOÚû> wØñ¡y~ñ{Î&âÓŽ7­ÎQo.µ¾SÄ?=z1ÅKjÓMÂåL3`[%Y÷ÝבcïÊÚ˜£~É*ëÁGóížùS^¶Þðè1áЄ¦ig.ŠÄËì¥86ÜÃ2n+*ÔªëáÓæ§iø?ݨ&°\/ÃéT6Z†ëé ô<ÄN RÕ+Ï’ïGE|5`ц=4CD¦¥J–’ôñ¥pæâ†>ÚyzÅ`™ÁÌ°º¹Ê}3 %Ô‰»dq+’H* ͵G *²ì¶?¬êšÛäͬŠý\9Qk‰»ON@µ¥‚HÌ+™ÎÖls%9:ïe_#”ëüßì@ó²cÂ>ƒÄ¥Sî]3¤p]t¦G‹Û÷¸ÉEÛ låÚ{$ùé85½‡÷]ؽ7›MäãŠÙyˆe,®{jû–¬Æ7 ½!QB )BqJ)^3olx¯b)©·ˆørEôœX;I>§YüY—;ÓÉñ´“|¢‘ îFéS[‘éò3Ïz ºQy?ö!ÇXê|'};óæ:M[SèkQ&êEÞ ;7ÎÇJéFô"%›_DÚ3‰.‚Åþ ©9>º5‡éþº—ÈÀõή©;k+VÄî;´´BŸvqÓX“+#Ë µrå];æw >˜Ñ< »Ü`ãÄÄÈÛ×W È¡`GQϾýQ»i]ƒ3×Ø0”½ [±wJ[“Ž³ñb+¼åhž#ô|¸«ÆT_™\Íΰ€‘õ›kãVØ5ž=¶Mo g2˜·‘j–.ñ;½¸çÈ•î#ýž®Å’Þ,“[õ–ú†G`ã%Air—ªŠ‹ã24‰ß]ªÜ½ok®tÙÕž€Dü ùøÙtÃùÙ¹0ãn7Œª¡]eZÚQ óܪ¯—R´Âõnà;ÈBÊë%1É#Ÿ×Ît†ðÉïsç/dM÷|$á\22IîBåI6,¥r ôÍiwò =fÄ‹›'ÕÁÉ=]"â¥Èw=ˆHܹO<ôƒ/gD-Û=ÌílCºiÆ6u™±ÆaHZ%Œ›À±­ö6ùFÔ1YrùûÝwE/¯ÖG+ ñïܤãïè¨zÕèö>þhaiL¢’ n¨pÈ«Á‡h•‹axžî~û:ÏÄ0=Ê y/PôO¿ªê·éˆ$—–çò:ÙäÕÁ6Gwbéãnå9å„ Õ™Fk»FÕ¤"‰–ÎcD¤ïš>Í™âÿ@•¦ãïp÷«‡‘ÇC°D{¡¦™Dà«ËžÛÌЕVÕ|÷Ø9E-ZÞ¾ê.ìêMp¾õEþ*‰„ØÊDñKÔx¢¤i®y”Ŷ÷ƒ(Øeì²qõQh¡úsnyh2Úq†XK‹ ¸Š8ÁÚ^ WÖ4ƒ»…ˆÊp>_•Ú½9oÁEb”nDã 7’pæŒ`?JËÝÃg}{ðmG ªÈ2ð_øXUÏH¾Ži¬1²¶¯†‹¬ÝÕ:êûÀ!{Ѭàâ›xrš/D\©H‹fOž¾lÚRåš¼qfǘ·[ÔJ²È ÁŸ¿¸¯ÔCJoSp9Áðº^ñk<Óðîû*ªÇx%Ü)ä|üêC¡U£×RÌ2݇úöqŸ¾¦æ †8ÑӛϔtŽÏ},⥄èEíº ãD°õ jZXK#”‰FÕÛÜ`õî$a9Ž‡JS‰Ç;kóöŠíÇÁ%t\­¶Ÿû¬þà§30 endstream endobj 4654 0 obj << /Length1 1588 /Length2 7995 /Length3 0 /Length 9052 /Filter /FlateDecode >> stream xÚ·Tl7N—RÒˆ0ºatwçèFcÀ6£;$¤ éi)I‘.‘4@º‘ø¦>ïó¼ÏûÿŸó}gçl÷õ»â¾âwÝçŒÙÀ˜_ÉaUGÀQüB@i€Šž‘8…‰ØÙM`(Wè”ˆÝ Šô„!àÒÿ¥WABÁ(4¦ F¡Íôp€¶—+@H $.-$! „@©ÿ"ÒU°7Ì 'ÐFÀ¡žDì*w?$ÌÉ…¾å?G„ $%%Á÷Û äE `8@Œr†º¡o„€]Æ ŠòûW.YgÊ]ZPÐÇÇGìæ)€@:Ésó|`(g€ÔŠô†:~• лA&@Ä0q†yþŽ(0 @®0î‰vð‚;@‘ôÝc-]È ÿc¬ûÇ€ðWkBB‡ûËûW ü·3A¸¹ƒá~0¸Àæ €ÔuP¾(>îðËìê‰@ûƒ½Á0W°=Úàwâ`€º’!Œ®ï¯êŸlÑÜr@À]ýþ1ÿ=\A##c}6ïï‚ÿV)+#|üÂ@¿° $$%@‚þÅ û+ à?¾ZpG@êO²è.ý'a￦Ïõ×bpþKf,ÀõÁm€b@úKèÿ™æ¿]þÿØý+Êÿ…àÿ›º—«ëo-×/õÿG vƒ¹úý¥GóÕ …æ¾½ðÿ55‡þYW=¨ÌËíµZ(0z”àN®7æ©ó…:ÀPç?Tùƒ›þZ0Wj€ð„ýzPüB@àÿèÐ[qA?žh>þVAÑKóï+Õà„ï퀑H°zÄhI  „^C¨ïoàÚ€./àˆ@ýš§˜$@‚pE_†#âBA¨‡zÿAÄD‚Ž04­ÿ„Ñ ù7 >ü[FëÝÀäE•¢Ÿ¿<„Ð6îÿ¨h ýÁ]¡Ž¨P¡¿Ð?úûzQ€ 'z5þ–Ñf(g$ô¿D‡Cù þ „®ÒŠüü«/$:>ê7¿ÑÍýüû©‚B}¡¢¹D&òa]dÛYÒ]þÕ¹IöUó nþ€9ä[¯ ütîêìðeä¥ôÁn²…¯j\'ŠŸ˜®¶šëñ£[ž¶þ ¼´K1_m%ú8FÝ7Z¸¥ôº÷!¿‰âZà•G Y˜ v3f‡6{¾‡—$‰AÅ™O†ïëÞ²ùQ3«†kÕâ:·.Ë&øLãmÂJ¦Ø_ØçLÓ²à¡øïðÜÙ÷%:ù1y'oô†I;…—(h;A¤(ÀjE8ñ|Ú±ÂDس“ŽÎŠööÉãÊëOµif^-#?<›¦~;üÙ-MÈuËUßè ¹qxŸƒ}Tš‹ŽV›R+.~¹E3Õ­„9O4gA{ÙWëP¢ÙÞ“” »¹JÔáTL3¯ÙS2ìRßßZ^¯áßT“')AÉhàÇˮʸH¿#<+§“|6æ)¼“jË]žû¼òì¸æNÞY<Ó8ÿu4îÏR¼3€Ÿ­$†®§%j¦I-í–‡f;°P~(š¤•hÏcesþqs©GrM%a…¹•ª­Äû–f ¿†Ý¢Íã!Š?ìÝÜã«´¬¨d}zÉ §çÛ†xAÒï ÉÖ/Toòóóê?ÐÿœLq½=þ¤'AeQøAgh¢®—Èð"éJ+µê.é´J©ãÛñÌUÏ©qÝS:Z7ÍòÛêó&Žï­ØÖ÷+'3Öš„?øº~ªE{Íú¶§:i¬ bâIosèÃCöÙ´Õ ×öü.¿/EˆÞMÉ—ºûq~cɈ¸y[˜¿œ¤ï/¶À’ ~üudØxËk-Ç^F½L’Ë@Ý+p–RÕ˜=ÕOî:Ê Îlfõ4z,#·¦ {õc­òU²&_Ôw°Äƒ“§ kvV²N9VW[ÃÃwêË2 xËyy!!Óyáé1‚Áx9­Õ„ ïú8ñ èT†¦“ Üfäõ$ëej¥€Ç*”Ø÷“£ÍÈ]¨(>ò FVo)N0ͺØc¨„ ¶ú‡×è¼`´Ã)«Â‚ñqÎdJÜ"Ò¢Ö|6Y¶·wOŠ »ÓêbÚÁÏÖŘˆ$Ë'—Ë£ÍÊz/OA©ÊþaL&ôÖf— Eú•Z@Ñ?Éœ+†5\OÿCJƒø§`žY5™™Ž›1•>º‚jð}¡S?±’ÅNçf?G¢ZOr²O’a£5bU¹›ØpOÇÄõÛýrVqNÞ–îÆñË–ùÄ÷Èy Ã$ ³­´• x!YðPžœ-î†Uòƒxò‚Ý'QÅCÖ>žúÜ6½À*y|e`™xoç«Õa_YbYlhKÿàMJ)NŸž>óÞê“®Ï>Òûk¯d¢P•Yi³ŸðÚ:¥ÔlRXMQ>º&¾Bxú”=Y74 ãÎn”Œ«?þ¢tÜï-ïÛ—Ð3¤Þf?Œ–D·Çt³gŒÊz¯‘óX¢âö„N­DŒp»cN¥JîGPƒÊMÈK!<‚fZ4–ã©íÖ÷OÕÃ7ê¡ în›øM¦wªI›ò'ëòºèØ|Šlªµð%y;óÕäJ:-boàCf)ì“ó Õ3yï­E#âß©ŽrÏïL$á¥mFÈ&¼áÞfw¿IVe÷@ºŒ##-¸8ðRÚû 8©’eïOµ€"dÔµ° _4©d~×¹àÇrs©$u._ë¹ÈPò–Ûj²·@5Û'”œ>*ÞyëƒO!'ÔkÊW³šØÙWฟœù|Æø•ûÇ:o} ‚g~’éÁ?سr£QSÚí¸M©Jö7Å 7j_;Çù˜{Ùu}ﶦnH•k J4ë·e°,oV`o#ªléÝä~,¨c”Ö•ÛÆ-Ã~kiyÓ4^|ÿT¬åñ#¡nƒ¾kòOoOgÔƒr.È©j:-˜­¿†Ï}ÌÇI|p>èãxôÙè"™P”%Ž/˜›Ï‹jÇûö²›iyf»MÜs™­ø\ú `åmñV¶™¢’µ¸äJ…Þa¿V¿›ÑG-²¸?—ö‡R=äT4Øû4O›æºjqƒ•„ %Õø—cí…øWÖ>ÄÔ'?/¾´²!+èGî•ÞÎþÖïÙ‘ÉòÆ~“ÆÖÈ/33“9  $sÖÍ2žæÞ¬ð×[“ûòŒâš…³Zz݇î?a€0o:ÙäqPììJkêá{ó?êΧÞ ÕÉqî'góÍ,:—¾;ŒpéKšÛRqTË»P·}<ç÷îÈðÁ€oL«#˜ãú{§AM‘²Ô•ßÐx)¢ó¥MÂ$vÚϧ|Ryø˜ä£ íÉ]ÚŒoJM¾xJù‰ÄGÇñ |âõiX,¼ª}MGHg]Y[|%^ñ5íní7RßWç;’w©B„OÊ2 º —¿|Öým³CŒ¾/½¶ÓéÆ 3µŸf•‡r)[R+Wgbsœ½ bºÌ)‰šL 2yºyJµø“B*‡Au‚kc‚5)µ÷"Ã:K÷(ÇgÇ(ZRb‘¹n¤‘â™ÚLkJ»¬\ _hÀtÖµ¯iá40ŒÏªüš}„Š1Eò<ª0ö%/­9mûøÒ©hžX#--EìÖÞ⮺Ym{Ÿ/ö]5\»Û•Ù<ÆtAïL·ˆúÓt:*5ÞÞó )sÓ~ÙÍ.F·X:ºWì äM!K÷p¥ª=¼—ß'wGz™”OŽJÙr³âÚíEÙJÆ6”)†"©$­*ܹè-©ÃaØ–ç[ñ™óÕ²œ@_{Æ6’þ0çûÔ…QP_dmÃu–¹ð[Ógk8ÞK›ˆÄäzð‚çü@ðk›V]€Ï¾(,fùyÓ“°gC‘·ÒÌÀÆûââA¹äâgE™wV/Bè±î.ÝõÍ;2ç¤]ÙwRÂLYaÃöîôcÇ¢x"G­X~ `àGiçS2¶QÒð¸¢Ù½K<{y|ûšD«@ïé•[²ë‘Ñ£ Ëç!õmÙåãlcùÛ•¡{QÇ8wû‹Å›3™V3“’4’(µž5>èqtñ¸ RD5áZqäp¦tË}#)Šœ²ÇÑ*qb0Í#ˆ€†Vô]•*½­Æü–t‡ï²äû;µ4ŒŽ ²ïl%íÚ±Q=~[V=Kb GWò¨ºÃæÅV—™Àëì$„‹E!>³-ÿ]ï—}Ãôâ>EÊ 0•.wÐó[µwHÕßw=Ó÷UµΓe¤éæ%´´~ôɼ7°‰mm<žVòíQ{¦»ÂÙ‘}£¸Tr˜ò©ú+>ZD ð.M—žåÌBêÏ-q7v̽oˆ¼0µ9ë+‘ à÷-¤[%˜ð†X‹ÚÍûùØáh³åE„4W>»ÊVËÒ^©¬QqoØæ$Ǻï˜há$!•>±B%·ž`ªw·V¶£~j‡@¢÷ÊPÐà£R57¥üp?åÛ„A'ç”ÎêÖ.~oÒW‰øžï}\C«Ÿ¼ì”„I[±<4£§‘#MBkK¿g-ÀUX%l{u×@¢tÐo¦=ÖݛѥÄäÓ‡Y#^ö^ ŒÝK¦ºæØÚO´Žgõê¤'¥ŒƒÎ8acvŠÀ{öš¯×WÏ ¶õ9P}Òò´j ÷–ÚÚ{Ú¸7…©V‰OÊ6n”5ù™1‚ýÚ&èܧ?<ž¨Àüš³2Sí°CLî/¸Yx±,R¸ò*¥§“ëž6¦Áó^6ÎêÂJ¥o&g w‡Ê|Yzí3DƒEm-H¦[ÖRÛOïeHUI™È¾Ê{ÿ\gûå£<)jk­€ ƒ ùú1#/×nõIàB™wyÝA~žÌ~À†È•/NP«»@;Ž}Ô<—¼¬@jì»­Š.Éø²ü.b;sýsÀ|kçFãzv^‡œÏÜ`?Ÿ²Êÿ9ÖÓøl™^£Ô#³a‹ƒ¯r÷l&¼Š[”Óñ{wŽL¹T¼û°}4g ¢n‚1Tó i}Q;“-Õ R­|I1Ê'ê"_7†sWó®Ô7f’æ‘Œ¿¯ô}ôA4¹ñ´”$Y\KÓ©¡6Ã]ð^g¿v·ÇƵòƒnª3këÒ^¤L'ÈeÓ,ëzI•Ð+ŸDœ•w~ƒV [±Û= {M}‡ËÉOÌÕ8î ºég@{?þ-«·#L†±ÄñÀœ7'îqæNüºÉöEyî§?éülæýñ¸œŒJÄ V {ý#: o®5hŠå¤L…KÖ>GP¿nV©¹*f}áT›…’ ØF² JÒ'xý%á‚r ð‡ã¯isǹ*ñg{†¸ø¨³ŠAaÂ>·6dÅ_¨Ã!ùBÌ«JÍþwÍÆŒî^Põhe¶n~¬ã5qéDÐHUeÌK“.šÛœÇx' aù…*‰Q¥­õu;b8Ú*<ç¾éó}^æ7ϬŸ$VçÄ7)-œ—³«žÐFÎþÝkZíÁnÕƤòºoˆÏ)×bõ`TG=Éý¬£áðœpÊ8ýâ³ÑõÚùÜÂQ¥eb^¬nÅAÎÑñŒ(Ï–(;™üÌŠFÊÇ'\v¥WM9Ò;msÒÜ»áÔŒÖã„ô 8öר^ýýb¼ÀÎ)ƒ9·¾ îNÁ¯êV %ÓòwÜ ‘&6³V¾[šÄHDBxÞ"o¼g,xî}ð6LUÄÅ4ýغsb–—žo«¼næ#--ß6èÖŽ(ûr4.…&çeo­ ¹àú놸œÛñ—]Ó|ÞrÍ{AQÙL*1eÙÙ~Ä-I xšÖŽ“°Ÿ —:%ñÙ)¢4¡µñr³ƒ>øV¥­9»S'dÕ$ÿ0{)¯¡ÔçF^/F¸«ù¾þÃ]’.kýiÅô|«7?î­É°:;/èH|g–©VYl(ÿY+Lì£r'©:1…e’©ÏºÞOµ\{€uØ>¤;Ö*2ÆŒGàK¾œ¡óM&7.q,ÍoÈ;4]J\‹[‹…9¥gZðÕùÉöD*—AŸÑfW=y„©ñË$¤²Lç”Ìts4ŠÇº m¼ák\*᯽”jº=pèÆ\×M ^ÖOo¥?œ‘KRËÂ;˜Î£>Se:ª©¨¡æu@î¶LPP Êt¥ä'J9Rùý'T1$ð†ÙÛ±— ôSk‹Ô‚)öy—ƒ8œY©g÷¤æÀUe|îùwÒPúA\ªY}RÖâþäÄ×¢$iòÞ|¼zKB›ß;ÝÝcí¾V'nW÷a¡×Ãéé{ñámÑÉMNEíVB1IÒ¡‚×`\©®ñ¿Ê¹xT«+ö:…H¿e\â”–ážY²eÚçÛ§ñò…|×SªGÌÝg.=Ö%Á¨‹MeÉ÷¢Îezþ…h0;X®hTeL$Òº $y…¹ðPëüÂôјÈ0↊)7Ío«HŠ§ó§|Gçrôr„X 1£3qH¤Yè³Å|ë'ÞH“{‰&“Ë7oE¨@íóW{9v ‰²[#‘“ªÛ¼„%7˜KÎTKô±u"ŒïÃ)d?¯Â6÷}4é¥k&GØÚ„U¹Â¯ŠåÊ+wË'u9.l9wJ:xdbõdžŸXÍÕoqàQÒ—ž²Nü|½NN‹-š@Tà´R¤d=b…œäß9}Î4Xů®¥Æ»Ÿǹeû§¼ÙÖ᪣Uƒ³G9ίú8œ{>ÓnÏ »] ~Bq B¨t‡î]ò QÉ0 ¶ø ™p–@§Ðs­*"ÁÚhÙÌ:5ƒ2¦ÙeŽ5çµ—¤YªmÚ1‹TÉ?ÞG@èèUû­¾E6ßXÁÈF6kO—Ÿô:gýÌ·–e4éƒÖ"?%˜p°„á*m¾ýøYÈœGc%uËldžÑ6ïezf{‘BkŽà 8†ìñÌkõÈëQ•T,ݧüo—å‡×ë’㛺Áœ çÌì^÷á<—/t7¾ !3c}Òå%-ÿÖñÁ( ‹ržÆì£ßþìÖ¨Ÿ ŠØËQ¤½Â'Œ$‰Ÿ#Š/x™‰ÅM3ŽnÝýXUù‚H9þ‘xËû;Ëw!=÷+ÅÒ¬ÜH¾åTšû_¤±õ{µq(;ë3Šn€GJ£—K)Ó%Aj¢ùƒþJ•ëK$æIÈßØÌhι[µœºË ä!BÞ t|gå,;yí¥G¾žhR»rø.½Ç:ÜéH+àXBy€¼;mW…ÇÒéø AU-Ämäͽ°¹åOéÇLAò˜ ·—±4“å5ˆ¸úû›KßvJȲæÁ1åh-®Cô2S„ FÛ`oX/ùŠÂS*¡¸u䜴ĢÉKãaÍÎbßÌŠKIDSù$à•§C¢2ç£Õ—¯ÃŸ G/d0Y3Nê[¨*=â{×p‡]e­Ô× ]GÍ\U¦}@´/*ÉJi…çîiØÇSÃt¡šÊ´C*ñ¼yM4æ¡0 2é¢Ð¸kZw‹À|»¥®=ú9Áê¼,c ‹’²’ñx eã6ßPa[$›äsG72ÓGŠBÒÜ•‹¼@Ã1ýaþâ¹£Í{=™WS•ã e퓉„ÇÑ$»ƒ4d=m‘uè<ŠÀIyEó3 ¶F¿Bîgë6¢ÝñÀIÂk×…Qs*»Eû¤,´–~È"Ã,§"~‚Ï›»›¡âÂn6 ­¤š‹Øð/gÕaç1€lY–hm6öý˜u›sõI"Ûxô½«({ÕGà w‘1饌B”£aÐù$=£©IŸÃÂÈiè³³Ðmö¹ŽO*¯3§îÐXf;r>PÒÅTüN]v‡VôtQÀQË0É«¼è pç§æœ5—ØÇHÒPaØÄ{h~2ú†à ­ŸSJõt5Þ6åL‘Œçá©bÿN‹Òøkê·ã7lB2&Z¨þJkëþUyûn¡ Ûç%9§¡7 À†mÃÎÿ‰x"^'µÜÝë|]ývB¡Õã€eÜ<øY×{ªãWvN;>Pbíhh©õn+ûºd‹ï¥¿¿âTp¾SNìô@IÖ›/ÏWTA?RÔ  ÊÒmooK4jym¼ aíMÐÑ{o»ÐaÝÂ\;&àÀjƒèl¹q†èïÆ BnW(Îcmn…,^™‰4¦¼ b&ç|›ʤÈxgã?1kÿ)Kº[È…Ê8"ÿM,ÏäOØÅ¥_Ýæ**ä3ѱFŸãB÷«PRêâh®€I‘Ëv&›¹¬€€Ô^:RÜ6lAç°Ä MSD‹AóUhž`C(Es ßÃP È=êçꕘ×Ñ~ôý{ß6A‡·ž³“kFjÚl•J¦ù¨p€é´ˆ ³v½ïÞ~«ØHB/Þc—)R¢*û™J8©ù†˜T¹iuÆIÑ*›$ö÷×….sõÂò˜òW"0 µ^U…ÞM_Ë¥’BìW)ɼ£r÷›–fXû5>uâºjŸ±Ø·x^£É‚xÙÝÜÞ.wľZÇ“‡#ŽÆVõIÑ\”ÞÚt.ü4ÅñÆŸôÕÏì«ŠÉ`ÝŒtT ›Ïe>¢–2—ê—25ÕòEuúÓWÌÈkRúsÁºÜ§-Êq­¾ð#ü5±êÅÁ¥c_ëØHwDi‹Æ4E ¾.¤?:ÉÙ{ÏéDWãÇæCMupýÖRíMž$—rN$¯x탆åÁÚÃAìbfMêž– ÇžGãΡiÌO—òÏÆLy“nbý³­”±•ìê‘Ï*­õZsc S¢~£« xN1P÷4ôìþVÀm)lŪ@Ö÷9¬õ^†s 5Ë{€W2¸c•p( ôÎH8Ý|ñ²ÔVE;Ã0"³Âr¾›}¿I;4yg· ð×s¼¥Yàk-¹j²¼«mFÜÔñi9ÐËpïî˜í*‚vÕWóßCžÖÃ,óÍzë2—žiËUF{gw¿Œ}´€Œ ¹ÙÀŸöD¥‰ˆlév¤wª&wq¥¯•Ý½«vö͂駦q¦NxP >c¦;µ?fµ…^oý±—sËxS«™ùˆøM îÄBÿk¦I'SÚ™ek9­È.u)ú‡ÖÈÎa®Ë5ljB§Þ(©…¶t„AÿËÞÄb.‡Ö}›Õpšg"ƒÀ¡Á¸ j—ä(†5Ûd\"“mõ¬cû-sçƶè›÷˼¬úÇ.’®ä“`jØø\˜ØéµÅ-Äw»«{ÅÃoªCžûš­ùñ­7Z¨¶h®­èsu1a y冯Gµ0yRwÖƒ9û¢êÀìSøÑ­-ú©×@ëTñ«Y¢]Ã-¢·â;beØ#·—Í?â—KæT“íg40®¬WP‘iˆÍc„¤™<ÞbÍÊ"¬¸Þæ4ŽRJ0¸Ô>¼Û:Ö<ñM‚+àºv~Á¢iR3^m{XØNîz&{7},ˆ¦ëãYÇ/Yý ØÿŽyÏ®+C8 bp9g7Öºé )•qSç6mÇ<¯÷"Ç* ÒÙx§ó<œ¾ðÅ2f[ lƒ%ÛñØmâ~JŸÄÚ’-ÅìaLr#œ*H2‘Á‚"¦ R‚H1Í—ÁŒ_´+wVkJÒû"A‚àQg,ÓêKÙž¬¦¢å/e±¢ T„G• ¦‚oCº7‚R<ùäUûŸ‚Å·ëˆ,o®¼m©QÝÙEžn1–3ݲYd£o?˜ºJ„‡†TMm{½AîO8XczÑ8uØ|µ„¶ní0#_Þߘ¶Úè7iƒîñcp¼¹¿ë4'7L%ËدÉ˨°<–8}§Vš`å |;³o“Ö¶xMa›ùý‡Çâן^ìø´qá;®àËTVG\Ÿá0D˜wô¦…ñO¼/µþ1„$íà| ]4ÑI¬´cÚTë9­Ùýö݈S’Fº¦C”BbüŽÎ°óŒLW¶EïÒ9¨t×7LÜ6Éë×'èxny‚Øí¥ÿ¡«Uf܈”ÑCš¡¸8…^ÿ«"IùÑï¦é‘Ò–îžfSï¢c~ºË†YŒcTf¤.‚Î~$y!À ±` ÕŽVQÙcïÏœu%É(s`´—šý…q2ÔE) tÂIùY!N­Ä®D”]7¢oS>HãhÔ©¿%BOÉAÅ2ÏxAqðÎD€KÂÚÍéIÖˆþ+Cë ’úé;oÚ>žè*:ØW×Qyœ(2‰«îÆ÷Ñ‚W$”¶Yö‡)ø“Z½C´ÆHç)òe¦AÎwo~Ö]%Y”ÚˆÍá˜ìSñç$eIÖÖºP‘Ä9äõ îg&yQÆ*ÐäE}i!ÁHéjfÒ˜Îpë!<ú £eâtaÛ¼ ”.å™Ík½:³Ïµ@Èod*?‰‘øNÌ'’Ê—aã??~Y“÷†`ã7ôòd9™'cÚÝIÄÝí^Ôm•ËίĻ'xÓÑ.w§@^ݽêG 7±Û%ãörVÆ"Ãôÿwx endstream endobj 4656 0 obj << /Length1 1373 /Length2 6090 /Length3 0 /Length 7029 /Filter /FlateDecode >> stream xÚvTlû7%1:¤‘I(½énI ©1 Øcäh”$$¥Q¤¥A@¤$$”.%E@RþÓçyß÷ÿ¼ßwÎ÷³ÝW_×}ý~÷ÿuc3QUg´\ ŠBÄÀò@uCS ,!‹øùÍXOø_Zÿ8ÆFÉÿ/»:ÅâuP,ÞÍêùz!@ˆ´©ÍÐ.X(Ä+<08Êà‹r†c€øÚ@3]àm/8ê/gƒ¿D€_ "ùwº¿£'B þCa04Ò Š D \.O8ð¶–6+„¢œ;B=}Ðøx¨á uÂ;üi ÔR5Bñóý= ƒðÂúˆù <OúÉš(gu4 Ga}¿ûÓ@`à0ü­‚þ¬Õ…öGáþ:» PÎ.¿GpöõY Þ¾p]¿=ð*Àt®p,P ËÈpo <æúÜ<Ð þÇù­Æ÷‚óB{]ð#ÀC.püçõƒ±_xîþ)  3†:Á](À²ãÕp—¿düæ1ˆà]0x ø÷çß';<¶œÑ(ÏÀÿ¸ÿY.HËZ[ÓØBøÏÀÿ6©©¡€8Qq ¨¸ˆ‹eð‡f1†"þîüŸX]” (÷W³ø[úWÃ~o_àobÿ™ËG,(ð€Û‚¥À0üäÿæBþoèþåÿðÿîGË×ÓóUà·ùÿ°B‘ÏÀ¿íx¼úbñØ7Dã€úoWKø_t5„;#|‘ÿmÕÅBñPE¹zþû>Zˆ¸³1 sû *é-~Ì‚£}¿ ( þ/žU0ü£áƒÇãOš–ÔDÁÐοÙ%.% „b0Ð@~ÅxI ˆƒàiè øƒ` H …ÆâC€øñB€.h à÷>%å€ ü³ô[ùGÆ×aýÑä‚ùb0xšý¾‹É8 ‡Àa€éI4ìÖ=÷×÷ÞW«rø‹®)Žñ¯Zf Šâ¦1-¾§4dé‚/s"ç1GªéýtŸ—5Uf¸/p›oÈbšRMšÏ‚ÏRLGW›S#ÌmªÖôpQpŠš«¬_x߉ð n$lÓãÏ÷ö•¥1.d<öï֨驘ý=¹j²öRZŸò¼â£h¢E‚mDé8ÓÓ VR¬(¹Ã^íøáÑCÞð%·^Š0 d+Q¢g³ žt2ôå¹¹¸O;› +ñ!ÇÑ8µ =–O¸²â¹¢q[ß’8‰ÏívÚ¡“K2 ˆÙWÊ}Ä××\nµQ6  D´c«f2ž­]ˆT†UyI­­ŸƒóúÂèvp“\ u¯yÚΟɨ¿y|uI:.\÷:»¢âáÍ4î=̃?n¥ní¶ŒªëÑ jnj-Ã7¡=. ä5¡Ä\žëˆòŽ<€~¸£UOÑ9…sªˆž}eí}6‘½a»HûB@Ð: ûG!ŠýZáX·ò1"÷Ûþ-Ÿ½·ˆ(öÝq;ÑæE}Zèà¡5e†Ð rz-i,˜l%mÕ²ÇÝš²“r1Áþ¾êµSBÖ îsÜZmB‹8½×ß$)¨UrÂè×ðþèI¸1ÕÕ2æ©äv/„GJƒ£ûîÄÞŠc{vm‡f¥… š|ç[­å¥»š‘˃ŽÙö†(ã~ó„)Ò¦’P¾Ý¯t/¨û}5œ™¢§$’LÈ2ÕØlÌ\}%©6rË:JšçGN~å%@¦8>.X-z¤Ë°Œéf7*ñsœo„Œ…¦nήš?¾,½Ê§Ë?té½ðÈX—·FÔ!uxãN€ÇMg@Ï–ÊÜÛñÙF›y=i·ðÝK3Šnª3ÕóCHåéÚx“ÑN“~MsL`x«í÷mÁ6agA8µãÊ!Ìø¥Z®‡½Ð…@qþ¸Îÿí‹ö“›¸.ȧvç!Ð@+LkºFÕm›ä2Í~±áäÏŠ›©üöe- ñ;í ,‚ ­ìO¿}ìé]˜ßÛFî6±¹4±‘]aà4M³:ÎÅÕ› @„G+&ŒIÞsFRéOr!_q¿*ÎÙ;Ÿ¢¶ÿÚ0é§Zó€Öø¥À]áǹµmU¯ JÔÿÃòMÞ3²¾Ó ¥€õΊ¶M©Q’¨´ƒÝëþcö_S©N˜¦º‹§üÒˆF%ED‹"áßߎ5‘+ƒLã–·2•“4j¼áÞôO+9ÉkD òËÈ4·w€|‡Ÿ³™“ …$Ðo«²"­Ç…Á8a#±Ó‹Úð¥áØØ›Šùõ½ºzgœ]»1ê<>^¨Èê|ñHNâTQó|ƽj“HòpÜÆè½8€àå¡~¨D“ò/Âæg;¼oò£Iä*ØoÞ¨^|bHC)òÙ¾éË¡µ“3Õ+~_ö¼: )ÝIªpÇ^ß“˜{(èÎÃÀŸUÏx4‹eiµéŽ ÖzVºë»[ÕbÝ[hÖßÆw™e9&ÛÚÓ²_>9.¶ËåƒöXÝ4VwO›Ñ&S… ä¬ùØœÎ*ê> ¤gíÒÐæ}ÚäÔYsýärNÛ%¬XA¸{]øc—*ñõåc‹ôYJÅ»4Ú_ìŠú¤ä^?© Ax•BÈÎòCyÞ·g{(èìrGáé¸Bót‡ØY—!Nv‡¡½”éíV¢ì»˜å¸WCéÇJ+•´Ü’7ȵ{”1ŶÁÒÙe4û áþ%¬)Ÿ»²Ô„1ãjÉ°õÙÜ|‰û~€ìÌ…ëožËƒq¾l€k]…#ª×ÈfÝCpÞ–öjå7Ÿ~¸`dµ.&èsC'-»M7š-*ø2œÌtS]meÚôpW×¥Ç>D¤ Þ,O¼Wœni˜ÉïÍÜLÅÕú¼TÜ@ÚFFD¦·ùÒ{Úk»õqO‘ªœm.pf&ûP4ŸJ_Mæ|Eâtjq“AèyÝM⊒éUå•ÕMT›j~#.'·ú1·HócH,.[ó(vKlÒ4i$ÉÖä1¿&ÀDàϘÝè)6<¡« nË›][´Õ$ˆg«Á.7ˆÞÌ“?>ôºØÄn~¡`ŸGoÓ*q¥¿ ™/ëÍŽÚ;*w5WŠeì`Gué³X5ÇZv(ãì"]zN×ï|«šH­œs—¹u€ö·ÿ8äÅñnm³¬•rˆFœ^ɯs:ÝÎœ½û]~GçÅ[²qU+¢ÍÍæ´îËÒŸ®y µÞ¥l]5j•k“ï…ÜŸ5Ñ»ÑLê&ܤâ»Òª2#‹ygòWxyÕÂAÔ¶._W}õ`×2[hôóV÷ž¸¥%úØ!‰Ò¤¨¶×…x0;Çõm ·lew¥|CwVïÊs k«‡Ë¼Öæ1¢ŒŒ±‡mÆØd!Ù2U±*fÃÁ[GÃyÈYaÅêŠ;ÝŒ:¤–ùÆ# ûÁgDù^ÈÇ`žæâV g™õºO­l}wïXå•`[^j½o ÁLÔ6Z‡æ½au™©m™à¿ÚuÄ}x_ÛpÁ$t\1Éx`WcØ“`åÀ€ÞÜ«×ú—Þò[¬lÎä©üÎ<{ê×å²yù‰SàPen~ÝÆ€­”¼œ•Å(Ð=žÈ4{Þ•×n—ÈÒ»6gצ¡,e¹9üIÇjl,_øéÆn Onùækw^áÞ¥Þ>ÛÇ“¸ÔÁ´°ÀôõŠt»‘ÚÛÇ%ì³þšðG^äwÎ~œ_ŸëÚÙ8?_Ï×Ö¢[לïèñ©Tï>¸ÖÍ’@)ô­Œ½5;Ðù‚ŽžJ?vøú~á ¸jcSâ˜ØÛ$SL«ÊËJ5£@+ä蔥Z =]H‚¥Òø˜xÐítï5’ÒÒ0ïꨢž\àý_ÝþÐþÏÜ|¥J>kdsÛ‡E¤WÀÕÖ*e'M}eR§åtõ8Ý–¤)"%ÆWÖ#_£GÔß|ÙŠâVWlW;QÞ)zÛÁcK_ èpuè ­;ûé-¦ D¡? gšKßB([Å;}Œúr‚ý ÏmÿEÌJ4>sYo0 ݼ‘jàl3r mù#›^lS²4)Jl§ÙžP¨x„«†y@c:x×F¹fûžÌ½$KÈá *!j ãeÈ€»ÝIÜe^+ãqzþÒo”¸¾3i°ç);\îbGЃ?ôãÓ“ âoÂ*âë¹ç(>sÎÇä?@²2™‘*1uˆ>M˜â NI¢º6´t×B¼:Sø ÝñP«¢‚®B»qî½ï¹3ùEKxÀ_‚ñK^抠©-/WCÉI¡\±Oäw«8ž×¼NK´þĸ\A´V¸Ñ ‚Ewò›ÙïòMâÇS°Gœ'âŸÌgP¡;bÛ•QÀ{méÁ=×÷Xç“~y ¼ÐºDP˲B¹çœÖ'ŠXÜéê®ìVKîƒÝZ&Ó=ß½'ö[vodÄy£_´Åì=È0­Ö›i27KU¥ßÎÙµx/¯Œ~áMUCgiKûëýÕï«ÜyÞñD%,,Æóï± ‡WÝ—k;{MEü^Ê< Õt"ˆìYk²‘bRd?TêÊ>É${¼×3™Ãt\Ä{µÙÍŒÁTµfKI¼{Ž4Šüö„²'-÷œí¨Æ·ÛÑ1‡¾‡Ä’!ܳ½¹¼åTÅŽFm±§`£J²HºfõÕçÓj KŠ•®›ú·i  ShËõíë1ã©Žz/>±É‰Åôš ”BÈÜÉJ¾{¢2 j~:žºœ 3‡WD²¾˜ ¬ðmŽ×{åî¯1Ì ‘ÛëÓ··”1¸$¨ýØ桳!‹é cÙR%0÷’:߯ü:º|‘ªå^4ĵËÕXÿÑéû•:ß Šº³¥;ÎhóF‡JM¾èÒhà(ƒúf„Ó7šº¡‡É¬‚¥¼¾¿àE_È6„ é¤=!¤—×Bâ(„Ù¼©‡Ðé¥ ‚¹nERÕ 9òñ›“êN6 2¹’_q¨|=•Æ9ŸÑÄõÔèÅÁ©kô^LuЉë¶ÛíÜ#n­„ƒ™f&â/WÑÔ¾6³†­$~ê¯ Ì£Ñ#Ì¢–¸{—‹åuŠ=“þGb# >=¦‹¢\±ö‘ê¹/. ‚’~¥ÎeÜÉsmZ¤ Ó™[{w·÷Z§ ~íÇ ·¢p[¬¡<7ã?§as›ƒ¬:®‹YßgA‹Ôh'ß {!‡¤“зYÛ/Ì»|,È6nFd·ÈjêxߨjK«)×q÷ô‚.áö×™n”ŸÇ9”o gÒL«¶vè”t옇Ñî麵j÷#›Ò«¼€3^Œ4×åê±"ÐrØli ÙÔ£Œ‰ç…3îþË€ókbôgÓƒRk”°‹…ÈÁ™-Ïu_‹2–)¾KÔ3 &åCÉ)!’1ôJ6µ6Î~Û…ef‹¾R%à|Ä*\-¼Õ¼JÕ— é#^8ÚUVWÝsª½J`uÿ ½T>&gb°^pÅj¬å¨‘dK’{uÉægÊkÁçe½"KîÆÐøm¨äi¾{£Ò·P¾_ˆø)æ‰ïŽè E¼bVY-F] åã:Áqto/gÐuìxõº¼B3hFÁéõP%”òG`Ðṫ0ÃküœË á§ã³ -ÉÔähÅFéçèWeÏYöOžMÐTq¹Œ:¤&[ov€­tÊù%«… guˆ±þÛ¬À‘„Žä!'žá?ºgÞBCÕŠ.ì`)(œp.ËiøG:¸«ìI4ú¡.#dŽdÙ–™ŽØ­‘ÂbÔ¢X‡p »üaš®A¤Éäyb›àF˜ÑÐPÙ,ór…¾%¸[â°L-äx»”\^ê-eœáVî“å”àãU£f‹ÞŸI›×yç©M>¶ÐªWgäê¶C×Ð?)Á¹$ñK|úFTop€\NSìö„ܳE²}Ô8¹Öé ‹> È…9JÊ*~¨|î"çU†”M•¢³êcu%úF—%¶®í\¸Aó œ›]Uoý*¿$…ÂìHh™çØ$£ƒøÀvše­{E³³áí®6î‚øU³Y$¼œ£“§«ežrX±IX!—ûáÒï|?Fyžj5½`ÍeBªÒEd—}ø†ÍXÜ­ôÉr3RÐê»ßl[ª5 ÿœxZ¸=õJ?g^®Á ¢ƒ1¡Jˆ©Ò±I4B.üŠ¸c?3{—µÊ½gäìÎþK¬mÂÏw#ûÚízQ.žl[«­›ª÷]\” Rêt|åÒKž®É­éuB’» !Æ,Îe>ÃŽÊ’_È%g>²šÔ2>p |mÒS ý|^K-À±ã/kûõ±­Uî²j_[v˜d¶ã»—ÛÁ©~ÑËQ3â6Á‡”¹÷óœ[¤IÄd´š<Ô×@ )=)çì5VxŽv׫¸Sö(ïȪŒÆpîE¿HsŽùöù\£Þá`Û~âwdÑpu‡-¥.F>«CY˜Ú~ÃMUq*ÏäÚk£w Óš‡¨¼’Ó–dÈ™ZõÚ×Ç,#9 Ÿž¬w®‹ÒŽ‘kz¸¯ o~F¢_vzððP³ê¾ÜXÞ­ ¤õlùzh°‘†×‹LsNsiþïg#:0ºó¬{Å~D^ÎŒíU P] ÜÄY,gÊu7û]¡D×höUrz²b;…@îü¥}M墄Ó.¿» _…¡sÝŸ¬À¦Oêã÷–°ëË=yñôQ£ûÞô$ƒŸ%³“ù ew¬ýj:ßéÔ‘6²˜#Ù´1”ÂÊ+Ë¥ûW”–|p{7ê«ÊU¨­‚è©VÎ^ó®0èèkð'øÙ„ZÞNT¾C.Ñ#AlD©u,"Gn„,p—‡Š§¹ƒ|ωÍÜÌÀMÿ’0àf—y¸îšó´·&óí¦)‰£‰¾ì+nÛã½™ôp°Ûaþ+`¸BÕ¥,SÁ}êÀ¨©w¹ØÛ·Æó'[Ñö/z!s÷lïóÐU«·j9íþð44! JãnX*ØÓ}IP-ÛàâGU):=´@Ä?“[|;bLÍüÎ#òYkáv/½3À|ÿk¤W«›DtY¿õý h¡Õ—¼N’Z!3kƒ&5c‡»‘:–$j Ý&®.k@ǽVÎPú²¤­»f‰‚Hˆ½–)~ùÊ¥ì ¶€÷ S½«¾#^öÝ­*y}ýG$—èD® …B*¼^tÞ7JÁ5»äk†Çª¸å/¸Òˆq9:óôÔF1°–=ÇP.­ÒO±û`š$¥ØÌD»,˜úéXž-\:~Ð⥙_mKÆ BôCL1+4:JJù9Êùl7ù"P~g)¢8{ånÈ2¶Éž½˜ñ Nâ‘õŠ4'ÚÈÂøB‚¼‰6R¯M¿ÕîT±.XJ¼Vs09L,ųòƒhnðWý'×qûG.Y›‚í,‘DÍæ¹ÝŸªoà·Š;¸óBËôÂÃŽµ=ûôÄ!á &Ãm¨ØeE4†íE³¬¼†„1RTmÐw$u»[3x÷Ÿºtˆ®GBˆ<vMSãŸìß¹R´.ѱ¿ì$CDE%~zßKg·ð?Ç1P endstream endobj 4658 0 obj << /Length1 1357 /Length2 5943 /Length3 0 /Length 6878 /Filter /FlateDecode >> stream xÚTT”]·¦¤”î’¥sèéîI``˜™¡[¤»DR¤”.ié¥ûŽúýÿw¿ÿÞµî]³Ö;çìgï}ö>ûy‹ž!Ÿ¼Ü¬‡¡ø€ü‚REm €  0¿  !›ÿ±²™€H&õßpE„BÛ”@(´›6Ðp‡€Â ˜P\JP $((ù/G8B  ò€Ø´ùpIȦwõF@QèSþµpÚr€’’⼿Ãò.`ÄhƒPŽ`ô‰¶ (Àn £¼ÿ‘‚ó# å*% àééÉrAòùxž”#ÀŒ#<Àv€_ít@.àßñ²Œ!È?fC¸=Ê„Ð(Ä C¢Üav`}6ÀP]  ë †ýqÖúãÀ øëj@~à¿Óýý+ö;dk wqÁ¼!0€= èªhñ£¼P¼Ìî—#Š„£ãA dƒvø]8 "¯¡ûû«;¤-âŠBò#!Ð_ üJƒ¾de˜"ÜÅ C! Õ§A€mÑ·î-ð{¬Î0¸'Ì÷ÏÚ³³ÿÕ‚»«€1 âæVWúËm"üÛæFDÅ%°ìeë(ð+¹‘·+ø7øÛŒ®ßß×î °G·ö‡ØƒÑ„¾H€B¸ƒý}ÿ;ðÏ!°ƒØ¢6`Œðïìh3ØþÏ=yÄ `.ˆ& øë÷ï•%š[vpÔûo÷ßÃ0ÒÑÔPÔåùÝð¿!¸À—OX À'$* Š ÄÑ ÿfÑAþªBðïXu˜= ù§Xô-ý«`¿¦Ïù—0¸ÿÌ¥G3 àü›à‚¢‚¶èðÿMóß!ÿ»eù?þŸõ¨¸C¡¿QÎ_ðÿ@A.¨÷_8š¯î(4÷µáhÀþÓõø\µÁvw—ÿDÕQ ´äaÐ_"©ñÛéAP¶Ž¨òÇnüK`P ¬GB~=(>  à`hUÙ:£ $š¿!0Z4ÿ8Æî«°ù\ƒfÆ·øõb0mŠºehÅ%ÝäôY×18Elý´bg‘⤣À¦TŽYjTKr)bIÂÉÞÿ¬±ä¥þS¼ÁÉ«›¹Ñ…ŠW[w8ŒÕ¼hAŠIo¤~ÐK ÊN«­¯ðG‘{Õò¶«{hD w=ÆÈÙùXf‰û“ðBæón@é{ætª¯Ùj«¨´Ô §W¢ž€^ÿEÊV:ÃÏÞ¡XÃSu¤Í"CSþL@`®Ÿ^¶k*µŽ­.Uý› ù¡¢££· U&=_:Y¹Œ G¬ÉH¼°žÓr|ñNåmGrñ¨-EKqÁøÀM#ûõ¡ZV kø ›Nl“´‡ÍÁ¾*.E¬Ygj{²M¯Ý2‘dç~Eý~ãa„D >NAæÖu-®„¨pA¥üïÞT ¯™&Þ"bÒö8Å.fSÕÙoé¦á/lx2yš¹ƒ­q‹4AWHXb.‚ ˆá³TW}j»Öb/¾6T8øShfˆ>q.ßß@|ýµ‡¨¤S݋Š’‰z©†\‘ðÕ¬¯¨V”qI+¨wÊ“#GF·áP‹ÖÖáToõí¶G¢ä[•LŸs*6Ò§¥§dÏÀ~Wºi6{!•tá­Ÿ.¶·MÊ‚5‰V“¬ê»Â$&ÛpiW´‡Æ„}y€å²„[,=øõy"cI…¿®ÐÒÌp˜òë]½û!‘ªÉF.¦þÚ‘™z…ý›B£ÕP CìàªÊÑðVñ÷ÅšÅ&7"7ke º¿s¼Mú.Ž¹Ð@‹·i–ƒÅX2—:²[HRÀgªÔ1æ"‹%<\»SòŒçŒ.¢5¿aµ˜Â„t„Ç`–!PõÊ5Ç[‰†QmÄÃË×5ˆÜV‹'ïèÙ¼ù¡uaœœ¾‹*’ ^eK[ÇÓ3j.;É…³Ó(+Ý,§M1˜¿« ³T®Újz¯!Ù†aÃîé½™5lþ`h:¯tËÜùÛqL¼C¯ù*«£ó€â­±lâþÇþ1{¡¨úœâ'Ç‘÷‚¼v16;[\ãZŽž8½¶íw®½ï.UkPJ9QþjÜHÚ4õj˜ôåƒæÕ÷SüVÙß¾˜cL€/2H" t6µ&6®VJ8µúЩOÌo)¦±Á›&.Ëâ2ta ? î=—Vj~>À3J*”È©Á2pà7;Ö¯š•\´9µ›õrÙYr®z:„òìGOvU,Ð'ÉÃËg#ìÙ ù(áTË?{f{@L¶ûÍgj%¿±þõõÐD ½±÷•‘ëy;jæ¢>.ò‡õeªHñWØ8²8)ü+5 î¤n&àÞ d&æþbŲü+â~‚§hJ±É€+4"7â1 è^àjg¾7° uî¸Å5ØYóø-cíJÞ¼i}÷>=®‰ù÷ Üd5³«œÍÊ „…çÑ«æ¤@w¶=ëê "«ÛØ2ùk‰›”©“Ù}aŠaö-/ØøfæëÚj 6¯Fécc “ äz»4„+"j/i—÷|ò7Ö’•ÆB_pRƒý+·¥hñ•G0d•ƒB[¨ïÈtÌm2Ù ²†ŽV¹ébZjáZµRÊfžŽ•ãŽwi%iÇ¥†Â˘_zi5¶FGŽ¸÷ßµ i²›ûJ„I)9Êß_*7Qw7ƒ!ºW~ŠÙ“£~ŸÁ<ïóc^µ°(ò×­Ýês…2fïp}˽l,yCÓöº¶;À'Ú+F¬­0Ð%9”ÏôXÅ$*åXQY×K#ìœÐIÅ¥ð™#i ö+Æ©Ñðh‰÷!½LÑs[Ï}¿¸ãuE‡Úæs¯K€eçlÖ—z1 &å×~'Ãdr]c|dyŒNßäíW%ßµš\Ú¾ª! —À2º˜·«v¢aÙ2in|±®>BD™yLšñ‚M ÇÃpd Í°vu«àžyÜÌCk)¶özf#ªÌEZáþnøFû.NŠÓëe6Ú]äR9+»áÇ]&ºß(!Ã_“çJIîVÜóóv9áâãø‘uÛ>TåØëÑ9qlKYË»XWd½)K¬˜_ü3mŽ=Š«WÝñsK¬ÀÞÞƒF¤Wÿ;uÃü4œÌ®¬Sr“V«]'ñuá,å&¸ééœ8yFV{šÇ|yβ1?ú¿gL$ñ¯HÛùrM­¸â+8Òàóˆ”oÆ»Üæ®.ÛÄZ‘:wI~-ý€‰ ùô- áëÕ~ ÓÌ!Wv‘c§tª5º÷ǺVÍÀ·¯\=b•B­Ò(»ºð˜c2扽î¿x·Ëc=\óJJ¤{µ!ÞQ)³J4{È° :×f÷ˆ,/ Zޥ噦‡*.|f¦Øî ¢ ¼ÕÓh¼uW*·:çý²Dpåv£>ÝÄë8?*ºu§ª™“‚¿ål"yV_ÙÝžÍëÃ&§ +>&¦ÂmN„Ûc7:wLËá25&‡ÞÙ. ÚWñÜä¼ ©·:³úòTv˜Í»aSSS×wæô£ý`}h˜/Ð7p"J69ëcã€Ïy° ű”ï939ŠêËƼ*åÚˆJu`×xu¹ˆ’,hr€w¹wÞÉÐ’Šý#pGÅmt»o›{¾ß4ƒ;.R ÿih¯“B‘æëfÆHPÉ-×»l‡s ƒ2Õû^±jv)æaÞtgL‹ æÇ“ÐHfܘú‹8‚õï@;¬ÅåRÈÌ»JZ^ËÛ6rR`”ÈwXˆ0IëLøÖâ2‹Ü쾺Ä=*_kת옕a1å¿ÝšíÀÔ\¹`¢~íötÍ0››Ãà\&‡8Hªµ¥‚ií¬kÂG»G4Kz•¡’(óc5ŽIšÛìeSì³ÅŽÜ(RUx ø„P9nF‰Wþþ`äàÅäÙö. z4Ýt«$:3ˆCðÕƒ$?K1çVªŒDÖÑ °=áu¡.«äìn.¯"iÚ¡C  ùçf«S/©qw¬QÙeTn½éx‡9¯RœÝû¼«ïñ”V•Õv´@ßl>jÅRÖ#Ó3~„­÷Ü~dÃ\eÉ¥K6ãdËpu &]GU¤K[$|Ž9–Úæõ¨®–¹ÂÖ Q2ôF©ÑW©[üs“dÇ1‡FÐbÎÉèúÅ=àáÐ)Mj ÆstK5w¦{„7•j"Š¼n^xª¢~c¤¶¯Æú$ ã8Ã#«5õ[ɺ Û?hÃS3,>²Â[[á ÆÒbèîìíÁ*úv^ɇpºè3‡}ÿÉÒ0Æ3}?"öéâƾö‰ºFZ[agö‰æYÜÜ;".ÃDæŸÚÍ“ûý†-™²(D×– %5Þ÷Å6Üí;ššž ¬ žúòÒáç]‡5!£'l¥Íw«Y_¾î »¨¤AÕ!Y]íyŒ%ž2ÑYñA"<°Û$û¦n=¨YDŠ3Àâ‹QÁcf<䃶šÜúåç: ²Ë„Ú/ûîìmqT}´~Ï—aÄŽã¢hááºÂtZ*ú¾2ÝzšNˆì†ß]^g€æC¼È›1”Üåæk÷Œ¼'—&©ûš>Ê߬Àò»ÜVÊÛãߨ~/á-w©Æú¢\´]/&ù0uâ²X\-Œ^>mŠ¶¯«Þ±Qò"tøåm{‡iõë–¥ŽTÙ<Öôy…‰é %ïÑê;Z;Ú •x»El §;ü¶éý‰#ˆo­Ëœ­¢|?äEe£¹'t¹‡Õuaµ¾gõèÇXÞDü—~˜êÞž²Æ ½€(¦PѧÌÅ^âÚI˜– Éd†:;•_c*úA³± ëoÔ)æÌ6Ì9“el|¢|0Cõ,„¨<¨1Pî6&p‹´Ž:iQXv&¾'#  ïÖ4E2¡*»+Þ0Ðß$Kœ'é‚øü Øc_b-|ÁyåsÉ–¾6Ú—wý½2âf?ýCÈ{³j·r,mŸ~c™v (•õg§$µ1-xQï6QŽ¦Á¦ðJt¹Ž?»0›*T>Ï«Q\ç‘ÒLœÜŽL~»r¶ b‡£ãP ÄWnÜ`;ÆNš .Ny·3?²¸Ö=ô^­¡Y\Ç-£Œ ölQ„ÞÚÝ(-›3èTéзÏâ,w7E§JZ¤~ß–ûÐœù•kn³;‚ñ½UL£2ÎhÍ[ý[Î;ö>‘ƒ_¬îÞάåH­©ÆÇÚ¯#2Ô Å‡ž5S÷†äí=&'ž3«uxeÆ21æj×I`,9!ðÅïÕá„ÉH‹‘59õ;ý}ëÌrêP`ú…Å°êŒêŠWïæ¬HÖê÷…•*'Gð[Å5x¹c+i>“ÌÞ›yü>#µbOpR\  î«ì~í¾K{¤Ùò¤´jÀýCÜ­¹1¶Àq–û¹'H›Ó ¸e òzPv{å*§3æ2ÔéSxXVu7ØÀq$–ÿ®#e±t¬#®ökxϧrÛÊx’‘ãn¯sNæ}H;m”çízª3Áz÷ÕÔODÇwöŽðdŠ1Ŭ&é/® îWãÆì›3&Ù'¬ ïNïº.Æö¡äÔáÌî¼(ÅN²—ÁI†ÛT:îôü¡bT[±?£xI<;ŸÒuw²M{äÖz‚ ’5W‡0?p³[™Èì¹wLšQ[û™ ØÂ#WºòÄ¿pÆãÜÕ@°3¡™I4Ês‰lDòp^`*W¤öy´“wªØÖ9àeñƒü¾=IDÜãlJt¼Ã5­ÆÛkä³z=á …N¸)*Rƒ5 öô8æÎß}Ÿ„<¸œi\'b±DÓPoÙ£®=XU¨õ$¾ûQ&ñ`ûè·ÎóÈ(FjS“xÚâ<½X¹cZ* ”ŸËP׈æˆ÷哇Vßw”þîr¯B¿þ®(³ ½»0O)ó´¢mpé‘ÙñXô¤°M¡ËRzƒäýJ.‘QÄݪÆ1ÿÖè…àæí_îÄ—ïYðt­úE·ˆ¤ ÛÅ–z&»ÔcÒ]øz¼ä°&æ?Æ#ÇÍÛ„0š# btãgmž¿àɇl6eæñôÇœ–ÍÁÈÜý—³_ƼÙÙs‚6S¦¤(½“é·ÆÎÁ÷œmøÌ Œ–]•,éGˆŽïW&?0ô~gacÜoŽ½Ñkí1k×ó‰«3ÌWû¼ ‰^j)<ôzã—`tÜE7qo¸o>fVÿ#c¥¬5À]£ð‹âÏÂz1—ý'?EQcàøs ‹x–÷mU'ÍׇÍú!7TtºÐòˆˆõ.›uݾJŠÑ®OÎ`'gAyqzèwRq_ég·GS“ñ`YŸõLwv@ó*£Y 7­„b5=Ã=&Ïä¥ÕÇgeÞ?ë¤Ç«ûÏtÍ„Ìî€Æµž°“Ë&† ð¡îh¯]eñãV¼Èt@íýˆvWÓWîgcpYÞÊ"ÇÙl«0¯©hÙ”}¸fññõÛ°>L…¼ÆÈ%!‘~Öï*÷ 5³*´n”¹¶\J?{ÞÎ[°åí¯rä}ùàž}“Û5ÏÝ%-Q‘ÜTï‹­6 üØ{qi†Èú¸PžQ¼C§R¶–ž¾•é‹™ÍN„ÛúKªì඄ê§U$ÁkÄOèÖñNÔvÒÞ?ùŒKfè—zÄ¢b7?ž6câWðД ñ ªäPN¡®.-œ)HÞsø3$a÷ßTÑÊEýM7³›d¥GÔz+—˜ôt¹•Eج'†p‚õ½#)øÁ<ÀÌýþ‹ÁGÒCÆ/ šÊråÙhp» ôY'ñÖvÙL”J"Ë£ã3©ÂÆ7¼wY"¤©‹œžð—0×¥nsžIV^½´#`)J”Ž.`ŽÙ}ððž|Õ.Î2[÷a;®ŒWÙMÙ{;¦ÓB‡GP?X¾ÖT5Á/*ñÊjã™P†âñgI” +?¾¯'¸_|3.v_Qh…ÕÅÐԌ̾ÔeºˆÉ^.ÜÊ šNüÖi"ë7õ~&»î‘ÛUov-ÇQ»ÇÓîâýBtMî®”kÎ8U÷þ¾[“ñï!B¡eüW×tìrCµ:(é˜ÜëSìáªÛûñsGðomyJ5{æ3ƒã£T:»Q¡>]u>ÎAg–>¼9ÐNIáìµ·­âî”QÆÞx_t±×—[¾ ¯õàÉ÷0ݦhüæ®(tŽ­þ&—x7àå!½CHzR攕Óu]¿¹è8—Õ@¿}«ÈÐ è9XÈûu hßa®ú´ÕÒ‹y(•,Ðùå‹FQåËbŽ;—>q*.içé–‘ûŸ]Œ:}Gž:¦»Ì¢_pöÜ­$¿òÈBé¶Óß•zå<šGK—)§Ûïл ˜Ì»S¶ùö%Tz5úd¡fázØ÷¤æÐ[].#*ŽÅ~¿N+ì°HY,†ìAÈ0ÏÂÏ¬Ü ëà×<¦:a&ÃZ[íFê²û6²èÜŘ{ËÅ ”pj”›ÌéWm™ÊkÙs÷¯"Žâ 'Õ›OÌéçaùSéUW6ŸüÄ·:7·­)RÉ»0åö¾B>”ÛE|rŽc¿[Ÿg€U̶=¹ Œi¶ÓTÒ±Íe®\ ì ¹×Ä.–|T#"¹ôfpâúhh™ü‹©ê]ãÃJ“É’Ž v•˜{ûÆ#+r&1‡-œ3°×"ª(ã£iéÐ éaN†/“ÍJìѬ†){¢g9e°nžÙnE‘C×æÊjDã€Âõ~iÝÕªT„P4™?IO…Ø ë_Ý^§~Ý%¼јÍþ=¦§&Ýc§¦‹²0‚°(Dt¤²a¥L¢˜·Må5^ã ê…çxÒ6àíûÊG-i²¬ûƒÄÕ`x ïÑåF&x™– "–ènp5½³lèõ³goŸbÓjûk郷°À —¸þ€È]‹ KJÚ¨BïÕOjþéu£»×YþjÁï/'Vjx†CÊÔÖÒè]#«¾! a»ÕF¿Ç™­ûÝ×çÙr?6Ñ‹4nÀ)ßÍ?¸>)“žØ6¦Ó¨{9Þ9.Pu:ŨáJ0gßYx懈 *Ó:µµ¸siÓ¹ÄøÕ9ÇAŸcír™³ÄÐÙîÎÊ΢ÜrÛ3¿­™SJw÷åów»ê¬?ÄMsô:Jë;z¸µÕeÙµuz]njb°„ùx˜ñ“g’Xô™Ë¿V¦éÖl7}*Òú U¢Ÿ“fA «½ $óÙ­œEù„uÙï*Ûž [4çhNˆOÀnL.\°.âV¦H¸6 ¦\6u1‡sа]yöÐ|= QT 8ÌŠ|Û•Ó9¤)ñ¬õ¿ºg± endstream endobj 4660 0 obj << /Length1 1723 /Length2 10320 /Length3 0 /Length 11446 /Filter /FlateDecode >> stream xÚ´PœÙ-Œ»'h4îîîî® 4Öи…à!Xp Á=¸»»Cp @°GfæÎܹÿ_õ^uÕ×g¯-gm;´TjšÌâV ÄÉ™…M ©¬Á`cãdacã@£¥Õ»9€þDÑhu@PW0ÄIà¿ô’P¹Û3&eîöl¦ q(¸;Ø9ì<ì¼ll66þÿB )s°@™ q¹¢ÑJBœ½¡`[·ç[þs-éìüü¼L¸ÄAP°¥¹@ÙÜÍäø|£¥¹@b ¹yÿ+PÈÖÍÍY€•ÕÓÓ“ÅÜÑ•µ¡gx‚Ýl WÔdø.@ÅÜôGb,h´-[°ëŸ°&ÄÚÍÓ <`K“볃»“ x¾ )¯Pu9ýi¬ô§à¯ÒØYØÿ÷—÷ï@`§?œÍ--!ŽÎæNÞ`'€5ØP•Qbqórc˜;Yý64wp…<û›{˜ƒÌ-ž þ nW˜?ç÷Wv®–P°³›+‹+Øáw†¬¿Ã<YÚÉJâèrrsEûÍO Y>WÝ›õ¶Ú;A<|ÿ<[ƒ¬¬§`åî̪ívqÉKýeñ ¡ýƒÙ€ÜÜlll¼ü äeiËú;¸–·3è%ûoø™¿¿¯3Ä`ýœÈl zþCóu5÷Ü î ßÿVü[BcgX-Ý °Ú?ÑŸaõŸòsç¡`/€!Ûóà±Ø~ÿþ>?Ï–ÄÉÁûó?šËª§¯ )'ÅøG«$$ ^_fN~37€“Àû|ðÿw5sð_,Øþñ•w²†øÿ$û\¥ÿöø«ûÀ¿ƒðïX*牀ÿ ¸7›åó‡ýÿyÌÿpùÿ›îßQþ/þ¿|dÜþЫÿ?ZsG°ƒ÷_úçyuw{ž}eÈó8ý¯©.èÏuUYÝÿW+ïfþ¼âN6ì*öY©Ý,mÿ•?qíß æv©A\Á¿3;Ûÿèž·ÊÒþùÑp}žÇ?T ç¥ù÷•ÒN–«ßÛÅÁÍ0‡Bͽў[ü,q|ÙŸ×Ð äõÇXYœ nÏ.€çôüÖ(Úï~òóXÍCJìV ¨¹¥=èù´vûçüÿ³›ÿQpóX-!Ïìÿƒð<‡¹¸?·ño›ggkðóVü p<wèßûó(°:þ-r<ëÍ-¡ÿ•û™¦ÓsAþ¸ž= ÿ-³XŸ1§ñæbÿ ý7kÎçhÎ èócõ_¦Ï,Ü]ÿ¹’Àê òý ®gäy%ÿ–Ÿ£»ÙBAÿ•Ù3 7OÈ?‰q<ÿ8p=WËýSÿ¯6ZºCŸYºý±fÏ=þüÇ‹ y,Ñç –‚!vÕ!-7•â¤žÌ;cÂÓ´;ºè™}¡­î¿°“é+2ƒÖ¡?Å“»^¬lI¯Ä–(|šj‘ÿ&ª7ßùÝ›&hLî4£-Lö‰×ô’£’1k‰íú=¸øéÚÃ7Á¶+Ð溸óa©}Ä»ñì‘õªé-] ›ÛQß­àQD¿/bŽÕŽ1 ü4C›g‘5KLäÆLŽÂ€{æ…=sõs7gü‰R!Íÿ{,g¡¯ÁGÜí¬Ïê-׎—¯^“Ã_áŽLÒùJì§(Íû®ô-x5 Ræ`2¥®0¿`ÙçȨkD;5tWyŒ,¶±oç&B^“öám'V•4à›B©U *šM£ñܪ8íAäûmÖ«-?u:­íRÉ–ø§jž³¼T‰U˜Ù‘ž£«zœy9 ž§£Ç ä í6ï¬_êÞ=È“|g±÷Ñ5]宊ýd³¬kp•ªûSõþÍŠ1•"µ×@wÿBä$Ôý»ÂLaŒ¨ÌèÏÑ­B‘K$Œ|Á¹„Iþ¤5Ök!Ž¶‹„í÷dšeH>„Y"¬Möë»æ­ßÛÔʨíλ߯»møâ.Ѥ:ï&ì˜b›¢#ŸÄ;ÐG>^ÄÿI5Øtç:3Féþfe5‚OD)ÉÁè›0çEŒýŠ¡ö»_áÝJ˜=}VC¥Ô¯ïýƒœ’SQIQÚ)­xdHRžÃ·g‰¬ïº“'£ÞÉç…wOÒäxºôh^ üŽñ&b×Ûíç°¢õÐŽ5•AÖx¨(Ëa}áÉÈ•–cÝG‰‡]¹ËÌÜaimÙ ê3õKoz³µI¢•+ÐKùÔB¨6sŸÂ›'Òh¯+›c®0E½“2ÌxßÎÅ€/5׉éɘ!»¼¯kwÎ?¨Š)ß•æ‹e #I•ð#¾•Ä¥£øÐæ Ì’(ª(Ü'šõ|.˜òŸÓåiüØ“K,Ž«Fú‚Gå &ƒ:Š×¬¹e%Ñ}V-_óDOìxº‡éÑK~9“A••:¥½Í]ð•CÐÀÈ-f/ .oîΙ&O‚ñ£ÿüÒÛ滂×}UÕEš&¹…„ÓjÃuiæá2W•ÈÀ¶7YÕĵ?±h°š:JBBVñ¿,·‡”.H'åÉèźprv·F·)ý#™7?øîx‹Ã¼jt¸AŠ|=ä_4ý ÏÎÄèð©ç«È–ëÃ(eÀ¦wÓ‘Ši¥n•5Éý¬Œ–¿ÞÝÿ}!(¡NÞqÜyºÞõyœÕùÀ¼Š:ëÄ4ÿ!²¬)³ÓNLS³4GÁ%.÷wæ–Ä^Ð2ªöU% ÉŽ–wîÔXá8ÄŠR‡qj/ )“-–·>BöZí±¢/37©îVÓæ—EšÖ¶û)bêClB’ò§Cí„EÈØ«’äùQ™ÝÐåiçáhêgªC@8;Õ¨óíûl²E"€‡ª Qï,ç»ù€«¾<ã‚öí÷ÜŸK…O ¦f™KHWg|((y°²ˆlVpéÔ·* ä ë„t“ÍDë_u„¼Ás¤ÚVë…;:–¾‹ÅJõx\é§ÞݾúÖÓ¹DØT5RÈE ²ïn`P/š…­¤á¬~ü£%ßö¦yYL];s«>2hx»¦&½:°`=®觉)þBÀóµ.^\ó·|šòõeS$“¾³¸;‚AŒ¯Þ‹ÙaÂCÞ$+1^O/IlÙçÙaÓ(<‘óPÓð¥ð+Z¿3 žtnèQ\ý×ø-ü˜ÜªÅG†ÒåÁDKç˳@-O­æ.¢í€1Uä”áš}ó­«4ÿyÞýeß1oÅ;[ÎÄ$(;ãè[êX>ñªî0ظ˜¶5ÅG\[ÓÚJÝ™—ÝÑ® nÉ!8¶‘„+Ñ5Þt­-ë3õÖÃA ¦­ÉÂR¤­}Ÿôì£Ý6 .›|‡º›—Ë|¦Mˆ²Åvvã^’2Z_zòu©[Ø=ȲèRuˆÄü%ø’t?}úøuÐ-‘ßÅÆæézm ÙuuU‘Ü‘<ÝßË𪟊Å@ÒfU<çvù åÈü¥¿Ç8…pÒÊ–œ‰"¢8É5ñV´]d‚?OHÑ#}Ú!™TäVŸ&ÉVz*ÎÌ ¸?F‹¼(FðÀ§rˆlR1Ä’¾&‰¢ÝÊS Ä Âšã%ƒ›ùè,‚ƒùCŠ×ÎŽÜ:ƒ®â«´(ÀX)ÒýPxÁß=š’rÕ( 7ü™þÈöǰЧU·¥…7p…vìêÙåÌœþiÉù”+ZhøšîÌÆÄ g¸f¾Lu@ú‰æ½\Êõ"¦%ÚöîJ*Æ™9ã¢Kà1µžS8¸‹¶"8é“~ÿ…Š°”w§™‘;R'É|ÓðýRóUÔ^…å‚wР ðÛì ° }¨ÏÂJteЮãÍÈ+>äÏUŠ\ÿíný  c£Ò»¥ oyŠó–Ž~a‹{ZUÛ9Ýoб&O¡ú™þ‘¥z’䲕¿É8ªqÁÃÊ;ä5¢5¾Yÿ©“Ã'„Ï×­.îêQ9S1‹PV;¥ñó–fñʵ2Q±±t—±«ÊÖ^àù Íg>ï !.9zmònù_ïùêík‡ã{F5î®ü/Ç|å2F I ³Tàk‰^¿\&xÓ´¤9ÕïÙn'™Y”cœ=”˜P²pçhRÆG4•ý-ð¯g ‹Tn•K¯¦GÌ¿´ÞÍ+î}Æ ¼EX/ºPÛ„¯½ÅõPc3’ \kq"|“wÂv•ó¦šëõîÔj‡lc‡5L!1טÿó=[ÈçÖt’q.µéjŸö‰E½“­±3@(ÛÛêAÏÊþn•XÑÏœ,pÃ3re½ŒpL*»¦XG¡ì~¸]Q¡®ÕUAËl,Zƒký›¼`µÖËñ)ö{ÐÇüLððnÆtê#Ѽ üçE3IÜQð€Õ•}&3³ªwŒ gæË• ˆtC'ö]‰ú “%/Þ+ΠVQcŽñ‰– d‹¡—rÁÅ쇰Ýíý”:áQÛñµÅ›˜‰{£§Ü¶øÓÓ¹¯ô_,knÊÎÃ\5ïÞHá–³Ó(4¬Ä(÷ze2öÒm’•Zi½eÉK°Íꋳ/ð!ÁXõìibÌEKFÃâGö$áNsnþ&⤢ÙD§Sòô ÔD! û¥¨ø#Eúá—–ôÀ€ïõ:ñw«E厞SŸdƒÙ:y5ô31äèøm"C?ŠÜ.²€)u+R»åEûRCzkŠ8Hú’Ïô½§ƒl „·‹Ÿ¾VÝ5ÃÙEâƒ÷ ËtïÔË»¼MÛy^*æ²÷™ŠÈùšy÷º¨D3µ©¶1ê•op‹<¡Ì¨Š‹Žàvì¡Í‘]û±w!°pj}<¿#o#ºø¥ª\íÞ~zܨy„Í&“É^c ¿ŽÓ“„CœÄã+Ž9‚Ä‹ÎޔƀvÖ«LýÞ}vq!íÛù¤ÛíGÿË-hc=¼ ³²=cÔØ*ŒÅVó‡åOn¬ö*~óZ­(ñbsôŸ»)ps©Ú^˜Z½æG­æ%6Ç4 à}¢Ž<å §*«zéwi’ vw-ŸxÍ)ØÕü.áýp¶Æ®ŠÐé6u)Ɖ*öÓW3\ñÔhŽ—Åà©4æåTz†*P!nµñ²ÚmY69¤ßÖÜÒ‚|qëY«É?^oœ¥ihE<¢ýrvÃ;º†'5kËÄD“I›Ò¸ùepþ»žðòb±ËÄÊòÐ1ôD.Q‘íhªï;¼¯%5Æ1ªÂœ)Œ€PY*y„¡:[ÎÑàOØìɦÁ‹Äy7há³íÓ!—ê‘®Íhn¤“Ý-=¯D¼O„˜¿ùíE}‘j§\‘“øüøu„¢a˜•µk{u'ÑfÒqîAT³‡HæV•ô…t§ïtïÚwíõ¸(íÄCëÅÕó-ÒXØ^eŽ…ÍÝmaK3¦iaˆŸ¤ 4ÌÈæoÖ^vŽ1Ì ßÀÁ}«ðXO^çxxÿ½ãªhÞí|t„¼Ò²®çïnàûÀÐà›˜zîæÕ0€mA0×9å—H§3W êU/:ˆ9÷©¾ ¡¢Oó2ÌÌ_[å¦Ûêx$7¢Ã2ÿdóþþ.÷Ø+[äàqÁ9JÇ·Ú^%ô~i½;EÎÖ¨ ú2ÃÉrxx®X$ÌÁh” A{m½ÂLI¯¸}Žv°ìC,ìÏÈ*Ôœ‰Á yŒæú§òÔÔ¨†‘%Úmž\²]óá)À±ÍÍìš… â+.8+!ÝVp­³ b÷=ÈÖåË‹ˆ¹ÉãËHÅŠùåÙ¥t)ì ¯t©˜Ò<ãC¾>£Õ~“grnÿ7OŽ¹µñoZ.Ä'gèoüä·½3 ÒIňÐ>¾{§Mgs²¡„× ÅqJ‘c—b‘F “+žÍ”øÓK€wh¼¯-èŽì7Ýç]mtWI¤ )5ȉ<áqgè ˆ~iÉ诎w²¹3¡)E k¥® Ç}»&ï¦ràq†Þ¼ÓP ãŠœú´3î#¼æé^½;H–nT¤ 7-äTø påaÆ.c9\•ã³©#¯I×kp[À#ñ]Jó^üGì@t»_/51”«ùÓ™)½UM²c9½”k‹.]T Bá…­©jñNŽ:Mö¡‚`Ï——¥ƒ°œ/\xõÕ­K†FP_ Uýúp€­Öh5Ñc»ûB!Œ¬5(ÞÁ&RXÓ‡(†£^î,"åLZw/‹{»ë€iÆ/Èøž¸è*¤¬Té`;d„ÔÙMÃí{kú„$Âûè6$—”Íð?3³íìTÄ¿´4»‰u¬C¼óÛ‘`d‹WÆ"‹:7ŠAä¶r0\Óm|Ñœiw ¢°ã~Œ×X)Þ˜Hí ïV¾;É Ö–©œ8^¯+Yhæ±të^t StÔ ©;øÓ;Ú¢6ãÕà}m׳C7VaÞÃQÒgªgŸDâ,Ô¶wÔŒµy²&ù6_$ÜoTDÈs ŽsÅÙl^º2UMìîDgu¦u.[©»bì¶ØG5Õd öŽ†}_Yz.â»@zF)Uˆ¯È ßËLæƒ÷Z2ôÝqS‚Y –œµ¾’øä›—à½9"¶ãeëô8§+KSt¹Í*wt&¬ñ§ßAˆc÷òðÎDáÒ¹G.æ\²¶âî‹~LŽ[ð¨ÆîO8‡ &¦Ó´ïüHufojrG±Ý¾½à 5wt ÀZpHo¢ŠÆæب={L ëý¤Ÿ›ŽÔìŠìŸZ)K¨$U!;®É@/¦ÂÉM/Ù·Ì”AìyuS7•Î%Ü:ÃC­ìã—m¼,®@o¬”˜‰ ˆawJ©È‘4ÙS§’oÅýDD¨®ó>³ò,-j'Æ ú×2Šciöö‹°‚YÁ1‰˜Ôv,‹s™ÙŠä¾Ë"'½œºTyò÷âJ“˜«†® ŒËAŠÑ/Í“ÍŸ$;‹ñúòîß½‰õ\ËDñÐ)FسÉ;Ú/&â dË­*ö\`‹/U^)Ø”"þrRrÝö•pÑ2¶{™\gý¨/±=Š‹:¹ún#¾à®vÖŒAúÜ)YSë"€ÏÏï²D2Ö˜öõ‘¬‚ÿ*ê­úUsŽe—qC‹Æì^¡6ˆ¡¸\::/€ÎÎ\Ý"kþ‚ZFÏ¢™ãC¯ª £`‹\-Þ¿_‹^h¤ó¤ˆFSXÕlð~2o$öN,"bµMU «zZe·+ \ÄïZŠñš3é" õþ—þÓÓB0ò"’ç Ó¸&±‰OÆ´AäEoIiy£)³fíhØ%dÚsˆgˆìБ›T¯î¿Ôð™¶Æ‰ˆÈÞÿYïľc Àvò™\idm¼¥qºuÜÆ_S­„{\ #öìòTugPé¿Á²‡ñ²ŒÊJ{ÒÉŸéäÿ"×åÂWÉ1X0ŽÃyþqìÇù€ÙŒËÁ,šéHŒDbtØ­Q F=“ÆYºëyTUÖ  Ì»OØÞ[Ç·8į:5O£IKÅbÔ:#ïKBÎ+/Èqvf¾«¿@Î߆IØÇÿ6’¥[G OÈçK‘à(©½Ð Ø îöHº•eXe°^Š‹c×—^맯ÎE9°+)D`_8!‚lïü’ äõ<¢>øl&(¿Ñ{;±ÈºhÏãÇ]3›¯TÓ.ª­×s7‹Öi>çóÔ}/ÐôªHô…I´Í—Z‚;ýò…ÀÉtgü· &}*·ó™÷Es×ÔNå~eTAµ?¢R`w õ-Ÿ ñÎåð)¢ÿéVž‰Ù+JÌL íbÃí5 W3-üžTZŒ·¿™Ý›#‚aŸúý:G[‹Q$Œò#ájfIY“å,Aç®ÐDÃ47©§‡wßùŒo¿è±ËMYô¢ê•I%Ï(›¾¼!ј²TöÌ—G€ÿ»î»Ãèþ§å6‰oòð. vó>Ag,ÖW“Mjù^ 41 Ķ]΀´ß}.H†:=*°àŽ¢Ð'ËŠT­xÐÜ#“‹nåÛ<>‡}8…|‰ $šC‘Å©ýÀ=í9ÆKÓÁpdŸ^Ï*€‡B™o¦¤Ñ»µ¯c‹c™P›Ý8¦~bçÊ ½É¾$¤ŒÖ¬"ìy.~L+ª3‡3ÓiƉkÇì-ÝÔyø¼ˆß9è¢ñ¬¨InõÞOT’ó=ÖKP“ÂUòy|tÓ¾N©¹ÑC}”V¸K¡´ÕÚO&½‹PÅ<ó–ûäÓ\¼¼l°›ß¡†õ’OV+oLf ˆKúê Øu¥]*”ð„sÀ{éçͬ¹RÙ:Œòp$ŠOÕ–žÉ’›¹mgD4òE‡áh`J§Ù‡rÒ½ ]ÅÊïÞ{x—â0µpñ ߪà¡øÖV÷jŽ–:†߸Ùãþû~©­t#<ˆlQ™üóyŽèq=J§WÓ¸m€­sͧ”ãÏîöÂ2“Ë–{k‚åÒ?¿O¹HÊ|¸R %¼5²£¢FÝ´4UÑp¡VêÌpwËw`~»·ÅàÊ2Χ3Ãf] ¿ÍÁh#€ci½ 1¸B8*R"˜Wãzqd”kvÎS­n0®¼:IkBø r‰¯ñé®2T$·u’õvÉÞ·"ŒÌFdNÁ0“3nD>A„kS¹îT|‘û«ì*S¡ F¸<çýl¯VN wØ%lR ‹xpwpl,šï¢6l)–™Lžï¾ó†Åé—æ]KM´d»mKÕm.-”ØAغöµ#׌õpÔ)"y'!¦š•6Ö© NC¬~ݱ²Fч™×ÆP“rµó ®ª'‡\q^VîÀ·ù‘«kØG1ü â…s±FoÛ$”bÍÞüüúÕ?è ×p‘‡¶wjHp»¥·¢xdMˆÿñ‘þC`)Yýšî÷ÙCÄÏŸC_¶àEO£9¬3Çœ6Lÿò56µ¨÷V ë>ñ…Ágù”¶ñz îª?¶5øÞ¼µ6ÜÒhÊoDþ$S1 ¯ùšlŠ‡ÏN`íÏ/“²7W5m•µ¾)‹5 vç„•àT%‰ó!§Æþ„U2|VëXŠ)ÝWÚ¦íTcîÞTÐOüR%âÉEÈ mj”[ŽßË2:ÅÑág®Œ¯Ã'BëÂë;Ø£Ž‡J£gK»e Poõ4ú©¬Å©˜û6}£\‚]Oè›­„÷Kd:}VcÅ1¾î¬úká 9ørjèÓ$®â¯„®ju$ÕxôøYŠUYn›SôÒ_âhósŸÃv9¡V¡ ÆÙ_;Š‹¼ËŠ[O4ñøY9ƒ&›þw5Vã™øø¤4þWë®-½¢5Ûðñj„t?ç=»WËʧúÓ’ ùì :Âb´Ãí¼» ÌÇT›ä{¸»˜ `X‰Q#‹ŸIGf8‰T š¿XkäWj;(Ç•«·D¸¾ž4ÃDÞĉ|æ1øªóú|0p|õs¸«ªÞyRˆæªdçæ̼Ñc# “Ròw¢užRÞš©6dY~Û¸þhõ³´Rà|CÊÅ]˘yÓÛ%«ž^AæXþ’î}]`Ó¥ýdÌbÔˆ ؾ©†Œ}I„+ŽvipÙ(¤ò'¡õ5+×O9<Ñ qôÁÁ \Š²ë_Æš?²¦ÚX+¤â>~ƒ‹1ºPíß'­´ôšB1øã‰ïŒˆú™Å¯GF @=r0öÃiŒþ†K™rg©äYø€Kx%Ãî|¼ñ{Onཨ!`û¬’ÙfðL¯íY² ¡øÊ£¬}õmÄ\_ûäRÚÞW„ê¸XÃu âœÚ2xJÖ’ÄcGØФ©‡‚¯­s‘Ÿ. ¨v±™>Ñ&­¢ÊEîºÇ~hî>/'>ägOŒZӄâÏUá~l2 gam p¢ó˜"þÈy»S)rÈgñîs’‘- Óšå°±áâ‘Ê%} ¼('èpVfùéêÓܲç’>yl¿„ÿÉ||NÖnŸ㑦–É…êþ‘•ºÍY^ÛÄÁ h9\—Ù3'J³Žµ,Àäe=sEØÅ7!C™2¦–™VË¿»ø’"ÝÈ‘#‘[²U©L>G­0ß»^K¦ö2|™‹yŽdL½Š=݇[f×¾øÅÇjÔTÐÆ¡hÛ/e>Rû[oöo¿|“3v=ßþˆK©b£rÙ{®5ôsr¤r\ D Œ6Šœ¤eògþµv)ÛX^MÙU.¥£½QÎáŸßºX‡N·O÷Í#¡þ¯­\ˆaL¨fZgC²à­©Kl/¾¼95”è<13ÎŽö.óD†£—ðÉëÜÃI¢D“ö€¶:}¸zÉuÖ©#`gà2 Þà?qý–\ü%[WPÀ«Ð9ÿø“DÏE Ci,m0€">‚Gqz‘ Üra‚áž½ý”¶{E$& YüË C˜ì –Còë»~Ûa\eÕ1¢yŠ£ؾ¦ÆvŒ©uˆh®ŠWrž€âI࣑Ltc”Œ«iƒR2—}1\Šî ’¼å¨‹Öòuf’@ÕãK÷mKS—W+Ùé^ô ~o“J·ïË°”§¯<ƒL~¡­ö+ÞRQ(») ¸Ï£3¡9vZq~ÂŒ+®Õ­†ëN¬qi)ðÙ)®¥ÇX\"d‹ß740 €~m¤¾3:U¬p{{¸´sí™Gòv+cã¾ÊgIÜï’i!XÖ-bÐÊ„©¶1Ì’=õ|¾å«¸*â†áþ¼[¥ÊµZÊ+Á'OžPKÌɶ;$˜ÙÊ#@}‡îU ¿^JÉU•9ƒ“Iüco RL®Vvûòç¬4l†–|nãånu²ªÄCKoè5à ò/ð^»Šy8­²ŸS„°Û#p&ņé(G^É VÆr&R*~}:‘+ÿèÌÍ ïW–hNn;öµËQüuœ„±†¿žëøŠ¥bÿ°7Þ`_öçÃѤQÑ,zjQ ×RÜÈ5l1ìpö1I!" Ùf!ú”²/|ùˆéáEª¦y‡ÉåÐì"9N׆4¦d5’°Ñõ~ßCøwÙ xJeñˆÈpJÈŒŒø’‚~!˹KÁlÍÞü¢ÉXjÌÐQ üZîz d²×ÛU–¨á˜øD)N»Lþä°£'‹\’t/iá>¤*~ï]Á¿ç˜{ þÚÖx.—s#Ïî0À_¾êêg¿ 6£caþš;›mµXHY!jR‘ ÊE€""+µ¹ {“ɱÏ"Üû†y»ƒ,ƒãòŒÕ<ø€vµè~Aˆšy7`&öôWv"iÓ{'­ê‡—Ž!Spëdf+>@Œ¸ð’u°®›Ø:°¹Þ]®ÜúÃòûn­™³Å¦ êd¬™÷qÝ`ÏñeSÀa‰ô‚¢™èzß3G4ôo—_ËÜåRªê· Œ¥kÐcöÇyLUÆS»5| “ä_(Xô]ðÌG¨‰ða ‡†ö÷`Rßxñhõ«‚T×Ê gÍË:ƈ.uo/ -«håt¼I¢d@’Ϊ€…Œ=¡ñþœô£L³Ö—F¢qñ‚u™»ˆ+0aIƒ…×›6ò£$7ÔoyvYSËx(DÐé4¶ÖÊ*7yœ<Éôôj¸•‘9–ò8Ují¤-]—¢˜íÒÜ»é,üÑ3k¢ø¦Þ²»Ä‡ð÷ÅÄÓ¦¤ÈQç^ù¾iÕËMÞ*¶k/îªõ32€Íü¨-¼ÇövË~níñ癅̪n£$'ò¡úǹ†GlÊl$O÷>àð×S¬[i‘9&}#’y2¯õk’×såVŽst#Äirξ û{åxxù²? ïÙ§Ùf´Ñó’– ­ˆœÏÉÇâÍ;w=`UßÐáâÌã‚®^\lÖœ|ÀRòe^dƒä_»’½2wB" pvb%×Îä€fÎ÷lÙc !?ô0Á 1¬¥¤NÔú·ÁæZÏ’ù¸ŠãׂC¹W9ï(là¿l¤FÊ/ôIá7¦q¯f»fM´é’T%³BR9xk¿}ú Ÿ†.Š€!º”î85DnN\à?šæs–º­ŸD…Ü9 V¦˜ß”ñSµŠ§-XLœ„¡t1Ê`È¿˜üT¬€]*7Êߘé²2í!˜Á3TJ.䥫À`Vú£©VàBßelÈ¡Y!ª}iá¥WÒø]|ÊåÛ¸3CÈáÆvº¡Còz¾Vê‚Ä”|$H^ãWm¼ ÑYKNÞ6×›+½¦‰ $G?°WmcJ¯Ðlœø;Äwp U$Ì8¬«…ä0®œÛAê÷§(l1£óB ¥²ÎùBº¥#i@£™gPõÁÔµ[W+KÑu«FgÑÎ Óg¦)XÛþóPj.…¤UÝ@o¶—-ÅSÓ ’÷Ô¼Ê$tãc ÒÛ´¹9©ìù•=½PEäJg˪©;O¥„ ¦˜O0üóõ?ç§0y»7]ÂÝs«u뇙e‰FG&:8Ý÷¸’l4Œ)a^1 ¡Yý Ä;ƒQ7l¦jˆN;£Q3L}§¨%ЮŸ)¿Ù<’]ÅêòÖ7ª }{½kO#N”Þ_\)êÚë]¥ú¶¼}s!â\ò¤B4²+McvIRÙÌ_c×Ò¼ðE‘;ƒºåGl7š þó¦È"†‹`´¯' ÞNÌÙ‚Ë3¤<¹Z÷ì‹Œmr“›ÐQ›sö÷…¾ýl¿Ã˜†šC£¦fôø¥:Oþƒ¥Gµ]7O‡4ŽkUkzW óýÁ½{ë¿·ÇìÉñQÔɶ\£’9ÏõX»ÜG\Wyð25·3Ùªý€¿šÂL®¯ê±´tÀ×3x¼Î:´y­‘LCáÆ–“Òà\¦jê1Ÿ˜–Óð÷ºuÌ)˜dwWÚ}oêñcMŒ~ðy6.5<> stream xÚx4ÜÝÖ¾ˆhQ#ˆš!zÑ{ï¨c †1ƒè5z‹.D'Aô=z‹-Zôä›äÍ{ï}ïÿ¿Ö÷­Ykæwžýì}ö>ûÙgf 3ƒ¶·Œ ¢ˆ€£¸ùx€¢9 => àùñ™™õ¡(äoŸÙ⊄"à¢ÿÁs…€PhL„B5p€ª À'àåü@ ÈßD„«(@äµhðTpŸYáìå µ³G¡÷ùûÀfð‰ˆsývÈ8A\¡` BÙCœÐ;‚A0€ … ¼þ‚MÜ…rååõððà9!y®v’ì\(Ê  AB\Ý!6€_%4AN?¥ñà3ôí¡È¿ z[”È@0(G¢]Üà6Wzw€žŠ:@Ëÿ‹¬þ ðçp|<|ÿ ÷ÇûW (ü·3 F89ƒà^P¸À ƒ´ÕyPž(.nó‹‚!h; Y£ ¿Set t…êC‚]¡Î($ ûU#ï¯0ècV€ÛÈ!œœ pÿW~òPW}î^¼šëGxÀ}þ^ÙBá6¶¿Ê°qsæ5€C]Ü *ò8hÿߘŠ ò .ˆ'Øž÷×ú^ÎßÆß0º?g„3À]Äj Aàû AîÊÕ âç󟆮ðùø6P0 ` ±ƒÂñÿ ClÿZ£ûï õ˜Ñòã½þõdŽV˜ óú7ýw‹yõt5 d´9ÿ”ü/£¬,ÂàÃÍ/àøøø„‚¿ÆÑAÿäñ¾*p[@ä¯tÑçôwÊî4Àög@ØÿŒ¥‰@+`û·ÐÍ€‚@0úïÿ,÷ß.ÿ?•ÿŠò¿ ý¿3RtƒÁ~ÛÙþ"ü?væõ‡V® =ô,Àÿ›jùkt5 6P7§ÿ¶ª @èiÛ¡ÍÍ÷˜øø/ŠT„zBl´¡(°ý_ªù 7ø5o0(¢@BÝ0h/ ð¿lè!;¢o$Zš¿Mô ýs_8aókØø… WW>º×è• À‡=•6ÏßbðòÀ(´ ]£ÀáŠÿ«±|@!¯5ÈõúàçðÚýºË ®7t[þexaèTþ‰¢A'(Ü ùøGf`7WWô˜þ–:í¿×¿ïÄÆŸŸA€ÅBÞ†´^TÉÐxpoŽ`¯¬¶GÆ›ôF¢Xf_úØ«ãd(MºÈZÙ¼~0ôB{®4lbÆ—†ãËŨ§YgVàrªr. C¡w]öˆ;oàûI§„ÞAm7&ü"rô0A‡ŽØÊË”5Éhæ*T¸K`ëÍç‚ëväÖS‘=€ èŒ„!•#“Ó¾‡ùÜ„i5hbF{ÏÕ4ÍM_Å`ìó94ö\¶5šê»×ºilúàÒÒû¬¾ÞÇùjÝ•B¯ÃȨî{«2ä %öS‘'d©6 1XdÏäJSâ© ÂX–o[ /ÿ˜ÊïkIèp«³Ó” ¼«õl¸Þ­!8#‘Óµ|Lk¹‘©ÿ—ðAcb¤=WÕ &YæJŒ³Á´ÃJXn7=»¦}á§Æ¢¸äÜDóc}4γ`‹Ïã.¬b2øøÍS$`Oú?½’Ò†Ñ;Ù}¼OQ3“i«ÜÖdpXuzÄÅóíU/´Üøaüt»ñ}ë`Wø‚é ùd`¼q[Æ^ÏnBƒŠàÙRC!TµÚ,¢Ã’=.'nÊ_77K»¥]Iì©´ÈÜ8cœ¡qž>鬾úFš&ž‰h¨LÀ ™ã—Rº7+„†_J5J¤< >[?º%¯³GR½~W§ëû‹xk×#^~\ µÜö§öVÅš¬ª¨ÇñÐú½ø«mY“ÉÀ#á™å\ÙK²’gf¹¶1?b¿mÖæËÔD<…E&wLú¯[¾¦k{ÚK›ön|¿»5eËS¹îò ëˆÌzPI´Ÿ1¤V^'Ø,·ÔGi`ÚRo=mÄuí¶­?ýNÀgz.öx#ÐÙb»NóÐùG™‹¬<à1ë\¨ˆÀúk,‚CyÂoOî‚Æë‚øgà<ö¶õø0)µù{¦LÏ£Hk.•œÎºi—Èš«iyUû½Áç· ƒŸüp×XüÄk¬%ôÞKÑQýåÙÞ–¹‘ |Fv„Éã•â“°FÒ|“¸éá|cm…#õkþuKþ¦»¯›JÊ)>ø|”ž“T÷vY;Zݨ|[„g—Fšét3’‹Ò›â¦0O°$¯§Á*þ¤0óW'ÅÔµç{C¯˜cýµèõ˜g8ŒPîÂPT¸ÐņBën;æ´{¥±wð°Æï&E æXŽ`üòÚÂ_·â³y™SØÉhqˆZ™ÖÀd,ƒÊÝè·Sol=ø¦Kzc‰š2KïþšÖï&Íö¨ Å1\L6u×àe–ïú·o:~ MÅØí”ö“'žX48“¨De#™’®×kb5  —Çoåšï"j^,¸7çì'JuÕ$?KΪ–Z”ä é[/.o7c,ÿ^Ÿ’A9¡{pÇ]W.e®+KGÞŸŠhJÚ’+§Ÿb(‹¸ÍñEŒµ-lKFåBÛ³¬&Ýc>ƒ¬ÈFe@ÙÛ‘ |.ìù#ž>j p_oÐ@[¥ÆÖGm´tIJðeĤ²5ï€wß½3nÌ4¯éÇ}£:³Vžô^ºrpXÒ=ñemÖXÕWC þî Ó\}LµŒöÅR§5{R«IÎ3!ÂîD³” Ú|H¿u%â$éÍDA‹#”HýÍš'¶Íaj/¢ðà&-öZ  ðÔçIf¢P¼%‚‚ËD]ïWd''¶;>áã¤òö‹§âù>éék²)C»3~—ïúæsü¶¬r'^ËkU–ýo¦ÞH›ƒéŸ$Ué…]Xƒ©>ßR‹¸zì¨%AypS.=cH,Y„q-i#ž/S~vÄüÎA$ŒërÛô#öþùeÃèÜö”¢%Èb–©%zóäØœô ,%n£ÙÄÒÉ¿¶fÁžÁ ¿Ù"<Á\­ø2?^³Jئǘ'·råf¡‰/#xœ.$+Aºï_H×_Ç}W=ÖÊ:q^Jf΋=Âíïç1Ñ7 ;•Êùœ6Jtëº u†,¬×N}šö)#Ô, Â8´gF~/Û9Ê`4Í®jPmlV~Üíî•f˜ŸnKMs`[£ò`Iiö$B ?µ"Ü»,‹±uw†kDâõ·µtœÏñ:ãiΛ\…Î[;Å kž¦nwôm¸ÏÑ‹8x‘ÆRÔ)'z9‹QËÌ®’¨ø²ÆEtCÌ+–2­½•ä¤™ƒ|!K… ÛÕ©#B1C…ºÚÛLŸšD¶}`h‹Ux4·]hÃZѽÙAÃÝTO𞃗¦Àü5Ö/|¾ƒ&zn‘’Ài(´òéuO¾:Ñ“±w§ó1à¡“º1ÄýyÌŠ¨LuåÂÍj‹§'õ9ìißp\r8gÀ&^)½#-…¹™·ðÉ,5†£¯­¸¥kp€÷ ±¯iXO³ÆªÇÏJQz%Ä6RKÕÆäXdlÁ&Á¡=玚Fu&ïçÄ·eýjRwkºqVtØ>NYðÏ1“1e®®÷BZ0¢G‰w`¾NÁˆ©÷û¥©t6›É_‡äye“ù&Å}txïóY|A.}O²B8öÃÛùÛ‰}{³¼¯Ïè(öPs¡·¯”!aóÚrµ;îš_¶•„üŠö ¿àäæ˜×ñåÉPÆ¿‹NæôݪbÛh2œþº¥TRR³¥1ºï½ìšky ñC‰Ñ‡µìñP˜± ˆ­ãAwJuØ!•7ïbMý¼÷¤z÷ÓߦHù[ô}¹‰¿¯œë£¨Ÿê]6žÈô¯†WàFÔ¼_¥šk”ÙHnêlCÁÚ«G•¯óL1ô=‘£ùt¡Ú‘µ/!Ò¸"Û¢v Çáè/”ùØ…qKâ Œ1ã݇AL@º¹›ÀÚònC)hǽ{‘Þ'[Oúz}; %m~:xégÄv×:õ~±JåR 2¢ ž™¨ˆìÑ®½juÃÈg§ï^]8Þ‡F Í™ïïó0YÅ·”Z¾Ñi€ÒúSo8¿;ë¥ÄÁA&b zñÇݦyÃþõ3m¾~ÞFÑ™ ŸZn¾cyùp”Ã’y>. èMY¦ô†nõ¡KdCܨÔHg‡Ù;dêêÛ¦9ãêü.”Š°§ýÖÔ£È^Ó¤GtÁò>%:;W*r”—|«^Ns?tÕš²… ÃïNÞ¶ 樤Ù7ýÖ¾%Ùßš!Ê1²¬Ng‹9CÞ-’ÈJtã¤ó!o†ã±”I´ë®RãØ 4VëÂ\0¬gõžz2,C÷‘þålìnÍ´~k2iwzü‚úè ‘êÞáñŽ…<´äÚ´èH)ž½ØÈßÅðõþ²Aø¥o&Fê#ì!{¶Q».Ú~çW“¾?£3пgºµ|µ»±·‘"_‹écý66“8ðé8íœe¸ª¸:%|ÊùIå‚„3¿M$¦VÖ½˜£%ñçÙáU,¡¡h槢t³V›£0yi= öÔTDÚ/!3NÎÇ_TõÒUÕk©?-ve&ýŠ×tÈw:dé OŸ1‰(ä7SÄ;Hà?7—”ogûxÜ©´$8/Tüb7ÕQó8[6}{#s_¦¤üÞj›ËÛ±£!â‡+ï–'×áDчÄá{£mûà^Š׌^o®ÐézëÚ—®Ŧ KîVŸZëªÄPžvø{ž+1ýÌ¥ )ÜãñËk½;œÜPB¹8Ö®8’ž ®ªÎH’xðºÓ–òÖCŽ¡¶2lÞ-ìžHÝ'ÍlÒóóÏ3¼ ÁmÒÝš,*N/r–^I3¼wJ|”…Qýdœ4”SÞ¾È~òÁ‘r:Ꮈ×E–¦!(g·°¤­—§¨ï¥Y[ØãKÒè(£bÎN©qAì_¯—ÿù§Iê<¼Ž:(;=nš¥„Ã"–®?õ ,A¼öàŠ¥aÀW|e´·àÅy;ýõAÕ½Ÿ»óeœÉ`¢×õâyϼXö‘âé;"Î –í˜Å:­¿m°if*Õ®ÞI“$Âì-yç`^{~"`,©šç-5/ ¡yz«ÍNHããBimÂ&É8ÿ„cûyûÀˆc‰—Àb-êcp©¼ÞE'ï±Öta^@ÐFO¾góÒG!‘|°°û¹Gà<Õj:)¹áê–=5*ëÌÛ‘ÉÑ‘Éüñ^%9Öض1ï²’¤EË(Uúxèä‡@öÙ ç‡0Ê—I:ŸÓ#±¬WKÈyOnÕ¼¤ÕOriWœx‚ey3-CšØß#Óù€ó3ßI-Ö‡Å[L|º#;ÐéxÝ*<Ì Íg¯žfkºÌ,¬»«¡ÑŒ_WBèÒçÎR_9x.·²) ‰Q¯þY㡯íæ“@lm«ºÐÎyÎÉýº4Ïàù‹jÅoÚŒ-j£aaœå­“&ía2)`9[Ê.Ô††&C½VÌÎG¤ó›‰ w|4ÌêÍ·/bVÓä[ŸeÆq•Ekß¼\5Q¦³æKª[kQî÷iôî×µ0™È "âÂɤXò!UY~þØZÊùÇkâEÓ}íefE‰– ®þ>Ùpì³ù³<%µ9mûšgšµ¦X*ƒ–»r¸GúÞË“¶x[xâS©ÉÑW·¬£¿•øfTY[¯W—˜¬ütñ°‰ƒp>ú›•®iò;ÚæƒNnªÂÙþ$»µÇî«»§þj F>YSËR³q1¥ÇæßE¨Ä?Œ%I»c¼&v'Döa"^d±1YöªŠ˜T.ƒ~A€çn’bÿö™ùÆ›àD‰ 㨛»×‰‚µï¢\4P’^•aëÖr·ÛŸY¶¡zid\«ó`¬õ½E)W'·ÌNÏçrhÕ1÷‚ó´“X„Q(bÌ37%o15»ÇO&bèÅÜØwjÄ.õRR»ÜÛ†Ž®¾É=«‘êP náMTd2à©Jnacžr.ªéL…©§Ê'$ö¿"w–‚=ªæ«³e ÃWBZK<~ÏsP{Cþ‚¤Gù†kC¥5œ¤… ¯ß]Ñ GÕ ƒ2ÞÌ”öymmö$áèçFË ^)¹Ú­`÷3Å…¿ˆfñ­Š«ëˆÂ}–²¤T¶1÷$çÅ.a^%¶†ûæ ›%ª8x}@øu,þõ Ó|Ô¼WsØèA¨Ö\u„Oô«Ø×Gxº¦í”ãiMq‡GŸqoXƒ¶zZù^“ͽó{H|j¦áŸ žaƒÄUK…†­“=ML¯aŽUÚ»]ÐUºEL&¥_‘ ˜f12÷©ùZé¨ù}Ê¿~ì&–•IäwÂpÝóD„çz¦¸eËšÚ]Ìé¯ÐÁ)E0 XÁ95nÒ–‡Ûâ©(n‰Ju¡’çâ±õ ´FÁ}DürN¦…ŸÊµ„%. óKÛ0‡Œ+Yƒß~¡+¢È"&ï7(~;«¹ðDaã°€œ% —$HDCý5uÅjœbC.© \}¤¹›nýħ×ü8Ú©)›7œênßW’œ–ÙXòBjwªç&˜aØ&©g7=Îd§;é é =ÚÙŠRˆc=ÚÄ"kǯ3;í’d£²£G{絿ĞŠÉZèÄi•& |ïà½+Pìo¹ÍÔ°¢ÒG´û3×R rcõÿaÓ»« ?nrÞžÂMH@ŽÔ\gÿÀîdUÝ-z’}ûÛæQEÖGx×;-»å–»üâ#©}œX$û(Ú®²*Ó±¬ê*Õ¼›R-éf• åBTQÝœ;vpØ´u¯õúD÷±†¡"ù Pðç(§£Ê&¿‘ˆ¤mª_i€dü¢§þT^_þ³9Ï¡,¬¨Û—±¸öóé—øüÜþSò)õ(û\ÌX“{ä5ìsAaGò•›¤GÌþ8ʉf\ž£¾§ÈJ¤çA¡rŽ¸¢éúFøÜ‘ûâ»MO…Æ„b8q-OØëq=½Gt{TõkCÕù DÉÆ¢‡æfv V&Ét¡%¸¢½âÑm9©ŒbP[ˆb´Øœønçr#¬¶Uècsf”¸´Ïòd:*!¦å†ö×£ð´¾ݳº7ˆ[윘æÓ¸R¢"D)—ªv-w›×£*Ûé>Nùâ Þ¦7:?è'äÔOóO)<Ó<ð>µÑ…*6.gÞa!|Ʋ¡$9æ[/f…EÜKàþƒùâáÇJ}Óð ¶ùa3ŠQé…µCÌJ9vˆWÔÊÝsZÔÍF'Âí©—åý·ú6ŒIe¯¬9·:µÂÌç`•žŸX…<Ž×…ŒßÊ‘tÈ«ÑkáPu†Ûf²ÙI{˜Û¦u™îú?Û‹æSü¾CoA,#à^׿¦•é>YI[ÏËßûrS¿qùr8¿tßúÑYæ-ÓLo¯±Äi&,_Å‚ã´à ]™}+¶ÞPiŸx‰;^F’G’— •[^ÒŸ{6¬^âþþK¡[Y¬ì“z$î%k-\ c`ñŒk>º#]þá0—Û&k¡Ímc× £kó3cšÿ9«Û—A_rÉÀÚÊîÖWÓo’°O§sû4hÅ5UiÍ\ò“è–tÕ{¾ßÞÃ}¡Ó‹{ê!k7ž°Öz­wÝ’“É8[Ë´>:ókªNSñš6S˜½Ó9´éìZâ¨AÐ -Ýay÷R % Ö=‰Ò;ÿÜÃLxÀ¾Íë¬Û±<ÿ®Œñ~š$Qð‚³g¾ Yüô˜•÷~uSñ·´O[Ö:o©Oªô`÷rzÏñTÔÞ8îT$ËkϘyÈÔ¼Í4ïçE…l]­ŸS(ìâp­C ù'I%4(dì÷¹UÁý†Ÿ D'© æù'%ø"fß'1wè5¿ Öºþ6‘ð˜CËûG3¸ñÄœ\nÂrµ²877F·¿+±'|/ÙäAzíÙÅû£].Aø ÊŠbT o–ÔÕpTú*¡9ÉS«É{#7Ý‚I„¢\¼VUzúAè¬Ep_èQ±|ϪÀÝ nº¶*W-¦WH¸xŠ©ùÚ¬CÊâ1ë—¬mëÒ–±‡ïXEÕ&­<œÁcúd©q ‹ –? ΔÓhª.¢šb–¢ÂNnè|R{)>úÝ(w8=E!’?Å/ï –·¯$äêäô7´Ï[C%³žjÓ¿ ‰J²i¶Qœîƒñ™ËÓîú‘ÙÓ«ê¸ãʲR›eß®¹Ï<,ÔµñV`»R•G&ÈŽò-§~×qdÙ»/Å­aƒ1®ðâuõý$­ôNÍødé:ï-eW¦R6ßæóÎ:lïˆET±ý6ÎtDf3KùÌMy´Ï” «¾i;Ü9¡*L<zNV€u(°ù¢ÆºœÊ Ï{ÎÀÌsx oã³r¥ÚNŠGæ";èG‚—TJÆA¤ôOh=݇ö®Ç°{û)¶EßµûÚlmÏ£ïúµEÍÿ{ã“^ЂŠ… êQ¼ÿ!…²Yxêk'Ï•õ¨ïÜ" HR+k4d;½§OWr"„»pê_Í%©ï° ïÃó ‰å¬ųáâÑìz"¼¿‡*x/˜Ýa+Ú¶˜;dm¦ÂRƒãÔ8ü.$«^4ÞgMjjO;m—ï^‚”ºàãìÊãÓ¥“´KÒJ€mzCjUúså#mÛ‰vZ·º©Ùùxž‚sÕD©²7¤z²žÖÜ"³™….Š…BQ¯UgÂoÍñ7l?Ÿé¬ŸÁÃÑ$aãf÷I!Û|êlàdŸSþµZ,TföåsO》ŒôBú,0 ¸§bâ¶{8®ó«¾g!f• »ç›Øôžõô…7÷çp{JýàDêpÖÀ í+iÂ˾ ýӚǂõ Ù†J1 Èyö~(sì£5,ù£|±±#®¾[ò¨PÈs2˜ªØ'Ú'ÚÂdÜÈ»)“\á­]TÄlN „ºK-Ü\œ‡Õ¥‚ ±s;™/‰ˆQJÓÈc¸Ý¢;©”iï|ÇšáÎTÃÓvS”¶Òú¦^]¶~òUtiV a€î„w5 .õ\8aó“P2ÿÙBO endstream endobj 4664 0 obj << /Length1 1374 /Length2 6044 /Length3 0 /Length 6989 /Filter /FlateDecode >> stream xÚvTTïú.Hw(% ‰¡Q¤‘®af€!fˆ¡»$%¥AºQ¤[RBZºC@%¤Qþcœsþ¿sïZ÷®YkÏþÞ÷yëûžgïÍƬ¥Ë# EZÁ”/¿$ ¯®k$ðó ñòó °±éÁQ°¿f6}˜‹+‰ü_y…¶)€Qhœ:¨º9B€€¨¤€˜$?? ÈÏ/ñ/ ÒEP»Ã¡€:/ ŠDÀ\ Øä‘N^.p[ºÌ¿n' !!úÈ:Â\à0P£laŽèŠ° ‹„Àa(¯¤à²E¡œ$ùø<<ÖpÔú×P7'¾'¸³LEá/m"ø͆Dø%DE…E˜3ó„ØòýJ¯çåûíøeFOàçã„t¬ÑCÀüàÖ0ô+Ø \Ü`~>ÿÛñÏ€…CP€ÌŽ øOv´fýg>|¸'`ÂæžÀÿë÷ï;34½ H„ƒ×à¿Ï—OAþ‘¦š,÷Ÿ‰ÿí““Cz>‚„°0 ,,ˆI~ÿÌ¢†ÿí‚ÿ?¡*k$ ñ§Yô.ý«a÷¿çÏñWœÀ?si Ѥ…ÿá¸)¿?}øÿfúïÿÁeùqü¿Rrspøíæøíÿ?Ü`G¸ƒ×_š³n(4ÿÕ‘h þjû£Yuîæøß^­Y„ šË<¼üÂìpW%¸' ªGAlÿ0æýÉ/¥9À0-¤+ü×£ÅÏÿ_>´¼ öèLJ+š–¿]0´zþYWABÉLPD»¸€½øÑl|Ðz„Â<àãE Qè=£`t!øu¬Â–½ïhÁ?²CÜ\\Ð"ûMté­+ó„Af¦û¡v5¡ÍgU²ô<C7—VZ#ãº#DPìÓ9>¶q_(9ËYBËoHÕúTüttÊ—žëëÙ°§iGfÐbÊ£l†b÷šÜ>Ï«þó£Ø(’ÎfD,5rü[‚6#©¥ ¶É½$ƒ©«0±N¡­ŠÍ×?Z]·Œ%vG à„Œ9…õL6«u÷F´3ë jÀÈ”,–ÂÅ$ÍMOåÉÈÑðØS¹æÚs¯5“Øô……¾ÌžîT¡Ã\µ®JÑò§”´TÞªÌY{i©2Uë\1ØåDNä‹“ãïÒæ;>e_IJ[¼ÏíiJèr«µÑ"Ôô|çö–‡B§äKt S ²C·*ÎEÚÎÂy-fßü=ÞYAŸl_ˆVT>§ÞäE&* q"[’Ñ[Iª(Xbt–”[Nö-†·Ô;7] Ê6lñö¨Ä˜Z<©»<›¾|¶õÓã½™{-=nºvòSo1mN·@·<ÞrüøF‘`Ku\¸Ä(]nˆÙ¼] é‘<Ã~kˆÕ†A³G¥;KÌZtXˆÇ>!¬Þ9Ê?@ëE»Õ=GE"—!Ö5æÆs5ÅvÖûѪ^‹ÕØoÒ)W¶ ù˜2tæl#çW“O^èMÄÔ*á½³`ÊÇå¡›{kZ¦<¨Û‰×GsµœÈöå®ÉåÏÓCH`¾gë#Ü@ †,'*OK¡WÍøxvó½ˆÓïŽîO}ÒQ!Ú”4O€Y7¼k(¬1N…ìák»®-ëÕsÛOÎþÐ6®Ô®1ã2_ S10¨NÙ›-wˆ×a{à´–AÑ$öŽr“´ŠuÛøäYî÷äÅGݬ×ö¶XxÆ·“écèñ¾µkú‘I1]¾ƒÑª=À”Å춲391÷.kA5ûÉ9åœÅÆvÅçÃVÂ\ƹðCq>L\ÄŽ‹0ý0mk7šözq8+;¯¼õUFh¢¦Z[$JH+ËÚåþ“9mØ‘×ѼbŒ9¾bãϾîm±ôéÒØžðv]¾»òBâ Pð§e‡ ²ãª5T³_èpüTfÿúÆV«Þ)ÊŠüÒñú´ëž5ôÃpœm‘TÄ1e5nYWNèùö‘vî§ „k†Á·|k‹'Š°›ü[­ÎG™Üxƒ„œ0ŒJ53W^¦i¾XKf`×wVçç÷¯p¯‰,=ÈUâázÇ»5úcI0¢‘´r{Hÿ¥¯¸b§iÉh¯•®uŽìh¤ÖËëV†>qõBKBšrKH@6ˆµ­ÔÀ:(ßצʤ‘êÀ[„é(¥²¥‘TÈ|ßGc?¯ÿ§¹Oø µ¢Ö#¦ \æ÷Ýç+!yŸÒAÇõDï2ÉO FK! ÷™æ’¥\£BkŠüeBdµÎSñùÈ$:FÛ¶ˆ.Ÿ²  |‚s«eò‹î)HùÃÌ`9v9;Ί?¶âã.R?u3’òwŠWiË»GMKD¢ €6œ wË>ŽŠ`ÝyŸH&÷ƒèízÒ%¦ Ìï ­R=x#ÏŒATÈ{ë ég¶9j£…ÛuâÝå\~Zž¶2‡ò€V*E‘q$ª»ýE=ó'ÝÏ,¾žÑ9Ñí:ðÚÁˆïÅT^úúXQ ­k&ï”9ÏÉÖáÇ>; ^ãz–Xq¿ÖOYK¤K2{ÂðUWšê15•‘k’nŠ ¡ñ:¯îx)wÐé>8Û&U©÷µÚ˜Ëéî[q+:\Ol·,ÃW¾HÄÌg?É—L~úRò‡Ð£k[ –ÎhÞð"AåD׊Úñ²=áÐÅÍç ­6›(akž%Õ¨j|‹îjxЬþc"ènµñ£JEÁÑàû½ªÊ¤vŽbÝÆa)÷c‰4^¤—Û‘'ŒÑµíj84·°¨ª|áhõ^(rc)[Ä]%ó†ìš‹±8áôJ?È[âý9ÁòÒò#'7›?FèøëŒÓ:eJ=™¤÷ ¥«•¨žÕã¢~¼ÅL§Ö=šŒß‰1׌Rù1cè_\Tãz/™w<Âti÷,FÆR‚èq…¾’r™CßíÄ·¹ãfYÏI¯ûù´0¯FV 9YæôDØ'f¥)3è“–ÀÏyý&ÞËéT-Tp*èC‡l_bÔ& rY>‰dœáLZŒæÎO†"A„eb5Þ789Wt@TËÇ&JZÑéÖeÆé·Ï@¢ÞFEÕB~-JÙŽÐhŒx¦8–g‡Rù(þì[¾y©«,¶3ÜŸÔz¼h¦#èA‚êD i‚'ûüGŒxßžd·â™Û¾Ç$Ç%§^<½/šw-dlY£”iª o,q:. ¯·¶d®êD¡?WýÔßX—°¿1ÐwXt!W½¦“ÕyËscç„j°»h{,(Q¶H“™t§lwŠ—jêídíîn`Jéž« Í,ÍÅ8µ!kPÖá›Ñ­2ƒõ´^¢.®k5ûÙtóPùü]rgE¶În¶ÊáåNàׇ]r‡Ì”Ó§LÜ*I'Dxcg©Ï–d ÖÛÛIIÉJuŽgnêM´¹6í6ñ¿µ±Âû·>7æ~½\,r»âhÙ”¤r” yAhÉWÔIJ2Ƭx¨cI ìH»½½$¸¦!‡¶XNÚhù´§±ZüTÍõ{4xÝ^Í‹y,×ïD·øÕ3Å¡BUûÉ¡³oƒ(]/0™ùüšYZ¼(‡V*Ž ‘8Ñ+ÌÕ3ñNC­çkí'O|öyñ"’^4IJªÙŠžb¨‰àù˜d ¥ò2K'$Ö¾&Td6&HZ绾yJ”wèEJ&*w›/T:ùñš~gñåÁ©y<Ù”.ƒäìÜL>¼Mæ=3ÑiõÍLÆŒïã`»¦Ù¥»júÏ7–?|ÔNl°´Xï1¥ÙýX×i+ä&!M|ºÌ?ðyyüc¼_>NÞ÷ÐCàµÈ"ªK‰‡ Û8\Шbt,et,A¹á;ߢ| ÙšMŠs¨áЪÃÒx!oM]ÿìz~Å"zì+=aR/“D/êf% M'™hdƒ`ÇfN¢i+?­Æ‡Á ë)ʆ$w w¸ê¹S(¨=qÓÆ°üäXJíävýŽ$RÂp0íë5‹eHç¶Ïç”ÄŒ»ü FAs¿rKÜWÕ¥¹U„LËíX9²}ro¾¨çn4rÊ$„VÃ,G¸«Uýj4:ûß´‡9Ÿ“õv„¥ÑÄE]r/* tÆjh©ë4./Ù³jcÖLj¹t 9¾¬»`7¥^ê4™è›Lê; 9¦½yïj˜ý~èZñ¦`eÄæ瘎µŠ)UWý‹g˜ïßYÜ>§Í€2’íx9:Š„ÖÚÛ8 §¹ì›—Ä>X#^áô;+6ÖÞUnÉUéw̧×}Tö'oÂ;]mS³[Ì¢sžÔ+ÉÝ*Âß^ˆÍJÆ‘ù9@½î={/“(¸4gnoæ £k9@%Þ>ŠKtU:@Mô™¬#ÂU ÇAz¯BOôùÁ‚¨ê7üâ“9f‘*y×&S!»!îežËz¦Œ1hêE[žgˆ&3ñ‡Bà!ð¾òBsscGpLCvs’ùÑdO±…ã¼g;§WIAûÜ36HC6Ó\MÆCmŽ9¹!\vBíL=»³fMÛˆà16Ü/* Ü×!Fs…‰sŽÛ]{´mux³e@t N„‡“¨é¸jäãRÇ¡ ü@~EÜê¶óÖrk cžaÿ8 ðˤ­Ïùë½ ¦xTC ˆm›§‡oÞú¦røÍ|#‚|âú‘Ë.°R\ï€ÙµÏò}XF¢ÖÓ—M_LK4y)üPáÖÅ8bmËc°oŸ¼ mÞ—H"¿‚­«¹­´»×˜§ò0ì¡ïû=k˧3¶U›øÕ–„º0½ÙýÖà ÓfÒ,†ã_4”>k~}xuó¤{CÖS··ƒœ‰ê¡ËF–·W‹åãaKÓ…Ï눵%Ÿ1ÍRr¼šbaâ¬ÒI7Ä-£Ëóö6jÒ–¥\ãÓ‘¦Œü”?ÁÌ¥šß<°W§ºú;èœyÉ ±Z]Åa‹ŸºïkÒ/5{MH(çnèŒ3BüGԪׂ6Q¹µiòß‹ÖT†/µº±&ð8™ȃæ& 0]Ûð´[Z~¿û©}2S‰óeÕìØ3#L ÷m¢ÕêfÖ¸à†âºDÁëQWØ­ eà=Í2¶íbcl| µŒYB{¶µRÊ-4íØ.ó2%„ñ6W×ÌìKÖnŸa;²ÁwØj¶¼ûYéäÎ1¨~¡eA z­Që1oÈQ)±ù³±£N³äRg~cBzíÒ wFCzNåJ´ÛO7Ôø´Ãk”[¤H€údJn2æ£ùpôðº‹áÎÙ€ao…¼HH€~8‰a|·`hQ½Y;pšòÕÓ*Ì.‚q ‚/6aÎÊ…]£Gß<«ükS|Òã”»¼¿ì¨fæTÈ<¦á$í*LV[1ãâ¿å|Ó$Úb'eÐ>–ÁÞu®¾ü;çtãÌŽÕÝŽd$«"¹™û=8ûîÀ%PÕ°…ź›V ÌoóƦËõá@›¤l,\$e‹¼"±×Z.‘¡Ñ1 "£di¿ìX®M;Ÿ¼rçñ2IÐìªHv¾Ú35„¨ÊµÉ|XóÔ%¶:zÝÿ–v+Fñ™‹»Ì<éÈÂ;ÆN㪂€Ê’^Æä®ÚõL|Øñœñ´qè§Àƒ>F«{}WØ“ä€iå©Í,ÑùBTö§`ó&u~.±PÛ`V²)€î“$r•¬ïxû}Ó\fCßœD,iZ)¯“ïö€¦Øèeè|õ8Í'\y wú+N³´ÊÅ’o÷½zá;aORç¾íExh#!¡9¸ù¤,©»lGmäßt+‘6LŠ&o¼=š*wÏÞ(ly9¤B€ÿ–q`æ9ÿˆ¹ŒaÉ)$ —Qk•k:t˜Bc9D +¹éµ<À‘ÇÝ¡«K}˜ë}©å¯@ÑnB²™¼3u‘fwÃ4Z©¼ ¥>>3ÅÌíŠ$Âà³½±w‚øãó…(uFÛ%d§æý¯ÍíÒZs–¹5…±g9ô­wî¸Sát+ºØ%­ls”Îv{«Ð­ –s?OªSwðzçdKøáS[a}˜ç燂§¾{®Mó¬9ÈR´QW­`i ªîwUŠÁÊK[AYvŽ7[Ï.û½PÅDø á˜xOè}©´7~z£k¬mF)ùôŽù(oÞ»O¤Ä¦,îAþ™Z ¡Ãv½Œ„d솘§bu´ûMÈ5»Èa÷Û1o¬NÕäLµ>1&”kmö6Ú9C.;§e0k”¯¤æmøX4æöI?nfHô¼ù€¢÷+SAÐçõšõã%ã7†Âk£Ž°#üp8_kl íµøDÎ85E1TëºÍÓGÍÔuü`€Šl晪Âå‰éz«LùU_GÊë.z—ÛåqUÄÚªŽ íÀ)Å ƒ½SÜ>M„ÅlFP×6zÄF¼Bå4¬e/‡Ì*«.ªðGØiøp¾1kØ-u`Á¸wv«xrÏŠýÓâƒY*Ñr&–'Ò8°=¦œš•¦ëÕZé’Źõj™^ι;ÁNнKx0f-qÃð5ñrþúÏžd» ;•îbï¶<óVoaÐãHeÑ-Èmêoï¿sË'³®ñÅW0Åûžš˜Íaf?ÍÁáëé·S%q¸&êÛ—â ¨Þ7r´Ôê+íYžÎY«nl¶Çåþ½åOú¾7S±PWÚ{ +9 ¾[…¤y(@½t?Æ_åb£ç†™ŽËré¡èÊp ƒÙw³ã…ÎAÙ­¹’-0 ®¬<õ~aûFƒä”õYÙ‚à‘ñ7Ñ#¬÷f7Ø%’»Ç¨y>Ms¡Z'ÒPÉ”±VþwaU+ã)’¦$·Þd¶Ãy{[N—‡œÈÐÒQ×X;Þ<ÿ^ƒÏºÿ苹Á,²-Œ‹‹×«³Ï‡8Ô „‡Ûƒ-JÔœïã˦ùŠåG0¾”dH¥&Nè™ÊïdnóJ_Þº û¢tÝŸp”ù]8Æ¿~¦Ëñ1.Ù~X?ïë„ãT>Dç]ÁzņªO1Í#'†Î…û9 ¯·‰Mc0± ±£©ÖCñ†DMeÏL,JÛòhÑh“óáa Ùö1Ïø=ÛsF?,[dÅöÈCòQsË;o9’ËÇïÝtüt¶ŒÝ»QÜ•f;—kîž.GNûm“&ð•· ß—0Œªvá¼ç•ñtñe%ýƒ”ߦ…e¡ÓãPýÉ^Þý×[Ó|9Od?ß«©žLþVÿ°ës$Þ«UÏ=î89Nܦ]¦­×‰äžnMñ-f¼mnË­Á58¸GQX(› Ìg5œ±š {e§Ò…[å÷©š ŒËµ°qk²htÅ´EöêÔû)]ö‘Eßĺ,ÔZߪØm-ëm`×”>½‚D57w­{u§™S”0´gÆ“aÙSÒ±Þ•$¯ø>9T†Ë¿gE8é`Ó« Qø¿è‹áãí³º {%o°Uœ—hµqÞd%Ž¹¡Eó0ÕóP¦¶4Œ8Ýlê”ÎtPcÝ<¹|°ŠUðù:Ü&¯ç|©ö¦ó³&ÕRïåbÃ:zA²û‡{5öþ H³¹45u…¦.ÆtÅÝVÿïßJJVÓƒ]_¨SÜ,5êþÑ¢@£•J©>œ¨µí>n°Î>jqŠÄÄ ÞÔ™tØŒöO¸³„‹;“Yý¤uO¬žQ~5Ÿ hc=f2­n=ãÆJPÝÓÊ=ø|˜ØíÞ†ð#j¡7ç~üS%ÚÓÎí®9°õÒ¼“ þh\Œ5ËðS­'ÓCDYRO&¨žž vj`)«YÔÈù.\Γ¨L*ÌãG.·Kñ(’±u^¦ôsÿ¤—× ê4ºU(ññ»îS™Ì.3 ª=Š_lo³©I´P™ŸQA^.)Ôô`•iN÷éBrâ»i ¨°#T¾Š¹fNÖi)aE¶W³’nd~qàâÇ**ï×ë1}rÊîÅõ³¾Å—jQÿ,yæ=mñÐ.Þ~H±•ÄÚ§UDª§ *²ÚŬ¯þ ª~ï endstream endobj 4666 0 obj << /Length1 1431 /Length2 6353 /Length3 0 /Length 7339 /Filter /FlateDecode >> stream xÚvT“[Ó.Ò«4P¥“ЫJï½…@DHIè (½÷&M@DéR¤WéMŽÒT:(¥þQÏùξ{׺w½kå}÷3ÏÌžÙóÌ^ábÓ7T€ í ªHF$”(éYH€@Q! P„„‹Ë†qþ“p™BQh!ó¿J((ƒÅ”Á,O‰hº»@¢„ HRˆÒ‘(€2Øè4‘(š„K éê‚9:a°Ûüý à±ç€¤¥%~»àPÌŒè€1NP8vG{° Àiƒb¼ÿ‚GÎ ƒq•öôôÃÑBH”ã]^€' ã0„¢¡((ð«`€.ýS™ ÀØ †þƒ!0ž`€\`öPëᎀ@Qìæ# m€ž+ñ‡¬ý‡ øël !ÐÂýåý+ ñÛlo„»‚Þ0„#Àæè©j a¼00ò‹vA#±þ`0Ìl‡%üÎ PU0€±þUÚsÅ …Ð0—_% ÿ ƒ=eD ‡C4ɯü”a(¨=öؽ…ÿtÖôDøþµp€! ¿Š€¸» › `nîP å¿(XˆäÌŠˆ¥%$Ä$P7ÔËÞIøWxcoWèo#茭Àß×é pÀõ‡9@±/_4Ø À Ü¡þ¾ÿÛðï €Àì1;¨# AòOt, uø³Æ6óX±Ú€¿žÿ|=ÀÊ ‚D¸xÿCÿÝ_aM#%#MEþ?ÿǦ¨ˆôø Š¥Å¤°r‘HJIüÿE û+ à?®$@úO²ØSú;a¿úÏó×lðþK‰-ÀóÆ­â@{ìèÿ[é¿]þoÿåÿ¥ñÿNHÕÝÅå·™ç·ýÿ0ƒá0ï¿Xͺc°ú×Ab§ñßT3蟙ÕB`îðÿ¶j`ÀØ9P@8bµ,ŠýÁahU˜¢ÃØ;ýQÌÜäפ¹ÀP}$öëjÁzÿeÃŽ—½3öú@ceùÛÅNÏ¿÷UAØ#!¿ÆLD\F¡ÀÞ$@¬šDÄž ì¦â}rç ‰Â"”y¯wWGåZF˜( .ž}ü\¼–Ê¢J•¶u¢Š€¢ì­Êyúhë i‘‡Lªì”ªöRzip¬¹²hꈄ¹ðÓm°·âʧ@_'HÈùƒ7eÆ®×"½ÓûíRÎ —ù8„Ô’Ô©¾R‡žmáàÓXÙ8Ñð\cxgxáêKöKf¢I¯¼nA´r5Ê£Žêebj×:õ·¥7/“ÉèáÞÂ**Qöú:MÞ|¯óXp‡½{õŽ˜9®Ó÷5·1Œ:Šh¹¡zEËí‘:¹ß™üåÏÜÐs8ü®Þno6©lRzhgýœÚàsÓÛ*ˆrvn0[Ãåqef¤BK)wžtбnåìf(›xVZ¢µ¢:ŸzèšÐ¼è)ud'ÎUq”ãÛ—zÛA“ÙrZv³q¦™M{¬›G^:À§Ï¾Ö~N5›£MYáÒGuxÔ¿=8ÏFÚ(lѺV)·âUσ(¼¬!•*Ø*‰4%¿|—ªÁ}«Èæÿý/X>ñtµ#ÊÃFìY½¼*YRº¼q}—q\'ØNÔP^ˆ¦cøAFu»f ºÒ‡0¡Lz›ºw‚æP»ß6Â#å6gÞ=Í$…QÝö6?3ãzKQèq7z4èÃ4-~ü¬¬›ÅœKum³ÜV®±Ç{:¦Ì“E”î(¼7ÈÐ5Òþ©†!,OTâÄú­ÜãEßè‹~ñJq‚Ý‚»~ƒAÌÝýÉj´Ÿ´¯—Ë%”7½Î$TLÆP~ åMä˜æë6JÆ)ôîñYÓĹU¦×}J¦Ê‘‚”›üC¹Ë­C~ì^ú Y„î¹¢&´”@!?6ö¯Õ3g­ˆòAUÍ“ïN9ÄŠñ:K‘¦ŒŸ§ÜÐå´•<{›–þ2¹FÛá*oúT&9*Ͷإèi×SˆüM¶ÞæW·Oé‘^—¸Ç uYijÖLQë5ÌÒÔ¾¯Øõ>ˆûJ÷.J•þ È÷Váf4¾ö¹Ú­¡ñ0‰`™‡žédCƒŽìËV<ñ¾®“-ïÌÒýK;¿òÀkj‰6îDûG~¹ 쟟x¦ ëµ A‚mu7³4¹c>·qŽ|g†Ñ^{·¶¦®=á1QvÜÛmz—ɺõh# „o Ä/#–ûà­¾í'±Xtß7#û¢+Z¶açÚg_Urn^j: p@PYœóawU{Æ$ß8Ÿæ>g½Tö~!ÇÉmQâXQUw=Ër¢qŠŠý$i™@]¨ÝµÊSïÔ|WçQ¾L~°d©~KÕö5ùFÓQœ›DGa t\tà ֹ4Ìñ"L ƒg³ÌrÀÂ>Hþ歓󩺖zàñ‡u÷þ+«Ë²üëÌõµ K:_OuñÊ+Þ$Ѽ{›:¯fÐ9°ñ-/¸ª)Üb lVîæ§5õVòxC•¨”íøð2ä+‹lû07‡éÕБF‘eÿ Ú}ªŽ†\òÁ¶›¡‰öZ3*-%ÝDÌeMøÒ‹au‹4”Ü1'ždÖƒ>þHi½}©³K´êÝÕw1rßü>å´G\3š3ÿ$¶u9‘vnÖÏ|×ïÇàŒûhúÓý¥MB)3da뤔Yªsõ`4¤9ZVœ»ÈÖk:ñÉΓ´„STädòëg’$o$ÊSÌ:PÈ¿Ò…[Y6ºõ'»ª†ÙßVàRŸyŽ÷b_)ÑôD`sà^oeÈG†È]¯“…žºÍ‚ãG.ùÏGkŒmÊb^°Öî—ðЛ=ØGCiIm´tϘæ=†U$oÔÛUr³†'}­ÉƒÜµ¯ù¬R'²·ñ¥ˆxãuÚæÈs yÅ5Œýp9Õqì ªeT›óŸ¹Ï™sx/ø©”ÃÆþNæmõ*б‰v2f±35(¢†-Ò¶8à„@žÒ莃FŸ÷³ðá3|é…*| G[Á#Ò®9=ÎöADŽkžZô~q-{À«R¿dѳžBu<«ìÐGxóåvùB¨ÙŸ«µ·pXçÌzð,5ÕÄYìSvÜeë\9„s:i§V^9ÊRÞ² uâÝÊ8ì5ØÒ¦døäEŸ !Ô‘]r¯×ñ‘_ËçÍ ÍBNfñö® Ú«åæYé,—¦u[ÂtêðëÙX'Ù”%ž–¬s]ôxßš”¿áö ;S¡•KÞÃÓ§ao¢¦_·ZV 7æy|$K—Ùêïù¬ót ÅszØ<|Èš?ZIPÌY[­¬dVPq]©ÒøðKß.FNìèNÛ4aò€ çÞàÉLQ$ú²[=?r’LînLãÄ^ÞyüÎDð jÌceí´9ÃqrjJÉPR7v¼n±5×XÓG&@R°ÙÉ2gþ<ŽÀR¸èy»*µîùvÞ†¸Ow~#õGÃÂ@Õ\‘¡Ye’Öëz)+8×øñ®ë{º!GYÆÑkg5B¼$äŠ<ÞИŒ©ºÒc^Lî•Í»Ùg9É:—öõD¾PçB8¾/4ÉFWÁNCž°Â0ey˜Q#h$RªZîU6ô¦Ù¡²šx•€h^áâ7çõžUÖ$å”- –\ áH̵èå áŒ?7Á¥p á× Ù˜WãpŽ/ºh³µ¶® ÌÂñØ\lè­°p;?ñºmm¼o½yÙt?Á¼»2Šü^»hððu;r¯°2¯°?›ÈÚKfêKH óà÷yJ ÕX–Ë$òGÓ:7egõ‰7$.>ð–NÌfx¼rÏ $«6ë—™|"wêlnfMólŠ¨­“‘\1 ÝAªÑøŽò#šÊž?ƒ¤À%çf/ÕY¯ƒÉÏ8‡cž¾Õá+4ËD¯v䔾Ç¡­ˆDáÄËâ4:j'?[Š´¶lT¶²ÔÖ;ÂóܪûìÎ Ò©B¯ú~Ô¬¿[Š¹Òä±Á¾T›j·]”ÿæ!o¯}Ö¨ý>ý>#ãÃ'øÍøfôO !ÃVYß‘S©ttKMŒŒïäL&I¤S/.¾ñFiªÖûÓ¦§8OdE´9͹¨ÐucAÒÐ6øh~€ÚØÉìuúªÎ"²_‘WX(ƒ|«¬¼KeGjð¯Ù%'Žç–]$7G2L±I†EDâ Ö–œ×®”ú? =·`ûœDÖü¢àÛsÑw›Ù^ÑëÔQ¥?òœ4\Å£{‘˜Z~–ùRÁ¾öhàá‡OÒ¿”)v}²lÃÀgefÆþÕAÅšiCžnÜŒÏzr]ÕÓ \ nŠÍI©ÚÙ»óíë¾EŸ;[9?¤^úó¤Ïë‡Iif@KRõ_¶S~´ã;ƒ, „›_¡?)ÝÔbýYÕÛŠ°LCâýÍä5¯:‚Qÿ÷ß{‡<Š^¸†µ˜_Zè«!rç·ðóµÛ‡¾Ö>‡“üH)N1&¡Þטtâ¥Èç*{øÙeȆäÆbj¾¿Ö†!-´Oâ{gJIñEæ‡Ë¯>û)áÄ'¦®o\7kï,Fpt­ŒŠ-„V[ßᛟ>•i~¨I(–˹]È|!fþË,ñ¨Æµ¼Ç¬”Wð)ç¢ y ׽›¸â¯¦¨Α+ÕM»£­ù9§è½ræÛ§ù蓨„V—?9Ħ¦ qz-OŒ]gž÷=_e úÉ„˜|Ûò+Τ¬Ú¬ˆúîýå–7<¾»-×6õœ¢-P«y…´?/vt”V£üsJË%žßTÞ•Ovx;s×ãaçˆl™.#2–¼²ÇSQv@åò,/ƒ¸BØŸBÊwÙëlT—G…À­tËü• ûÎÊoºâÓ¥¤²L¡¥ÌƒkçÆËsÞ ^Q ì‚^øÊE¾åãï•Š;ÌSéø}úW¹~ÎíMèÞ°M&ÌàJüIѬ#ä<á"Å.oÑ1Þª~\Ù}¯–œ‹0„8Òç>±Í±QïW]àÞ±mÁ'"éùò©¯ ŽÒþF*YÒ7,àù_½K(O†ö²-§Å+ÀOèò&ó? oG”Êò¬¼ØWG‡Š›ÄÐKõ’ómvØæÉpH$;w[Z–}n¬ÈïLÙzYüˆD…÷u/ ¼~è]T)U«î‡x˜¢þ…¡qÒ\¯@óú“7‚3×Óoíz1ŸªrUëØÊ"¬ÓðÚqL’n15¿´»ÇÓoÓn#—î‰íߨp¹£œô:€«Æ”ïsâà ‘>ÞbOŒN ûžõèþ¸Z4¾p6ëÄ0Ú'sÍó‰Q¿¨åncšŠ‹>bþÖœ¡Za¬šåiù®ån2Ñ@_ Gü觤tІÌfÔš\™®Ij…w@°nfòÚ”‰·"ÉÝùŽMbé´‡]Xo¸Õ4ч±ÍH¢|‡%[z×cm4ž=½0 'ü„”HÍv€L+A†\ð Ü$Ap“[ ‘O Qzy.‹»Ð—p\ê8ãOª\_l_ÁéÍŽñ{òø;td OL“‚l¸Ïs›µÉÍ,u Z^&ÚL†L ­A}a£bKšã‹|·Ç»²$¾6 ZƒX¿?q\aL‹+3ݨL”&›ßgM•{ÚNÓEOéø>YŸW037¶ }Š·=ª‚º/qاÈöµ•ùŒƒùÐ,RÒÁ!xðBÊäû"<¬=ºWW½„nPÿè¸+¤s£¾²…WÊ1Ã#y¹ÃËJVŸ¤âÆ×ñäMò‡qƒ«ïnÝÅwÉÌ¢@w¤‚,¯Ø€Ü uÈÎ'g…´h’2vÃ%ïXÌè¦ç%P xÓ>%çàòQ—’ù7…çÂ^R˜ÏútÕ§^Õƒó~‹$ÀrTÍ•Æu´Ù]qd_(¢¨ê4^Y[+?Ò&¢MÅûÝMðÙ ;^'YÝf T­ÂÄ'¯•³:ž&ÒíöÛ­<‚{S.ŒÃclÎâØšÖïDdÒNðŒOo0{óú÷5ƒÖ”XÓ¦›8R7dviïˆxÔF 2d:|'¨z]ìê|/¹+~„nj†zÄçü&íûÕí¥žš|¾Lo%°Í*uøÝ›ÉÛ¦ìG£zÇüzHZ[€g¢^žq]ž¤QPeÍT-'ñKµV3fŠÚX%ë/6W¸óõgbßSRª:úèk†UÇ•îÅ,R¼”t7(Ρz;§Íà;Ê¡ ž‰Él|l¡ÎûFQûƒÎ›h"|Š ]¶!ô€Vé-ô <Àí$#1‰¥DNˆÍ­–û„¥‰2‹[ m¤ŸštêoŠ;¤'ãŒP嬰VU6‹Ê`ÿ’Hkæ‰#%‡9‚˜Í&§G²–šs«^Båý¿Ñ:©šjÒW“'ew›ˆÖ ¢ò6Ý‘zz·¨ôJµš÷EHûÐR§ÄÊ{Ü ’±ƒ[:ÝFP¼17H¶¼'øœÄ¾[ôMïóñJ+Ô¶š”!Ò°¹ô¦¤h†o%t÷c ¢£Výännô¹VSºRÜÉ<ÁLa„|_îȆÍóõpHŽèݳý*ÇõL¨r¦kÞþ©Þ·̌՘>ï Å`gÿÉ©¬õ뚺5Ç÷! EÆ>Š;[ýƨÍCS¤£,uYeñïê±'âÊù2q#I›K^,ÞËX49ŽþŒÂJd¨žmkÒ<Ñ'»0þËØjËhIû¹&&€þã—}÷Rò‹BxØå±)©ËõT{á[8•¨¬7!kÛå8 …;¶MˆkG[>¯e®“Úúl¹çæÞþêýKbÿjÆÁùj×Ræ6Õªg¬÷ÎëÉ–Ý3yå#éçe>Ù,yõxª…CZÝô;³ '/{.²ZO¢³kźƒ«11þÇQF/\Ú·âUw‹kúZWèšÇæ‹vMªv®$K›Õlš!¹†ÅÌ"*K«¹†Æo­:øá¤ðÑ,=Lz<ÌKO³ ÿÀörW#Pܾ¦Ó'É@…7Ô!~]-–BÐé∘2c´o6¿¼„)ñf§êÁ[×Ñ ÒZMýŽS¸ûÚ’ó'S?z‘B†‰UôÁ†w–_ˆ0ûâÑí²ïPßxÃ̘¡ì±6õ’“ÚÀîo{<Çn¬5/ÐiŽ2‡°Ý°†ðƾ‹@¶Z’¾Î}3³g‘wIÌ:L6+ëöl™x·]½>•Ø5I1†ÕÖy‹—Æã‡åß‘J¹z¶Î о3îË'  xŽë =‚³“;¡[åíüÚ¬4oáqAm’¬ãc}=´žbÿNÌ*}¶‚è( d²GWÛ/ßö$jUU'c#…´3ý[NÄí3¶ñ—W #=ô_‹±¦ÔÚ0w‚úÖÒªq€ÎÊ ÝA3uôüäÄÚ]}OUôy5ï²»ê¾5SVáPZ9ë¬ofn¿hII·ÔÚæ‹ioàYÊ_±u\ Ýrë¦YW<ä?/KBÎÄçšìgË,uÈ–=Å+eªÉÛñ¹EG¿Ï‡;°šã~KÝäZšœO´„|ÕÏw†áÝ0rö&ÁÛYkg=ošr7Š®¥¾t~ g¥¶ì£PFjslW¾3:ƒoŸ‚bÔŠ÷ßy¶ÞxÈáÇB<ñóëÇüO«iìýά å_zÅëõxIÝß^‰Ç”—f]äVuØý@(´2@í*“q0Ã$úÁ¯^»Ôg¤1ÿô¶3TF¹÷fClHs ýâžpóÛãÔ‚þn'ãzzÈD¼4¤Ô® pß²ÄÂ_Ž¸«SbJ8‡>~•ed»ïeD'¿3ÿŠ£ñ¦òU¯’UJBÜýMXýkVï¢"ò è›zü/Ó6j»ßë_j~ò{ð™*†d¬w¤âl¨ÍÆ雲Þ%åÔ¤twý-ëŒçM† ©ñÕ$®C͆h'âZʘ*ùÆ]iô>ÉZ\•9˜£/ü¤¾ì#I Ê¡ÑŒJóÒO7¿€y=ëú«þ‰Üp4Ó-Ã6ôs#aÒꬨ=ídnÃ82°.¹þ>Š)ïÖò.2E¶VÑ÷v¿Y[šfªLDT÷ë}ßóÆý猅çî;œ8>Îu)Ïÿ¿k70 endstream endobj 4668 0 obj << /Length1 1441 /Length2 6390 /Length3 0 /Length 7377 /Filter /FlateDecode >> stream xÚtT”ïö.Ý(ô €„03t#Ý´à0 0Ä CwH (]"©€4ˆ Ý)!Hw7‚ ŒsÎÿwî]ëÞ5k}ó½Ï~ö~÷~ßçùØYuôye­‘V0%$Í æ‰ä5õMD ÄOÄÎnG;ÂþÂDì†0”+‰ÿ_y ‚¾Á èž&Pss€`aq°ˆ8àÄþED¢Ä w¸5@“ †DÀ\‰Øå‘Î^(¸­úf›½8¡\°˜˜ÈƒßéY' … š´ÌéfG(Ä „Âah¯”à”´C£Å@>ˆ“+e+ÍõàGÛô`®0”;Ìðk`€Ä ög2>"v€Üõ®´A{@P0À à‡Â®7nk p³9@_U í Cü!kü!<ü=˜üïr³‚#~'C P¤“3áGØlàŽ0€¶’ÚýAXÿ"B]‘7ùwÜbuCøÝ9 $« €Ü øwÿÜWEZÿò¿0‚BA¼ˆ@7râø€o i óü­dDߤnfôØ QD¿® €V¨ƒ«#ÄÕîWì â¿Q(Ìfƒþ_°À_øÏÝþ ¿©áG¸¹þþÑÔ …ºñéoÝ4ÿ¯õï æ ƒMM ¡¡ö•¡?Êe«÷XúñÉ È@$‹>Ê][uqº§-®f7—Þ=5ý4P;}Â&¨Ò¨ãžKÀ{hhÆI· éž²%iŒÇÌT4ð[zÚn@Ã,Š4>ûÎ[ŠÈAw?s:î;ÅÞîüLøŽÉˆ(§ ´R×i~3cÓÇ,«=ÿDÖ“‡ß{¬ß‘¤uVøÕl¨§ŸÖlEwÖÎô@ÔÝlÃ"ìè)ßñ]¬³+(Ž;ô=Ûü½Ôëô‰‰49›ÀùÇÓBß ÁdÏÅÓ…$×ýo‰ CÉßpĤ¼„<„îé Ì „í¾¤™ÒÙx{ËDª÷1SMѳE˜œÕª!‘.Ç}dÍ/Âp¢× Ž÷ù¾‚mŽš¿%ÍLP£’#ó¸/ø¾&Hæ’ÌOá˜Ê@Úc*e˜œ”X°<øvE¤N1@æãkö k?ô,jè.ÏÔ˜¿Ã{‘›R¥"$Ø1-¸ÉC ˆñ)Ÿ˜Jv†kòýù˜ROr~8–¤é«C ÊSµ9³I»·}p«ÿÌ}K„ÀEØñ6F‚ø'‹œ3ž—*LT@SXRÚ‘ÚfÂ’uvùQ¼’§jGqª„¿‡ÛÖ)VŸÉÑ’M/7"ÞëABd[i»Gß…ûæ _QHDcÑ~9Íjô•…ï \Æfd‹ý%k)xlõÇ‚ÉýC…<–x:™ñå[µB5 }È®Oaø?¯]9t#Vñ=ëŒmDÓ‹ÊÁÃ,ƒÎTƒ¨P0xƬRt*Ò)s¡…oÞÌOòûŠÈ%étCŒ·Æ¼ˆ¿ažkvvƒ4 âUyoLt™_à|_í·/ ·ŸõîeÛÀEg¸^ ê~»3Cðt«£y`—uÂXLXñ¾äsâv›×~¬ZÙ ¾ «ÀPõî^ÉÒàÆâŬª!œáª§aɆõÛjIk.Bb•š¶‡Î™¥«}þ¨«NGÅ­‘,Z¶ü´j,—î!(¦<©‡úçÕôŒ-¾oO¹RŃ¥5‡ƒDÊçIü)™£é “1]ᇥ÷"Y˜3{·<­:Ÿ„˜=$,îÍB }²ÆÇhºV!ßÝÃã*ž:°eöP”Ãñq¥ðïË¿\ú‰££¸çz;“ƒ@úÞzšæ€±p©â+y¼Ê‰Á‡”ç£+ø€óC}E„ž‰Ži‘þ‚jôˆl1Nƒ õW¸×ƒ‘ÕÊ´;³·¶jÅRÞ5$0¦½Ý|œ²yˆ1h0GCYêš#f‡taÌ|a¹·üB'›ìf‹»J¤Åf'‚¹´Üãfš`å¿š,ÆÐO]»[B驯y\ ÜoÍ{ÜÊ1Ùxëå{kz¾*]ÓðŽÜ´®÷§&, ‘Óõ= ã!º]ì+ågÝ0Aä¹çé¡Ûãyœèû¥°‰G¡B$îÅÙp’Gˆ§üiæíÔåÍR‡Æ!´KqJ{ìÓÖ,›éU%J¬ÃèñýüŠ"]in2$–xYå…AŒYáçÞ®Mêߺä€e\:´W Œ=4œ°nõ×Ãe—)ƒLIÆh^?C¶M: ¯¼iÛ‚ÏcƹgØǨç&†QÊëfQÓ+_ýŽúÆIè1¬%ÛÉÞ…+äÂiÑæ–aåù×þ!ÍÀ7Ù‘ñ±û·² Òø!œÙø†üÓZBÒ '?¬iûÝÒ´Džâˆû³w?÷¼’"Ð~^0žçbÃÜTýœ¼ÌKŒ¤5MpðÏdW$ÿ9(KFñ«`u˜•c7{¤,éi¢€hö„ãù–uÈ…¦^:ïÖÐ¥3uÆ}“oÊ#;nûíx–Ü1×V«ÌUƸïZg÷Eqp” ¦•Ä}!¦Ï‡§eÆ(÷ÆI„Úd5¯îµ/|Â*û¤©o׶”’[™PpjpáU@ 3šæJ¬UM×®ü~«ù‡9°ñ•±å%Y¥êHe¾¶sZ¾PK¤ˆ4Ln‡½ë‹XÑÏÜÇÛ¦¬óÔ_¦%î—¯²Èqʃԣétœð­F±>Ñ°Ïtúàq1ºV'/»Ô«¼,=ÅŽÊ‘±é>r§×gÿûî‚ÏÌ&o¸Š6ÙnùÂ¥Ñ`Áuä±ö€¸2?ÍW´ô;—NܹùC1zA<ÜQ&N‡&\¹¯ç‘uH½Ño{óf@ÿ Fùþ9’ÊãMì=vBÍÚEŸØZç/wCK>l=„yÔE3Êœ15~OŸÒö}_)±Ô”ÔÒ¶è¥4³» >|Kz¨œd8¶+0¶Þq´óxAo Y»\×fAÍ”™ÚgÑýõØ †¥òª%kòôËCÇGw‡YM¿ô8´‡JóÒH1à¿Rí¥T[çÕ“åÖyXÇêÖüì°v«o¦}Âç1ìEnÍå%›÷O˧)Íqï$Œ.òQ%WáU’?¨ûI;Å5¤Ühö×UNAM‰A[ò,]«ÞÓÝÍ›Å"ÃÇÑÓí ÷=z³'õÕÌÑߧ;¹bxÄ}ÏŸ¿A0%¡ *\c½†±Á…þnD¾úY9ÏLzàO¶¦¼QJí>öÊŠF*QoE‚8ólýâ4G§Æi y+˸œY»P U˜mG¶[ “FLF­6b§¼hi;âIgî$TÀË%MŠ@‹i†'ƒµŒ ¡ovxzÚT=ÃÏ¿¬¼HxÖÍ©}°À†+f¬&h°a’þö.c“‰Ï7T˜ýDzùé{(Žfúå[…O?h wTK43N€tšæ¼ï‰0çOáJÞqê­‹ôäÄì± ZC;$:F‚ ÌH°úNJœŒé;‡æ =ÞúlR$ÓuÁ÷ýv3·eúÓ;?[¥‹>V‰_x%h÷aª5ôsJמ꧉jášZEGWÐWiTÇý ¶FU+”ê ’ÌWdG__o?ê(ÕF1m®ñFòþ8x&Ê‚v±?2ÂÖ“ÑÑ¥i\¼L­ÑÃ"Ô<Îû8Å<îñôNHÕ¸§LërœÒ#ìà¢,vX£¿~º°jƒ›Ip’RÍ|}:÷]:3Î×e~ÁÛ‡Q¡)Ì0x‡JAj⬅ó{›jÿ[ßΡвºÞÉP¹ß³£ð?;1ó_’½ m?)(K†m«ÍnÔóÐfîЉÄ;Æ™æhŽ~ÍŸ®‘l5x¡“á\ž‘¥9ôæ‘^KyR~ Ínþ OCb|S4x-±¹›»Ác¨8¸ßë֠ǤÍ=œÂÊ¡0®%?DÊ»,6 ã•nÌ&“ØY¢,! §ÇŸx#áØ\´°p}þhdaz½‰ãët73ß[ {ó¦YÉÒ„Ÿ™’f•¸©»I=Ž¹:DÛƒ‘ͳä„ÓÍœ\{*\¶R›­> ?Fj²ëË(úÔ–pž^MGPܯŽ|bpÞ¼¼Ô—\”{·°Gö!D4PŸMc‰wåQ^c;;ÑÎ38ëjËy®Nˆ¡W²)ù®ëe‚¹ÞRK¤ßåÁÙ'%:îÝvLRÜrsBWUæZJüÙ®–öéŒÏtý»Sµ[_+y¿Tí>yáYa¨pQ•úÄù€˜‘ç+àë­ŽŠez{m^-¡’3\Là %妕̉ͻW…‰‘Üê3?;rÃÍ»VùÊ÷NI—˜óŒ«ô¡+¾¨«çfÉSöêr„—D±NC^÷¿C—fœ~<2C¥©3êÕ[ ÖNuêûä¾`eùÄ.@1GÃGâ·@4É+×Ç:Ð>Ÿz½òòg|ú2ˆ9 ÝÿsH½¤¦HMàTXã˶½ñay×U Wñ¿,¿\^¼çoE(±KVý: „ÉŠ o;~˻Ŭ­gÍæ)#ê²t‰æ o¯Ó&³MìlÙÒ ¯&¼bd Éf–3,Éh[´O ¹uþ".BÿfOˆY4*%·Ú‘h:#éU]Ý°žH!xe7ØW?Þà~ð hWU¥c¿Þä³ú„>„¸YAþÄÃ’ÒŽöä=°ÜY¦TÍ}ÛË?ls¸÷óý#âÇØOJ9w9>JãAÆ£qS˜wŒH= VÇùH´ÜxX+ûÉ· K™gÞ@.j+Soýp2„T@{âHvEî½cۈϺ«ã]Ê¡#ðwÀÊCß(½e…fÍðñö—¬=v¬ìjî=.͹L঺’RÃÚáU.éxèMÐ|Ô8Ô_rxjˆ„f=\F“›WWWÏ"îz¡¶Z7m‡`SK¹m%Vcl½\…üY%ùºEg2™õè£Ö¾ö(X˦U+un«x¾¡ÊÛ_$Ì]Á8µ‰¨`×QÓ%/™ a|ñœµÛtóÙ)=ˆ¾Ó{VÖ’þDèñãv/=‘¹ì½ëñ óU é<¨x{c¼þÉ8A‰çÖÕÎÞVô>[,ÚïH’™H÷Q0„çUg"m×tØM–pôF¯{ùi Õû7„~o©yÈâtÞÙ+òåTŽÿ0~O÷ª¤ßVT]™ÊrTÅ4<ñ.0 ¹à|ìÙÆ´Ûñv³µŠpgJÀéè£ðëïÔ¦}Ný`ʆ›û[iG #|F-—Ì5åù7þ«—û×ÎsqÞ$ªUvùyR»ª-jUÄLDs_õ.2Z2Öqiyjh02ß±Ç+uLèO¼KˆðFzıh—m+£Ž}ÊMŽý‚¯)¤Ï÷…æ6Hˆ»Ô“uíNI ¿t^¿(`Î4+lè£{¶™Ígaõ£fäs-,ÎgZ´˜ÈP–¾–ù^qµßo¤6°rj ;!Iʼnöá>ÞAtyRzï¹·$ÑV ­¿ìñš)Fë¯=Ÿì7;>ßÀšÊêuwQ·\Îl9“ä],qx８+È»Ó]ðÆf:‹“éô#'SØDÔ#‹•«¹5Š°xP!~õäÈ^ iŠÐºzŠåñ,Pµ°n×”=&¹@Ü<EJï«äJÊc6.Fµ§E¬ñËY™ÕÐÞSá8h½gôüzËw­÷³K>Ö´C“-®›4IŒBÿ+ Æ.Å’ÑνP‰Çi ×ÎØ ˆÈfÚ‚´·çnKsÜC!­¡Ö¨ƒEvW‰a£Ù"꺰Ž×'¦½\ô;µ3€ÂÚuŒË'ÕÒË ²‹»“F¤*Ëm…ŽJR®éDn]© ®Ñùœo‘Ù°¤m2c<»î^S<Ê£Mj|5ñãÞ –õöt&í£Ø‹b‹ðŸ<ø·k‹}?Ãb´»‚¼œ SÒqì‘ùâL„jíKµ«í¬ÊÅúôå¡&æOzaÑ÷}*É!wÌT±ÂB/S×ÆõzŠD'»87òJF…Ýq/+k}ãlc‹–gß½ëÁ¦10G¯mu§`¹D›[q–OŸ¾B<æJã‚7ôê\„LO¾<†h¤ñºfuÂ÷dMBÛOz]OEô~«¦ˆzôFÁeÍQµ˜_˹…´yºÊk‚WÎ̆- VÑЗ¯O¬‰>*£jÌ^˜—_þ,ñ¼|ÜàÜ癯<;H¦eG›Ü uá^ ËQ=yÀí† þ6k ¦°5£ùùªóö„Ž¹.ÙÖ&or%åý½Õ}¶˜‡E„ò=ŒîÞ1ᛊ;Ÿ¼"è…M˜Ë}=e‹èXòö;-ø;J˜ZÀGMá—¸.Ÿ]²Ô¬J•P%ÑF“0?|%3/‰5ÚÓÍk®Lå;§Ž'ôî{Iñè~xÍÿÇT¹ endstream endobj 4670 0 obj << /Length1 1371 /Length2 5903 /Length3 0 /Length 6848 /Filter /FlateDecode >> stream xÚuT“ݶ-ÒÄÒAŠzBèUz/ÒA 1 JIè½W‘¢‘* "M:H/RD)"½Wo,çœûŸ÷ÆxodŒäÛs͵öZ{Ïù…›ÝÐDHŽ~€Ð@£pB" °,PUßÄR‹À`Q7·)çŒø ¸Í,’ý_U ŠÃcjPž§FuÜ"b@IY)Y0( Ëü‹ˆÆÈÕ H8PÔA£X·*ÚÕƒ´wÀá·ù×#Æ‘‘‘üTvA`0( ¨Å9 \ð; Î@4 ‰Àyÿ£Ÿ¼ç*+,ìéé ‚º`AhŒ½¿ Љs#°Œü50ðÔñg2€hê€ÄþÁMÐv8O(ÄÎH…Åg¸£à ¿9ÐD[hàŠ@ý!ëý!ÿž P$òïr³B¢~'Ca0´‹+åDÙíΠ†ç…BQð_D¨3χz@‘ÎÐxÂïΡ@ e# ?àßñ°0 Ò‡a‘οFþUÊê(¸*ÚÅÂa¿úSCb0ü±{ ÿ¹Y'Úåûwa‡DÁí~ ww6C!ÝÜÚj)xðÌJ€e$%Åe€7  æ ü«¼©·+âwP䌟Àß×í ´ÃðGÚ!ð?_,ÔÄaÜþ¾ÿ;ðÏ@DGÂpÀ{$ ðŸêxa÷g¿| Ò ãµ'ÿúüûÉ//8åìýúïû6ÕWUSÑ¿õgâÇTTÐ^@_!10PHFB(""-”’’úÿ³Œ!ù· ðrµQvh ÌŸnñÇô¯Ž=þ €ï¯9øÿ¬uW-È÷‘[ƒ%À0ü—Èÿ·Ô§üßþ«ÊÿKäÿ݆»³óï0ßïøÿ†º ½ÿð¢uÇá  ÆÛõßT ÄÓê#àHw—ÿŽjã x#(£ìñbÅÿàH¬Ò 7Dâ`$ó7ûe5g$ aˆÆ"½[ðY`ðÅðþ‚9áßX¼.‡xûüs_u ÿå3Q I ƒzÀx9‰âïÛWoH8Âë·’Â ‡OâgôÚ¡1€_×  » QîØ_(à•aî Þa¿€ßö_ëßvF ¼0Àô&æø*¬ñ¨R™ÅSèÛéç/Íщ–Q8žÉg¾z—35GÝTîÃË®÷¥N½ˆ™ðcØ8ô²nÍžKÕzŠ#Pï\PÙÊí=ÞmµGÜ„£™í‡¤Ò¢¨7Ý ¼!†ð>¶˜8 —j[._*8oÆ.[ɬ]€…Tì©,¸‡Ê9Ík„±–ì\_pï-­©âi0twSm³¡sÂXdü¡JcÓ±÷$>ãýìlOvWgšØNžn{…dY-{N_R7ý£l:,ŠÄê‹”D¦ç.ö×{5´:7)Û㔄8Kd_ö–}ŠÏŠfõQn?ôðªÚ'¥¬¤ˆU4¾‹0¨È£æaiøL+nq¬êg"½æ-·oº³çUû’:Õµ¬uóì\£´ HŒM¹©`jj¡ÎUóÉjõd5™¬›±ÙÔ„ ¨ÍyéÌ¡½¹àÐm‡¤‚N1¹‡jÏý‹6øJÓÃc—L‰hŸ¢('ÃA*æqÙ/ÉŒÔRC’û ²MÉ&z£ñ(¦Á³iâ`ùS·/¬­T1¼ñ‡´_\_9Kyƒí¹ª¿Ëi™õ€Ž{©¸SÁ⣷²D ¼*ž–„Òöbä6¶÷ÇÉÓ¨ƒÞ3“¹j)ry‡Vïuˆ±ÙŸÁ19a? oÊJfêÿÌl¹,þAµÃœ-Põ³U`<䀹î¨-A‹vV zšÚCOâ ¤<yÜá2ž¹è—ÇX%µÚãõõ†#Ɔmõ%QšXX §iÑkÐc¦B¿]Sªáìnèrƒ¹æB×%š<ÔUòžËÁÛ(™lGý ,1DþÚõë66¸Ul>Q®‘û±ïÿ’Çd¹4¥ÓOØ‹—]_.‡é—J˜ ¸ (D#Û/AìƒÍ”ú% ëúyÀ#Ýc£"cIÌU«O1œgÝ}k>]'¦í{ìò‘Þ 6*S¹¯½NûÀÅwo6¹qY5±åÀöÈfŠŠk ¾¼ð¸¢”)"@Øšˆùv9Æò…ȶIrbÈ¢o°%…fÂÚÒeÛÒXñ¹wC&»&PΛDýCwfÿÁÄÏ¢ýÚW"-BÙAMæš ÍYaPK A™SæÕ½Xαڸe «àŸarÈ¡œøb°«íJíM×Ó75 %ïTôÑ =ïÃȹ¬@ê»IÇjü –4 ˆRº k‚V?žWv¨³ˆGµØ&P6­Ô¤ÇÎßþéÇ=k5Æ?FÖ]à—®³ÒÄÏÙ3’ Âöm3×ü‘)uÅ‘ä(;ZÀ›ÎÛŸž>!>#ZXHøúéZ¦§Žt+†,º%{àš†·&_Ř\;Ì4Ýå m˜¤)=n/¦ô3ŸÛÔèÛ|ãö½aOÛ\œnù”éCD Tì+Q­Eö›¾îÏ;jÏ^L ò¼r`ïš}75̼îöÓXE`©Õ=¥P^xN eÞ7>Þ™ª’âuH2ÚK¬¯&*9ÂzºXÀì]‰Îx#›>ÈGÍ¡¶”£uáÜÙÍlã%hÈ°P0Z{cyn ;õû[•*kî.Ä2Ö;~:^ü±8‘f|ÌVQ¾õÆe‹'áÕ«.›µÈB”EhÈõnXþâs žÆk’ç?'­¨M–œ‚ §Fª,·ŸÒpuMõΔçì¨1(xNŸwYEBßæÐ}“îXh5ÄÏÈòÅq¥~:|°xà†ðL g]‚flÆ©€¦in.pó·s‰¼ËYÿý´<üyyšlÛ]÷óÑÅ—•KïÞøÔjp°Î4p0<ç1úîŠ49l̾ܮ¶ aIà[ Vñ0¼É#ê\À³ãÊ ªÍpC÷Ž7Þã€È=ùº¼¥5 9{f_vVhzRpÓqd=Ò»?Éyžû<)Qþkl]ö|þÌí #ôà`ä ?x±úIÛÞ¸¤Rûû}þJÏ Á$ A%¦¡—ÉSÊŠ¥íÏ eûñ˵¯„Ôf¥òŽG«¦uy¯±Ÿ¸¿Ôr¬Ÿi½\—/^ {È,ÜzÑh§¹ï0¹Ð•X•c”OA“@Lñɧ@á¬ïõ`˜VKRfÁBú¸È¢º›x¦,?« ÍPª4;i¬Òw¢íÿpë™ýîçÈÇê%{#U‚ZW”ÕL¤õçbŸJ[4áPĈ¼YóWÆ‘²ù›ƶyfø?¼ó>än…®æqmò{ß´(ŽUÈ°ú~V²­¡àú™6"?Ž‡†ÅÈ|¾k®`ã¹Õ|Ù–£l§=OÍ'/fʹdâœ+ãêàEt} .…jz[*ßv‹zq—,GJ×4Jñ ¿íôK?ƒC¾EqQ¶IÔ]'×mõW· óµÞ·¤—³%u-l£$=J¶”±_—˜'†S…_¶×÷¥×°{õ†:)m¨É|Ð%a½”ÌÑ CLG'PQäªøôréE½pó×4‹I³_@õœ¾Ô®ìV7]—ßìó8½­ò5µ‡)òçF,Ê“½Ëør˜í®6Û»ËoH`Ó·Rø ëMyêKÔ7ÆÏãG÷/±|žìì,Ùc0Uqû Fc½¥$˜Ô¨Göu ¤Oʹ×õ­tÍ­4~ìl̬;B¬\ew÷x‰Mõ-¡Å²¥Æ–O[Þíj}qKs)ˆ ßžÚA-m»¶ZYƒ é±(LJ[àµtÙW›Ã2 &ÈŒ—å)=GŸúqxtŸ›®.~¦Ñº\4\fÔ¸œö´~ ¾B‹ålâ0«ú!šÚ§êNÅ7éE5Ï<¸Øˆ:÷!ES‹ŸµF-‡™­} F€u¡I|u)§!OÆÇ¡™RtUw;|ý,öóT¬*÷¡2éôZ…­wš¬ÚÛì–ç{¹Ê„¥Â«­˜ÓÈIC†8ý!-ë=FNäɹ‡¥Ê»r?î8æxt:‘ˆ›.Ìô^ûÉ#kdÝã7C±õÑ,T¬¢?ÏyÉ"b^'*oA]»»J8g_O>åo¡¦á^Þ]ú¦ví¹¢ÿÉ•š…ÎT÷Ü{!’oì¯,Ô×뛹vö1 U>…»äK»ä¿º•‘=…nøŽU•îymZjåV·×$…Ì¥æ&ŠqJ4è…¡éœÌ8-â‡`´ÉôM!J¸1OI?U=©héâtÝìêÿQž¦SB¤YVg'«>½5õSÜ2ý㯸µ­â¥Y»Ô¸UŠCG2ÎGÉ Îž¾)/ ‡h-е>Ù¹¡DO<ûJ]‚ùmçÑäT4C˜u3ü-F£Ûð)¹k[LøtðQ1„g¡IL”NÄ£Þ•ZÙ`ud ~ü£¾j]  "9î%|»–ã,7)i*¨ßOFZÜümûŽÞˇÑ‰n”láîǧuû÷D/Îúî#fä€ó§`¥6û#>°@ÇpsájKÞ󓘰ók¬…¸m¨Ù{ÙÉk BtÊ°˜ˆöÊÔµ/9ÊÌ”ºÄIwHLƒ«0º'!¥ôÕÐRþyÿ[ßÌëÄ€üζ–œ'u÷¡#^Ë” „eøZv…o+·¹úáBDâŠë¾ š%Õ§Ð|m‹ÊŸ„ø%½í®[3µ«ùës3V:M÷•øîõá¾K˜wdßMÐåDä™:{ü—RIu¤bd´…ºjœÏ:¸òL_Ä]@«‡qNœÛ{TÜ».*úpºÁ锓™RIošùªœÐϲñî”c!$ƒ¼mÛò*­îÊæÄü7î!“¥b«¯QkÌJ(§xþsÅŽ3q‚æ”ÉYûm²£D…hêÛ•™?\æóØòûû’6ÊÂ{…$_J1ÁçªNyêt¡ÙNn‰•‡Áˆ–‰~ãõ[:² Š›Ã„X¸zÉ|THOM’µp¶ªý/s‚¢î¨ôÑlRì&é7\ëÞãÆ\’o>Zmƪ4ÉX"Ç'wE®ê ^ÃòLŒ½«;o^”‹ôgÃÊôÎ’-‚÷ŠÔ~Í;WƒËF‡k¨÷˃ëÝ6+UÊúÓä4¢Ï™T*›ßÞ³ø“'n˵6wýGÕzV™J£Š1ûŒ‚1 ²<­éÖ—{è‘ÊxÙf< ºã±–@¿ µÅ¦›T5ºs"O(íÓÍñƃŽׂèKÙ“…9HVÇ“Ž.‰D¹²ÇÅïE?Ùê5ç¾´Cýp<Ù|Ï@Œtq¬% öˆìkÑÞ{$¥')ÖQ`x†¯gÔ¿,.¨‘S«ñÔ#>d×Ç?¾‚„f,¿RëIŠùÀÞEÐ2Á1 ®óÆûAû-ç©lã‘žO@ZØT:(m5Òèç)BÁÂnýø~ú‚´“©jaRÐۀ砎Æê܃‡EP%,’k%%zA;—»çìÉD±ã¹r{\¦ÙVJW>»’ ¿1G0e¹oË,½¯ SW¸^»hCͦι¾…( Å%Eå;¿²…Ú4*ôýקH4Û±$¹Lj£³‚DlÖ `™IµgZ¦TØk®w¬$·Žwy&€žýd÷@zîVï*.j 措u3”ÐgÿhŒ “Ÿ„NfÕ¶‘äô#Gïæ/EV´ ÛÏ÷ùMa×ëøÑÉþ‹¹·>yÚPÕ1ÒN_u¯(}V\#œW &´*í™]WVÚÔ¨éÇâØ –•ýÉz¾7'ËÈÍQü„Ï•TœàMÓvn¾3¹©ä) k¾6×5añ¢¾;hVU{e ×ðÓ³cšþ³ÿ[(Ýzæ{ô‡MÝô÷ïOêÇõL×È%/Û¨¾íÝã[F„wg<àÄ¥½ßZ}¡Èë’Ì‹À9“¨‹yv¶è¥ÇJ‰…ÂõZtxÝw'¿Ò{l×K’ïèÙ\ª!Jv’ Päðoäf©”\ª8Q†Š0åO…ø{ß>µ¸]:ïÎôóÛ éͼIêã~NûåìFž÷'ØbKmlTB[àC ŸÉ§0Ìô&©êBÙÌk¶¡ÞÛûÒ­—* îE¥Yz…Žy0J$s‘ï¥Ü•£„ÏVú‹;Ë¡$ÔVoÎ*ïΞ6U­B‘mWiÐjú­(ª ²ˆ*ò}A¿‚— üdK­ƒÌÛÞÖ|×Öëp×ü!Û–ä ÊW¸˜¸ íüàŸ•LàS»Ñ¨·uû‚,fÃ3™<ÈpvsõòåÆÝÚ"R‚Œ«J¡w›8оU5¯Þv‰™ZÌOí˘;¶ÍRAæÕ÷XÓ«)Ë¡Òï,OÚ?¹Zx]šŽ¸.PG~Û·íäz—XîÍyÓs‰a0ª©-åï´v×,j;.c ½ó’ŠZÌRç©ØóS²&é‚Bdµ—GlŒâÊåxC¿aG9ò9+˶¼^Ê¿~V;3ipïãY×ðšõ¥÷Ý«Á_»7¢™¸DÀRDwüÕï«(qINXŒ½ {ýui£!gõMÖXºì¦\äež¿öÃ2/¿ž<ûcœË«¶ÕúÎnc³Ofïjßy€ôÈ +éÇs%¬T_·#Üß¡hêœB¯¥àâÔ…_Q!t‹/¬®}Œ£mž½†½¸–ãv4 £@R\fšKÏSq‘c˜DIÕQÝ=ª÷cŽNEwÌ.d8ìÁ ÝÕ¨èœ/ÝØoâ3Ý ª äýdø˜<ø8LcDKÁÿ´ßZ™™ÒýåV"™¼œuø–PÖ™?¼,Êg´’¬L“†ßËëcΣ83H» ½wlðpX9 /¤étÑ¥³¯~¦’¨Êïó]CõHßEh#/±ÐwIݳ–ª7Žò–wÈwnKšº|ëw}0–¦¯’ë^é·£SæXÿpleçRKNù2 Å ¤â¸”Ü}÷%k€íhû2eÂgYŠ;འG+ª-á=WÁúé“Ö®X>"…U*:Èü°a¿I¹FãA¡&D9É ¥P|÷§—E,PQ#âÈþk‰"Uûäå]þ˜úÔ8Ï¡C6:Þ²q g½ž-Yu1A÷Ìí 1OÙÒqÞ–#宇ö¦Í[Ÿ$†+XéË=4o ~j5»šêÓ©mØn¹ňYéDz¿æÎ'o"DPç¾mDóE|Y ±Êê£ëê¦ #‰ 7g¹$_H…ÄòÁ2ÌË|+س—õc$”Âühìž{ži\Þ»|]YMYÉÜ^­¾j:pm.ÿ »÷á…÷S«;îèܶs5Òdö÷j`—5·Ó©Zög¼pä¹ 5YÜJïÉ=â_Ì™ùUC¬T¢fÔLª¼Ëû~;øB¼Cö endstream endobj 4672 0 obj << /Length1 1680 /Length2 7901 /Length3 0 /Length 9007 /Filter /FlateDecode >> stream xÚ´Tê6L§HI×Ò]Ò-Ý!10 303t"HI7ÒÝ%‚´¤ ´ŠˆtHJH‡|£çÜ{î½ÿ¿Ö÷­YkfÞg÷ÞÏÞœ¬ÆüJ ¸XCñ ÉTt-¥BB¢BB"Dœœ&ü7LÄiF !p˜Ì(¨ À@S¢Ðzºp@Û KÈKÊ D„„¤ÿ¥GÈTÞ@W  ‡‘Dœ*p?ÄÙ…ó¯¿nG€°´´$ßs€’;qº@” ØÑÃ!`”ß¹à–sA¡Àß½ ÿÛÝßÖ¿A`ŒŽŽpw Ìs8A `€¾ºŽÊÅÂ@¿P$môB @´ÂŸÌu%C]àßå!R þ.Qð·t—Õ` ¸»;†BýÎO‚;¢Ûî'ø×dÝ`pXÀß' äô»—‡ ) âéÖRý[ ýƒ9ƒQq!i q!ØöutüíÞÄÏüG(üFWà÷8¡‹AœÀè¢$Ð @!¼ÀAÿ)øï‘°0qDÀÎÑ?ÞÑ0Øé¯7zøˆ/ÀZÍ=a€ÐïÏ¿ÿÙ é‚à~ÿ¨ÿ™¯ †–™Š‘Ùƒ¿*þ·LYî à‘ðK‹K„…Å$’’’€ ÿvc„ü†Ð?¶Z0'8@ú¯lÑmúWÆÞ€ûïåàü·/=8šµ`÷?$,$.äˆþþ¦ú“ÿ?†ÿöò#ùÿ&¤î…þsÿ‘ÿÄ@wÔïo4i½PèÐ…£×ö¿ªæà¿–V ‚x¹ÿ¯T D/‚ÌMf~a1!±¿pRâ @PŽ.Qæ/Üô÷ªA!0° ù}[ÐVBBÿ#Cï—£ú~ Ѽü#£×ç¿ãªÁá ß{&"."@?"!4DÄÅÂè…}ÿ0 (ƒ£Ð&tA'8‚è÷XEE‚h+¸Ï_ÃBËþÀÂBA â?É?Èú˜CÁP°ÓÚŠþ ÿOq4Œžø€ @w8 „¦€Ë?°@íó÷‚ÿ:ÿ¾®`ØÓ øO"he(ºEÿ¢AwÌ ùð‚¢ èÆý;Ž@vþsÚ‘P òŸ ÐÁ<ÐéÃAèÓö;"è‰0ÚúCØßàÃÑ @[üÙô¬þõþsÁ`_°#Ñìg¸£ì3×ÆgçõJ >üë£x‹Ë]Q –‘â(®™üü,)Oe{P íûtƒ/“Ÿxœù>~û2t!M3…¡6°ª|À_0|ñó­3˜§w—LZ%ßO4d"µ·Æ±¾Ÿlþù:\²Wô{íFñMò»•ôÀPzJƚƀz¡”ÛµƒcÉʱŒ±|LG°Îð2Ñ2¿ÁŠÄ)wÄÒ]ø­ZÇeŽÌÏ¿{98.zTø¨¯N¢&‚’îž¿6kîû¤!:ªÄ—Ú-H .eñS•ŠÔ6º÷®l{É…«éÂÁöÄ!Q¯fg=•Pbý௽š ÑÙApÅ|Zn–ìÞé¦û)•iÞáýGT-¦; êüu·Ã*K#CdפkIætœ‡ï92uò^ðð½ÐùÒ,u²ä„3uš·Ò´(<¯ñ‘ép>Y¾X&Ð;hLêÌ/­žyÒ/£ÉÔ-©Sú;)IªÅõKÙÏWü}÷¾EÒªÇí(¯µ$rngÐûHÛ§V*c±áéáò× “PÇÛ˜.ŽŒM¿ö›¶%Ǭ‹é §ZœmÑ_S4­|ÚØ΢ÿA‰ì臘¨{Fjàƒùö!)Na×?f‰À'Œ£-a˜õõGÕ‹ä< ÈÔšl‰âãs}ÂÛ^@~cÍ;•Õ‹ï»÷†ôŸ¼ètZ<öÚy“ú¡ V›F¬ãÑî»ÕÖeVì®k H¶òÿnŽQÄU!Käão”«{öâæO L°?]LzŸ=Jj»6ÜùEÔõź†ß@÷#uwWèZ~ÑëKˆ^ž‡ÿÙ [*{^“1köDÆ~¹}9Wf ¿½Ï•óˆïáòâ#ÆŸ¾^¡#‡Œ¹©´;› 13åi‹‡ì÷2±'ÑÆpßF*nj:)Úíï*0«ºq6osÕ%¸Æ~»7,ïvÜeH½W?3õÜúKóÙ^Ï8=…Tî°^ï„8þ^å·šZË“Ы~IЭCrGèxT‰þ†5³æã [©Å NA{ ¼êl(£ÍZ6G+¿Þ,M/jÝÔ#Æ)Pºá1\a­U¤‚¯¸î@æx澞Ê)}ô1Û½ApÐð}DÁ¹V•M³Õ~«kÁ9¥¶©d5ç#$^j|=Ú#ÝÍBÔ©ò:`°ü½ƒW °»É÷‰øÈ<¼$çì.$¼Ä<’“&71 &ñúlÇJm–¹f€qëZÙ;úñ*o€³´bÚ%É …,¶ÕmûPïq‰U¯´©Ã”ÊX~*VÄ´ß°è /eW8+­;&OŸæ€õœÚ±é”âÉÓ’Œˆðïìcù .Ó2­,­´å¢Ž“ ñõfewI¬kÉg8mvÎg¾ñˆ;9xøéÞήš¿‹¹&N™â.Ò1[kmä…˜VÒåÆ%k¿ï‹¥íúJY=vƒ‘u¢Ê\1µeexÓ÷Ôv›}ÎÐäRLÙ’®¨.4&Ç´RnÓ"ÞÈJõš/©G×Ðg2h¶Ú‰°<¤ïË“Î6ÝÀjTtü—õ•"­‡?×ø™-Y"C°3öÂi[ÓÐsÛ+·r.¹´ðéì²c—‹°ÏLQÖ²>ôËÊ‘qº]âã£Ì芷i=$΃«7@K­È<«‡øa4þ‘åÒu>TY€»0ú_ÅV ÊC~¥Õ.œàé½è\rðï}Òcý•­k*ûÜdÞ†ñb2/ÕŽÏR„³™H8½á{ÞçØßeÁ+Œ\Ÿ]÷ÜhÈÌ)9Iy|pö†µµ@ò0À°¥“úµŠ"´X²Ûâîs×.PbA2,¬V~÷ÃÑSíï›ï‚«÷,,ÂL‰••Yž½)í20'<ôZ»Ü<3\\“ýXKÚ¹aˆ-ÛCªüK¬¿ÿz¥ÖxùñOõVØÏ/\fMu†S®3Î+Ô¥Áßé¾ä0ÉÁ< ejÃéÀeá;·”éÝð÷5ÕP_•óH‰”ßv±nÜ¿“Ó¦F1§®Nò¸-³è¥Ÿ¶cnOYdîÓ"힇PãŒ*‡‹R%ã¤÷T\GŽ8-o4!f5NçÝã”K[ŸºzJ[ô¦¤Nñö)±œÀV6X3¢Cµ^H+6“œ3¼M6ªÔvî±uÃ|„ýV¼x’0ð9WøøŽ û½5¶øè€á¨ƒ]-g|DtêÝüŠñj÷«Wà¡L×ÈûC¾d¹Ä1TXòåcyj8]¢oLèÕÊŠ Q›yæ˜Ö×à[ä¾™™ôþ„ÚW Ë»@‰Ñrçu­ a] DY4<£Óä.FګżV)¶îéÈdW'5Þ#Æù1.Öri‹(—Œëñ¤^f3øðSø5ÖÓ&]ê#—jì˜Y:=q/Jy×`Dijú 5uí<,ÓflÈÈA¢©ç&%IÌ)F–õÎUfM^¨Ø„ô"ýüèˆ|,(«-úg1ÉyH¥wŠ¸Äz²cÔ¿ÛÅ'šÀk×çå»ÿ'¾HÔXÙcù3ΓªñJ³ütÓ¥X·írõlèçîÐÃ9îR»VO¹^#Ñ ÕfE;¯”úÑL^mÇÓ Á‡d,ÁÙü·Ì<ïžìFŒÚúJк Yy@mT6 ‚S3~LHøˆõú™3$]®6‡¬­¡`í¹™Éƒ_ îP“< ÐDq1&ØùeƒÎ˜.ÚÅûéo꟟jøü}³/Ð5.äá¹+ªÜlõUO~檘6—s«¶34±I­¥L¤RWßRAêÞ3ùÁpã+8Bªûõ`Xõˆ9ÚC@ì¼ÿV^ù S÷·ÚÝNYf«?»BŸTzîlWâÒtzHœD~2QÙ© ¿sô(ˆ@:¼l—É`ív›$×D¿ê¹¶ñüQÄê&‹‡äE‹SN)H“mÁÂU>H<;n¦þ'Ù}%Ǧ´ý˨ä¹,(Ô¾¥¹˜ýI(Á'z²%jò”ßÞþÕJûÞò‹ª…s3ãçS!Úø¡yJñ$œ{ì¤Dog/ì,òžªÑO°ûÐÑîˆÉ"™èƦU±ã5"žG­ú%½yFc%¸@a~{¾ùD|…1§A•m(ž·˜øË…9»yçÃd­÷ôï:“ši<–ò=&¦]JsÕ~”ÕmPÜQ F€ßÎ{b…÷ôÀÒ¢Yì÷ïæ•æùeWy„ïÑJÒ÷œÐÑñ}ûZaeT$z’¹‹Ê òì}irµ²Öjàá¶îÍsý¬5¢8¶U²fkvÚ9bÁ(°¤ÑÐØ®–ËG`*u…Ù=^0kÔÎÍŒn%Œ¯Ô¨ñÁeY+vví¢ªõØ"Wsæ(Ðj<‡—îTû#á ŽæŒ}EÏ kÍK1 ¬h@TVT¬fÍúÁx–[M””s,%×µ$¶5¤²ºmŒ.±lV'A¾w&Óû €L*šÓOJ“ün[},ò«§G¥$Z†üe›/§.‘*ÉÒÐ"á„W+œÉ×Ü©¡zz¶f3*oLÅyúagƒ=—HÊCò0é?­ÄeÔsJi, 3såë]/‹Hú×^~ëabb"JfÄÝò&Räx„’­r>äŠÌgÆ`hl>^Ž0§%{¯œ?ùEä‘ló¼‹7f’¤àîÚ£V9àì¥MÝðθ¿ñuµHôÛM¸¼sœ#T¹Ñ—ÿ¸"Þ§°qµ¸}™üiU‘ó— °Ëût=3æÅû"½±’‚Òêú+˜9‘œü?güÎ_0›ÎiÖ€7iQýÎßƯ "wTr+: iŽ¹¨MQïÃð§[„›°3:(»èepòœ§FÆnhLÚ¸.ñˆ8+lm·!ög†¢¤‚‰â¹rZz…¹'?%à´÷?îânðNÒz¨æßšduöPšíhÇûÞY°­y£×VÔX¿ån(ñn,„é-C’”éS Ê –‰ížÁ‚¸¢:¼saNõÆyÿ·Ç)ú´ª$—t÷ÞL¾R«ì]xO²§$hR·ëãàØ„åI‰(‡ÊJ_ó}Ç2u<+¥‰“ʽÑxâtó¢2GÖß#¾ŠŽ3ƒlµÝš„ñ5„ûãʇÚ&Л0†–ÁWnøßëc Ož”†ƒž¥Úrë0Ð8Îá~¾}Vé½yÙ”m/yƒAƒãBȤÕÁ¶ðè·žûtArlxÖH™‰u’oXÕX<ò³”õªÜcXM¡¡’ZÜ˼ú¤£ºØšØœ?ØWÉëš 48"õà2¢­~}Æ¢7'ìp<ùÁØ"ÖqEG7î©”Ù€ÏCœcðI§Sáõá9Ó#6Èý[kûÂốÑa¶ÖI-¿¾¦Ð$.É9à ë€Ö’ª½û?«ü†‘‰ãÉY]êTÆßᄺh¿…o`Eµ Æ(íÑ›’Ïs íux—´lŽË~š¢ ¬‹nÒUÕúÏ©¤ÛLdf~éýÁLnŒútWÂÏÒlµ‚ÛGqåîG©)ø"ÅQÂu ¾˜ßãûÈCªpábT’–2§ß¹ïÆâTØi6EÁ 8G#¸…ø?ÝKWÁáöU˜=¨Ù|Œð®¤Ö×>ˆ6ÝF‰8òäj uÒŽ}˜XàsÅý¢H@”AµOä{)I™|ÙŽ›Pj}½ ùÙö«wR=¡óS’O“Æ;@u\eüe«–ê@;%û²Q”,K#gº|,Q£ûÐM+ˆæc1p¬¯löÔfѤwôL¹Æ¥âfjW •þÌP¬Ÿ é ËuÍ­ÆϸRøà\jrf{Òþ8VC쬥wᔫ¦âW Wε4&úU±%N»<Ë1Ž‰¥Ú,òáÕ£<“¶/!E1gr"åËwó‰:€ÒZ+bÁmž‡0ü\'i‘í{{'xï¯/‡ðú{—u'Í·jDäkDXöúVü¢å¬;jû¨*}_Uni%>,Ð-ÎwWÞT‘Stªõ{Tð|%3¡ƒgÄÖ1ÉÏ䑃ƒÊèÐ*,%¹,F/+a%Í°Þ—.}\¸âaK‚mæU¨Ô:=HBM­$STWf'P’ØŒzL*¾ÊhS‰S›ÕsRžÇy¿Îæaغ?ó@Ó.õÌä¸ð±¢k°‡ÃAaKÒbõó(ÙLö*½Òذη%tÚ7ŠÎ¦Ä‚º•ö5íkå¸)í¦ e{¹’šój› t¨4û¡·â”;Þ‡ ä¯nÕä‰È$óº>ÐòÌñ¥i¿;»ÚI®Ô´hÍâî >…whó\|YÕ% î»w„ßjK%kí·JœÒŒ:榯83â"ž°µVTábp„”­vœá"šU6§)!§Ò®$éØC ÌMŒ>*Ÿð{;íˆìä€{öÙŽ…¼‹æºsOî2«[ šs¿{¹©Yyä¤;ÖÝ­o¸Ñ¹©›Ù²±WÏÏÔº‘]Í1Í*›j-‚1OÈ«ÞôkÓ^æ |b¤åµ35`ÇóÊ‚6RÚݺìC3”ÄNõNs½±€¢›ð*Å]¾8ž>$ўŽ_*™iцª\eÞîôÉD‘¢†˜‡÷eÛ8_Mç;áåݾ—"|>·qpÒn/‘¢W;vðr´ú 5ÙŸbq»+0WpÆW¯¨pÃXuhðDË£Fú$¶S± Ô¾²yî3fP8ϲrŽWæ“%ˆ×V}6¤Æ2΢%Ä\ˆAw¹jæÐU&K×[0ÚÅóî›/DG½CâRœ ßK¢KÜ h1“g¼}ýCƤ >8^«'àÿ.•0ŸøË¢P~ýÅ#Ôèð¾ÞÎ ÓF}µÙQ<òi¾äȲòÐdºžJiÑC¸Æ°tË•€ÚßÏù¥îWƒí^©ðnòKs¸‰¦¢es­w©ÜfÿƒÉî°*–ä«Ï"}‰SýÝÌÑ­Æá-±êëB¯;^;­)?ð,¢™}ÑÍ9`ó‚/Ò/—…4ˆ,•þÀ!âµfœ˜DØv‡>Â*Ž2ÇëCÑ.Å›Õì@ªa|ËÄ2ø-{™Õ3öÌõOix_Ù»˜Õ.î1H&u¯ “ÐçòÏT𲤞œh“tŒ¸ÊÜ*ÙäŽ,drŠ~ióç )°MÔœ-.-?ön4i¨i»jŸßjq6ãT µš†c¾÷róåÈ;¥œ°,Ѧ˜ P×v˜ã¤÷ž%k·Úóáåb+3K]Œi(î€ÂõkìŠl6ÓòuNœ~üòÁ®Û¦:\›AvÆäH.þÂ9ÜŽOzyb:UÏ>ASÄç.JG «‡+l –¬ö¹¢OZ[i×–ºD5ÞDÖ™5 Ý}}96Ò·ßXvt|49±žVPM_¿N»gIPÄqÄÁy0¡# å¹ã9& é,µ-ѱS•ðž3û¨)|¦wö ð*Ö÷~1!ƒ™‹Ñ1 ™†ÖÁ~‹{Ö/È|‚ß…æ¯Sû0uàåP‡üz©BOw-I0bÈ R!å|,¢D÷ÀBNmóéjãæÉMئobB¦ÆJÔíy¿}ë¾ÞÅêSrý£¯ÞÝNæuŒ'þ_ ˜ýƒ6•$üü.E^T¼*ý;ÊgÔ %ñI²îUßLìlS x"|§ÖÙ%bOk®n”‘Yq•¬„ðŠ­Ïªë0[ïÜ<û¸3Èl§t%T6ûðªßNÎWï…^çpøÙh^^vÒ~žZÊ ïü¼ÄE†kÙ6+ºBêÍñçã«Ù1xäW¸ä¶¯ƒÕ$?v³ Éß~Ó·XNF?ÚÜI TlE1(ð]á>‚šÖ"•yòIâJüå·°ï ,K#Íq#ÅÛý¸Îè¢w¿)úõ×Ûc‹€¯ÁE—%韹^õ5®zŸsû8Òñ²ÑPÇù¤•å»oš}© ìlgªÕ7:(÷`=«ÆaÔ¤šóSfÒf.i“ì2P¯|@2§Û,A¯›%õ™xŽ2êËv9Þi<‡í“xÕ2P)ÁJ”Þ%öy^ÒÊ.Æg(ßÜá7ÁUñÇîž·Œ—ƒ†$7=ý›ƒ©ÓŽsÔé.ì¤ì¨¾Jœ 4±[ØàÎ[]þjÍræ_ §Ò>ñÂ2¬ék·ŠR{Ö”Y̪•xŸð^xÞ}º!½ãså†ÁË;¶$ázôLbôbÛ¾# &6hëð3 0£VìÆ0´î’.<¬9 _tŠ‡ðÏSãñ$™ô¥(ÒÐøxrØùCÖ ¦.ɥᩂ²Ú^ŸQYSkïXB.­‹¼Tc-è 2 Zß\Ö~ ÿyóíª”óî`Z­è\XÇ4­™¯œ —ACÏ|TãÃˬ©o«½¹Ó\oÎykDèÇ7ÛÉìz·S¤B©Ls½WÍé.Ö×’ËÊri‘¡EøîšÎµ]vø$ø&ÍúÑ$q¿œþ…}IÿðËÝkïÒÙ‰W+©jÔIHœ°]îP4¨™´¦åÕñ~‘4³wìw³râ-BõŽhÞ%TË’œŽ§wûú­Zî%þ·5þÎú oÅÐú§xÁ)ÇSËà_ëvqð7Ójb³¸ÛTþï‚~\ endstream endobj 4674 0 obj << /Length1 1457 /Length2 6642 /Length3 0 /Length 7626 /Filter /FlateDecode >> stream xÚt4œ]׶b¢„¨Ñ†èuFoÑ;ƒè13a†1:Q¢E‰5Q"º!ZDï=j„hÑ%Bˆ>ÉÓÞçýÿµ¾oÝkÝ÷½÷¾ö>{Ÿs]‡ƒUßP@Ž¶G¨¡QX° H¨ 12ƒ€ ˆ $ àà0Bb]ù&Œ’þ„2Å^ùT Ø+ jyºÁ"@°¸4XB ƒ@RÑi  Ô BZhÂÀ¡ŒvóÅ °Wëüõ ä†ñÁRRü¿ÓŠ® E!P¬ÂõjEÔhˆ†!Xß•à–uÂbݤ…„¼½½¡®‚hŒ£?Љu </økd .Ôñçh‚ ‘Òã€!Úë Å €W$ ò¸JñDÁàÕê@CM žõXç?ðÏÍ‚Á—û3ûW!$êw2C»ºAQ¾H”#Ðé‚ê©éb}°ü@( þ uñ@_åC½ H¨ýàwëP šâ= ôjÂ?çó€anXA¤Ë¯…~•¹ÚfU\íêŠ@a=¿úSAb°«}÷úópï£ÐÞ(ÿ¿,$ îðk ¸§›1 éî‰ÐTùsåüãsD`b HRDˆp"|`NB¿0òuCü‚¹¯fôwC»®Æ@"W€¿Ô Äb<þÿø·ƒp$ ´G8"Q€ª_¹ØWçAú-AWôA¿ž¿ÿ¬¯G£\|ÿÿ>b! S]uU3¾?Gþ;¨¤„öú ˆ„ED€b"@q)q`à¿«èC‘vñ™š(4Pêf¯v鯆½þd÷Ÿòàþ»–.úŠ· ÷?4·‰`W/ðÿ™ì¿SþÿUå¥ùw¤æéâò;Îýàÿ‰C]‘.¾"®x뉽Ò}¥ÔCM‚€#=]ÿ;ª‰…^iAåèò÷F"=Ô>¸> súÍ?ÜÆ¿tæ‚D!ôÑÈ_7 P ýWìJ\°ûW·‡Ç%‡WÚù÷Šª(þKdÂbâ@(õ€®˜$,&ô_©ŽðùMb  ½J^Mt@c¿ŽT\(¤üËõÛ’ iþc‰…tþ±$Bº[’¢@!£¿-Q) ÐÕ-÷}…õC`пÿêæ‰Á\‰ö7¥®†ùËþ}C >àÃ&æ\ööø•"ƒ·ÀêðÝqŽUÓtÿ˜fÏS2¢TžÊìÐÌÅÔ¾ö›s+ªÜ‡ ³,?ý·jˆ"“ï5œÛ&Œ­6fFiºG ¶_w13 )¬üt0 ¹ß€Û¢Å‘ëî)I¦ŸëØ»SÝçuWéÇÁˆ©Õ{k•âÚ7ÎKß ÄÇZ…MpäÙ?¤c#Ä 0]ç¥üæC>qøcœ2gä’E+‘¸'òÂßbQøñɤß|¹‘°G+=;½þ!å৿ÒÆ-ÚiÿâÂØ…»ÓÏ@<‚8 ƒ],-¬_¤-u4)iA.˜RêƒìM¯…BÌ:Hˆ³W íÜx«Ý¶É¦éø¼½ÕÔóõê ;mÖz#‰¢0|pˆW<‘®¯ÿÚÒ‚CóíCíí/Õ#–~ý–ËÄ€eê¹:¥y•Ÿ‘îTBƃ5ÉÖ€ç¬ö*ÿç‘·qŸ5Ãæî2Õ¯žd¢‚Ô ò›· 2ßHpô%Vݵ"®”j²Ç!¶jã±ì£ŸU3þ(è¾·v!ú%oÐ"]RûÌÏÛ›±Ö×%e¤PSÌž²ŽÅ–øÅ‚º,#š?Y"§`ª¯T»JúøŽ‚ÖGøK…±&µÜ!HäúQ›miÞœâŽ#_õéöݺ ¹íh‚ ‹§‘Рúº4SÆhÝCªh 1s¡ÙY‹êî‚‚¼È®d\Õ¡–Ãœ¹qš7ÚE7&~Æ~&|BNçävß¡.Jײ"›ƒF鼯¿R­]ÞÑ C»äµõ£¡YÃqýÐúÖKòøòwK—-;’?X¿ºó }Ðb¼ÍbƷߧ·2¶:²ª'Ä”SÅ2q|'‹“²vµqR†MŠ±)\?ð$ð]âBKÇôpÊYÐöçp\îì€KíY´ Ìãù„X~>d„YÕ3™Àê¤ãgTkÎ]æf‡ªÓže,oŸ‹õ4¹}LPÒ|[¸”m¤9/É•p»×' ‚ájdLLŠ~ó´Ü!õ6oîx’ùlõ©ð[Kìèû¾þ'³Ïck²å2¢ëí³—.x?0á±àÝ/ì¢Ùúá$áY¤Cn²…æî•ð<. 0Ûí.ÙŽu %<)»¥R[€=¾9Ok/ʽ[ž•-6ôýmÛ‚¯ÎmÛH…Ë4šå[½<ô¸cQFB8£îQ·çFÕ6«ŽÀ)XÕ‘Ð÷uóù ¤cùÁ´`úŽçÕj6òOž¦>Ýo/t§ #²Éf=‹Åã;z­ ·æ‰ ææÔ‹´(”-[½’ðûõÛ3nò<ª\Ìøö=$FÕ'Ôœ«±·ôhK,J tåüNx¹y’p Fµ‘à &‰;?Ü ¶ÏÑ´ŽÌŽnó­¯–~<ø™Ôa*¯dn+&yuk¯ð¬ØÁq‡£Å-ïL¹Ç¢ÇÌÍå_?Y=@æ]va¸fˆÈâ’T¹ÜcX~-<2ܺÈ|¤V¬4YŒkLürˆàa[ÚW‹ÂÂÛ.¹R*"ÈpõüÇÔÒu@—²L{CÎŽGdÄæ³ ô]'zùrM¦ûýæûŸ'eÁhX"éìDlŒÈ9ú^ÎÛ¯^­´m•'Zd•*¿P&°©û)uç@ñËŸ|Ò6ûú\Ï–BRµt·)×?~$Î…R—z) ½&iÐ(/"u’ÆL@¦Äÿ)~ñ:çÍ á2U¶,Ͻ¦拧%v»rc6vÌ85Ü©ã\„®§L7´¹Èµ—ÇI¹är(²Uõuù¥!þц"êÂd âV9‹òß&mhÌ⸂?n©Ñº;¥w\;2gÈÙ?s …–{~Ð}iì6TdWQq°œ ‘ª"ülK¥åøÞÞ›u9dð­GgH¿Ñûœ •V|ûÐ>iSwVë dwžwS²ÝåFA Q,×j»Ý¢“ a;‰‘Q¼fJãÂåó›|Šæ¡¤ýÇG¹v”ó?¦VBÒƒLϹŠ™Ý¢ȸï”™ƒÖ~”=Ê5n+/ÚÑ;½fà°ãÜaôã¦Óî’TÞAiKå·øht ÜòZV=Ÿõ±cŽZÏýÐxÙÉð¬¾ì"Æe?`?ïÎÿD㇠P/ùÕ†d×±®.êÈ¢S}ÿ‘»çs]OÕ$ïÝA›ãÙæ\OýåogóÊ¥Æwäý-*·ãZøku š)·•5x¦Ò0ó”–7®¸¥€ïQÖì¸1_s;.HíOnü×+¿ôCn•é+ÞévH 6bs`Œe#G¥]˜q&¼ëTíÙ¾a],¬¼щ#N@²'ïÄ#É9H-¤½éððÇ“dVÚFPTí7ìÍ:ˆlW ¾ׯ¼À.ÎN]xb*»v^E.Kˆ¯ÿd'Z…À}Uó¸^¢³Êï5œgäyoÝ =¿w/©Vµf ˜{Å°`$˜ÜRùü‰çüŒ&æáïýš„C2MÁúÖ´”Í}µ{ 4¸-©ç©šøü)l½òYO“C~¬Ø+åŒ ÷žOKÌ}Työi~×J¦Qƒ€ê^"„ G-Tú°˜ Rå‚Y奩—(ž¬Þ¤ÁÞaîX¤‘çh;Ju ‹6lAXúeæ †pÂý N¤ y̓,§”Z cS{ÇaÓã­G5†OKV¸rn3øùÓ7lÛ×¾‡Ý×·¿þ ;gÊ«jï8.òcXѯ` #5zXcPÊ>Îÿ‚9´xG(wC §`g9„S5P²íuFÏ9„ØÛø({G4mf¶“?{Yin·ÐÀ‹˜±6ç‹s?€$ðÖ=}ÐÈÐê7×(ûÉ7ÄxMyT!"ÍüyCŽŠuãÀ‚«çÓˆañ³@½MzUA#ûZ ŠÉ†™¶"Ñ&ù5_és kD 6Ùâ™h ªGk·¾-‘‘‘– #´Ò›¶q¶P7˜ZpŸ„mjè÷)¬EKÀõ:ž¯õ‡¹›ÆD@÷é+ç*hŸI{Ðry1ó²Ad ™Ó}7§—¥t5­®¥w‹Å9MΓ X%GŸ|Öa¶Ÿ nã¯tÔCqIR÷÷–V¼d¥½­:Á%Ãt¦F®Dd÷qчZt]Ö‹ÇËHœ°å Û½WxÂv!ÅÛmØ9‹:yÒÉ |ôZ†ë°xôZM¡;¹ì÷î÷ Ó61õÖaÉ›¶ Ða› ,¶Äð4>—2#6f¤ø+[/Œ‰ÞGšüˆë¸ „OÖsBK.8 eø4å½ÒûÒ=n,,¿ï¨ü•ê^HÕ7@ ¹&‘¶eèIWÿ»ñ#Åô]ýA"ýûHÙ#S#ÜÕä‚ÒÅm»(ì°^T’~w¦Ë`ü#^+Ñ!fŽ^¥ÙÕ\Ý\’jùk ”47úË/:ßjRÌjªHg?¨¤@u Wå !”˜·¢ÓÉ“ ô'ðw¥im)ë^•bT¯ñ¶³ÅÔ*|u°»úH¼K²f‰’L™£®®1Á™eT+*u¶:­³5* “Û_UEÖïö¶µ};`ª)Z]ÕÚÔM^ê²NvXÍp’±ì=*Þ3'£9‰^û†(øÚÖÂ*‚|]ÉÜÈñf:á,aU Qž4}8*4*§lÏ:kÂ1§°iââ›Y¡-6œ'Ì£8Eæ¿P|¼»{8ý*7±¬ØOŸ÷Þ@Išá´Á*œ—eÝE÷ íL¼ý-ç¾È*<ïfOÛ®"|:FÐÈ Û׎»øB A÷ö^{:,çö¸4‰u ò›–åûn¹;—îeðúogŽWó={“§HÙ3Æ4ŠÉ_n*çÔMQ–šrÅ\ èÀTS~W?áŽÜ×Â\¼‘ýÄ]æ¨nÓÞYóúA¥þ&¡M°öò§ zÚ¶EóSóp•d¶ãúv*y‡: æ´ÙÌ…@Š†$³Ïè¨u‘ól®e>£pD€Äჟc)µwIS„ýÉÀT*OÀànz råº@JKAÏ”.Ú䉄­y }Ö öÀ,Þ´Q]cWîµcFFO#¾=¼ñžíç¬zñ]·Ìm‘ÅD?µ%sѦD3†ŒýéZKEÏ6y\RqdÙ[¶PèÉwìuÉPçxG.4ô¨Vˆ=—g{fº,3ùRSük^Š—}’y)±¤}ƒUR©¿ù± nŸà úy„¦vÒ3Ê  ]f(?²-ez»±y†VÅ[šÚM!•5‹‚CÚ¤6zë‚ùˆYÉÞ-ʺª7xÅù:‚¤äŠjؘÁ›…_¬*ÃåšoH =(ú”4êb''¼ö)? 6jóXˆ šî{¹°T v@înßš÷|pÆ0èÓ{Q¯3¼üöÖ³º~CD}Ø·+îD”Ø¥7Ê—™pUB}¾Q3“´ó. Ñ÷äá6=ˆ¬*+ä?z™rzφÉdðÈ6T~¹†w·ý½o?É™åÄÙ„,«@!˜ý•˜NÊ'…¦€ÜÍdŠæWp$üN6¥–ÔWÎ Íxüð;UÀ‘.ÇÇ o`¼MJ¸|ÅÔsj¦(x$pÄÀÜ3Ã^¿.´Â+s&oë¹/fîDÏS}f,Îyýð½CnþÚ…/êírç3µÛCQü97sËÓWï÷Yã©JÞª“ÇOÏ™±ƒFé Ù¹‘¯/o #ñ‹O±ÄÜB– +2Ê… 8ÖPŒøʤÙ!i˜i=?Þ[å˜h=šîí<2·+^·Ó²Uª\dv*špßÛ¼%IÂ*Ó'¸?ÒÃÐÂÛÙ¢9*ïÙ]ϲoI)„hÓ§AýíÑÚYšk¨1ã0t=ƒ÷¤#Ó¾HRÛd\@¢Á;w&yŠoe\§%äk¸†§ShÍ)«N¢ÖÈ)#ÇÞ˜8KÛ‹ZÛçÆ—Ï/RÄ *‹¹t%½É!QD|ªÒ^±€è~¶0üúñÒÝ’ ¥dh¡̈9Éc»×®$GUÃ݈¸ýÝÝ6{E¤»çm T?SGq–ÈZ{,btûE•c÷ ú¬ú-ð.ûŽÁIÝeNíÅ\ùéµÊ.üe-i˜s©Ha¨ƒ0@7©VZDY9AFïf¿›lMïkEy©»-‘Фqº^ªÓSÈ@Sô›œ:k(ϧ…At/D?æ˜X.ò æÛ†Ûo³c”%€·ßöMõŒ·ÁÆÎ+ý?—ÉÊfyíÍÕ/Ð úMDÊžÞÂÙ{Ò;ú|GjCø‰®6„-Û>û&£?Ýws´t*Ïdhmú„®}êý„Üóùþ3ŠÃ ý¥¤:S^& å¾î¬h½g[†!ÁÄÛ ×›Á“ÐxÚÆÐá©ÖFÂUð*±áÔ#@‰G¡×'ºi>´eñÒÖk*¿Œ÷÷6D(F§/˜ãÆîâÉ¥Id.Ë•]w½¡F­Ro ?ÝÀ;z»¥ïÕ‘_™cy]ŽÜ&MÅè¶ÛFÌ‹&©-¦> 0CzÊ¢”ú2!`\’‡¯à;è[Hè_K•‹ûRëfɾ¦yr‰µâ?P»fó±ë¸Õ)å–ý×[ ­óth¡•ËkÙÃá’Qè{s±êu¾³ú§×Y-Ö}ÚÐ#rìçÞ×iÛ+·ðñ’Œœz)©fCö|_kT+{]ýÅ ÓŠƒ‰á8•cœÞmdŸâÞÞ~4NØÉ=§9¼Š/ª"+2?oë‚×mbr²ãçÁŸg¦Q´zy?Xÿ£\ÖÊIÏ0Q_$ãôÊ2kÌà按x »ï‚™“ÛjŸ’&Œä7†È>ÓícUÛ!_ðF_iû$1Õ‚zXTZèõ®[5­,š ¼-Šü ¯‘³±±#z­ÃQ.üŠagCþÛg9"3+åZ±ÐüùèlAw–1UÛ‘BÐTjj}‰ÍnNïEYx‚ÇàN@"­|˜äÍØÍâÆïQ&< ¨Ãßv9eû‡q&[Y2íéikž‹E-fIŒ-vú—™nï!>™ƒÍ¢–¬mÄÇYÅH.!I“¹Å]†õï Y}JgH]Užõ ª¨ª-•\—Ýzܘ5dZ댊qŽ/ùÔû,dG'HÊ‘îY&skf£ðaÑ¢eßI2ÔØ­%oÓI^qö|KM³öæSËÊå.^•¬ öÍÓ–`½™fe*~%§1MùGŽû²a2 8T÷^ñLºá?bOH O$?9¸ÁVF´Êu/ö;¢ U-æö–xj?¥~pöt§„¶nl9y­Lº¨-ÃíÙ7òéä…˜³.Ÿ™É‡†Üö ‰ÊfÜthãð¾•J!íÜú¶«éŽ§6ýé+gEÍ7Ôëqu=’|™kâcöÞ,ÍàWš¤z@Jolç¼Ç„VäïrF€b‰«¤‚FÖ$Ý_ o±‘“tjr|‰W¾•ŧRk"N3÷­?r+p^P¡óÑ$'–þJ6äZhm^«UÎsܼwº`ÚV½†ëÕ?«w7ÿ¼ÉÎôeùM ÈI…a™ëŽ|#i©S´{3«­æ¡”js'_à²|©Þï8cÓ°4Ü5q^¨ï n*²·Ó£vzi¸r)º›š¼³jrcMN$õÞ96ïî í´¥*Ýá•Ùà¹;-å÷Ù’ÂM齃ۈó†oëàÌÐÏŒLzòMãx5N Qï§,ôîýÆŒÕú¯â®ö4A²wœ|¨BeZÕVq£î8³‘ fO9ö^ôæj$„nr ¦øxAÁÏs;>Ð馫^qçNëË/k³"ÂújÔi˜ : ´ù‘Rªç\–IQ˜ñùT &@¨èÞãNm"2Ã"˜8ò?nïÄŒ endstream endobj 4676 0 obj << /Length1 1306 /Length2 1345 /Length3 0 /Length 2180 /Filter /FlateDecode >> stream xÚS 8TëÞ±Ûì‰ÎÞ]EéOÙQÌÕÈ-Oã2î¥AR*Ë̳˜Yk̬1&Q®;¤]‘RêèN¤HØ…JEI]„Ó–PÒ.·]8g ºhŸç9ç™çYóÿß÷¾ßÿ]ÞO‰»‡1‹‡ùÃl Åidªpó°q£Q•Ê S©t’¾¾'‚ áOv’þX"E0Ôâ+„­†pÂfáJ †g™Ð€fjA[eA¥:•jþ ˆI,€‚ð€8c(,%éÛbb… ààóp ÍÜ|•Ñ8°D°áB(pƒp,"^äBBàqWL a`%Àq±…"—ËÉHJÆ$Ö†F@ŽàÀ¥°$æeÉ`-$‚'K#“ô§‘N8<0>.‡$0 B„ £R‚"Cy°¯'W°N £`× €˜l ‘iŸÃM²•tœ q¹˜H ¡  |DƒulW2Šå)PŠ|(B„?OlÖzNÖ'åJ1.%K¡²FŠ2 Ñf{”g‹‰D0ŠKIÊüì Ì%ú® L7ÅähاAy|e<™˜â…"Á2ØÉnC˜H_l0˜TÍÜŒà`‡råž 1<î¤)ÍD áabL øDp8‡‰?R˜ .‘Ááa_;¦ÞH4à!\øÃJú0Ãü‰;1  6S ùÑUùû|ÚB(Œ‡¡BÅøøˆ)ëí<½mVN–üÙicƒ…‚0c&›Ð 2LÀœ8„Oã!“y|ÅuBùX5‘.ѧO)‡LjÀ`rA ÁÔXk1B¹00ø"t_*“Ê%>´ÿ[îã”ÿ¦re”ÿ)ôo3bË„Âq¿Áào~H„{™–| ð†'Ö æ!2Ñ·^'"v€…?·‘²‘P˜çŽà\Á„LÆí0¡þ©\{”‹ñ”kBgšH"$*¡:1°0±O<8t\†€BF1œ ± |LBRŽ„Ð)…£4‘¦„åÊ$b;Æ'G¼ùé>¾Š0 sIM1®eL`~LÉÇK,¹qG ÝD³¢/a@Ýû¥ý‚®õQ¶VCýŒS‰OY7;‡þ˜õ†ž9V´q5hëói‰óš J¦óýÛvÔÍZ=üFê*£wº\¿¾Éòæ½+æÜ•¬i0œoÜÛñ(ýµƒÕ/Ź.Þ©-/ì!k¨Ô$%ªi™™14TbJY饹6y¬†Æ2§eÒ¾55o“±_¥Ý¹Og¾¨xvÞhÒ–¦ÓÝ­)vHï¶>üªÜTÛů4è¿,·×Ùg5Pià/­öXíðgðåë¯n5É 7D·û7ÕŠ:3èã¬ya­îÚÕó¬Á AËMžª5oܘ|þIýœê‚_¬¿Ô'{wζÅbÈAOliEþiGsŽ 2÷_fýÐj4rg¥z9‘©îžGf[ÙWk3œ›Úêî}ä/J9hþ~?ûUk‹”ÿ|4R[ÕÙçúŽÙœ¹­N•TäØ´«@_Þ_šÕvµ²éö½dݼåìêû§cpÃë"Ÿ=ÿËÛOÇÜøè›y\ظ+÷÷Št38cZÓs2ø.-âäÓ±(¶'5»uÊÛóû]팴Â^æHÎëbõ+äˆM‹ã:wœó¬²ÝUÑzú½.³½È& í–[G6ZæøÔ̸9²ë!kÑ&ìléÌĕïÔ­¬Ró?:îIÉ=tm/#X€a– RG·´æ¿"‹2dôÌtOWµþÝý'=§³×núU¨$ǃý¹/:^-ãú2ÏÜå¿ÍYeINVyé<ûª-GDUÉn«–+½¨Ëqcé‘xÇi½õÖtûéz8³güëdYïBR%¿öG÷äMܸ}ÚÜ—Å—ôʧ™úäns7Žx²ã­ÂÈæfkPòËâÍ*œ3³SL‚žP­î~ÿº”©PoT$\1 w¨À7W´óu}}ÎflYSW-*Nêyi™/ ‹èŒÚ}½x¬éý‘Ùä‘ýzGîxVQ³ëí†Ûæ:þûñ3¯ º÷yFþ¾Âœ9.^oŠ¡ÝõÖ2jùµÍsƒ> stream xÚ¬¸cxå_³&wlsǶmÛvvÔ±ÝAǶmÛ¶ŽÝ±Ýq¦ÿÏ3gÎ\ç÷ËÌù°¯ë·ªjÝuWݵêÃ&'VR¥6³7JØÛ¹Ð330ñ¬lM\åííäèU€®€¿FvXrrQ' ±‹•½˜±   4ˆM,,fnnnXr€¨½ƒ§“•…¥ €J]E“š––î?-ÿ„L<ÿÃó÷¦³•…€âï‡ÐÆÞÁhçòâÿú¢*p±Ì­l€QE%miI•¤‚:@ht2¶(¹šØX™ä¬LvÎ@j€¹½Àæ߀©½™Õ?¥93üÅvœ€¦V¯=Lÿ¸è@'[+gç¿ß+g€…“±Ë߸جìLm\Íþ!ð×nnÿ/BNö#lÿúþ‚)Ù;»8›:Y9¸þfU“ø7OKc—r;[ýuìÍÿFšÙ›ºþSÒ¿|aþz]Œ­ìœ.@—r™fVÎ6Æžsÿsp²ú Wg+;‹ÿd@pZ;™ÙÿÂüÅþ§;ÿY'à«ÞØÁÁÆó_·íÿõ¿8X¹8mÌ`™Yþæ4uù›ÛÂÊ–ñŸA‘¶3·03ýÛnæêð>7 Ó¿DõÏÌPÿ%alfogã 0šÃ2*Ø»üM  ú¿S™á¿Oäÿ‰ÿ[þo‘÷ÿMÜÿªÑÿöˆÿ_ßó…–pµ±Q0¶ý;ÿ^0€¿Æ øgÇØ;ýÂm­l<ÿþk &ðß$ÿp¤]Œÿ6CØÎ⯠L Lÿ6Z9KXyÍ”¬\L-æÆ6;õ/»ºÐÉÆÊøWÑ5@ÏÌÄô_|j–V¦ßíþi=û¿]@;³ÿJþ¯Hÿ¢Î¨­®)¢ªEû_wê¿¢”þjï¢æéð—Øÿ,EÞÞìþÁ±÷xÓÿ}ô,¬œŽ¿ ¹˜™}ÿÙþÃüŸgyc'+€îß’™˜ÿUøÿüýçIÿ¿ÀˆÛ™Ú›ý3+ª.ÆvfÇëþq›º:9ýUõ_/þoÁÿqþ× @Sصe{SÞŸÖi™é.uX¹#Sbº}Ìà#Á¥jEþ5ö½?ÒÂv¹+Þkƒšfx>Û=9|ÈÐŽõaÚPö¦¯òñ}I©û P¶(:9i JÒÏ5£¼¯—äv t8˜4÷¦”U JÞ¡f:Y ¯ÿPû“ºø£“=9 ú™¦6Äbt!7 ÖžS$žüy¢î½…ì?À£Í‰…!ç5ÆòK>#Nrñ4rzh4ý„|uãtßãUB®g8Oj‹òs!ºÖnö† ä,h±Æ&OŸWþ‘3äR®š‹É2^œïO´,ÑL=3ÐÄt; 0¼~„i‚!g§ÞmmtB×ß1¤Ë‚nµàçØ<Œð(;ðˆdûm×,Ú·Á±DH:$4xxÛA"eÊsáÚm“ó£o´ÚÝD"æ辜Eøî^ÎiƒÕø´ÈUÂüT6%Yß¼ãÓ›G½ÄX-÷Œ¿I+÷H¢ôñawôçÔƒ31œFVpéôÁ‡Ñ9@æ¶DÓÓ’¿§¥|uu¶þèo±0$ ŠC—¥æð[ ;Ë1Tž`˞ǡ]´ÞÙÇÊ#ô8¥ .¿’Ò%„R«SB»Øȹí(ÞŒ6üèÊOQ²H†è{¯…7ãKÒ!7½”œæº\î½JÜ6Á_»>šdYÅ!Ø’87(S?Ke¾äÏ<ïâ{ªöý‰=‰<³Û@/ªlv:;‹·Äó˵¦Q6cCèOtm«<6죔|g„×eÞ})K@þ5eáWê ‡Ge‰Û|ÔX…ÂI(-¨­ þC±hÈo×TyR÷¡?źZ@YXßáЯnUa°D}¡îwvÇùûSS°‰úÐ>‚i»/ì7ÿÕ H8!ˆÏu1!ý–b¶RMüúŠ/_i׳͈A±I´ä<ѵ½©e,n\†`yGdüM¾D¥C7ÍF·ÙÑY?.ôƒ<¬—$ÞòÁ ñSõ†ïÎU†s7@)Ëí»Ày¶¹&Ufí^¤–ä”ð­ã“à ìϬˆTžÐ*Ä`žG5úöï$±j±”Ú–”ÄÚñ-/lú¾Ž]òPóx²jŽ´f1ƒÀ¢áÙ¥  FN²cJþ£]ÄŸù«¼ÖQˆžµÓ·í~ô+)-&Ì‹DsÔñ§q›w /ùÊ}NG1t}Åï'äÒ`×s1t{a)€É…pªŽ–@uѹ§âq ¦#6”’ê31Ö¹§Á0~ ã ¼Ž3ïIá_ý±W?U5sö±‚Q˜GvVO/Ú,ñÈbá¯x]³æ6©ßøüÁ¦'ªfw…;ìŠö´ ‹ø ÛÒ·{"NmS sÉå«-‚µf!]šYJ^&‰dM{ëFNÌ{”¼ð©`u“KºÀ÷v³ZðéÇЂaø/ó¹õâ˜ÆèAÎ)k×;Žƒ+lÌØÓ/†rˆÿ˜æá ,±–{^©ß÷ç›í§éΣÄgE•ä€ûAw¥UuÇbh²±ßcÓÑCZx2!óýAÕÿ'ËÓR*ŽEợyƒU½K{ÌØì=¯VÖàâúmeII£öóbˆ1Üg¢5¤§ˆÈiÖÖYtqÓá¡u¨ž4…½ÔT±‘*©®¬Yj±sæ$O¯ØþDR*¤Ê²…ñàÆÕ‰›ZÈ4”ƒO˜yªÍÌd@¤¶Èô÷ŸŽ'Ñpããk…¥pn¦#QìuAmzp/¤é~„b¼Xæ1ÌdÌŘw`Ë’©{*àüd¼‡q˜*ä:òíh:á_5{Ñ:rC̼®D†š ÚP×÷+æzþG£ê:¤¦)i”†jao.ÕD÷ŒýËšDˆë{î'ìz7‡g³zù%6r¬»Z'·§\ûÃ劗‘è]µ<ÂÇ:ºd6ƒ&i'¾Üã`áÏJΩD‡àÅ5‚›¼½Nâ9’§XxøÈ7f¼˜H{Éoð&ýq¸• ÖEsO3b‰¬õ觃+\ H]Ôe ¹™«\Ö"ø™+{E¤Û{©ñEGJã<¿¶Šö‘¤½i`Ks[ˆ T¡ô†cÁ[©ü–(|RÍEÁv³ð.@ÿ!|ŽÂ¬iÿ¼b¬ær˪÷ÐŽ!–'èO.ûÝ/•/WÙjíq-ž2¿ïKšä C"FGÊ­°@C"1cÄàV@Ð{ôŸã¨Ò½·-(3‘ä^dÊ2Ò÷£®¢È×jÔ_ãÎò÷¤T—¿!ÕÀÕü ¸_¢TVÐ+’ó|4Œ8o ÕR`PÏ ÉdŸû!3p$-¾Û,„«¾±¾™ä<˜#RÛøYQ«rŠ¤ʈû¦Ð<#Xɲ>9&÷©ëWâ1FG[ègš\a˜´îCÍ'ðŒ½c :}¸„…‘ÁCïåÒóº’H»-©×ú3{ðâ7¨L›RN±J•µ*†TéuÙm­Š—êc×Ý‚jOµuV¸é´{½¿[Þ[ÜD(+:ËåÄ”°ѲK÷蟸<êjoæ|”‰ 2Ú_!O7ëDg±ºû_‰<;FÉ—ß@·ò#¿ô­0œ'áJÜËëK臂Þ:ýë®àC§M‰Å[‘ç‚õïà‰¬m‰ÂÆÚËÚÛ€.€¨¯®ÍHÝYîJeŽÈN®¸ÐÃ@Aç÷‘ßg‹u¬å Œ6ŸÉJ%çâW¸¨zo´FA‹^4¶t jeµn=ˆüΙÌîçË`|U1 ³c†V›½Ð}@á[Kþ\Cy[¥û®ªê4=úÅßA29G TÇ?¾(vÌlÒ˜¯ô—±ÎÞØÛê’¸û’VüþÞþÔçyX+(ãÝ\¤fŸó¼íÌ؉×4›Dæ°[n«´.jþaÛXCtÂ6™ L l/»’u «ÕBÚöJ­?;QÅ—ö¦¥JG$¥wϳÞVr}%ö{¶[ù™0ˆ͈^’Ì€ðm";C+ÇGPzv Ò $9ͽO&ÍÆ$Ô€\Óö‡K­ÖÐD6u¤pûo·¦?\Ę_@Ñß`¦ŸØ?¬ˆ^p;'A<‰‡ÔÄk·PÖà{½’ܹEŠ]¦=²âÖ—É -æäï%Њ/ùL1R»›9Y¿ÌsèÖù4“ëÏ°–”9%蚯Þyl'õ|m7ˆ}aâ¸F¦„ØÀhŠ6}*GÕ÷©„C’¬ho:Ê*‘$pH<ñ§K]¤Â}žûæBÃôï-zwiC{i T¥8{ã–Ç¿æJu2§Ÿ›‡ò9¦KÒõ“7~«Á/éi¶ý€)±ä­ý±ù‹ó€¯Þ”Ç©‹Ð©øåg*‰ƒÓªéöiœ9<šƒÙó~µá"”Í/är¾ì/Ú6x‘:4­ä†Æásž ¼ûfòP/#¥á¥õ™éL›g—Ä?ækvhEƒM¢Nô¾Û;î>úp[ˆA™È%“m}6µ$ŸS#6öÏ”ˆPEAAñ+°…‹º”ì_/¥ßNÖƒÄúŒ–úáYçXÞÁ¾"Â}deõØÓl*"‡ÆÍ­UÒ°Þ›sèU åD"›qÒŽbâ7÷CÓ~êç×dÛ G1ðBr î[q=¤E1$³n àq¸iÆw5(“ÖD1-àv2>é9b7™ßihÒ6cI»HÍãVS÷aêG Bɪ9Ã4Í@… 5âãý¥>l®š×cd³kð×ïÈÍ<”D¤#ª©Žø—›â›Ù|¡¿|Ѐ³9öÙfù7ˆœ¾TÊŠÆÒCs¹ŽSC\~ÊB "+Pݶéý&2ïKSylòVœ¥%jLz(ŸŠô÷«ÈXZÝZÅ,ˆöÞ. ”t¢«Ë'â¶èÝT"2Äyl}!×/p$c6j€“"Õ·!ŒZú¶ö_k‰x£‡¢ [-¼bÑг"¹=L¦°}~iyÍ‚drƒÆܶãS9†€Î Ë 1AnN$6/å¹G½ã öúI%EQîj¨,VLìONgêˆfs„þ¦]/–aö²wâ « ´¶­\¾³æ‡6¸Ì|þ ë>¦âH­ðÅÃ%E§¦¾eô–ļé|‘«¹Á<tü[S D¡Ç~ ü!øð,lŒZf(f.ãUxÑÿ kšÂ=OšF¹ÐÃ\hqD€ÐQ§4³~ Ìz,ñMRCp ÁŠØ[’üiŠ \)óÝo•z­ÖÂyìwnv²°}ÏYÎèíz½9¤¿ÿcœt¦°ÎjÅGzœ@ˆpË¥!­;3Ù"ƒ(Ѫ¸óxrW–ŽÛE{ à³©L%ÁQ&Všz<‘fZKÐ 20ªŒõñÑ¿Oz‚¤ÀÛëš jˆ²VÝûê^üКf•©Ðœ†90²òÇwëÊÝÍ»_Éך¶¾g¦2â?ÅеÀ—D5 UKçÑZ|Ž_I>QbrB×÷&“çú ñhÆcjI3î$S?"^ÓrÚ:à1„isãúÕõzƒÈûÒ3ñgDÅN¥]Ë ¥.óê–°«Ék¤À&%×.pšÄ„l`ÅÓ¾ï7aãù›…2Ëy·1¾üÏÕ·"v"­›ƒÉKJi{”¦$·‚ªµû (aŽ?Še”ŠKŽZMi­CI ¥Gþè½øìâPC[ÅôŽÎGªàBÏl¾-”ÁU1eFš"Ò¦H‚áýÚ÷øœme6U?tɧ>ޅ߃Dá©%$}•KUfU.2ßLæi¹©‰¤k\¨¤ .üwtˆò°¡Ay×Å$ý,COµ^ß‘ûQ&ÝŽar©}­-J9(s]ÑŒÝbžQ¢'\èbîâÒKëNóšPaQ„o¥pmè™j@ƒŸŠ2uêÙ³¬ÝV® ¯Þ;mŸï®ÝÑŸñ‹Ž9ïÜfó…!­#íüÒx`U!u±·ÍR•–O¾¿[¦©÷ÔäwØ$?™âyˆÏ6í˜ *ù38ƒ~½ô¸ M\èüÙ~2ƒ‰ºÍ·Sdžk'ÉüXEN$ÙŸ‰ÝÒWá]û¦z¿Š$Í¡¯˜{i:™ìØ€Ó’½õ1@̈´dYÁå1g¯õþ}ו÷6§¡}? R UÛð¹è;/¦`vzê4 y¡ÀHÏ#špMmûýÏîÖûÑèÃ¥êf”~íúøïÔbH«S ['S'½°òÃ<„}€g´‰:¿ue_nU©‹Þ(3lûâ2´87ÕuAfQ.NÙîhô^£÷á?Fì¨=+'Þ•1l÷ä:,µŠV‘žÌUúÍžïaÈnÉÊ_¿b¤™ˆ‹‚©WÕCn÷R·ÂíãoFäNà–‚qžû{³¤0Mèª×&;SM"Ì^¾[b×1Ó¶G:êñï—¦‚ª€ï{x_ 5îùTq‡A~ºrá,úEÄtËÕÝ OÞ …cvÌ[(Û¦ù›od±›·](±é…Ýà>“{R£]¦þf˜î·å×”¡Í‡!ƒn®¶ÁÔá>G$GëÚEÇuÿ‹e¶b5:KK]ÕT5ÃŽæ&dÛL[µ•†yÎç™V} ˨%ý†>_wÏDÆ‚¦Ã]w$è>'éŸ?iiA]–å]}Á´XÞ„9Hªt.lß͉, ¦RÖNä.Þ,j ^jE)ÿ>ð³÷,”âÐà¤É÷©É ‘dì ~w¨³\CnÍ囦Cgo!­.FÚ|Z~y}hi€¢¾õa¹o8ìÑ)ÓfÉ•hÅ"$Õ°v×$êª DÀÚÖ8éÃì]ˆarÙ;d²“,ˆè)H|³AYŸc¥)þ4Äà™»¦DÃë~·ÏøG¨´¶™š¸ZÛ"©m9üU~,kÍ0^wïL-8‘R…&ÖÐÛ×qñ’ÙË Ð1ZÉOrÜæ#étŠ‡Œ6#9DêÑÀöM½ªÐÕÄôó…€+;i‹þ •J´½Qpö’soMoAÚ u1’ë'r,ö†À”U„µ‹è€5ÞŸÍ$DN… ˜âmI›ðhÎqwÑSBÊ…cëO“‡=¨D°¬ÝàÊM÷“óÎwS›úN¼³lÛ˜ü6ªV¤´ùð $¥#G×±3¥ŸŸs¦¾žï±žƒ‘’TÌ!ËΔÓRÞ©±¿2'È¡Ùõôô5‹ßÊï™ Ä@«IÛð}$ 7óïÎoÅ¡!‡·hbåH÷ÐÉìûÁÏM›C T^&µ7e‘®¢½`ž60“.Ç1Sò×ÿ±—`n³´7Çóé+ãF†ë”sv¯öSv¤E,EcùO?E[DGGn±°#Ôi÷fÚÄã4rRŠeWrüFÏgªÃE¼q#BÛó ¡Ú_Eý¢Bdˆ•ãø,"9´§öó@u¢3_Ñø(åÞn•dæ4Žñg‹£þœ{#p-‚ØWFtRªf%­ÝÉâ„·'î(\ ÉVth<‚Ò=}_{òéhöðÆþÙéðʬ«åûbÛ·ñÄ2dËïÕvÖsÚ?1¦ì‰ëý{Ëáu5àUZ·«2"µÌk=‡Ÿ.“ˆtº0šÌU€ÂkÃÑ’~h­çhÑk«¹ÅߧçšÕ]çd›‘0T)îRáâÞ“JÃ÷ÒÇ+?œB=eÏq±‚­Ý¨p¨úuŽ3ÍmuòÃÞ€Ojò¤²Üø†2¤n~Ù¤TÃ(M‹)$üæÆÉýL÷…[÷$p.BÿÝ Ö›ûüøÇ™Ú7ÿ†'Ø]>ê§7,×¹'ô°j˜Sxyƒãì²{x º¥œ}Y6 –~>dð­ÙÒ‹f‹ê_¦ù3,erG“¼Yj–굕§XÉ77Ji“…k¼à@Ö qHóäÝ´ÆÑl6²HæÚ ´Zu'Œ4ÌÂtEXª©87£¢åû°®³"ÐSàù÷Ðb4;¹w£”£šS`±î%`³Œ6º§‚Ov Ñ?AZ—2ÐhňÀ`]q&áç^[›œŒŠqØ­8mïp3÷Ÿ“;ÜúI€ª†‹9×ôÚ‡åoè­jÌ\eä›Ç O±h±S+" !ŒF \›¤Q–A“TNa&Ž8ëÕÐc­ÖÖÜ&âè06:á÷'_ûô^ŒÃ±(Ìq2ÐI\›õ´°ýĉ-‹–§íþ}ºL:—ð¶8û Ë×Bj¯ÐðÄ‚Ù—1¡ùŸX!e}l¡‰ Óû8”HŽO;13¸Iµ‰‹7GWÌi_-töc‚ÃÎdéAñ`ã--dL!ˆ!#Š,AÜW Ùú¶mGß9î+§:À»šSZO" Õï¼÷œö|Ð…ç;$Ÿ¯£PÎrÕ>DŇ£ ««‹L‘ºÎÂŽ =\ð=Áãè=êtÁ©á?w 3 YžÞ´vP-5PÄßL \|ä¶Öˆ%ø`µ=–—ÔNã¸×†l‚–ZƾÕú×9Ô1ÖÈ¢iäçs|ùOé™!y©ohç`OWØ£B³ä˜¿€±‚)ˆØkÓÎдnÜföPÜ¡¤,&/ØÞ2lÏ3*Â…!Ýê¨@z"0L‡d®GŽÜ@s&Öé¼Z굟.|à´¸š“q3«ÖÄ{n«dŒÒ{¡“«d EÙ¤FÛm¶ŸÎ ôpØ~zx~#É[Aý0D£›†ë£Ñõ†•rÛ¤ë8ªŸËK[£ %OÓ¨°”LÛï•¥n™¼žä³Þã‹“Tþ¦û¸—®.Ëø"‘v³’ëÇ_R:½–²@kÌ×´ÈIçXÐÊ$bz}w§IN].žfEä.ö-N…¢J¦„çX)É5bÚOrüg¶ËX®~[y=sBÍì9UsÄ @Ñ‘Rì½/݆½UwÄ=~îȵ‹£##´èrJÐ@þnjg/DˆŠAÝL‡!ؾ՛ý§ºæu=Ê'º¿pkh&@s9)‚xÑŠyŠPÒöúG’$8­Ðdz6à÷tt :{½oétèûµ(¶/ã ;$½ Ûô6+šKài’ËÆþ)ï/²ck#­±N\£¦`öPÊ%¿à±¶ß_—›Sß}Ž¹”£¨“ýßæÛ‡¸áðð.G´^…´¼§¾×<5‡2ÇB‚ÇÓ̆EêŒoN}òB¡çíu…âm¨ b\:xîS¦×|¹»§S¨J†Ž~EéÈ•l,(~­šíUìÚÈâM;'úv(‡˜)F¡7iXfKÐl–ß Âˆ+ÿS˜†k²ýMxG°]$|¿4×CôZc¬R5¸kž¾ïx 9.@™üJyÖ„×VöÞsJY¨5Úï Ñ"÷ÍÈÕØ¢O½¹äedì2«2{£7~·7zÒ U\¢†žŒçªxe¨+û°j2$Ã÷ls|Ò,ð•ã¾GÁ·%C”š…`ׯ2íl/ã•3AÌöÒˆ{Û®ªSRÉ)®¾Ï¬eûÎ-9ÿ" Ì“éñú¼õHá“~´$ᦧ…Øe bnÁ¼ÖŠêš6ŽÅ²zf½c)2´6WÕÙ’™…óÂÉn¸ó˜ßÓOS­Nu¸µey#SbŽU±Å(ÒåõÇÞ˜M+ …j[1aEo¾nô—Æ[ú£÷†ƒTyàj]Ë‚P4½û°ÁíÁü`A¶mí# ýƇ>iÃ4’üÔl$Jk´™8x…ýYêëá#Ìä¬gpŸÄïÚudr?J¸)›ÖöF Óú¤)ŠòA,u‘üp(¸p÷uUš·Rx(ÿùóg}DtÒžºèP÷)eshÏ®õ‹ëª|*sÐ}¡FoLWÈ”| ïGnù¼ðŽ5Íù³;Æ;Œ#ãw'ÀÞ ¨¦¤œëã²—Öù ¡—t ’DËJƒuHe÷Ò5ÂóÂWF@¶>;짨«á*£îÛGð6aÒX >Ѥ:qÒtÕâ¥ôü•w¼¢€WQñÕÃ5õðÏCŽ9¾ üñ\ ‚z—5¥6|ŽÅs ;±ˆ¯¤¬"¿ò¾PñªéÐX&ü4CpóL5”c+qÛzVLóðÀã×íð/-Áøò£œïØå:Bުܹ«46tÃÐÜp‰æ¯Å„Mþ#l=²my–û|j’–Iq«åf×1‹3›ÎººNãɈröõÜ\A*Mð¿ ¬rmß÷9J€bÐÇ› šTà”tµ’¥DßÆ1µ0f´´­Ò;–к‹ň>'óäYnÈ´¼¼9dÓtO-Z”þ+VHql0ÕYtÂ/³Æ”ïŸp|ÂW.¼ßM…I×wD–˜W‘ÃèRuS·‹±«T85ÑÆa?ò[N÷MÝðØüo±yËK5Ñ]6¾“eÊḵ™ H q­8oî‘Få\L•ò)àÓn® Ed©î®ÆªR³D Ò´knØ5@z‹µXàq‰¦:ý®=èWu=ƒ,Jº€(¸ãZ[>—ïzÊ9mŽôDU|1¦)x9D¸@jÔ»[»yHÈ·ÞR»ÆM îµLϺ“Ç—²Ö´tíu?†/ZsÍ®¥g„‚½6I¶€#ˆcDpÈ‘WN•È£(øë!Œ¯|Ò°1òh~Øó àôÏ-Û>nìï*›xp Àv©¡“ýª…H™Žöp{nÖ¹K µqä£Ù•¨­¦’féZõ£®(\’°¼¸¿0:½ÏòÛøÜÁEùÆo‘ ²Y3¸Øìb¤œw²·É,bt£yMÖ%º–ÜnM8Šf¹9[ÃÀã^­µ¹‘¸Lñ-…†NÒð›ågÔ¬D$CŒÆ2äœÿùioO"‡Á´Ç›þ>Ъ¡>Ÿ÷z%KÙO¥Šô¡ÑL„•º¨Ý Ú„Ùô’¾…ƒGks+…æ[%ð›ã-‹ø‹E™XŽ¡¹½Uh/ŠÝ瓸~$±Á‡L“<¼£*ÝÛ?Ig.°L-å·Ï¿W¾Xp[CsK ?ˆ’*N¸ñ¨†’‚²k¯çZxõõ¨ÄÌ`by@‘?UÅ}ˆIøð-ìì]i³ÃUè”U^DžéÆþ6¸ fñ|°vR‚MÓ[­=삱ð ûøáSÑûMdyr ó÷äÇ)Uz¢€cá0d#Ï,a¸tN9±{Ú/#«­`è‘ÂÆíüÖžª´.FÎì½Í¦4ÅtÃIÆPöÞ[rK·å²Ì®UÒ• œj9éúˆÝ¨x¨¯z† ]æâ+öÀp¦ªÍÀÜ›¤Sdž>Uî7§)V_¨\&¬¶–8Tt’]xd´«7õ, SÓ·€x¦Ž,ü­&¸_.M¾Âšò6Ǥ7ÃL›*‰ÍI×=Ç1¤õH·N]áƒt“gJ]aü€Q‰äþPÀüÇææOî4ãs·jM™°VlØ E÷!/À›æ Ù;¯ÈÑB8.øð¾ÊéѦqÛ1¯Q#£Fsç..è æ‘Ã)tYØǪù²‰ÄËBzjc3hr9cœt'ÿŠ ·Ì¼L±ÞÌ„šÃ³#Ûh˜}»¦pŽ—v[èŸÄíŸÉ€˜¹;гX¥ @õ^tÙõ)èdO ·ÿãÚÕôæcßf04ráTøŒïwËí¢.Ëm D垦áëTFó¹Q£–‘M¢yO,•T aADžnï6ùÇ—]0žçNqVåžÔ/§ÙäåÚƒsi»&¼¼¥mR_T0°ï—`¬:>®!*Šê§Ž· Ïç9x•3“ ¸ÜðâÌ$ŽÙÝÿá -¤Œ3*rí HÆhK6C˜ôœ†óWn^!\övÃ9}RNÎ… ÷ÔTÕ›I+À¹“¸qL¡hyøq¤é”" –­ª’€¦×,cX)ªnGËÏ€â#HM$+ìUAÉJeЖùcvîÆq"b³¨úÂB„›*¦çì"³©Xé§ Ì­p®y¾æ#¸X:ÆÏ+”-bžŸé°½ èÄÐqÛd(2¶Û3‚nKã.?²¼™ž ¾ÒÐöç›p¦Ïʦ›ˆ`ßÞ·4WšÐ˜ŸÍ9¿W݃geT½Š3Õ‘³Ëš¨ã­2ùÝ&ÎKO/^¢šg/ƒçþN±!ªe]ðÎiƒ‹AÁÄÖÉÕñ†ÓÝa†&Ï8¹¢þobÊ̸Êrêê”{«ñÜ|ötØ”-¯#ŠÏl… [ÌËá5ÖjDÛ™ŒÃLUQbV¸^Õ<¯…Ýé(i'®íþ“gUÏZo}ðu ã·pÆÍéÑr&ŽÉ ¦IÜGÆ-ìcæÔîÐ}Z'ÝÌ<ð;c·¼ÓëÝJÎØ^&‰Â@½}ZÚ(‡X¸²™!FYׯñÐ+ÏšßæÐÂ-èC‚åwNò%7a¹úÐ$©½œimš*FT ÊcAKN5nR"¶¹PZûtËÕz#0ésOÔ?Y0”£Íù}™9hÆ\²ƒÎYE¡à¬Èl(_…O+ÐøØAÄe¿a O¹všýr2‹~L;Ú@ ¸gJ g4º5ö˜z5å·I5;’,¼ËQÖÙ¸½Ì…Õ3¢T!à Ù½ž‰*Ã#ó±|ÆtTi&'¤¥Éù-†çnÉgWJ8RG’£Šù Ü«³> ôœãªš{”/X”qŠ`忪Çâ#^—Hè±ãÑ –¦FÛzü µ1ui\íúAa\eÇ­®ª”÷ò+ÖöÒ6üU2êú‡IªkNZŸ6yŽ*Õ8æ¦dÞö1;ÑvÙâ3O‡?É´Õï­y¿ØÔ¾¼Il@Ñ#yÜÞ‰ò':TìŽ Í¸_^í)ÿ˜É<“…ÅSuéWŒº4¤ Íà ã¤Åˆê XçǪ¥h7aÚRaö6Z°Ð•ê혅{L"w[sô!,M`Óé<¢Xßk[w`1•ÿ˜˜RÛ±б“Œ5Ûk©ŒquñnÈ9©8àÕÝÕ†¶í=ÎÃûÌ»¤€„<Žè·7'Eê çtŒ>¼Í}×!†q ƒþ†_`ÜF§Yʲ/o…ejÕMU6/Iæ¦WòÏïó\—\¸˜|˜LWË 8•t:*<Ú¢5lj~‘Ž"Ìnj t D“ÇÃL‘sxåI–×(¹&CjÎ,Ù°a/Bõ¶°^¸zCí¢ eùâh–a¿.ëÄ«ŽQ“è7;Ê·ôö¤¨-âzÍ’­Ž77ÇxlÂÐêÚüèdÞ. ×F˜Î‡':J⌆+8b‹t~ç—Ú° l²ƒ½†Ç›¿ûý°êéä;OtË©V–ÆÚGŸäÆ”æÙØ1Þ”0$[pÙVÆËã[ {Ù¥[ž<UÎþÏ¿¶NÓy‡ÁèŽäMmá¶_ò"d^ƒ+ÙÁ Ãwbýt6ÖØhE‚µˆâX zBšé8È$>dØ!.ˆË †ÔäŸ ¯7,ŒmyA&<Ùâÿx Æ=ëY“@Oï™2âŠÞ¿ŸW+ë)’dtÕÛ©œVŒ.@Ä Ï|]iV¨ð³óßvÃ…É=DÙµ\tÖ<¬¨ã;àìþ$@ÏårÍë•©D<®Š„Ñåþ¸ìµ©OC+tÃá’ÈwÖû…ç6ÊìLÁÕÖ5C™8-Hó©ÒD‡äϦ¨æ„?hD<‰ÑýSñg5VDÕ–¶-ŠWM·=ÛkwÒúþ±s–LÌ•9·-µŠ Ïï¹_¹8š 4\™f`á!2êíÆ>ìjuÉ™röcJ3°qžD_{»ÁZ‡È”AÍr/¨Lgc£×táe^-*Öá½U;B"Õ—ª2 ‡ÒÌ;g”¿t®風®Óü˜q4yyÚ5ÈЗ^ð†1ƒƒë®ý¹f ®22´èõ"¶Hq¹ÁÚú& ‚hÐù¶Ü“"ëk¸;ä)6Åì„ÙòÄ\-hù¬ÕgcøæOœ`»4Kwï· A¢N‹Øó-h>½¹ŠœRtc.á66¹ã*ÐĦÜmŽg i“ä~•ÞˆÝ¡/?o¿Ö –êl`ì!5F¢³/tí ßBìUúhÿvÆçÌÁŠšá¼ ™‰˜‘ûÍs²fë%ã“i•òs²=Ý䔟M§Š—fQ§§ò’Eè•Õz}¨§;ÐG*µéòÃ$º¬¼ïÂÐÓ÷Ú{4Üpt@Xí^ÛZwWÿ|2\m¶ŸÆ{‘@-e·\êbç1„òÍÝ@.½o¹Ç[{.A¾P- Ç&eW”ƒ¬ˆ¬"ºMAÒñksZI ¬S­¬ý2ÅÈÈÞ郈ëV±Ž!~½ô1 ²;wß–.YÝ<‘ŸBıYŠâ‡Í®YMZ›°.árwÛÀ»°KNÃñ³-õ'ð–Òaî®aÝËÈ=7¿ù ýeà~º-šä¡A%N½:´8ú½ƒ6P6”>D §~ÕžÿyrùJ ufi]%JÚÔ9¿ë£ã~%z1l6º>íAYZ¼Q¸èªûÓhœvtm›MÎsO‘b?|¿#àÕ‹•æ$‹1aÅ·«0-kñõëéh:¿¿Û !C¤ËЇ§†Úa®xùi7ÙOºŠ ·Û–!ífZÑ×è5îLãÎbtÁÙÕÏ#Ö+†È”dY,ì"1[Ìjé¡ùx«³.ö²uâÈћȤ+Ñ÷vX‘—GÏEÊ0ãt°ö*9‡¯Œ‚„æ¢9>3¬Ÿóëé¹Ð’WØ hFV c¥ß…Õ½"£:EŠÂ)¿9òcˆm¸—=ôĬ}'„¯fS/'@¶7Žâ"±Æð™½â—\H$Q¢¾þÑšÍuσºñ ÷+”mÃQÿKÔH°óþ 7Wïlxñ®<ž]*T?ë½Ò!k¯I\·"2\¨à'¯¹J˜Ñ‚?#•Á'S—–(PðîwËs¾Ÿ9+¥BMu]*1“O¼†t‰¿·å‰á[¼¼Î(µç+dwÌIM!Ùh†V²ÿ¸«Í>Å`0‘c«ÄüX_nòª§ù|k½õgTœRŠ¢ϸùIá¡ûÐKŸÅqÿ@‚{W!*•e’SœÀ‘c­C3ªö‰ûNÓ[÷€¥&0éÔ.ͱƒ¡AÂ6~ð.ùž‘è¾ã2Ÿv–î9‡áè=ú=<,DÍŒõ#ÇvŽi+ÔîHÓ•wl4]7¸†3\Yw"|!›&,$R }û¹‚Û)’# °%‚2vîý ¨Â~óIꄹ4À„óñp%ws SÓY‚;,Ù‹fÀ¨gc‰ìĪ??·^¶SCŒH£{ÏÛp†/}ÁP„"Ϋ°”Çb•¯Š#ñ{q ˜.õ,ý°¾EaQÙ¥)O‡´8vÉù–d¿YÓá‘{Kx¯õ°0ÒmîÁ=S`å Š*YÏῆ¶­Nâ—3¡Ö§ê…énãå¥F2‘_Í{7·Óu¦ûýÍ~³Ó]»8®¾Ùq6\~îTFsþzEs÷5øêí L¦S&«vÓÂv}À¼3 _eWÖYÅIøT~™è¶\æÛÑEÂ3»ðSDæä§V.wLJ#òÔùÓƒùò0¡ø>rÒ—ˆepüÂÞ6ÔȾþ”=d¸áÏKÜ1žKnfJ4û M)$Íù}…ê8ük¼ 1ŒOÂRe`+U|…Li Ý?zýn jÐÞ6-½vÒÑ8æ|~¤&!ßÞF˜–ý(oz¨{3ÛÚÕö‰C‚'€@§² s4©Øœ%ä†cè°¨3!#Š¥ß—F‰‹›"|Wüc=ÌƇk{>Ô_©1q=+Õmbfm£€_µñEû̉_HËvBÒU3a“÷N5D6±Õö í¢ÈÎNÁ²PBá^åG?]Å=¿«:ñš#Wž ¢Ï·Î7^ï Sô³[lºràìx:ƒØZáô_ìõcþêË•ŽÐ [ô—½D`„"õñ.NLï/äAðÛÉ*‡Bì¿kMßß¹"eT†¹mo  ¬Pó!;Hnëvi®UVÝ÷êS$\®§qߵȠADc¬ÀÇ6±è˜úIƒ›«{‘s>E¨{ã–Ôú­æœ—ví|ôöŠçŒ> °±jèR* ¬!½$‰ÕØ"-¤'Çî¦p^,àÖIœ®O}ã<Õ÷A§£ ×>ªí¬ ·œwLÏ5ˆÖfN8¿6ÉÔ'qŒÅÐeʈe‚»1ç"ZÁgü Èç#W%¿ó97²òÏ8«mwZÉ}%X7h£Ù}C*‘ÈÅ‘iæòAc˜Xf]à°Ýá)æ5¿@ O–4öëÉm[×F¶/Åê\ÉE[+EðË•†ÐÝïÚö‹°Iâ(Íý#¿˜ ‘h°¾>~ðÚ=^ €Ù| i SµÉUÖæ=®Mù7j 2SŠ¡ŸÞ@$nCC]Žö¬ìÿþàP@£X!ONk¾0õ’ô7gÇvWX¥[C‡Ýó=51-¡ê¢L@j¡¡ã¿bØ«šðÐGىΘã4D—ë{7ôú1ÀëI(v£ÚêªCÛµoëI¥­¸›QÁâpú ýÖ÷huÔ6BôaÏ1ÿF»™„ùgú},´áX$eM˜0>9šßË¬â… ¢}¥­ËR¼^öØåƒÊ`ù™dþ,}¶Ñ%6 x¸5ÎOn¨.ÙÀ[œ|Äêy>Lt2æ € Èú.†F`K5$ mìúî„rQÉ&WfÆ»³3~!·¹RR…nê×­P¬(ž&„\O¤Áœ’ä:6¸aÅø}k¿]cÍvYÃe§SÞÜ|¹–²RÖ±ƒ¶¹Q`ÿ#NŒÏŠDZî=UDÊ"§WÁÉ!0hUî‘\gU·Â ¹îe!JÃi#Ž¤k§iï "ÿëÂÚ:5Œ|'l«¬á!7¨ÿŸ™ ‹ütwGá]ŠVÎiŽ½Þ‚šÌW¤üÔàkZm[°.D•H:©Ÿq°âð1]£ 8YŒ3órªJü{î±æ¯u²¶…Ø0(ÅŸ„ÂPd r¥êž’1¦ ãœ+ûú –k¸cĘˆõ0xÆÌD±Ë:C½b± §ç(ˆ‘Mjâ Õ_ýŒ×ünû±Å{Ñ2vzÉdµ€ŠÌm‚&±ŒˆP{Ø;b*aíTR°b›iÞ]nèZºéÍH5¨h¹úÜš¬ø r` ªÁèû³qãc¼Âwú€«Ô‰^Ù¶?LÔºúÉ>εK\4d9tŒø‰†²CØ35llÑ8} sÔ©ÁeØM×|Q|¨ütnBV;%1tªòÜ[€Æç6ùxV·vâ‹+jÑAïq(‡é“—6=ô/ì 4«º$´„­Ëç]‚<2’Ö–j¨H`”ÞЄ±ÏžËŒC,šEÛêçÏðÚêѨî)„OD~E'[©Ÿc–ë;¡3Y14áz—ñCq´Qˆ£mÕÙÕE`·‚¨q§ø\œËsõáE¿>JÊ›:ÝÃL5E9¿aÔúŠc2—ÁÄ]ä<çYY÷lú_&”ÉR&¤Ì­<›ŸÅ:l¹gpÓ Û9\h2­½`D7å Ë|9ùŒ"°õz˜O«‘5kÞž\a‰%uçÝgqÎ9S±³½àÊ4M´ÁÌ¥'W{ žR¯ %·zbøë"ßý¼ ƒ¾»!î 1 …Ø™RÓïÒ˜g‡nA’A³j¬±’3ñI—B½KW®à¿T\œ)hWíù:Ã&-nVv·‘¿Ï> ùùih”Pŧö¤·:[›2ñ½ÜȲøºý0ž¾þÈSÖY›YC÷ö“9¶zµj¸¶ò>“`ásP7õŒHÒÃïaì24ðóê‘7gÁRƒbÚ:Q±å«•a gôŒ½× sSR/ý±ê3¼¹®tïndæ³Aµ•¢–>óOûûÓ|kÜlnŸq±ÂP´ºÅ!m$US3¤’-ãsºd/éžRav{F ‰.HF¾Ù#kgÞBÅæÝO<¥•î§‚ˆ†Žû}éùçgË'êÛÑÈÒW v¾ºRÜÉ€dff2Úñ(>(ð榷7 ²I><þ‰;EßEH©,_üKbü7¶Þl 99åûaWâ–»t³`}LÁ‚XvwÚ¼®>d»‹(ïÝ&7ËŒ¥©Û ¼¤Íz‡ó׋su"T«šw¡r„Ì\¸»Þ‹Åoì¸)EO xß#5 ºûaòÛ³òúH¬ð÷›ª‘vçÿ². Š‚ÝË„ôD@¡Êêœ9¡ëý "h*@uáétæl+kì½Í±èûÌ—Œkr¥¯NWD°ëå@yQe‡âçãßF뿃R²2_¸ê—‹Žk"àNß—âk©µ¹ô×Þ&c§w3Ü9píŒB¥mïjÐ8XçEN Y4 ‚hAAךbÑï™l°¥ÁRIÒŒ¤+îåØUºÆ©‹»LèÌUáØOi{ŒE ƒÏõÐØW­½ ûûû¯Evä^Ô 0C|´­Ek\ \µ[©‚Nâ¤oé¾/wµ¿ë¹&Xˆ]g^‹wz¹0«$3ÑÌSè`+AÑ“Fh¼1 /ÝJv×›ípH5›5z2éÒyrá.ݘË}N^í¶Xà8äéÊ[~å!ŸËfTÇ«ZQÌ@ º™´É&°¿71¿>ÒYïÐÖ 0Dñï9¨s MB–P—½Þsæ;D=”ºèe–Ù¯Ä'È1"9Ûô‘˜}ºãýD¢¦ xâ É"®³¤þÏì–C¦É:Bd…Ù{ù«âaOÍ™zœc'(±Ïøà¶ÅAÇÙhÑ ¦ˆx/XOtp>aDwëÒ3U¿_·Ÿò¾vM·ÅòÖ%mo¸£oÔ¢ó#?qaÎçÅoå“ŽÈñv´þˆ›õðÄ+×ÙýÀlL9é±³ž¬6-¶.çŽðÞ”Uü(uŒJàáñ:«ežíÕÆDw)uÝG „Å+ /™i6Ôt¾4’ÂœLÃŒ^äd¼à–”+Y°åÐæᣌTömzàêÙ®Bp_“}ÙX±§d̲ýk†-]—*œÿ­)ßü M|N™0a‘0Ýàkc('© Ëu³YÔ¡ k3Ä ”Ï’§C>ùQcá.±ªMí¶ö¤j WY_äŽAöZ Ò³å y 5/儵œŽzÏ0%øP~!3ÊÊæ[XØöf\Ä°­b‘¢d.•£4ã¾ö”‰‰¬z­ª¿ó}75= Žú­þÑj™š§ì4+6¸¨nÜxpÛ Ñ•ë-] Œ['‡!VT¶> ~Žý­ò]Ìd)ÎwwÏ:„áà( :pxé`˜’DñªÊB‚VTšÀoHâOþ̪®©JFÊ•$€XLª>Ul_Æ_󇶤Ÿ#ЫŽ²"×”æwÖ¢ãöö¾ËkCîùpü;¹²ë¹¤®¥;ˆdî©ZÂþ^âćBþ¸bqMÞ]Ô¯Â4§j‹j(§…)Å 0Á VO_U,4'.ÜhkŸ—E˵DÍ.iÐ/ÓLà†šKYÈŽT+oznXàNQŸ‚U#‘âHÙ¯—cÈ° Ý$ÈÁS;n¨;,š¤vçš¾¶ |×±Í"xwæ‚€ßza 'a`…AêÁšcšßVv˜©—¾ºªò~É9~Érœ·NÁ@Ô>Š=ÏL¼ó>£pSwú±qn—r=:ôø¸å°äéÝžrCýDW+T•Ng)ÙGÉKtT»’¯ƒ!øH½œK|æë6ê¡×ó¥57º¾6N‹ŸƒÜ­¿ÏÜúT´Åäí6Ê<ÉÉn–@ßýQÅÎ9}êú™Ë”lÎóÁ¶× ŽG¼ë¬ÃF)jó?ñ õXEíxîž:GîµNòÀû¨t=4E%$â^F>¬<î&Û²A‘×'>ª‹ìÖ»·ôî/ùš½ÐÛTþb†&6Å–*/¯,´$o¤ Flt ·’àÊãJ ã3©†Së*Šª*ó®'8c! “žšDNFqü{®×FnDì…uKëw¹€^9þCÅÈ ] ™LJP¢Ieé´Úº(I¶^íŒþm7P®{BØóó"jg1ÈÒÝÓrþ}Ó«~Å$— ÷éž“ùÞØte«€CYÕÄ }6ÕÉ(ÙµIãµ­`1‰Û­žÎœÚ³fw À"ª‡É³å—ÿ_mÎJ¸vÕ³<“WøÄRSi¢ ’ç«Ÿñ ›Ô ú£èð+—”ŽxM6Îú,rë1!ÞÒ«º¤N14 ÙºlËðežå°í^õg.Yô_lì²ê˜Ñvð´[01ñ’¼i~Ï‚Å~e¸Cj !µü•O„ouh ÕÉþP%`©X¿0k'%,È/!OJæ:Bõnˆó%ÿ^Àl¨Ç»%(KClRÒ²Dè ›÷ä(™Œïõ›÷( JH [IwDç|ö׳ˆ;²Vy­·“fòVaME›dPÞ, œŸÃ7tG™^~jÙ 9ënÃŽ 'Ï•6½¯$6«rÆ7¹\™í«ÈéúZBqu›I”Ú¥57@½&ËR¶kGG«xÈsÃ"´ù꺯J[OŸiˆP-Ÿ€¢»!ôW.%l–ïVEÐ6Ä©úÄÊyl.2@Èg¬\1KÄêÇd¥Às Ç­ÑàxA ¸‹RÎô)C{ûåµi!‘ö_bÃÖª©y>;? Â!òJÊ /sy-ýQ ´ˆ¼‡‘û{Ø·5tÍ~*gøy]ÇhÁøµ i07 > ‚ðþ ÉþNîƒ=Ÿ«¥bºŘ):fZ³¾ÍÓßOÑX¢¢,9@à¦Ú±<î‡ø¿b„¤¼ßX¶ON4UAYºÐ-GµŠ >épñçÇí˜ÉS(?£7@æúŸ7‘Jé½:ó)O$Œ$o.~]Rà5%RÌø*Q®û YnêSïQÊ Q4är—Ž.Tq¾ò55%ŒXý~èäi®s¥›8e(ŠPYM³1”Ûx…Áç%vnûb‘¶îü½f柷X›½eïW’ÄJ̈qü"êW¸³nYI&ý>›”Š5G0sõ £xÀsD³‚*­å€ÚccnbAöC„n`JnöÂKsˆ+a¯ý‘™uÊ"ßo©6'ê$qE=½ÙÏKBàÑxDéÒ­o›Ü“OKli‹ÉÅV©)u/4óŽf•Ý¸æ0Ú㎓:#ÁV/ð&E:§gT3Üø®|¡N¹Ñ뫤gNfõK…ÆÔ1džԔŒÁò ÞÚ‹®ÏÑ÷+ÿ«ü¨¨›õч%£5Í&M=flæÞübÞûRÃ++€÷†qKg9ªÜvg3Ùî¦sa$NœÎߎðôñ§›4ÐYâ •‘`øaïr¢ vv×ýqØ!µ‰ª®]ÒÕŠSì\Âs6~ÖF³Ûy“BYe²Ð`ô¨mÌaä|forvLD"iKØ°ÚH´6ãI^:êWF×Ý‘°·~álW[‰‰ÁPP9àG>`µ—Œµ{Ô-Z,Û˜Séõ`[â —@r½ µÑÊð¯F·›ŠsF¶pL-é6̸%s?ÔE`2©³ãG`›ÿ:ÍLý|!ÑUUrßB‹Ì@îC•Ñ¤°áüÛäN¸‰^ ôÀ ùŠý *ÉQaQÅõÜá¼käÀ9 ™ Š ë˜/÷0?»}ºîhïéÖ€ ܺz:\N+ïî4ïìANIÛ=IýµÀ=ÁIî¤ààöœ¹¢˜@ü‘lƒ…4βWZŠI~ìkþA 7g¦ÂÛZ&:Þ«Ø,àv£@ôx- H$A‚„ºúDTœ¦Ñ³$wúSP>+uM{v+P[V˜ w(ZõçgHQP@Yó&Ð` Þ"äòNì ´¹ûØÕ6(ÔçX}hŠµ=tZØí×}À¦3Ì¥¾Ú_~ƒZE‡*Û›õ-RDæ!P“óC¬Gºq ¤ê<‚#pÇ€HÎ"$¶_KgÐï51ž¼Çêµè_q[ .R S}¡__=–äR4=Û ãZ<ÚU¨=8ê#OÖ§ú¯¦”>áj>„d£BÏÑ9Þ·† R;=hx–!¥öæßGH³›¾vÓÕx©œ‚T F(ïÇ-PPþäëÔséÊÇñãd ï8ºDèØ Ã± k¬®Ø9LzÃΦv+x)èÍ$ÎtßQÞF¥'Üáü€Õõ!®6 ØV‹6t6+_ +]ô,}—‰gdž6ø'±ÿpj²1²)þHaèÇ°ìÚ¤¾T?‘LJ|ˆB7aõ·»É@ÏbS¦Øk^*ÖôÊž§ì%; —hg¡ Œž\Lo*͆މ„wÑ—[Z¥ÃŒ^„OSÑ:[BÔÄGQxžv{ Óï@²¾šv!>° §¼'£°+ï-4ùECùÚZyÜQÍÓ +â™éî)Á½¤e÷D\Ί£püØ“-†Ï¦Ì¡¡àEš£bóZ¯p"¨bÊp"®sè4“Ù4ýéñ•jÈ0ËïÇΦ_äjî7‹²ù’-§ …äP¦nLj8÷èF#¤J䜕F/sW±H‡Q.Oæôkч›RตAþI«ŒÆ¥?Õ'×yº„ÛM½—8—mљ־;å2Ùvx¹‹Æfß´Q—ÁÊ–î¼gø ¶(WPt>ÌSâ QiZ1ƒhi{h`Ó›½¨äAË…@ D‚wL.í–-ÆjM×9e(…=(+ÜÔI²‘Y‚;DÔ!¿åV8w=‰#™l–Îú{F #ŸC4IiL}ú”?ù©õèÕ~ïÀ±Ù<¿âskµÐ¼…tÄÚÏßp NckU†‚8Œ šfó{ ŽäUå|TG ý|gàI×+Ì -ÜG ïmËØ`àfí>ÎÖ3º2½ÝÇ÷‘°šÌ1X[¬+d8Taij¸Öâg$>ýêO¢>•–¦M/‰ˆAংmöšˆUqýƒH†tkß pO. £ðá!'I˜ë‰Å´òÀ]”Èa¤kŠ*&Èrë‹-‘U9K`™Ô°j†[í/H¶¿z(a¹1­ Ï$5—/¬Ù&!ß»ÜÒ{ùDf°öà»);røBälpâêš‹¿î¡ ´ÓðFˆ¦j­ñf”èRÿš9-Û¡‡²O`‰èâëö¯Ää5_ߊÈ]“IÓ&+Ò<¬žH3×ãB¿j—éÎïÖz½àÑ©Š‚÷ï纓"Œ»»#1gõ”y-|؈KñåÝ•æsÏ™=¨Ú6¹>9|Äõ™·µ`ç¨~SÐoìÉ9V endstream endobj 4680 0 obj << /Length1 1144 /Length2 3664 /Length3 0 /Length 4414 /Filter /FlateDecode >> stream xÚuTw<•íÿ·ÉÊÊ'²×1³³Wö̊ùÏq8Îá +B²’¬$D¢ŒHY…l"»qìY² •Uä{ªïóô{z¾¿×ýÇ}]ï÷çzÆõ¾oáÓV¶Ò:P´'`ˆFá¤ådÀj „Ÿ'k A™IÛp<ˆ*Ah……í8$ð/šHèaFéCpDÞÎ2‡`@ò`X ¬¢¦$G\ƒþ DcÔ@V„:dà "Rúh/¼€ÂÙâýý‘j`ÑxŒ€UÁˆ•ý;+Hí‚AÀ½q 1{GqII©ßˆœªª*È3ä/¤`pH„¸hÿ™ˆF À‹†þˆµ‚A  ÜvAbÞ8œ¿š¬¬? 1,Làdʼn…  zh¿XÚ3ÓG`/bS!²ÎÍ…B]ú C  ?[‚âýeíQˆ<`¢ÿß`"Dûƒ8X¬ – ØË[öGJ»à')÷†  á—üÑþ ‰Â0€ø¢½„… „_ú¿Ä?w´rr ( òàÄkø­N„د½9‡Aƒ\À2`°üãù{åF¼P(… ùnñ@²vºÎÖz’öþw”®.š()-wV$-¯¢Dt QQUIáOE+â¿6AÁÐ Õ_…'öWñKt!Hì§aÅAÿT²@ã^Hì·I\ÁJ`¢?ˆ/¹ÿižðÿÓBæ0Ä#‘?ûûÕ8ˆØ9dúÑ;‚ùW8Ä ùþ t~ùüÿÑ1ÁA/ù÷˜XCD0µB༼ãn‚þüâ+4ñã›IË)ÉýÁÙy#¼|QKtßO @AÿHi€òBC(8ÈGôýøA{á1âx~^ñì_{‚X ^´ã#h/õ«>UW÷ŸèðI/ *t(Ûïãi“¤ó2d휾¥<Š÷vT2rõ­ú¼µ*\ÈÍÉIcSx ’Îùªê6ÉP³°Æ°'p¯ËTkX¨Ñoш½Úwp§^ç̼»¢Òe¼yºl×IXKo€Å6}*‚oßyi9À’Š‡¿¬ðÑ ËåqUö¯W>Z#/[«QzšõÁ>Wâ2éL[ž¾>5u¦{º¾Çú¨‰Åcx¤S—A)‚kD‹«Úòäq*=«Ö<Ð"ÿÕ»é¼v3i«Ôƒkù¢KŸeûé¾ÏõHè©8ÓSù¦é99‡¢”ÌüÔǽhx²‡ :›^‹õЫŒIë <Ö< ^› -ÍËâÄ›QͽŸÜ¯ë—ïmCÃ>ÃÝ®_ífk¬ë<Èvñã˜~ãÖ·¨×Þ|þÝ|?I¥+?‰5oúqú•@MôÓÕ0[÷¶Â,e£äEUû›5¬ˆˆæŠ”Ü4Õ<¾¥!ÛÍ‹Ÿ.ŠPJY•ív^åž?|¤¬Š6»ß8#vïØØhÔ5RSn†H˜hÕ•0Oä©Gzöçáå–l6›TD£ªvcÚiQ».¼gð%"7\15\zlJ®Š@%‡xght5ùÁ16'³‘ü¢ŽÐ„¤ûä“ùÆF+Ãï÷¿%ØÎÄ×FØOÃA‘ù×ãÉé D-Hî?NçT\ú^¡Õ¡Œ,s¼)œßIÉ£¹!‘Ø}®2ûÔù@–' ¦_BKï‡ÊÈs"»œf}î5'ßPMÝŠÉbK­çðˆ„k2^]cy)[ÁÈxƒ:ÄùbÓã8nŸü„š’WGa­Oèi‹H—t^Ñ$¼OÐú²$? ƒoÕuRÓ…Ÿ}Ö›ÈúgšK‰2yqµ™KW—¿[L=Qj ¡ˆzëcŒQcøPúøù†$|(™íÑ\iÈ>JUd8¯­‘É‹ð×ñüüy·„þõñò=‰Š3Éuþ›¯ßϳ$·::¨%¨ŸiÒlOå5o5ö¿r)nvŠ¾êTIw±¦ŸMÈýÆÄлеGã–Ú¾¼~ÛÖ¥iÑ×—H eÕÅXn¸Q)ˆt9š¿[ÿ"ÃüÕÛ\4Ê}@•¤bv0·$ý­u@ß²•Ú+z½k#NŸHWh÷i9KŽ¾Ü  éɬoØôœ°¤úÌ¿J’Ëû„wi ð?:zSP,4Ò%V©Ð¸/8¿Gá¤6ÞñH Û’R+ø‘ݽØ/¬·*6—dä^l±JöSoì30{Ц÷PntJãÑikØâ÷+i„ì4iÑ®2Ìj@XUÞ«­'“…y¯Ý,{Cõ¼‚Z^n£èAè‡)¡§ùÚùÆ!ÉïÃEXGyŠPrLš®íçë(á'ßåòðÕœø/üÖ-¤‰$à4Jóœ¥+BÐQÊ÷d^DÆ×¼4¿p÷Ào/Ö˵ì•îQ{߀ª:q‰%òµ·jDÖšùåÆô$cš²Œþ}ó@-Ãt(nÝZ}“^éˆ#2Rœ¬ vr¯œ_„#+¤ä…U„½Kb¹ÎŠŠ¶Hx8w·]ªtðV+eSkQ¨U³í|ˆ"ÀndøÉÅtø…\…tÛÞ–+&v))àòãjÏ}ã ·¸xVðïä+Ûéß^Y»±.~EAQŒFàÄ‘¦ÆSœæ¢zhtÆ®pƒò8«å·„›Žy´4†~#‰EÌ™$ú[#Çù¯8Ýô†ùú² ]dƒî°N™Ütõ°QoU•¤¤ËÐn*þÀ¥SxøD–†ŠQª'¡A‹µþBë¬óãÔ†lß2Ñl}ñªô'k%WsSK …“tÜMýI'+0¤Û¿Ú;ßË]ïTÁ"E±STd·ÓÝ©P§E–r· Ü V¼e·+\ÇÆÂ)Æ)…`ß :VS¿/l.ó|k{f–îºêw©\¼™VÀ™Sº*]‡GžB!äR ‡Å–d–ѯÆ!»áKd¦óÔÖŸM°.È/ß{»,R>RAVÄLn—ÝÞž¶ „«sÜþ8¿Ìû€GàbÄå,áyÅ3ÃûB£¿ú—Y±BÝzÏ _­ºp¸Élèg¥åU‰Ÿ_â@\®W¶?ýž¸d ›5Ë[oãL­ÂõêLð;2Qï •áRì ÷ÒØ£†/:Ä›ÉÙÚ·ÓNè#¼-vÍ_’^Ú/§î¹½;¬Œwï{ ‘•¢O›ž¶uæÀ·ë²ú‚{tE Ë}ÐÁ£Jz™oYX{ŠÙ8÷"o™òÈ9©WDÍ-™†'ŽçDr¶v=‹uxx—`oû©R*.è½ð= ]ãp|÷Õü€u÷ì¡`çjì¬L͘þI>¯BÏi‹3 í8›!Þ¢Æ •àlþäÞb:ZtQÿxýŦ;Ïü»$;Ž¬8碚sÍõ–FÀXŠqžj®bæL¾4‹öWSqŸ•É çZfzYç c3QÁ«ô2íಎ6=ñ‚íêMëŒæ¼¾6P·c§YæpÆÞUŽÊèeDƒÎxJr¸(u#™þéì¤å< NÉ¡$JÑÓ«žÅz€ƒZùýˆö0Ó.-cø­þñw„‡ÌñãtÖFïÁ$ºó¨Ú³Z+it]§öÓæV™yBLJfv,M8ï¦Î6ë+š1¬‹>´¶ ×x{•rGaMr¸GÚMGÔÄ~òŽ-׳`…‚²^ñú¾ Em¾†mìJÔÆ‚¯ÔõwîWu(K‹AnuÆž‘ZŸÚuñ2ºBæQ.jåÍÕµÃg)³­ÊgÜK¦Bºs^g¯æ.ð´,ÕH Éix (½g°sÍ@@F.ô\dó1-ø]UA +›ú ¬q4Pì’fa¦éWZéÔžÑuþ(õÃõë$´ %é§Ê™Ëq·üã땼9²Ç†Y{bò¯l¹b]—l Ô¸´3ÆDÁc–Bϼå1ˆD73}w¦Cwéèž6ás™¾­jÀ#òݒË©v´“ö_¾祄’mEKY>gAlÐî&”¿5 ù nj%aw²µÀRyšƒ™e.VSÿ ›×Ìb› ðn/$ÖuÓšÏzÍè$¹hhÅâž2!6z§zWœ^äm"\ŒëÙSAt:£&b²‡µW ;è6 Öâ«,½/m¾Ø~§BœÝâ ñ9ÛÜ-ã¼¼·pîfMg_Æ­;ãŽíc œ™ŒçwÔ^¼1] ül>Ux\S¦2W5rÚ¬’>z9V%y}ª³¼•×Î9µr2"Çĉlš^@zé€îDÓóªÜµëé—½º¾·™dÌí´¡N-¹©8h£3HŽ¾½¸ØÄu±r®\QV¦,…™L·¸a)©˜ªgêúò“xü…p,êÉ·+·õ°6aØ £uC„œoãœÂI%£öóçðRdÞaC£²¡K·olÐwo,µNùÙlæ@ûœ}hœå^>0½‰{ú ãóqá)»ãAUkCù¦voõ©[-˜µtß"W&Ë—0øá¸ýá¨#&s®3wbìF+b·Î®N¥Ü:Ã]¤Öá/·Üùì0ºZK<³|6g ¡í{ÜöÝŠT8øxÔ¯Ép1àhpè›±ÛdNVÖóf‰Ñ«ªÕl Ÿ[?‘YŠñ$‹çtO}É=ìL¡0 :OŠÔ‰æ»ÛÌ‚/7ؽ/n¸»ì‹}e ImðÑÓ#Œ¦ TK¶¼¤Lyùq¡ÝÐAh]Ù-^„Ãdî:I_ö©¯VÈTF­- $\”åøýÓjï}¡\Ãz7M–ÃÀC“¢‚ÿ–=ìæ!¥.úÖ]„€†gßgª,×®J°£ØØ‚´ãÚ*M’¹K˜gØÚ{o­d4¬–ÆÒú>hgs¬*+òiù“{~I endstream endobj 4682 0 obj << /Length1 1626 /Length2 16564 /Length3 0 /Length 17411 /Filter /FlateDecode >> stream xÚ¬¸StåßÖ-³b{Ŷ“ŠmÛX±TlÛ¶m›Vì¤bßúï}ÎùNÛ÷Ü—s¿‡ÕÚoôÑÇèc·EN¬¨B/djo ··s¡gf`âÈ[Ú»:+ÛÛÊÛsËÒËM-íìpää"N@#K{;Q# @h šXXÌÜÜÜpä{O'Ks •š²5--ÝYþ {þOÏßLgKs;Åß7 ½ƒ-ÐÎå/Äÿu¢ p±Ì,m€E-)y •„¼@ht2²(ºÛXšd-M€vÎ@j€™½Àæ߀‰½©å?­93üÅrœ€&–Ó€&@‡\t “­¥³óßo€¥3ÀÜÉÈÎåï \ì–v&6®¦ÿøk7³ÿ!'û¿¶}Áí]œMœ,\«*ŠŠÿ›§‹…‘Ë?µ-ÿºöf#MíM\ÿié_¾¿0½.F–vΠ‡Ë?µŒSKg#Ï¿µÿ‚98Yþ‹†«³¥ù1 8ÍœLm€ÎÎaþbÿ3ÿêð¿uoäà`ãù¯lûEý/–.Î@38f–¿5M\þÖ6·´ƒcügW¤ìÌìÌLÿ¶›º:üOŸÐé_¢úgg¨ÿ’02µ·³ñ˜Íàåí]þ–Pýß©Ìðß'òƒÄÿ-ÿ·ÈûÿOÜÿÔè»ÄÿïóB‹»ÚØÈÙþ]€¿1€¿Œ‘àï;üóиÚþ¿RŒl-m<ÿ¿’þ3Zøo¶Âö6¦ÿé“r1ú;!;ó¿²010ýÛhé,né4U´t1±˜Ùü׿ìjv¦@'K;à_]ÿ5R=3ÓøT-,M¬íþ€ýß. éÒÿ+Õ¿È3jK‰¨ˆÑþ×*þ]UO‡¿ÜþG+rö¦ÿëðŒ°°½à=3€ž•ùïÝûKˆ›ƒÉçÿPò_@Ìÿu–3rq²ôèü훉ù_ÝÿßôþFÌÎÄÞôŸµQq1²3ý»iÿËðÛÄÕÉé¯Àÿºü»þŸçí<è4[_±7á ¶ú™™îR‡•;2%ª3ÐÇ >âPÚ¨ZTà_cßë÷3|—»Òð½6„¡i†ç³ÝsùÌáã@šæp¬Ó†²7x•ïCJÝ_€²EÑÉI{Ȩ_Š~®ýãzIvB›ƒIýpoJIY¿äŠ`¦“Õ æú‰ÚŸÔ­ÀìÑÑ×$­!£ ¹ µ®ðìœ"éäé‘rh|td¸÷²ÿ6'–œ×Ë7åŒ8ÙÅÓÐé¾ÑäòÕÓDmÜÕA[z]„!Á´¹#Cάz‹Æ/“q¶Z“ao¹¶æñÎV.E=P/ZØö±DTɵöd¡^¢uhh™¤1>ƒ¸òU-¾ï)¦Ù"lüènŽ“‰±Ršµª®*¼-â„ž¢Lƃ-~Ü‹…=e¶( ÞØ—]þß8ã0 Ø}ß Ê#Ê} ¡•áµv0†d µQ¬Yñæ–(F¬©sÕ{šÒ/ìgl÷†ÕÍö˜ñèOð¼¯Õ †ÉPü¥âyYÚK¢Oq$`%K ÁÓ›A…=‚’Ã$ ·ù/v€ j’¾£L+Ôws?Öàfèž%EáhÚϼ˴Ÿ§„K ý 4.orl –+¨)yÇ¿T=\ù2»ñ‡"]ðJ綛œ`²"/Ž¬ºxÛ¼9üÉ,ü]Ѻ`z³"T/ð5çgÄ0h”XJ²ê_ÂêoÅÿ´™ûš×“ôlª â·Z|7Ååa¨T—20Ô]pTKy€z}ìúÅÀUíŸí|Öiö vÀ®wŠ}ÉîämçDïS;ö>¡Ù;+¾vÇŒSÞr·’Q´hX !óô6Ê‚&ÄàÓ¬wŒÑ!­jÂ6£ä¾ñA©ùv늅^÷i¢ƒÂþͤÚo1˜xÃʸÙÖ[#ok£Ã)!gm0Ä(žÚ õ²ŒÕ=Ñ O€¦Îéi—L°­WXeƒñÔ9Ç¡Ô¯‡øA„ÛÓ€õDÆ6 ÔÞn++PK²"D‡õCçµ|%éãk»Ws§ÈÔ'Þðn滞zøWš…‹ôLé¡=|9ôšÿdOÔ)êCX™ñ:¾âA}sg­‡Ä H{´©¹y -]¿Ec{<È1$à 1ÇÙÿ7ËÀÖw9‡K“Iìuÿù›È/l?kgåÆg­Ä×ϵU’Èw_„¬¨raÓŽúè:¹ ˜NÅ!BüRôkИ.œ LŒÇÐIÏß|:žVélÜÙYzJŽy|ÔMèþ‹š–·}xùI·…°.T6ç’ß•P¾HB+úgÛídìùº5?=Œ„i秣õ€ÚѤÒL˜&Öœ%]oŸÝz¬¬&@ˆŸw¿q¢Æž[,yµâöÅ-pCã›õ…1†^èчËÝ{«SóåνÔ~G#ÕØ:Bîž³Õ* /Àè´LÚˆºjƬa+Õhöøæ‡w9_y׸%‚ð/[¦PúÁš×}«âæ„šÌ_zŸ6åô+ü-}tµÐSwW÷Íß«¾òoÄO4*®8Ìô®åWL aÈa‹ ?o5’ëmy  ’‡ *KÔ6¾s„äô±¨1â=#Zø?zýÆ›ÿˆ  õÒ$Â>†öÉ n×Ê tekk5tw ÅV|»±ÇSp=$¥7- €á¼urµ‡ª& 6>_=ñr Á4D\|ÿ Ž›^•Õɉ“Ù¦ˆûÄ.FH“µN…WÔM£Á«Ã¬=gOè`ƒµRÅ}”¢ Ìè`­ˆ]vÁsò¾xox)Áx™Yíy2@MdùÔ6OÐaW—d–Þ–÷Rü®É»SnWlòÚ"âÈíŠæXÕx*~nº>H²EAjäÆPQ4j˜J—º¶êû¡îSŠ@>M M­ø˜TDÌNïžïBH•2I÷ø(qõQ­„à„£þ@¬‰KºL©Îö›ª@˜šH }s2富³<›ßd ÆÉ—>µ@FDW{ã«ŸÖwh†_»Ri!¤RbC› =V™P³ÔrÍïxä àäå÷¹õÇÒ*‘îÃæî Ê'H’ÚïIýjév¨F×ܧ'„îÎ ÷LWo5¤eÔèDì›Rc™ÏÍô$áž´xÌÏKüà›˜Ã&cj(Üpé(ȹp(øáb)S·é¢(v‡l'ƹɃ7fë[ÉõŽ©bîôÕNžÈlßÀ)ve·Œcó«&3ÙfÇŒr¨p-[ót%ûÒi‘’|Ëš)½÷Ü7%¸·Áeh„'Q-XÝŽCU¯¯n` Bšœ»i–Èî§æ± 8 uôlèú€"?]MUÏÙ 6Rîu  wB{keÙ`7‚µ¼ix’hÛ1¡´ùõà„ƒ1 •dŒMÞ\Ïe'ÃÈ1RHÚ­­óô(ïj²Ÿ©{²†Ó‰û…¤ýw@ËMte‹Yjjô:÷¸-Û%à >wôŽ7jgXŽ‡³§á)~‡dr['š¢à~ q«™"³~¿AyŒƒþ‹]¥¶TÍŠU¬ÒéÃÝ ì`÷éËŸ9ÈE8yöòÝôZØ<ãèœôï^¶®]·_@ìhòjÉ8ÍÖ~ ½×ųàÕUôÝŽur®ó×¢«í`´,:Ûàa¦ƒÖ,AÍTКPQc¢ÜÁ‰9óX醫ƒÄ™À»I)V:Ô°]ø˜êy4’MÀÊŠÔ‚™¼œ_7KaHÞð›Çâ;7JRGÈU’ÜŸ‚o)27ùÎìçidþ€£ ®t/lŽ9¾*¦±iÀÐÆ3-\„‘ï ê‰JTŸ–Ó RÔõj·úOh†Wçí˜Ü1åY3UƒÌI Ê‚›Hj#ölŠ6û½Ñ²³kw4ÀÚ<™‹£\«ÚNUˆ«{‡o÷*X´“3\OpʘŽ0È<µZøã¯î a€z3h*åYw“N¢`(3á`^` “Hê§ñÖ Z†~ÔÑ+yÞ Dr…ª.ÍDnBűþQõu/¥´gR´:b»Š&ïÊN,ÝIBÛDÝÍ ññ´›ÎØ:º¥Bõ§@ÎÍßTMÁ‡ê”G»Èð‹vQÆW žÚC)Ý^¦ B'CKv¸]Í'aCçµråçÄžïãAÏr›¨AùíÅêQô º™z_©ºN‘qß™ŒÂ‘ÎØRÊC‹Š¥––¼,Á.gFº#ý&•7ŸTƒª6A}r^¤ƒ‚ij÷ËèbÀÖÄ Ø°–ïnšÔkŽ -Ôt/õJ4uË )@òýa!nTD¦jÆ%¸ýÙ<­«ººeT=ÎeÉ·œV-3'×BpK|r¥ÃFªH!†Ý~'WçÁgÅÊ’:YÀ`ú ¯v4Óv·9YÙjâ[F¸iœ#˜\ÒÕ´påõbù#Cï|õ«1ÊÆf{r´”'óazl¶ V²*ðW÷ÞêâMÊZ±Ø²¿Ù—ZÑxÙÂ`PHÀ܈zc×a£TÖÑzUÌ,%/mM®¹ZSs VË”>m¬Ä-Øèé©]“ ÆåÞ3Qócü†ÃºñêØ ™ˆbèž Ç{ʲÞ>"âdéÆ5ù½j—F[ú(Ê«¬Ÿ2£óöh;ï’÷ÓúÕ¶¯õ‘†Š ¨£íUtÏ‹¡¸½$òÒKËXd‚ý^ +©ë÷›B¶Tö ),9p Yãt,ë›u‘M.ZÅ4Í/ÕÞCôgº¨—IUT1 #Ñ,päÑßñ¨¨ |Ú6ñ¹uÅ3Cî€Sð ÛÈwqÚ…Š]Î5A*žêöXñ÷Ïô2÷¹ÑS™7¸z¼áy±&íÇ°Æ“PÍ+ß b[·î¬T¢“º»¢î£ž;+Ò®WoÞ‘UÃÇS@ÒÄ.Ûﵡ½žÈ¡áøë㬚äx§õ\­ë»é=‰ú%pýy{3ýJÀ¹1“ÏKô5Æ …ºh˜Ôfsã§Ùßù•)°Ên“1IyÕ»| ýS¯õ©R„+w%•,q‡súðb†i}­ºi¿Êƒ¾k]YÒçøÞ‚T°uÐ’}­çž<5ñü¬aÓ-çp5è Á¶nb™4Fn0œ•)¸Gß¼³ËeáSˆWÑ•’³ÿ*@ +¾²Äö¿Ú²N§J×ÙUÚ5µ0™¸6Rq…Ôµb9-û¸õ5ÿ¦C ¡¼Ø—%Y4E7Šªí¯Ý“ÂD5Ujƒ]ËsKï(\~>½ƒ‰Ü°U;«58£-tç?êPmã&ÜARšk›ó¼ºÍA7ÄÁÔ‚_/L•ü”É%ö¤• >˜¼uk™p{©q9¸úÍ-_¯á.ÄMFp1‘@&>m»2»ˆ‘º†)åqgÊ…¶4LedÊ \ç…ĈËî|™ž3%-½2˜Â*Çy¾qt-²à<‹÷uWòO§LÂìPgÜí¶%i¿Ä ¼6Òz–í“ÖPý‚]Ml×;'}Ô6Ö-M…©Ú‡m áiZ9¾6¢ÏÃl;'Àe ;r²c]èØ[Ô½“=ñŠˆšO!®ø‡¨å^Çnã@vEM‚i[ä5T£-”Æa ív©9nEn´ÝÃW=Ó›dBMM[–©×;Ì5'µËa{{¿z(öDPzìV©9ƒnܪÒ;9 Q¥Ž¶½ryèS"/êů¼HãK"&…@nlÞ4e «Ô(6Þ!_{_xð%äËKsuöŠ_¸Ó*;X39ò™a©Ô‰¬H—l.%†#I–ÔñÙ×$Ÿ]8‡åIì;ѱW–³åª™møáTnõΟ©–wÚµuÒé¥ålt0º £÷aœ@H8üPRï^³Â^N¶ðÄ)ò¯ÂK9¶âƒ‚ûa*6Ù§íëù›D‘[b:®Ð¸ž&ôm8=i^WÂî:Eja±‘ýɦ¢øq2k¿.`Äa³Ý)–¹Ýç1ÚnOTCWÈ—²,X•A0*–(t]d;€¼Õ~w9¿û+/êAh*úªJ „ÏûPím2](òà,?s)>Œ¿Çµ,Y+á &MººKÔ¹¸‰íQjCGdRêë”Xí,XE"¯]°ööcè%Ž¬ë¶‘ë;n~ Áæ3þèßG§àâIz¾.Ì"È•Å\êXÆp™I:3~²¶*dž\8Ø”ü Îípïp–„•¸À•¦Å¢$Íê³èæz{öC¹Ã)­ ·æç¤é0‘Ðg†A¶"‚2Ìâ2ÕÏmÙ,Rþ( ˜Iò¸÷¼x%gWµ½ÎtþÉyuÓ’S®ÿ¾|D¶6‰×¬w«±D€Hžö÷ùsGE²…t¿ü˜;|Þ-ü‚tz±ömn³EC(h¦CJç3û&*ïjýømÁÌ™‰SPð€èôÊÇ6‚\Y {ÓÞŠù ˜ñÔpǼÐÝå§vsžßR˜/,A¤ÐÉ“£#(Ï€Ÿ¦‚§‚>ÖN[§wÎAD/WÉ3êÈ„îñ„´Ë\YS`ÚØÉ™“)qå,•}w»BŠ…~‹ˆe* n¬&:MúÓrsŒÏí Ü@-}kM ¹Fø½â9º>úËåýk´säwà €¢Ó‰±Ù'G T0¬Oè~2¹(óë1q…øŽ`’ 5Oã[}Ù•Ô©u oZ¦@ŠÎŽ?¬àCË µèM„.…3+ÿjö·@gÅÖù¦í{ˆ,}Ѿ ¤KËl-€úº“„çŸýΈþþâ9#¯ß $åBW:«÷’pÆB3íiÔ|FyŒ¦"É?˜õA®Lizi¼>ɯ \uÂF6Ý`Zl›g­Y½Êe”zQY ¹¸¡âÛuòÞ¯6Ôk/¤¼$ž  G›àqŠ$AMQ:b(åöðœ,éãºôŠD‘\4|63>%ä·|YŠâ®D «,}S¦­KØÊ)¾ÆsÑD•ïi»þÞöNXNq )o‰+âUø¥Ý‹&>F6à`20‡T2`vW —Æ,Í«)Ñ=EüwznKôÝ­4Wª2†ŠÍä8ûÍËÛźÕ0ÎÏ[‹fÝž‰hc©çtºR÷Œ¬;^…ÁrZîŠZ±¶¼Ã´×n6÷ØÃs]{ÉS”ùD•ÂÜtî'ü¸"U;Î˟ئ>‹j¢Š¹kº'3¹þ êËÃS R$L*Rº'×oV‡ÆW½½n’{éÞH³6A :”QEƒó‰ ƒWÉ0]…“˜zÜy¶j™}6¢ˆiupÕse<¸, Þá (×~ṳ̀LÕ=HkOÎr’ü&¸jôkß0Œ`Šdf Û[Æ}Ä›öÏ‘àKÂdÛiˆ:aדÜ\E3&8ŒµdàxG‘É oË»õc(H¢/ag> –ÞÒ‚SK6"8¼¼ôMêoô°EQKXñ@5˜O‘ŒbêÕ#87ãù±Cèhå‘¿Ñp'˜ß({&ïxñÊ`—l1‚[ÜmŒ —ŒçŠßè´o…Ó®Ì8¸Q9Å&b=M‚ÔÜr†„×:ÐvkÅ«û™À”<¦rºµnÌT?-XÝ…É”ûŸÍoÌEˆ¿o>볤П"ÚÁüT¥ôðw­\si óŠèÛ$’¶Öß ö‘@:ŠÌõÆ1ç-©Æ¹Óæ-¥º»V³¨†pð6ñWÓJžJª‰ç…ØtàäëúՆɨ í˜ï +mIçÊÚ«êÔ06“VO¤Vx•ÇŒL**¯T`TªƒI³ç‚ñF%SÁ/L"‚ÖéûRù[0Ù(Sn«åºŒÒ£kÈÍ,Ç4XµúÁ ô}"+j?©V›ß] ‡®ÛÔˆn93¤à¡æ“ u|c%Ì߃ígh=£¡¦O´¦]¬ƒY÷™4^â€Ü$ov[ˆucÛïþ|ÅÉ…ÎZ›YÅ´£ëÂ…øQžópCWÝK‹9”`ÿ ØH]}€Á­ÀÌEùKÝ18¿ú“Üñ1­Þ ›z첋¦ô±%tQ: qŒvê@RŸA’q>†%Äô¦Œ/ó-ÚY§H ÷Úx”‰ð#(L`Lw(lÄ¿á<3jF4¡=Ðcâ=Ö>DwËÕæ=Ç>)Ú«+Èä;DiÊûíˆÊþ•-ŽWUE}~ “©;`ú"6|ºçéd²¯Lý…ö…gVHäz;äG‘ÞPfï­}iãƒÝM3¯™‹K‚(ˆèÇÕžRɳ÷þÙŠ¢¾É½1Q×QÅf&iáË€½_Í(sV`³Ž$g¥Þ;©5G¥¸»çUbÐÒ/On´!FÄ}\€y „¡D| ×ï¿K0¡ig< èíVéÿÅbßÿ Y‰Xæ‰ 6ùI # P¾ƒ< ~1Ëû•åbOë—{Vz /ûM·¤i×Ô•ÏImn=wñJ¤Õï”÷¼fŤâµmhH[µ p)¯áÑd”2™ÞÓÁ™ma_ô4L)j$å_œpw§g@pÏгuÜ€–;1íWvpG>—Ó‰l!½.¯ž`ºð6 Oí€ÔٌŇiu7Pº¢Õ µ'Ÿº–öÉ…I8úæÄúY7–í¨þó]•áu£½-+~Æ/Iþ'»zLÎüº¹—BLˆ2[@KNm6Â]å°"sÁXLÒ4AÛ»Zšì/“d$¯Çüý=qe6Ê2}Jµ‡¤©ðÛAÔ‹{|¹GµÕ¥©ø£œ°em4õêzÉmÊœ–Dz“W›€¶/>ª9ÍþAŽ&¼î=qVûÝ[åø(9yô¾c›«ï:Q6!ù¢(=HH• Çýüw Èk?Lõ£Å˜µOÉǪP]q ö·øⱶt»ÇÄZtBhž®G-7–Y#2u,ŸÁ%„ƒî†W$}"_.>LËÒ+zP)/ÂM×q”6þX7л÷×ù1r%tóë[ú„bðvÉXŠsYóªÇùXðJ*6M®­róhúú¡Þ·öãÙ3ˆ’#RJÈRý ˆ¹[©pÈ%]º7¬?×Zëë qìZßά0O“(𬻌.²FÛžŒ ánà ·ã2òhB¯I—ÿDá«44Ea³ñøÛú]nŠ„mQ|õEµn2­™—¾<šÁVWß’‘È-)Adj{bP'|ÎaUBÏb²jij¥WûÏ0,*m˜ƒ²ªÝÌ ƒ”$×Ö]¿ÐÍ°œ «ÃäéÚ÷Ŷo$êñ‹Ë;oý60_n!îDÒõZl¼Ø,\g&§ëå­P ±ß­PdŠ–§–|=)ýími±0×~Ö ;Z]°1}°ŒêïSUÉ8ßJÊ Â*ýv㶑±Û5“Cß جÆ™e&qÂJÙççRàŒ—±×{w͵;ÔÍ¡Ÿ8¸âÎ}9(3øøâW°|&H{ÑŸ_(HlöQ£ÝÂíŠ=wEY¡{øPØbÃ2‰$ì™í·. r*F“ï\¨eL?{,RËaÃò5#ñ÷4êËã_Š¸þè-8ªTÒç¯mt1ö“[i¨{çÝÉ‘ÓË\½aWsÓAäâC#£Tû9&H’dŸ¬ñ;%ípu2ߢqjÛ¦û¤#윘fפ¬¤¸«{"q5tÎå ¢yŠõéáR=‰è!MÜS+þ‡P£2Ô¬®:ôE‰ÿ{ñ­q ÓWº=ß‘¤¤ ß#)UÉ"o«kFÆ(}°Àe×j9òH!öĺ|ØY Ù ‡ÍífrĪú¨ØJt6€övu*8Æóó "кœø;Ò˜6%†& Ò7¨øåÏ3¯dFßv;ÍŠ<€·ÊûÕò|É£xCFJ°}ìyÊwxÁî1úׇ´¿Æ²~ž?)E´å«šÏšùÉ÷¼Ú„2³M£äÍ#Qœ’üè¨8òaÈ?gÔ¨ˆ KqEVÜlMó«hó,ì#JFÁúw·—I‰í‹õø Q1˜J6„ O°Û™ÏÏUª‘H4–ù)«8Õ)[¥?ç ¸Peƒª‰P*£õna’ÞíÌÕ»s[( ´ºÊìu,eçߤ¡š^A–¹íŒKmTÎQ% ?]¦Îq.ý‚q£ òU)ã$Y •õEwØ)Zøó$Á*hù›íAµ(2>û­p©ƒ§Â¶•ËuÝu1’¨;H•uMì"í›;ÊÖï(Ä«R…Ëç,-æÚŸNƒÛO¥¬'ÜÆt³IFZ¬¨ñì€y±ö1× -é/G•Òæ%ÑÈè9Òìµû±à¡÷/žýœÜ{uWºBµ¸‡ãœßN;)L…#èÊ,ƒžË*)Äk¢¨ãØr†®R0í'ü¹?RWHÐv>÷_¼¾GN®~r?E íÉv!+ß/ˆv䛌®‹ç:iú lÈìcÓýÙCgt(‰ÌCpjÈõìç»}féØ¿½½¶FåãwЫêôº Öš#m&ÁMnãyª9¦_ûñ¥`7²þér¢½i´{@@‰ã0ÝüpRíEʼn@¸ì;ÏïüR—­Ù':]¾B¼ßU lò…îv‘»ûlX 6z7Ǻ8%IH«ù'&OŠ‰h¯›Ì^]øÐ+ïTb-Ħ:Ô¨¼põRŽ„+=³2³Þê݉~-[$gi܆ßö ¼aëo›…‘1(Þù8]7¬Ø"ì9ívVJý±ðCl–ÄgGëÚ´^¢](Ö—ûâ ݈s¡Z>œ[Ý?7{¤@â,3|­øÑæ!„)^;ž=pbi~@éšãÁÔbáêyun‹È™†i_°ülªÁ/ÿíUz&‰'”é\p®d^4F×FÏ–àþ¶ÖxUºJ²Øáê«´¾á•Ú "ªŒ£,l±À7éŠà. Wãe`½FßûÚ=Aÿ9 ¦Tè™ë5vÒøàІµ:ÈÄ·Ìò¨è”È–[WÛ–N|0ËÀ6œÂé5‹uB²ŸâÆc°·vmaó®5Úo`­?’Œì©uõ˧ܖ@òJZn]ÎTDÜÛhúsÂÌÌ”çã>ÕX”áCëF'÷Áïz·”›¦üâRï†Ynߺõz×Ô£¯y²Ò†ˆÝ[‹¥yjÅWx¬óã#·áÓ\¨5†A»”\Ü'SJµœR•½¥L¼?0Û"ïDxì1a’âõ|ý Ùq܉ßÕ˜ ¸‡ðK±¾¨ÚK•µî #­pÂë¤ ˜?}Ù…yá­ù™rÌÄ„‹¢7x º©@#;?o徯_€³¼BŒôÐ6®èÊ` ˜‡ÈK©I èQ%í듉¨¬Øœ~\çSÉT‡É)´jâ;ža:Âô<>íË¥Ù{»ÉCÛ]Pt~Ÿý5LN@Ï%Én‰+Ô'7‰ÙÛ° ת/E㉪àpa„ÎÓWWd$ŽJŸh¦-2·ë^aB¥Één¨XÝ ‹K("¹Z•¥iVë9 gæ é†TrAÒ'^¥Ë2±-Œ±¹@;šËm.ÃS%ݦ‘çMÉÓ“°ùs!^t"©LÕܦ†W›cä"®VƒV»¢Þ Ÿ[Ž™ˆ½Šøì·Ðõ¹Ã vöC¸"í N¦;nlš›2¨ºhɱ¥gAöLõOå+ãAý‡Aäö—)cá6Þ‘6“4ùAXDIÉ|ΚÂ!C¹y;Œ–ºq°©iƒz¼†¶MÏ5”2.—P¦Çaî`Y¸õH,·`&?3!ÚŠ7³øãh)F"æ.X¦òF¶Ôü ãýÖ\š¬C!ß.¸•ë@à^½yˆ¥K'üšºû‘D ðE«Ì(4Ž¿IÍJªÆ×t·_&/cxaóà… ò‚D"ÅpX¥#ÉoI ´K”Nvk#ñ±O˜!ý»¾~çOã-t+‡˜¶Æ1Œ–¶ñG¹ë4"™ù&‰z 1öØU[qZBMóaJµ’ßÕáÏ¢È&»¶•Òˆeö÷çÊ'õI!’È—ªÚ§¥•Qè3`Ð4”±Ñä—ø|ôöA,‡c)‹åðeíòÏc43_ó5O¡<ö3n¾Oˆ_£V§š„¼†6Ö©cíÝ!Òt½/g±'S±Ä$ê<¹jîñ~@bØô+–!&·óDÕ“Ñ”c_eC†b žADqËÚà”Y=bŸ¹¹>v@ S|6´ K(M½ëmÀªkæQN£ ¹Yk/K –«ky_Æuί1”ùpG²Y7‘I®Í=ÕÌz®UÉaâlÔ¯÷ªžLÚ¤ãêAìœú÷´¯CFúóºú,ÜÅù$¿ó8z„W[C-¢\«À^Ô7ÝKµCH*# YêO^ñE ÔºnKB¥ þ®‚ÌÉ…TÜUA;¶ò*/ ƒÌ^wBeѹaí–NÛm…èçf§³Nóq:wf_àEE´>í¼¿ýâU|°°;Qm:«JZ©ÿ¨s™¤‡z&½ú‘6hç”–VŽKìþ&|ÍoâÈ;ï£ÝE´ê‘p*8ØÅÛa@3 E=†àa€§å—€-–h²ð¢“«™ ›´½†üQ8Ð,ðËåhùXs©¤fÃÁ‘a\Ò•¹ 7Þ˦øò-Ûf:1£¯Rº+·\ÊóÂo»ªç¯\pñ2Pö¡¶[1?3»pÅ“Þ­˜i–Hž… Ï(q–[C)·&¦àŒ3©¬£3H­ê?DO´nÓ~òg‡ÜoæõÅãX*0h¯¬ò-+=Šgª‘²¶˜Ñ“ ²ÅE2oÇR–âBƒ©ß6ÿ–NOÊž»åÈLÖ JûÀÇ5]ísµ=u¦H›”°÷ŽM' ;å DI“ßSÌdÉKÐpÃ)á²ú€¾ìJºç!RŠè~”;­pÔ¤&ªo¢Gb­_ŠÚá‘èYœ8¬?lL–Üyÿ@¬(²z‘r¦ñlÝ<ä}’I]‘)ܼúÕL7†½‘ÿBÀ]Þ–ël5w=ÿé £ó\mÖ×LUµa>/K&Ý5Q~†?ñæׄZ#yHé6º?=aÖóÉ$5;¤ZˆUêÂÕ¢k9GúÆÕõ3÷—×_úUg/!‹˜ûÉæAfD“™)1pÿz²~:>5ß…Ç?Á“zyù˜.ôXH˜Á@$ðÛþÏœ°V~T#WÁæˆU¨ ;>r˜²1sëÆbý'Ù;6ÿ2Lôbb—»íá£Y¨‰Ÿå<ß:!¥<[™e*Î÷êˆßŒŸëàÉžhÔ£à—Ó A¦™è3iÏÇA3A°G© ÁŠ ‚ØCƒ‡;/q5ê‹CŸ¼éìj­¯~H‹‰ž2‘ýpÚñêûó:.J‰ SãÅ;ÎkKÿfs»=”%†.úÅñ­€îkãáXD¨×â~—·ÊœéÌu5C­fJ{/±ö—6pRF´uÿ{NEɼi8¦©A"$nF )j‘3ÿñÆn}ÆSD‘I‰>©f¾öð Ot†oÌ8~y}¥{,›:öwƒO,»Óå l#eèý×D³Ѽ©VLûû”Ë£›áx­È€ÎíDßHBJS̓V¥3`7s³UŒÂdphUv°ÓßU <‚gs9À eš‡ª7Ú8͵g,:무6žž_‘©0ŒØˆËýDG|ý´¤î'a"â+IîÞºf¼ªüæ|ø4‹Æì÷Á#ÇÉOFìÄt§7¹]aû¶Fàg7¨%’¯Å*S× Äåöùš¯´Ö±uûÔ±vie nŠŠáº“æȽ‘á ]þšcĤBWŒ«¤J²Ç(Óo?«”ò­'z×Ó{Ý]A²å ='t‘­Fé_ƒÉW°ØSÞÈÐÓÌüVMK¦0P8V°~a²Ä JuõEe58ÂÂvýJ¯°†ˆ4­ÊÀµcÅøÈ‚íÔºhdψÝó EÕŸ‚+’í²FümËó§¤e ÄмÖŽ²¦Ð6¹Ÿô¾à,µoiZQî0ðMâOÛ¢Eþ†˜]>·†ê^äðOøÝ¥­”ðkZfÉm¸M‹ðk£>.é:„ì¢!õˆAc¥õÛb6 ´#ñëRqSeÜÑ«¥Ø¼#M‘+¯0ÌxÈàk;¶*þÙQHÅ\ú˜ZûŸj;ìÀïV¬£y òÙÀ#Bv25‹ðˆI¨ òj5ú„ÞjPPµ„áé¸ûK†˜XçÓ5ŠÑ¾?h¤—Öº±\0^ ›t†ò€qÞ˜e‡ž¼Ùb16ø+ 6‚VÞ/Ÿå†¼²Áºù½Ô{ŸbZZxN™2S:½FËõ!‰2Aåöu<;Úq–÷à›D ºâñÜôD.äBd•¸K pvmµšª.ª<í;qÎåʹ ÂG aXÁ÷úT-™äÖÅF,((X5Šæh]oSXlìJ`xm¯ÁTX IðzXóÀnÈ[lÝ¥ÚÉäÓ» nº_|¦Øܶ¥ýÌd¹1 ÜrøþÔI‡ó_ì‚E¿rGîê:²›ÆDî‘üõµ5f3t»w[òÐ7M ïg‹à{âÆ—îŒÀ}x_C¹iæu‹¨d±2O^§OO¶ÞÓf3äFÊ}Èý…½ª?€‡¥•Äb¯m¹;*õ‹%J.^!õ ¦tAF‹¬FË+“”âHÒãµf}¯AœÅ0mðu/$FOj~׸%­èªS·xldd¾yµ;Ï3äe×$™Å’>ËÎÏ£±"2 ߢ%EÀÉ( iKܨÔ~‡ çf£›ÿŒˆ‰‰?ªÖýh7 hXòñð ÷ó‘¡í´'µtéK$Ö(VÐd”x¨ÄÂØh™žL¸$ú}>%:» ’Wy€WyÛÑ\ùÓù·9—x«E&D4-Ê]úøŽj°uv^ŸoŠGºG,U±b†“ïäÄ ÅزrMdƒÖ¹cÍ´:·Â–M{_Ž2a_ulWΣËÔ³+¹ß*ÎgÇØɯ¯fÜ:ÂUêëw¿wY=QCZÐo[ù¾‹FIæ®ë_s7ÒZ—ƒ¥JüãC/å䪟óÚE{×p£´ y58óðÊê &ÿmÅù˜úýàY×(…2BŸcîIßLFMýf›po'qs᣶›a’Ù(´à•DZI¢ô=âš¼Þ8ei¨ß&j–‡qà ^h,'í·ÄÁÏÒ³Ždë^|2#Oé*{¡îS "7j×mcbí„èîX[èʽ%o:XŒ°Ôx¿£x\,¥MŸ•^…ȯ^Ç«.ø8ž=&£w‡ME^PHÙ»(BÏf,ņ´úÞb߈ß>‚‡YyŸ $z©µ°y~[ÓG}ß7û0ö¡`¼¿*­KËÉÖd˜ÂÀ©Éh¬.’Ž¦ÊMjPa)9à­‰4øcN»ìa(»–`r«p0 }N ÕˆFA×àß'ûMšjO®ûÈ ´Ra™ü¥‰Àl#‘u½)ç›%à÷¨.Lÿžc nóÒëmõžù‚‹8f,‘`CéÊ.“ž¼þψ–g ÂÝ=-Ìë¥å~þÝ&‘ Sx)ž«àÔxwD—¹ä;+ì×#(VÆ…)i» Ó£KmúŒÖu‚«ÐÌ• öô„£g½?Vß«äHž³ Š¦‡§ A{áÔ¥oê²BCP¸Ü¥½óô¤ 8+é¦!5?W J·M%í¼`+¹2ú÷˜´T· gô„MŠ%-²ìüð¿”¹†ÈºèPñ7Ä Rö#¤ôþÐ’‘…³s` µv,º.¹Þ»Ä´º?BkC ë‘¥'·viÅ%7“Ì-Íúty\í¯åBÑ Âàž RòëtWûœ´ƒIî·… V[‚ároMÕž3°ò5€ýBL&×óÅÿ£+ÛFÀÇSNxÓ»â‡à¼¨‘ÀwòÛNò¤všFBŠ„à³±Rçù1^å¾å> rg ý×æ ]» í …=×-BaEí0œOªŽ—®R@ý÷)Ä‘HµK1jЃÆ]è&tãöAžTsjVð„:’_–àঠȑÿâ:¸úºÛTʇ”÷ÙûaãâÒ¾–ôyU£[EÄŠOÖ;¦qwÑKsøvPÞ¤× (ã—†~z$ÝÚ?Ø/.]Ù.r™Æ,pFý;Ïr-ý{s_ýÝö%üt…ˆATý»õáô3pþ¸}æÉÅ+_ÓÂk t8aVµ“7rðÒzÛ2…Œ‡† '‰ï0ü&+`¢”Ѭß `¯ë#ˆÓ"ÐÅmÞ>H’‹dýÒÀÐÍÍ›å$A÷)7X]Ýæ~yá»ìû‡K„Üçwò©«Ø7Ágl+&q=Ià šï  Ð+ì5å«ì]`ûA,TFÈûL­ X²Ke1{§ÜÌÔË`î8-™Í‡qƒ«®TZLé«ws@û2pƒòŒ„¤7Š´¹nP‰ÌÈÎÐYII,ôɪ¾ûì$ŃåcÀñ›˜—vÄW Li_sÊŽkbg ^^{Aš¿gLŒW 4ûÝÏBT](Þb&Iɚ籘¸råZ®*ü9*Im‡ër÷¯û’寫‹Ù¸j@«ì;#çXòêãÜϵŸ ê[]™Héú!kÀ€4Tµô£>Ó §H}”tð™ï^]1xºK“õý'xw’VY”ðT·ˆüJIµv9ß(|˦ʑ¸½$øU¦"9{—XÓèÝvt˜›%zÈ2mÇ7$Ó¾¦õ˜E}HS Þáuë DH TBlBßåöBiúЬ;Ñù‹,Ó8ÅW¼ã« Y P,O…û{ÏÜ ì6 pì~ÖªÏpiŒ…›$µÝŽ«Ã·hÜóÎÕ‰w«†ÂW ë*} ªü¤|8Ó‹àû¦Öniå‹ÍJÖ±w9Ò8æV=¸8ú½é«˜ öM/>¼w1³°Í›Ñ[O%)!fËî{R½YáÁëZÕ·EÔŠ<¿ûsévþ(«Çb Ó®@ƒl4êá[ÿ‡‚#ç%ž/¾W]ÅÜL]ŸiK±£½Zk´ ËXÜwͪ÷F-8ñX†cLZ©Å¹UQæ%¶€ô•E!~ò3=ÜYasòåEê)ÆÐYÝüÁrØjzÊcJ‡õ5AbÀåÃ!‘<ñèÉ÷‹°E´%˧",0çrîo1Dpð¾T„ ÇÉ/`Tõ»Ú°Ù3‚‘âyûë´dçqÌIZê ÑÅz¹½À_eÉô i+G·Ý)½ DXw 1M &Ïul‚,8ÙàÕIG`)‹;[>—ÆZw! võ> ^ö¶³&šrÖVdÕ3ϳóÒ±›Kªi¾#wÝ4EÊ2æÇ°¿ü¬ÎàF§Fûd¥²¬¨£C·¯`îàÇl…—x!JW¢†…¸Õqð¥8d…X$› EËͶÈ¡îF¢¶„`\YbÜj%ã›_ãV ¹lå;Ò3‘}KòÜÖtt"ÖyY¸3‹F +I9‡ ¿*¨äͤsªA]Àr•O)r]U¯êd™*Knø4&2‘æ6P©F…âù¡Öä²ÁH©5!S‚áBó’m¡?ºmRål2LëìnïL;gSì¥\Î÷™[/8е‰Y™»5›s3B“ITžÚ~¦ã:þ;ãF¸÷^'íWyX§s™W¯NÈU6£ ŠÎá'ßí¡Ô5Ô»žgˆãaO6ïED`ø“—å@:BJ^U©xRàJÌ%ôV$hlH®~wSï|úA…ohá¸ùç÷¾ôkÇ(‘—4‹¿S¼–ŽA¤Á™;7+=!NOÏ9öTEY22 ïq𪹟¼îc÷ܳ~´hýOô´ëŸOr‡h8Ú3öKvÂ/*QGO“§m`½=aããÓ‰†5‘›qyKæªÄù¤¶ŸZ_˜|/€4è¬Ü!Ü“?Ø‘Ýò=ŒuŸçø™9l+= }'¼«YæÕ_Dºc"æ1íÅV­9|Õ™£A‡6C%ÈžzbóжÅ)êû0Õbbí8e5}Ä^ݨ֬bÍ™7«ñ‰v€"€¥0‚Á=TI~ñ¯AêÝ2óI(%åîû}CñÝŒ°ô]Ì+Qkû¯^…‡w¼tÂkœà×¾kÐg™ï¡C¡u—]ù÷ÊjLêÁ”)§•³õ…ß'èdE ÙÛ0u¬´4EÕÞKüb欘wýuUYÖóÔsý[©“ÙX†N/™³,ÔÞÄz©³HñûkU¼/åZE!ðB²/ä[Xù°‚kÈLòeúO¤è…YëWô¡ˆzôqMxµÑ³Z(c=FV>pìHs/::ÇXÖ½l†ËÃóî´9*ÐFÿ®Â¡‰Å;æŸÁͺôÖm™$ D£w‡™BDíqºÚîødW–uïrÿ0òtÀž®²ð-yÔÏݼÈàFߟ‘Xƒ \Ærn¨ˆÁFêô)ßI; °]„£KFvœù>t<7(𺥪ØëžÑêök²°Ón©=[ê^´DŽEyÎz«]1òíÅËóí/ûɳ´ cnÃì”L*ŽÝÆHzävÝ4¾BQ[.¤eÉ`Äle®b(õ$QÝÇ*Ï&±5üõö¹]¬ÖÕ•…é¢QxAõM ÀÀ»6Qyµ¤Ýê™q^Ó!„è2%hà7 7Dñê‹gc²zž%è’ç½Ñç.ug¨S°ïfûmÇ&5ÂÁÅ>×±Ó§ïÌ—©Áä&ÅF‹†Õ‰v$Þ÷üõ‹°¢9¶©ÀX-û…`¹+F™²‰ Ðbž3;Hñ[°¼ˆß/-xÈ­êF,U¡¥±ñ£{CÎ#-ª¤­$ ùGB[X.±[ØÜŸUq20x»ªoü_sà î11i‘$¢ý-W75ÕW²JmmèºEiw{”1ÉD„qÊä± b¶3D^ú´>{ºùܸ/A£Lí†þ^••óªë*lØw¦Ì„‘ÒøO ¬Púç=•ê]Rz;t¼Þnî'ÀŒÃã7E"Á5À­@'RÁXû*d¬{xpºB«ã¥¡Û– z:žâšH⻃vƒ:e nž‚ ¹,ºoc<ÂòÏçK·L¬[ÒPˆ¥Ï`}Ï|è£??™ ›2)DUzP8÷¢TήÇJúh[y~Ê9Óœ «TN~kxš¯Ô0.[¸àÅÕ¡™{µÔeÊ ¸JÐR£ñ87ifbüÑù½PŠÕû.Þ±Bwch`Ð\‚L†`;õ$° _’7ûSV‘êy‚è ŒmòD˜“i$Í•d™ª8ç5W×îÆ@ææŠQ´ºG¢„%ÌÍß—úL ™aßwÝ%­¯Z!dWnS–úþü›£¾ E@¿“IZè8ì“™OßÏ. Ô)œ™NRLw+ÐK5ÍŒá„#bqÓó*~Ú}ýúV6 ?ƒ0–ôOÖÁ:ñõù§0?CkP™DæTõŠšÐ™}º² A¹¶(øÚôÆÇ m°Í¤O"z7¯Í¿ëÂã;;Ϻo9uÝfoæòí´ùÚ?º×C#eêçT+jv‚ÞFu®Bø¥v(x†CìºÄ(->ÎÙòn[Ú—<¤|G:ï«* !LÍCóZ¼ ʺÍ7÷’;ÏcÔnwù¶ÚäJ§¦}ÄMVaÏW ŠÔZàÂ{¡j]îU_4»÷±¸YÛcâ6÷ó&uÛCQÏó$ªÐ"Ê«˜•ƒº‡pÐjÝšj‹xYUŒy›ƒ M*ÉûaÜc%Ššý¨Vþîû{Í\|:ÃnyÞÝ!ä(ïhZ^ƒcç|ŸËñ`?©iѥ˵nG endstream endobj 4684 0 obj << /Length1 1630 /Length2 19963 /Length3 0 /Length 20810 /Filter /FlateDecode >> stream xÚ¬´ctfm·&Ûvž°bUlÛVÅOlÛ¶m۶͊“ŠSIŶN½ß×»w}ºÿtïkŒ5uM\óž$Š*ôB&vF@q;[gzf&n€¼…‘‹“²¼—,½2ÐÌðWÏGA!â4t¶°³5tr4€&Q 1€…ÀÌÅÅG±³÷p´03wP©)kPÓÒÒý§æ€‘ÇXþF:Y˜Ù(ÿþ¸­íìm€¶Î!þ¯U€@€³9`ja ˆ((jIÉK¨$äÕ@[ £¡5@ÑÅÈÚ ka ´uRLíÖÿÆv¶&ÿ´æÄðKÈ `p²[ü ºíÿ1ÑìŽ6NNÿN3GC[ç¿3p¶XØ[»˜üSÀ_½©Ý¿ ²w´ûëaó×öLÑÎÉÙÉØÑÂÞð7«¢¨ø¿ët67tþ'·“Å_3ÀÎô¯§‰±Ë?-ýËöæ¯ÕÙÐÂÖ à twþ'—`bádomèñ7÷_0{G‹•áâdaköŸÐf†Ž&Ö@'§¿0±ÿ™Îö ø_º7´··öøW´Ý¿¼þg ÎN@kS8f–¿9ÿæ6³°…cügW¤lMíÌLÿÖ›¸Øÿ‡Íèø¯Qý³3Ô‹04±³µö˜Máåíœÿ¦Pýß±ÌðßGòÅÿ-ÿ·ÐûÿFîåèyÄÿ¯ïù¿B‹»X[ËÚü]€ßÀß#ch ø{g²€µ¡ãÿ/ÆÐÆÂÚãÿõ_½5€ÿ.÷ÿ&åløw,B¶f©ab`ú·ÒÂIÜÂh¢háll05´þ;³éÕlM€ŽÖ¶À¿Üþk¬zf&¦ÿbS5·0¶²ý‡¶›€¶&ÿµƒ¿tý«~F)-9QÚÿÍý—£âßEpVõ°ÿ[ÛÿèFÎÎä ÿÀ Û¹¼è™Ù9ô,œÌßßß‚¸XX}þ7)ÿÄüŸ²œ¡³£…;@çoßLÌÿêþ|ÿ)ýø/0b¶Æv&ÿ¬ŽŠ³¡­ÉßmûŸŠÌÆ.ŽŽIþ×øÛõÈÿÚ{ Ðh ·¾bgÌl™ž•á\7:-ª3ØÏ >b_Ö¤Z\è_k×ç—¾ËUeð^ÂÐ<ËýÙá±|jÿq(Mó{¼Ëú[_*ð²€À‡Œz u‹²‹ƒöw £^bÆ™F´×Õ’ì„6;“úï½i%e½Òw(ÂÙ®ïŽ0WOÔþd®…þäöH¾Æiq˜Ý(Í hõE§g”Iž¿ OŒŽôÝ@âÓæÆÁRðbû¦œ’$;{8Þ7B¾ºr8U/g·iÔ¢&©¹yâ¿­¸“?Äî¢3g\|'2û=`\1Š“q» …e)Nä§#ž™S•Ökè^‘:[cß8oäçN·ÊZ㊵€?jŽZ‘H'+fÛþDU§”^ÊÒM0‘TgâDÉPÒRâ›ã`mÀ ãGŠ¬÷Ÿ¨LÞ,‰Ñërö!‚áë©QMjÈ9S¤峧a>r‹¼wàeÔ² ¥9‹~„~U®`ØçÅKÝjÆ®œ±¬þ9º -ÞÛƒZç&sy@ñý7 Ur˦™˜;Z*âÎû.E¯­O§§7]Œ-qQÀ`îx°Y¦tÆ£iTK²÷¤\–?V>ß—5Eûìiɨn¤¹™N'êîn~v§pjV_$û~2aàñŠkŸÒU@­ u1Ô=Ò i1v¤MzôAŸÑŒÉúDºV¶ÀÓ¥…£cÚø\)fg´¶ç'û>ó Zä LÝ,¹ÊíW~‡}%…ý¬·«kÖr|~^ &ÙAÑòG°K‹W (¶ÖB‰®}S†ý¯9W¨ìÍÔxób#«qãZBTPtÕþ¥iü ÷ëm˜L#×øû? ^Ld©î×0Ùbì·½F;?g8¼$ù@¡ëµJЬið¸jf-ζ¹kFÞ7JS_³xùˆ7& Z¦<9Ðuµ—ycÖàfšÜ-òšÔ§)S¦H]KnÙjñ‹FïTýnÅ¡€DšaŸáÙk |Ûy< Ù»«äʸ= k˜ vr&È/Òðð`¾’™=¨áÉt;÷¡7…¬Ï5gj´¾¾(•¾‹ËZ p§’а¯Ä& ¿Û&Y=´2}ícfxŠ¸­èMc¹¤(€©z<ÞÎÝÑ’w§™’ Ó0,»EÍ‹Æ9ŸÒf¾Åîµ ¹Qòcƒ“[¾æl'ý$¿àoèS Oì6ñ·–O-ltÿ\âf"i)cÚl˜/ÉãJL¿Ž?%zjš¥¶ † Ë´V»Ó<^GdŒ=¨C±Ç}9ãá™ á:<_oí'°Ÿ’‰Åµ¥ˆú²Wu…O79¿ g!ú¡Ç]²?ï…«áñ˜¿RÆŒj‡GYü†˜Á¼SùùÀ#ôÛäŽK™’ ²®ËŽæõëÒ{àƒ«q&˜˜ëWÌ‹7²›åÆ=Y³·¡dÍ)ÚÐ,™Ç†ê&ÊóÆÅ#åôקŸ™k‘äñú>m¿üÓú×ë_˜3OáꃞZÁUýšRó!N·% ³c~”KjÃGRå ê­›?Ô†ªuÁføòfºô 0š¹æñ|׃ $kAÕoÓ£tçTý‹5‹—p(¼ÿαX-EÄ©ÊtZžn.qð”0aX¨³ñA®ëTœÇ »ñ.‘¯ˆo†Ž@oº{Èg~0ù üPűö“GtMSí®O{]T«T¿À^Éú¾# #L9¾;Vm¸»úçƒc"vFX£Ußýaé m}â£å”œaÇqï¿ŠLJa¿YÁô¹\Ì«µ,׸³ç"“ÆCÅ|PiÄltaŠ£±»5±ûÜ5«Wñ7&UI`¯GÛ°¡oˆ@ô9‘Œå“zÄ«Í4³·Ÿ…ËŽQM 'EPÁ¨B)òšžÚèžíbfèv‘ûÊ=Hïäc)îQPt@nŠëá‰9Øpú6ƒýNL‹i¡ÌwßÑö|fˆbÊ‚!t‡ÓgèñÎ[ æTpgܾ ì@p¢ù´¼¥;,×ÅŸ'\½—”¢œ¡6¾,ñMÑtAÚ¤Jž ›±7¸eE#šæÁîŠN*ŽÕýãGÅQ²£mþvñ=æŠêyå4/MäÛ§CxÞ±…XrE¶l´×â0Ât¥nÿîîðt¸!uÏäwÙ•dcÒhÆ =qŠ¶3ÞÜ:£º ‡S¸'½OÙRù/L»Fü›B²y@oÇ^ñ*%åÖýÎ’sGhòßk |‡òJ9Vð3õ]‡q†’ï²Î‚~ ]_Í9õ-‰œ$ïsƒîåúµD3Mø±á(aé°çPÙE0bâè;Èf¿Â£ìE5 }’Øå UÌìÔ“òCÔ1 c¿ ýOLùD±Í~.‡™Il*>«Í/ÇRGi èèL†Åœ—o`{{é4BŠ<‚øÉ-ÈØlB­Ãª0Ç)*•±§ïã)B`èU†?Áè’N›ÿ>¶³É‚[³2{W:îw´¬/>¦ Rud†‘ÛÕÇl]äãì5k[ºÑie%H؃©ç@>/hø|ÞáÂ{ý"›l8<µH‡©9YL#©FQ{of¤Ú.*ðþÏâøÉ…Fe´Bx‡ãª/W­Loh&y±ƒ¨kÓbêÕ£G`'\\æÌS£D 9èÄSp_0Fʪ]^c5:´†ºÛXF¾«ûY$ÑvÞ<Ó’uCSëPbÝšÊ!üìI¾ÊÊçäšVWV üMh)®UÄ{»¨GUó†[€gôÂõ‹’büÔ£w&ªj™Å”¦½,˜1X´ Þ>9™î&öZæWa(…`ÄQ󦄄6ñ Õ.&1¹ ˜ž.†A8«¤­$¿l³ ™²{\EûºYéÑMÝyOØí(f82·Õ &yÕ*´mUé)~-r†þeÈ '¯AYÁÎN¿J9“RCÔ<3õÎQ³ã1—æ†YÍÅìj`ÎŽ­»Ç¯ v.ÔAÆ¥Ï<áÓÂ’\ä±&Û÷ËÄÙmWº¹WÒìôÆÆ_@·ž;ÙúvxË×÷»1ÓÔBªÜCjQsÊërktjôºdÌti†"¸Ö~¡ý°†^Ù½Øñ'S†·7ø‚uË)â¼Üu÷ÜX¡[þy Ö(kÅWRÓ¥·Þ¶¼NpÔv›U˜2y®X”¶î߈ ÈÙvÅŸ*ѬHŒðºñvƒ­¿;Ž0V¤½9¨ØÎ¥3º¸Êj§† ÁPq¶Ô¢SŽãôÝo§Ë91S;F GõÆ=è r˜ÞJ5TÝŸ58 äpÞ¸‘PM.)ÉÊB}fö ŸÞ²Çîè(¸¿¡7ŒPìPùy®f=ƸIÊJÑÎ!U*ý5cÈhhŽ§Žp€Ÿt؇©aI CrH—6Mý© ;7Á±§@õx¯ýµ“Œ Å‚ž SozboˆÙõÆÒÕh_+TÉzçL,¸]ŸaUL}-•ã‡}÷ñþàÅÔé'¨ÌBÊÊü•—¼ZEb·¿TÇ•óææyËë»+‚.&Z 4ãëz´r†Ž%=€I}!›£¹ð¥ìjê*îÇçÐìÄñ`ëòá·n7õ]ð\6Zójy¥÷æòVm¿È Ä?9+X4ö‹¬ÞozT$×)Tüce+¤2Že>òxðI>èàŽrd#žÿI:F·IÆZkCé ’5_€‰ÑnVLÃïßiaF³£óÙ©Hèæ¶,ß )ÔÝ“ï­cÝIhÞçQ*¦=¹Æ“Xþñ»’˶Gs†x"Ðð3E|X¹§Žà¬!gU/aŽÁíS…ø¼H2Fi#Qüïý:à欷õ›eIÉ,ô]òbe³³Ó•¬€?i‹bù(I³¼aop¥*ñ›ß Hå5-¡R! ©yÿÚÝ6-9·S—« e¥»„¬Œ^_Îìî%tݺV|6. ¼Õ½CUÅÍ´·Â²z¢ØïOn£.‰x¹X«ßÁs¼Ôä-ƒ)%¡ik€–uˆ þiÌ&36†¬¨¿Ï>úc.3$1<ܺÃV%;I 5|º§-æ剾!V7»?qÈCcó¢ÿ žqí yÌŠPéûÂ>BµS@ZÐUEa;6]ñ«¤pŽ—ù)jdOlsä×|}–&=~%Vy±—Å• Àø¤!J¸Ã†ÞïÏL ŒÌÒëlì¼³ÏzWªWÇtó?{ÚØ¢„À6­ŽßhÔ‡<#x£nqUï0Å€RXy_í\^!c|»÷ßtdˆ1mDfø #ü"ñ›ŠObŒæ²8Ю¸­óÓâ?…¹Í÷×ÍÂ@ŒÆ¾m³l³8D^ŒZýÛQWµ—uÕ»mKŸnZ¤â7¹91D©E€53*ü¦ ÂìAÔ0{|y‰µ;¬8ÀóÆ0MîT Q¿9 î5áܪú¾;ÈÞêÂPÔ¹½¶pžø¤çg^Ûj}Õ…ËZA5{–l wõŠ›¼­,"lQ/`Ó S .ioSƒ|5Ô‰Ñì#ÔËéyW‘b5qÔ/BÃ,ÕÖ‰]^6[ºâ‘Î8];`§:'·TI‰s®Œ¯&ÿβ—Ó‡zæZüŒ=IVù¶%JìÀU{þ |,(kö†øà× M>‹=£Æ–²‚iÂ×׳Ÿ‚d`¯Ú®ãŲ@/|QH¶Î¥Ûò¥Õw$ÊÑ(ËýÖÈ—ælË@q ·wwç¶z…ýÜ‹‹¯ÔqŒü³yÏiÙ.†wªØ/«Æ®ÎøE90¥¿v‚c±[έf‘Í '‚×2Èðl¹…PqPIÌ5y—SÃ/‡É—Ý|ûÍ%Ú"¨Ê˜®+>ôÁ«6j‚ËöÖ¼ ¥qª—€Ñ\­gã¤}!‚´xø±6'/£¥hÏC a6cêâíuËÃØ^aUž0Ë%ÀG„QÖµ.ºyȹ?LÍŒã} ³öH®ÃÃz›?)-OjJ·¦jIyô }ëëºN”Rž>Œm¡éÅrãÊ•>«ž®²´¢;;­›VpE=ùl ?ä ÷(T\ˆ¢ê¡ÒÖŸÈe>5}s©~¥*t_|s3x*wC‰”Qî‚»¹(ÉÖúQ(…É$cËY›;Ñv— MUlä#1Ë*ZdÅÿ$Ùa~Qù6q|_i¥'Ì#lû^Ê e#@wM)ïýqô[}Êaèš„ö­·.Ö›uIÜx'ò‡ƒÔŸ¦LË8§\T:©¯Ù_8ÊæÖõB¿EÏóFNÅw_0=}h¡vu6'Ø6«†·ÇãZÎœ^M΂n|Gè2Ú9r¨7œ ÿtñ">ÜÒûF_1¿3Žè¤IÞOòq˜±®YŽ¶Jy±f×cÓã,.E™*Ía Šèj7á×޵øD"(– fŘªUSXV®¥l•ZzõðÉn\õæg«Eý{Cô¯÷"—KŸ˜PÄõ$d×"¡5Žü+¶}ÿ:´°EÕ öðíøô늷„×jõ†#! ¯GáORâ‚Y2Ü…ßZ±é¾»{3¥\#V Öƒ‰‘.¥¹ÑÙ’AÞüóe×ò™SÇöÖ£¼7.uð’V‚›Èé¾;òŸÔ]+‘äqÖ„-ÆmYj%¥Þ”ìøóÖogõ>]£Ecf³’4¢á‘‹Ò0hu8ÕË?»ÒëQo¦ì‘³‹C‹Ûeø¢?2ï–qû$hNÔ\»Ð²—la…½¥',…úɈ`±Ò!0„ôŽ¯Ôvõ<ŠÐ=¿mÉl×±ω£!¯BᔿoVÇ^-ŽF©½‰2!Á£¦È–¹ßp÷H"ýZ±"ÎúüŽÀ2Z7ØØÇ4jMÚ)¥ŸêÌ §;3Y%R:øËžÌLiýŠM·ÕÂOg|B”³ÍZF?/éÜ7ÓÍYjVJÏ’ýfv·ó­ÓÕt Éu2ˆØ›¾Ið8êoÑ}ÕD\ó ¡áv .´(ò­Z’”²G¢—~&?íu¨X ÿŠž/y¿ó£‚åwôC¶cFËáÊJ‘ˆK³Û`_Òuyû~.nY¹ :ÌV¶¬æŽ>˜ÛtMD&3ôƒiÖ`õêÃ|¼Ã^)ÖræFìM~àß2N>UÔ °¹ÐÚšJp€š­Og'ÕÔO­§m JŽëBâÜNþ»pÊÊj.ò¦UI«‰÷ÓWÁܘ]sº30Ð5ëÅü’™œ1Ø âB’;y6+OäòƒXð)“w¼»ãÄí1ó¹Ïmå³gÕ1¨nØÊ`€¥¶¨$àH¡·TFËãi5<ìµBi><æéNh"Ñ%–˜ä<Õü.¨HVJPçc€ôx¤zÂQ 0[âµzV{•{‚M•{•×£™_AR‚Î3Q+œ“8ªÿÑÌÁW+(h‹Åݽ‹»]˜ÿ0ÙöòÁk¾¾ØõÒÉBþthWÒ‚eåË°ä‹ÃÈûž ƒj^qήo™)¦G“±É¦¯ËD\Óô*DB˜Ü™Ì~ìcùYÒlí.š¦@÷=×y¶®²Ú ä%¹ö»Ü×ç°”ÂX5­/Gâ¡î%ÙMQÐ×ÑäéeC¥ŽUËúÏŸÆõchŸ”žâ¿çÈÏaÊ_É$:ü,—­«ÂK˫ɉü5›ïåJÍ©B ÜNŠ©‚d¼¸öÁ–76'HÃ=L¥ñ»†Ýáp&<*ž@U+àVH³°•¾ü‘gIBLì7»5™vÚÈľϘMÿ5—Ýcƒj£ž7[$þàT€ ʃÉžtÄ+¡Ð2›‹ú—í6LÆLyОvÍÞ1ÕÑ Lü'Ë\«7DoûÛh¸MÅP=£ûô]ïìÇ$h,%ç„e¦_«‰+3yEÊAÆÎä·øyYƒ‰íÏëð¸†HY¯"ý""ˆUزsøm£Ì1泚Dpµ9;¶ñ"—¡]05Î-XÙ_CQdc½[Y]¶l%Ü’\~úãgY#Ní× Ã‘A«O ÛWM]¼Ê*0÷úÕ[31Û0âÕ Ì26ûe¹ˆ>Ðs‘èX/O?-ÜEw¿îŸ%;«M•Úozäà h×*5Iåp,’˜äÕ7›]”ª6Û¿YÕ ÆF‹Ân™ÑhîÊÔÏä>•WI`·Åh'Ä7ŒÒÊú?Màt˜%RÓ?”%· È:qFÓšó±2ÉoÅBYn Z­j¼6Ÿ®Pa*yxpÞ µû¶øì:Æ'‰ÑeâµnÝã~F$åä—úVŸ>±‚ÈŠ9¿¸ûˆ‹~ùÒ”ï¤ßb6cøÓæ¸qv·§”£ÏºUÍÊøĨˆÎ»P“2ÊöE™•u·å=$:kcˆF)ÚzºOÆñ6wÐÑTZtf¨Ûl­&)~èøä+b"†ÓV.0?Ãj‡M£ò$ÁÖo¯l³Ü¨ÊÍ5Wøðèæí9Á¨»dqÑÇ4Èä|·Øqf¾sfÕoo§Y#§ƒÂßl«¨=h ˜ñº±9¤¼~^xQfe}Uj¼Z‘¸êB¤Á>Š×ªI’Òé’íðyþŽT?±Åö»lÇD²_YIS1°8.1éB`87‡JAù÷;¸ò/æœH9tÙˆ²%¢ô£’eÓ,]®äWË©@ŽÓ)=•äÊï¿9Óëè9,àa½c¬W; -CÄ׶°Œ÷kûGۈƩppÜdØfµš‘ï×=¡éõÕ¯¢ŒóÌY¦g§å áýäbh°Ù…þ$‡uåòÚ;„å°8÷ØB®v   †Ô¡žßjÿzÿ9)âMæ¿“Ãë^,¡0±†Ûü®Ë|!Å›Ô{×»n„ô¢ê’¨fAtÈús^þJÔ!fÈb½ÿ¦è—²¤ºCʆâpOCyYõuçÂVq­l>—kËêÏÆšBð+þba-ìÀ+¼‡¢D6’:{FÆ6^ƒ‚8&ÌhE1?oíÆÉ0t™œWÿà¼ÅpÖ ‰fI%^ß †Ž;ª«ÐAæïÖAI\Â0¦üœm_jÖ[~u~Û´+7÷’>Rdø žcÊ][³ø᳨ŠP·H—?¿¨¾$É„Í.YŠ?eVQ7F”¯4]žÎ•ë‡ý+¥½Ä.+Nj_´Šy—A4ùäå± ‚»ünõ4k›4ŸGý«n…¨…¢ëòºö€^U|õ¬2U¤u\hj2£#7¥âeš‰(zª‰y&*gi?ZïCYÿ¬íʬ|á4ybLäUè抙ԙÂ0Ý#×BTÁIœñ_ò_¡Ðy°!àñjûÙ]lc"%AD‘:¡t‹´_„±:9vdš™•†h„+Hlƒ gE0¼ÒepyX›óÏW%ļž LP—cÑ#MöÒ‰C âÊ÷¦H‰uñ0–ðf˜ùÜyi‡P3Äm*F˜÷n®“ž’OE‡ár4(Bd[Ú·È…ÂâÔ ›[Õ×3LrVG51˜¥)c3™Î„žÆ\‚QŽ°SÌÚÈÍçI÷‰íʹƒßôðÄõ‚ÏUÅK }é8;§¦š¿ys;,  nç'ûÔ_üìr<¾×=r>rJ¿^®×¹I‡Ã計´=àe”R«YÚŠ¶Ñƒ"y.‚:6¢•+#6ñp›R± ùÆ|ò_UØFJê´]1k#¨'êØIÙ¬T)$½’ý¢ØÞ{ÿ´BJkâªs‰…ÐY:Ùt€àã²Fx©f[åV²ÝÀË_Çöwmüc‰ì°[Li`b§†mDè…-“Á¶|dKûM6DA¨àeJŠÙa¯ÿ0U˜#n}Úßã—€÷'H¿ÖŠ^! â*ƒ{xq†¨Qïô•åHÖåÁÄœ|bªÔ{—»6âùH|^ƒ´R“âá&rƒËhÀ/Xë}¥*Á?®Ê&öA#ë-²”ÚBM]y%çn]e†åmÚÀú¨>LˆØ~m\0º k—,þË™ü¸¼Š¢‚Ùš¦k:Ïê žz7E&ÔºrÊÉ…³ín eUe«˜Ôñ3 ’Uë0ÀLåLYQÎ|VºÏv¦ÉIWú…A¿"D£ë÷Í¿.6ñÌõã†vW¼-‚”Š”÷ ø»0h’«£”HmC™ÛØ·¢öÃ¥;¥úÒ•ž±˜/„¤‚Ò¼WM5ŠN4NèFØØee¥Ä¹vÑÛa#lg ‹39Ó²¼–°Æ¦–‡ð¶Ð„f(%#9ȉäÈØ"•%)g¢i&P©\_wQ+h–‚‘âßßïy%† ‚R*;3Á±6¶P°½¼îÒfœl”E^«*jÊ¢ªXwçq5÷ "Y*½xº8²lC'üþõ¾<Œ pðƒhM¢` ºXá}6¤lJ£doDõC ¯Fvê"Ƀ1%ýØÁ.:²¶ë6);C=+H#rØ[NÖqvæ‰2wéf—²EÊ@Ñ[O3¥iIÌ“œêÖÓÛ’û’Æ .Ú Ê‹ÿþšmñ ¶°AáŽf¬²@ÿ,ÙL˜"A>¬gÊ·¤~ÔBˆlíE!Ü°§YØ梻žªÒ£ù§œ<1ÏÎù´ª^MráÙ™`¨”Là)e6Ô|î ù§}`ªoë¿6!NÉòHÁ UÓlûhnÐØ(T;QjH\By–º³@OÊ“o“}o÷Óxäå:Tý|JqÊ…|JjîLé 6Ô=?kKÊÁ¡˜à˜f<Ìž)òfGÀ«µrRšx(O¬ì Õ—2ÈV˜†«¤\ÇEݦàòš(Ý,ãdí¸g\ºÈ½±-±è±^KpwnyÃÆömWSÍæ x5'o‚q¤ß4« b’æYŽ¾oM±ñ `bäC‰E*·ÆÚ3¬.Î-Ûø’Ÿ 8ÈÏÕÂ:ò«Ã#o¼±þ©‘,<ìÔG5mÀ„Î2é ¡wçËÀ@@ŒÞ²½¡ äN@|VÔžj}Á­>Ñ û:n<Ëoû¡C>ÓÞ†!.À84ØQ\ÞüÓz(5ë(¦¶AeêÃbšñwñ÷Æ÷!ˆ Ágìb< ¨ áîmå3$”Ô×|~–3•ÞjÏšm“_Ìþ–ö³R8ã1‰<½OsW)£EnÈ4 @Ù}©?Å#S-‡\ÊRï6±ËˆDûŸÏªõÍX‡àNûb¤Øk®Ì±‘ *©êù]¡É_ír|ª'Ü‘é[¬Ç‘b¸×ûæRMÌá“ÝŸ*ï†Lõ¼¾,þ$¦—#H~®’Dä&ÃÄ{p«‚ 톉úO”I'·Øu¨Œ<¦¥¸Ä ˆÔ_f² jNXZk B9þ‹a6•EzÏ°é©~,þœì?ÂL’ÈÀßΤ$Ž¨`uÞ!‚^ëwg+Ñôo ›úB´Ãg}ùa>~4ècÈÙb58άéÙè±'Øí3Wxðˆ­²ÍÓ­&¯'&gn ŽÞ8¡Ø—$•¶ÜªþÖì$‡ò¿/]œ0ä‹Å]°ª6éˆJNñ[ºšùÍí™P¸¦v(àGý1–M; ,©VÂYñΔâ«)í=ŽÒYôýÖ; ó.f™ä:®H`êÖ$z-XdÄÚ¬-W #P>)ÑŒ4“ ä! Ûþ~Pû 劑eúò`™a…ÐdÆ)ujíWe€éÛóžI“sDx¶±³2²k{­Ö½"zƒ“m.µŒ§r³½7S ~m$ËxGd÷Fwv™øÁÑï×4“ÃG©ÖÝά¹Æ=º¹†v+ˆ˜~ò…?0dfrVj·ßÉ+x–…KÈ^]¾Ã‰)EÎ’4ð×Ë$IŒK{©¬]´µUTdÅ“ð”œ;biƒN"ûýpVGžÜz—µßÖ]V3>¦”àôÈ–éÇgZŒSâç3ÓÕ;ìj—Ï Çp¦×Œ’¶CHZ!Ûdo¹S=¦ —ó‘A‹Þ#q‰·ÔÄ~UŒ ÞÈlÅ¿™RZL5’iïÀí¤žÐ“žÐšL–Nä†J¶+©=Š=¡Ý×;gD{7\KvTuö~ÁžÅAyz Åp’@ñ¸c¢K¥ÖÀ5§DS¹à2Ö$zØ“ý’+å #¤Úgt=:‰òžàm7¡Á€›úƒÊ ;›×Ëu™ÕÚOãP±ÍeÖk}¡êQ8šï¢ ´–o£­¯.]M²õÍÇ!ÈDÌž4•1þ ‡ø68 k)n™Tû.7Ãßey`36-ÃW;i+~EY¥;ËöïuÙ«¼þú‚Xx©=íX;rýbá7W»LKQõâa?¨5gJ)â%9„vµ—‚ÔSu|^g ø]e)mgÓþ¡PpZ¥¨>2Žp·ƒ’ËÄÂhzð$Žp­ý½Î0~lœ>mk¿ëå·w1µm2->÷,IØo9òã¡œ‚ ¾ð °‘ñ<ÖÉU ´6Y3ðï<Ûƒ÷FOÎGJÁMV“åæÉTÖ'-}m37>zå\Ñ ±GQ™Was|'"«0÷À-ê:i3R€%`f)z¬[Þü¤¾QúUo„®™/RW‹Çœ†Ò)ì!/ñ†¿q®Ù_ˆRwýfý@½öBÆC:ö5±²V¼A†,÷S½.jõ±ÏœéEÆŽN²ÃVyÅxXÙçXšeÓÿÍÏñ„X XMÚù‹6¹P\§99Ü· Íë5a³ì™gY¤H³äÅI”“l2²Ï@R ò5Ѓ7#ëÄLÄW«ÃHk¨Ìjb;Ðäü³B™Q>s^šêÄCéÍð\•õ5ˆiû„ÛÛgˆØ¦‰n_Ý ‰äqóÄD8ô0ÔÒ9¬z´è“m)¬ë&}©ÞipDAˆ-˨Šî±DÁ£§Cü¸ší5 {Cš½9t™TÇ6—ߨ¿Z¸%kÚÑD}SÂŒ¢DDãÕ¿ ˜cÃ寢g¡†6Tá¸?ó†ˆd¡òk%qÅѾlÆ)ÊbÖ×2¬ûT¨×,|R•bY¹Æå éáº/î† Ïþa“Ý~çˆxʆ•}Ÿ_ú¼Tšî/Xƒ}óìB¢Ú6p—ê6ÍÒKlŒÏ9¯Ì°ÖVQEÇzÍHç$¨2ÿ_&É¢![ÏJ‹øÝÆ(ÌŠŒšÐùw`ž¼4Ó¢2­ê›‘ÅzYú7(°l–Rz^¯­3ö¥˜RÎcs_¶ØX¬_ôÏBÍÜil©<”×UºÎ䘤„œx šÞ>’ÓꃹR|¨ǺN.¤Åé›Ò¨´9+ѧ¾É¦mœJ5ÇHuŽ5\5p³-&Ö® >œCˆΈƒrøÛA\»³MðÄþx^dM\[8îè IÛ`ËʼwÏOÉÒúFì9…ó§:$•I9!OùÆëYbøî&cî´# V™w‡t¦Ù¤¬+Þga¤Öò¿-u:[Øv Õ _DK…œ(¹Ÿ¯ñÕASQž¿þÞž"7·Z—b”{^-[CÑn¾ÑWl†çz14ÆŸ …¶ + KÀ-OeûQ|j­-”·:aþ¹"úÜŒsw^QÕ^ë &šÌ4ÀrÝÜIýZ'è¸sNžYzÊKê×Rm:3bèÚÓ‡|èš­Ê$—âAœ÷sIÛÔþ©×ž,¼ºò2#Þ]¬Eè‰@;Ïì›v½ü•ù4\j‚mÿpò¤;d¾Œ5Ñ]Кü|†Y…Ú‚7a­ØÍÉŸä¶ÛQûÁ¢ZÀÔVüݱ÷fÝÉLñiS°GìT5:Ôf½éq&” ÝØ~‚ïq£½.YE5«¸™?Žl¶5º¹asö×Ì+$Âyÿu\Â6~£RÄ‘®®±*„'ã ššc¦&Y…#<¾ÚÿàÖØÀÒ¨Á¿­=Ç_ß÷›Câåšv<ªð3.,¬Ã¢„ÃÊ2Ò«ÅTL-ý-<~põ^~$ôºB³åhIqŸ }ý;/—vÞ©®ˆÚïz=wZå¦Ô›3´j“µùBb þø\sZ5¡“XÄrÔjkÞ®¬ÎÏ‘”ªˆçkÖçD‚øäU•Am²åm½Sè0‹wå=Jµ7Ë ý½hÃJÖ»­*ƒ]ƒÅL4ÅàT¥x÷CˆHmÓšß}ó鑪eFQžNgŽôÛ%I@/BÛÂn=S ¦(GÈdÎ*VÅùÍÜœX\yÍR̈?ËO眹 9¢Ž}Ëõ¢É 4õ®ÊˆÝÛ½ô1ƒÔlµˆï;r+#Tíh•Ý˜ƒ5?õúÜRªª×£§ g9Ë&o¸Žæ'©/*ƒ‡¾÷åYÜP‡_>Š½»–—„«r*­lÔ4Aóþ€.€ä£a|?bÔaÚÃêÐå§?Ë‚¼âªåñGÙeV+ölKÿ˜a¡Ùv"²Æʇ ½ˆjz;¦ˆ$n € ž;pm>áo;Þ¹Ïoå‘¥ D‰Æͧ^¸Õå¿38×­¼xwê‹Xö¤°oFÂz8Ò!Ok$çý!ÄâÁ»SxßAò=1[5‘Û3•yÛ‡Pæw¬ý¦°+º?–¡ýk5KÉeåä ¾wòÛ½úF–{¼=ji ì[»Áﲪy·R€h>¼¿]}" å8R-ôèÈcO3úˆG×e-ÈëÎ Ú¡?8äh>5uî"åü´ëjZ.j,šwa¯w—܃Úê 2ïÁ`±ÙÎFç¡ŠÆy—c|„³øU¨j%rדUtÒ¾¶y ø;„ô~—jñki§ãÊ–G©E3²ñŠ,ëL‘;ëÎÏÝJ“cóÄjWH.è“¡ÑÒÔOˆ¶pŒH¬~bU-J—¯ ÉÛ@=ÕÐü¶ÇCÉ·e$ˆ„Çш®Á?”û %†½`¤ 1ê„dë|$÷sK7ù™äµSÀŠ|6ŸŒ­¿ÐËL3P‡‡iDo»óμ;˜&ƒèèÈè’xÀ(ª#u7{ 0ù%Yɯ¨gOk³ïÕ]·¼Q¥Ë]ҀжÅѤJ{æ8ÆÖ‹ )°KçÚ ½/–ønÈrÏÔ¨±¾JnCmÀ†²ÊÁôã U`²·o£J1ïó‚?Ç“g8a«g[Š=ø6–ÔΓ¾E¶6/g²Çpî ÿÀS‡ßåxñ>çè¦&—Î*yõÉ*¶Eœ: áúr¤á…BX#ø®Ej& ¯Jü j«±¯²¯À=ÕÉ­à+ä§Î‹å½\{vC#‹•×‡OˆtRsõfšMP)º<—Å–¥n8+J{ø¥çû0«8á-ŸŸ7Mxu@.ü’aoEÀÔyc¸Jùq2mÊVøÅÄ61ôŠÒBWùVœßzíô*Hµ™[ÖéŒ,³Át¿€M¦Òó«yJÆÏb:BR;‹žßEפZxyt]¿ÐR1ÏÁÂöã…;b[Á…a9ÖO:]ÏtGz¢½=ɲãŒHsHOº‰ær™=OÿƒÔ´€ÂTÜa†É­~s/ç#¼)ƒ·jf;EöÈ)"AÐ#Q?kº7ç1yÌ[O˜±ñ²Ë{3?ê¨5(Z)Žš3ÇÈó÷B×úËK…“Sz ~…[µ†c,Þ’“}I,z78;Á™SšµuÏŽa7Xi1¥bvˆ5úÕ–e;Ké e~Ncá­ ~J2›à¤¹ö33×ÏI·ð½âazttÅ+dz1(Knµî°ܧïmÀKúÉyN<‘‘šëY­ôlÉÙügÄGÂ?e'»ß 1Ï>ˆzL­AìÕi·a —h66uÔSÃü1£:>[fm+œ…œzÓäÀûêìªÜ.^-Àì5ûd3ö‚r딀Õ趣JzÌÊȤ³ @×kqŸt2¹{å°¼Z~ÿö¨ñòÞ€Õ¢ö~0]+N–ÍÉÄ÷äÊq…f!ä— k²ÌK ¨t¨üÞF±n©™jú¨Ãƒ`P Ê€Ö‡{dqréí,Ñš›µF…Á ç@‚øÒ¦›› úTŠGð(Bg·Ÿ«¢ˆ98ãžs\¼Ù{»¯9ù‚töôêåw¸Aq†«—çÛå8hDP°ÄF˜ ~ì“ÝAphŒ×™Ò Ìé%¤:¯ÝŒ&Ûˆ¨øìSÑIÚ„;|Ÿ¸;ðû1ü@ •®?«]»0fÃh/µ(e™žLLPìs‰P“NNb¤Üº¥JŠO Ut劄ì É&¹¼«\/oþHÙLFhdÌzyúo ߟ­¬²Šªe{ê/Š»þ&¡-x'‡¢ÞŒ¬Œ‰ø¦Aðc9¸÷Wœ)Ui@‹K€€æøw¸gp‹§ZwˆÛò Çæ)ÑØRó¹]J¯åOСì!Ŷ7_§Ó“zAà?Í·ÐTE†æÓª½gPý:„ÁзÊ])|Toº|ÍãEÀÉë[3PœÃ.Ê= У:"¯™ï(K™ÌÖ‹Ìá}wîíyz¸^éiT,ÌÝL |nfˆÅ¾ëŠýAã2èÖ¾˜¿å 튨?Î@µA[Þ)½©øÿM²ïçÄiàÛ8¹ïßö¦mÑÑr›JÁaj{|û ¹1 j**wǧ8• —8~vzðIÒÂ5Ï帜£±|´<0×ÿf7Ñô4¹ž‘÷çE’aê%ùÉ®©(“yX\_ I~[ÈšܛߕIÛû&Y}¶K ËÿÁV Öå²#†߇L2:ÔÃ^lùej³•¾I¡é/ÌkGŽÖ GŒ¿VWüìñƒ°( )jL;çüŠ;–±Zp/¿ ,¾ A¥7áN¶¸âHBÿ7Lp¸÷Û “pÈa‚¦P Ë¬áÛÐÒPÓ^×y¤TTMÀa ØWr{êCUbãy=ñ×·<›íÏÀ ²3 >‘Š'kDËYb‘’P³)írßBEU–¢ ²y^ü<Ï |¶vRw9ÂÖƒrúì;xîC¾>¢rÐvˆ¤Ñ^@ÄXWPëY­õt‡Lå7ñ¤ ?ÓUÓ›ë>Äwÿ܇„Ä[V÷SÛR[V´ÞÀÝ:IÄu· (ÎdÓ©é•ËÊõ»]§X±|5˜¼{äúæa± nÆØ_ w•w+ê­Ë1ÿ6˜°NdùWïEp“!ý=¥4²?¹¿2Ë»æ¼%t=D’Âø Ð^ ØhÉ?íwã}Ô—ì Hp¥.+´m¶=[Úü¥CÙâ;ÝÜ0>p›ºT[ÃòŸjÜû\©î!É$ÿFï ÛÔÍC)Ô&RdïIºe X·Mt˜ÄïE/ëë×b¦ãÞ¦”WTô{èMÜ»¡‹7Keè…/d”®ÀÛ·(‰ JŽ7²^aÏ$j[[=tÌ„o„U(¨*=’7­Í鈫.º2=Vþ=ÆŽÍW¯µÒ²¸X/QÑïÂÁGA†ÈZ6uô‡ÈD—=3V _þI0Gˆ¢4xÊs1Þ¢­Ø Û 7XÑÌxLM’|ìÁv†a~]ïå3K?³ºÊP½¯_l<ˆ’ wž0žÜ/+ôâ¼{ Sn€ÌXlŠa,bžDçN¨Bã‹¥XWòØ„£±t†4!LÖ ¦øk½î€uÐ;YV´´ñÇÐͲú­<·¹>½ Ö¡](áͧ¦”þ/Ä2A÷}u% Ìç”ÜKq#:±ñ–*!• 4e–ž¶úé¤nà+eþa+Ý¡§>y«Á…ê\7u ]õ$ÍMâú6 TG §ò÷C£é[m4È¢ˆñ /Uíñ@Ùä†4¶ #J Uõ §þ¯^+÷õ~Q">úø*NquèŠÞîjÌÑí¸ÑɱáÓn+\_ÙòC…¡‹Ýq`qÿ²n.ØL¨½J¶KdW%!~›D~ÄI_GÍ_Q'ÙŸ¢±r$Þ L¿E¼ðÆõÜMí'ÃÏ­ÓxkÏ)¤?]…ùh€ÙÞ£·_&£ó`W"*ƇJšiE‡¬ly‡Œ}×rnðLDƒÐ]ÅW§8X²ñ—)ŠÁ¼,†­L#Û,RÅîè;±ª‚h{ü»,øÂf]Æ£„›hW7%5uw ¶I“lðhåbž¦X+¨ ;aù™LÉÒp¡LXXå%(¸ÝPéºÊïìa¼B j•=ÙO€ºDÝì6V,ò;*°a½—ƒ ¿(TŽÐè äÃv$Z=]FÏ/+XŽ4ûz\œ£&¡ú‚,ñ©r…¤ç ߈H÷€ÍÆRRCŠE³ÁŽÎW ¬ËD_U²,^¥¶íµÑ› Ǩæw×*i»4c—Ñ1/q/“Õ %< o ŽX„ªðƒ:L¾ô“•L=F$~Èk¢—Ò}ß…Pç@–ÃEb¼(Cn娴“Š ë3™é‘|~U…¹3 Ö­:õ‘‹¿oóÉÀOòÇ7íÚ­+çQ•¹È(æ®ú?õ ¸pbq¸±ü‘Ô @ZˆsjÌëÈ\ç­¿å¹ôþêü­œïo9‹Ÿè)šÊïLM‚©yÏvåðzÕ»HpPÉ?Ê漂Uõ/Æw:~&&Hauw2Ìe=K”i1zú ~¹H3V;"ŸŽJkp±íê¸þ‡È®*YÊò>î«ä˜åöCf»—'P×*H}añf•»â/š (g«¼ 樂XŽ £f;]]7Py8½êß@;Í;È’ éa‚Ê+_Aç?ÙÇ÷”Zwà!pOŽÔ,ä«øWþêÄ­El×K¨4Ôb/õ þV7„×zįBÊø4„N=õSù‚Çük6¬3- FWÌk¦SQl´·UQìVRдnTÝ÷تõç;‰^‚M혂„yž¿›V¯FŽ€>Y¸KpKÜÀG~p«]UþŽ4-ÌW^•ÛÓìËš–—2ýáÏŠØŠØn|@Åö¨›S3çò[ÉÝP\ã{†‚'瀲ß$®Á]Ta ¹©l[64×2¢q«“Šrˆÿ¦ ð~@’ù_AK9·w:½FF0^~•qFbÜ 8ã½l!G F%^&wÀÿ›Ýìt£~â-h…góÎÄ«Ûõ„Èúþ‹'‰m—„;×;µAè nŠZ œ“ÔFqUîk‹kÊ&ëv³jžà“jg cç×Ó…r2Öï°‹,À©g¥~ÑÌ»‡Z®fï&ÝòniòæN;AútŽyñq©…“‡wx+íA½º‡Á.& 0=Ü*TÊlg¯Üj©î^%]À¼£ôgÀÒ÷]C¿é JUÜ×ö´l0£ªP4&Ötó‰LmRº1X?†iG™t>КvˆÆG ¬ÖƒGÄï1¼ü&ãÔ#ÅÅ¡n:+Ñ í`[¯Zú‚±:W\8ýfB¹Û ʧCcÎN.3} “2¡¢pŽ§ª>pT•wŒ£gŠ<aåIoÊw­À}#@IÑ´ÃI°=H5)îhßQô7IŸCtÞ`g‡y_³càM̧ >»•³¯8°*>µ„9&â[/«»¦N{ÀH5OüÌ̇ÅS¦A%[h–˜³”XjèÚ¶ê'nœ®/M™/ŽËK% ãVòúy™uÙý`š/»y¦å lõÒ¥‰g/_ábZ¶½Ó}@ë;Än”EuxG†EïÃA/¿·@‹»+Ɇ‰Ð”s%+—Žº³ævÿ’éTÊ!𜫠rÇ(ò<Ú1a®ßQ3*²RVrs踷A,ÆKT"WÍ|¬}ºƒàoöÇÌ_C’³Ù>UÞžçۺ㒾KãŽ7MàwÁ×¥Ÿ0ÜH_î,SSÄØüv@ÚÀ= ѯ;]Ú4'ÒÎvÇ5‡> stream xÚ¬·sx¥_³&ÛvvǶmÛöŽm³cÛN'éØ6;vºcÛv2ý{ß9sæ:ß7ÿÌœ?ö¾žU÷ª»ªÖ]«®ç!ÿ¦¤J/læ`”p°w¥gf`â(XÙ™¸¹¨8Ø)8pËÑ«-ܤ]m1v8rrQg ±«•ƒ½˜±+  4ˆM,,fnnn8r€¨ƒ£—³•…¥+€J]E“š––î?-ÿl˜xýò×ÓÅÊÂ@ñ÷Áhëàh´wýKñí¨ \-s+[ @TQI[ZA@%© Úÿ¡äfbke ³2Ú»©æÎÛ/¦öfVÿ”æÂð—KØ` pqšZýuzšÿèŽ@g;+—¿Ï+€…³±½ëß3puXÙ›Úº™ý“À_»¹Ã¿rtvø»Ãî/ö—LÉÁÅÕÅÔÙÊÑð7ª’˜Ä¿ótµ4vý'¶‹Õ_à`þw§™ƒ©Û?%ý ûKóu5¶²w¸=]ÿ‰e˜Y¹8Ú{ýý—ÌÑÙê_i¸¹XÙ[ügtg …±³™-ÐÅå/Í_îNç?ëüoÕ;:ÚzýËÛá_»þWV®.@[s8f–¿1M]ÿƶ°²‡cü§_¤íÍÌLÿ¶›¹9þætþ×QýÓ3Ô“06s°·õ˜Íá\ÿ†Pýß©Ìðß'òƒÄÿ-ÿ·Èûÿ&îÕè»Äÿ¯÷ù¿RK¸ÙÚ*Ûým€ÏÀßAclø;kr€†­±3àŸceúÿq5¶³²õú?9ÿ×ÝšÀgý?9ÿ+üïÂö¢gfg`ÿ·ÙÊEÂÊh¦dåjj 07¶ý{xÿ²«Û›m­ìEþ×ùþubbú/˜š¥•©ý?j°ÿÚ›ý×þêö¯ ¥UdÔÅ¥iÿÓö_›•þv…«š—#ð?#iÊ;˜ý¯Å?T""žzfn= 'ÓßËø÷:r³°ùýÿ„ýó®å]­<ºL LLÌ€¿ÿÿñûÏ•þ¡·7u0û§T]íÍþ¶Þÿ2ü›º9;ÿUü_Óàoåÿ±þ×%=¦p+˦¼ß­3²3]ë°óG&Åtú˜ÁGBËÕJŠkz2"¶¹+ÞkCš¦y>Û½–N?öeh~õaÙRö¦/ üH©û‹P7(:9i‚ Ê3Ï4c|®å¶ t8˜4v&•U Jß¡§;Ya®ž¨IÝ‹1È‘üMÓâ1»Pš@ÐêŠOÏ(’Ÿ)‡ÆFG†{o û÷ñióâaÉy±ýSO¿¥¸z9ß7š~B¾ºsºÁ{ ú g~¸‘Ù“d8ˆÖ{Ï¿°Ru–Ý…L뉤»4®X61y_Ü[Šò“ Bß³8}ƒ$êHãLÃn¯Qöx™R7ieÔ³ºÝµÿ¤!úJ0R±fK{Þhk±Y¶òJ¬R©¬fë>Š¸)·àa$æþv)œí%®míoüa/N™xü–U4¶…åq,Uê+?ª6ÊjûÍ;1ÿõ„äñÜYD¥FÕœQà´~­ˆ©´Òz%æÖû½Á’SÊZ£½}ÞÏ`Hº Ôwô†ñ©•¹¥¦HÌä®÷Ht³çgÞ*Çlh5ØerÐ[ªòýÁ „f\ìuMé,Ê@/ÑG¼nö^®"S ôûT´MÀ¤²»qæwȼZŒ\|:n‚e¤2¢¿Ñ¯x©öE0’kP¼’_Ñ?°t[q0Ù¶à´}¦_â—Å>x`‹ðëpzMýM¤ξóiê®;š`ìä"òƒÃGåÕ”G\¦ÿéøêfT¡ç¸“¦L#ÂÉFÀâã0è‰8ÑÑ9¤]j>–è¾ï§R+‹ž¶ê¯éƒñ»wüÍ AèusüÍKÞ‘l‘ê}¼BqhZàj­YõÏ»¶Vt9°²¨ß«!wzú¹üoA®èvÿ’[¤ÊØÓBbÚ»ê¦:Ñ^OâfLM‰šk¤SùAÞ….›äjQL¨âš»žÈ+qbú{@Zã¡ó4ó°ˆÑ$˜Ìÿêêgã1ð†CUM]gL:M=8?(ˆÛÀΔ~ jË)ÿ…­A©`žþDÈíö«AOÎÛY+’JÞ„ïÏÁ–ÍPõ3:UùRXʼ»ÊU„–ÑuŽÝZ°I|š t†õ©­}èg˜q‰ñÚþF6˜{Z7…'ÿÅÜoöÕ±}s3`ååU@ÉÕd1û#ôC?]¥2LÞDÓ7%\½ŠÏ—¥Ew›ü³Ôò©-Ù 7ÿ«¯W÷¡wÈùì5EÞ ò2a"³ÈŒ÷ê#ˆB¸jg‹Gt®¸;ú¤±Ã× ƒòñw 9köÌ9¹]´Nçž6u$²i¥ýÞSäM䛉ë)3Mkš\æÐ 6. ~o†bC9m¯÷$E3¡Z-Ænïïz¿)“+¸éžE³Óìa=¯ eg)á .}EÇ×wâ³CçoØÑ'Ï e‹QÓþ0X Þlµ²ñƒù @[ ?sCÀj~–m!m·îó¬ÑâgÍÒ­)G›«„ÿÔâcÆû†Ï¯)ÿ4Ñ"{ÿ•yÅQ£ˆæƒ»KÄe7ÅéÝÏÍòÒKYÿ«cÑZ;ná~ÿUvŸˆ\Е}¦§Š›Ë~³ÄÞvi¦•ÎR­ù©ƒ_[Óa:þÓØÉHI=ÛÆϘuSmRx7¢¢ÒÜFjºÇ+¹O ™4Ÿuzß@ÚÓÐPyU¸AÇ:âS 0|A>½GgÂåTšl`IžP©±øùÜìC÷5dÈhÂÕs„O—¡”˃V’¾ RZ·–+' ø­\ö˜ë1Hd‘Q: •íe„5œ…ñ†jZ&ˆAH:vÉÓÜͯ¢Eǘí±L™Vì¸9’Õ.Mæ xg]¦Þ’6õãŸhëvUs%ê0âý¶dBÛ©û€>ÍÌ^yg>«iú`—<–Oõ_‰Yæ~¼îeLz×X8¶CÁs ôNve%Í€} ÞkÉŽd¸Ä¤ZSø=+nÛxæ€BE%ÔOF£+?kmΈÊ~CêUÊžPè&÷cY8–†˜6;ì¾Ü/SÛ/|Pÿ¼¤|G˜=Šíœ¶|ëË4—Y÷é€ÂX0­Øï ¢¼Æx€Ÿ´c\¸¥D˜Øe¸?¬‡M"²Õ±#Ç’‚mcÇ7C‡öc‘x¨M”òTîAhyu†ô^Æ,ƒÌ¼çBó>.P|tPªHNíËDþ ªDå}I ßçk/èC‰#› ‰q…Ýl§ö¤&ü'uÄÍÖ$¤çà7’´Î§·#õ=¦Í+¼¨î°WŽoúÅ'ï`ÑryÀ¦Ê,.ûNw­üV«"(dj®¶!'Ï#ËÉò¶WG/îÁ—˜qj}„¯¸£ˆ B+óÒ80Ý´PÛ~ýå$lǩ˪‡í±g¤‘›ŽJñXtŒŠ/0y] 9Ç|#]õz ®ÔHÑ·‡®\}òÌÁÍ'ðó†T»oƒî~—•‘"†þ˜+(ÜS“EîÛÖ§E3a9£|O3êG ûº:EGƒn¢¯³ìÑ ÈØø†P‹lÝ^éµì†!³ž…6ÒÔ¥Lòœ‘›€òx­œvø®·®½¡æ}y¡VÌB´ðc×n‡Zó°—ÍŠ å VòË}§KÝèöç ÅP}1Ð7b“)ÛœŸç~)\¦ ÔK¯ÓBÝO^`ƒw“7[lr¥ä_2n­¹åؽldDk¬VTbš—á›pŒP—R¼÷W‘æI/4-a[²CƒËCH ãgó`Ú(Bá¼z!Û»PæóŸ¾ä.;æ¬Âðg»} ‚EÈArËÊᲯùr!7Xm!;| mz+Ñž”>ˇù•e*än·lŒ~ÔØ Vó/ÁÕÐ=Òiø¥%’9;Áó,•k2…§âäŒPòm¿Óÿ(_ú„*F_$Jˆü D×i¸ L/AùÁM¡]¬G'¯Mí©H´¥6mñ#yž:Üj9Êk0 ÈU5Žç‰W1Aà@l”šO5tD_)%m`€ ÌÁùmÑ7âm)%*1,XuÃÄ0Á`¶ð4“ݧíÛñRt¼¼­­ø}—e.ëfÕ—¥,q<N>lÄú³ˆ&Ú@üÍG+éØ —Ïéõ}H)¨O3L]ƶé3® |øHø«D/FÕX²Ü€×׳„»_¯%$¡k˜ÙÎå³Ð8dT›sà¤ÊðODA³ü&65½äm­ÄXN )š|ÛǹD´˜‚ÕŸÂM²ýúqîHZŽ›ª߃—Ú1ªÔ±âz ~EخѻŠ^§¥öÐ2þ˜•E&ÁUrX{…α¶p«ôö£±gïìîwùs€b×!Œ5¸Í$Ìdƒ.mõG‹ö$³î®ËÁïXŽ®š·¬%Z’n¬ ›}¿™@b°„ð`¹dX¬H¸€ð‘øu/¡#Å1>;@Âæ\Åz)œ?Ɏ …ðæÙk)†|fÑZ;r›h`ÕFiÔ†qfÜb©.§ÂŽL·|‚™áì¨9ç 5¨ïÄ×uþ<±pkÕ?CøÒº7¹ß›)°?cöz«I*Ä÷±:ît<è—0DMAè•ÉÞFPÔ?G/GB:påð^Ï(çëm³TÛ¼DÁú|bSLçnúQšÑ ÂBJ0Gm®š`§µw1'ù˜Ôô1|…ÅÇ!æ‚%W¸ayÉ ‚\1w^A÷ªíùxz[Aædx»ÑRÄym#¿ÂÒý‰Ëã¿© |þš‘]™vöï™n`ØÀ·,(òܦpgÞ`m•vJ-˜MyA’ئ—‰' àIdâƒîŠQ”Þó­–dŠ·érbés­°§}{j(KZ¼exg&ì ¼(tÁgþÖ¸Ûçi³az AžÛ•?î¥íÔ½£س“ý¼)i®;3R:ÎòMªg/NéÛx\ÿõýÖ /‘u÷]G/ttâ ‚7-8\ÆDøxêCýDVšj“,¦ìsûX÷ý90?z¿àü.hω‚ö`Úêˆ-/Å{)¹)šV†4ÏQÇΈ+©$~LØ $Öùƒ¿/lþGl€†oF£;Lh¾½þ»$Ö|׋ä.CY.]¼fXM¥qqÿì¹õ¨ñe1ôˆ¸k"¶ÞÓámø1L5fÔ^Gï ±š†õÏ€ëk1÷!:øiV˜›ƒ-UQ/dksQúoðŸ|G›ûývRc˜4©- {Ý–ÔuWäEAbI Ö‡qÌ òj^;)»Ž<ç…´0ÓÑX8ªÞƒÑeq³-•ªéõ× ÚƉ(ÊÏ›D ¢¿=¹ž36+ˆ?ëã’oòÎ! SÊH [´ésãrª ŽYŒ¤ÖQ¾Ÿ]SÝ%bæW¥ô,ì;TQËi™GÚ¹Ô©pKÍx@JðÜM=¬ª¸Ä ŒÍÏ_Hµb×PD§ã^»öåév Ù_šI‰¥Ø‘HÐúô?½—ñ(y:Ì’öO1 ¶W\þÐ=¥W¸ööp%3ÕwoÿìLJ#=™"kOó§LM—*w¸€• ¿§?Þ°¢x×Âå§Ù·S :^@<‰ò$…k¼g¶Õ•Ôåi4ˆsM·TÐoŒEÌÑ.žf' 2@+D¸ ZŠ±'Q^Mó$OÔ½»^$œ4Þ¡Ý\?òˆð•¡Dõ‡É¥Å®ßÔÌV ¹)W>p$áùÊÒøŸ·Ð ÊAA)„Þ¤Ö×y6l<.ž7MÄZoi¾uÊ­gwÀúÌ c'ç"a¬Õ@ðõ艹å)VÕÒ^­…™܎ äæ?‰0ŽS_ËÊZæŽWaCÀà$špÈnü^×ÝuQìqÖr­‡ÃØóL«=‡†c)è=s&uúj.½Î•{ÿ–®þl¯9+¯mìQ°9ÂÚ%&–Ñ×p5î}•S2oj­hRŒZÕ5HujÀmŒ¤6ÅíŒû^)8©sÅI{Tjtd¾ËVto™ð~°TŠ‰ÿ¥½‹«lD‘¦WQÅÀÞ4ûjQMn¹ª¤|-ß)Þë±6¡ù1±`š³/]ºþ::Cg,Ér÷V%šû'qwD†¼â‹+Y¢'¨u¨bbxÕ"^Ÿn%ì¦ÔIüçé0ˆ—áÙ¯¥Í¨½­:D¤Ë3œí'»…,¬ãÔ†F´W$ÿ8!VDU¡ÙסÜ÷¾çû èöIî”U”U½ø'î 2\^8¥² ˆj:{YjŒ·ðeKa´!—0ˆ+Æ‘1,û„xÐìdl<ø¹~6Jc…fÞÓ!Þ3ºÊvx*Ñl/U DÝdÓ€]½²Uàú…ƒñn4°×j¨œ ÚZ:²›ÜÞE/OÍò–=ç™d©7¼6;´´ëž¢wg¦:X öøæ‰<ûí¸iWõ‹ScDä–,­FáƬ»‹ìˆbYA0»gI,Dkx\ý—å –™Î[}mš5Ð^»9ª“À-øüB¢™à‡„smtlË–—ÁåÐÏ·Ýع³2Œ Óhö(ÿ5<ŸÊ’mÜ4¢jŠüzDM]Ÿjü3Á.®P:­÷†Ÿ _fƒá[[ì3”[mu¼3  '¬¥¨_OÖ×Ê®lJBx¢˜YÙ'Óñ OÓ}Ô®s?#…¦ÉnÁégé˜1™ÈhÙ,-ƒšz‘LJ¹Œºº%eDzUbûtí5äú¢Ø«Á¬âúXîüB÷mÊ­ì~»83‰FJ×^‡K<ÑÑwÔ›!sã&rþñ,ƘI9툼(+™Ø™¿âí_žäÏAZ°ÙWS¯9ÖqŸá3ß9á3^Y:°XÑÀ¦ª¯§|èÚȃ=ÙJ+Ùª¨L½ GÛ ¤éZn$œ¼=˜ÔE>Qch8(üé‚êšC*vYÀOWbrvšvÀ¦‚{VÆC8M}ÓÃö"Õfh#¿¹æ!è`Í@è=N7ˆ1òzMG“/ÜwÛ?k®)‚žc¡ÿÓØÈ×?1¤è¸Â:…•’®<«6ÕÕ’ÁÏ}]ï×n²›J·ÒºªˆC1Ý©œ¿uééÕºØÚ(ËA¶5AKé‘î— m1ÚœöÕu¼°å½^Ù«–ä·­I;£Ëdš¢ùXf*’ÖÔ¤àôþÃ/G¼…Òµ$æÓÑ’¥'ÎNcÓÙiŽ¤”%(¯Ûß« jçŒRóÇ¿IRC±ä+;Ö,Zш°7+¨w jo’üö>YÝNk:¬üFdŸnwe{”¾¨ö¡À±(dw—`ø>œ¾çaý1ßC_e{´òÛÌþ„^á4Á(ø¦ÝZ¢¶È÷^ú°æê²Q ¸!ü¹$*¹™È´÷úç)˜n2Hée‘@bÛ'§äyÆ!"=8UôAÞ¬šî×VÁx#ó’@²œ3`i?úÁä2§`cm¿Ôr°3¿ †zcœïö¸?oÊlm(D¿¿”®µ_¿Œï›Ñ….Ž,2}C-?'±“žû@þ,Ãvðøy­ÝXÛýuz0©áÄϲè6%N³oÚ.ZÑ ;»mJÝÛK—PÊn.ɤ³VódBo³ø-†" ^;½ŒâÚÒL?÷cBÀg^‰¹q‘Â?êÞTø=’€jLtLÃyÑÿ-?a3©3§öŠÓµTù¤’ʸähÖâ蘛{‘/BêØ!Ëßñ ü0ºsïÈfý/ؘàL2ªŸwÊnÄÑ–©ÈHMpŒŒÙ!Õ–ýzP2+4 È'+4ÔÑ„>9®áÆ)9´*G"è UwÞ€@>.œÇf=ZË~VBšS¸Y…­1Ö®B>¨TÃî/uúd'Ðlú^R}³:R©e’¤)’vX¯GŽc^Öd5 ãxZ0e-Äë…YYvm –çÄÌ”ד’§³ ypüdz”4«ÓÔÓ¡”0OãŽ~ÒóùÀ§pSÇ…ào› ‹E†IÊ–·}ñ5”’¢iG™ßdh܉ѣ­[’T[|Øj÷lÃ¥XvÌ÷øé4+ÿ+BÈ`Á•»ÉiKiIS©ç®PP~Ð5êW¤Ô@|'~ŠoÖ…ú3 M›¤²LàÎaÅV&¡l$‰†ì€}ãæ;f¨ƒ8AxÚ1048»hT[–ì!mvÔf7²Ç?ÛHý›Ôúg¯âæl„š­Ðkx_j¯âY´±:ÝÔØ–ëS&ð±€!±"Œ‚fÕ/mÚj)„¥]ÀÕ’ôÝJÅÉ>ÿGßè¸k°VHÒ@ïGf‡Ó> ”‚‹.m,­Ð$¤?ˆr?Ö«_c¬Ï×~bc¶1@%ÈoC.UüÁl)™˜zæÐYÙn> û8÷8K§ÇÝ1„47Ó¼TéƒêN!ÀÎ0¥? ‘ÿÁ}ݶ‰!˜åç’íó[È·iD" Iì®GéÕ%Œvò¿U©çT‚s`ÙJ)Ö)¡~夫—»4’¬ƒc\97›úб'²5F³U+À`@©ÑÙ'Ùè0oé%¯›0b)ñc?ødà-ïu,î#È" ë)æ“=² täNž²ýaÐh7é3n’ }|xåú'ì[·ÖË”|AkË`È÷wŒ/na\# ¿mÑí œóÆÏùÝÒÏþ8Z'Õ6Þ5Ú–!ßW ©(dߨf ¡fAr<©YÚºÒ6S3O·TGÏI©ï¶ò²ê ¯ñÄ·~X*faYòî_Bî6»(رåEAû{b€¹!$‹è!ÆÆ5·ë¬ ÷'ÅvbA‘!‹cmÌ2±øNâ­ ]`5n‰G> Ÿíg«žŒ•Ï C,ßg©oêÜ1îƒävìÀÑqœ©Ÿ¾¾ÆÊè<̪ÖJhÝog\؉lò’Þ`Üı+òüàxS¦O˜Q%Ôð7Zä¯é~_+-ä ÷ÒPKÆ1Ld#—RÉŒùÌ ®L@þüu}V¤CüÇù"vL­Ìù2äb¶ ÒS[c´ðY;8§©+5À¤T4.£€×ÙRÙ%¥¦ÏwA¾œÄƒÿH“"Xp:|'…˽m÷¦ÉÄRWÕ¼}­º¥BpùätÏN=O±æ$jÒ›t Ãj¼ÈèBf…wLU¡˜Xÿ;à î°Þ¸õf[´ö®âþOë˜/UòJ·0®Ï@+!ÌÓd㦎*(Eª†O_T#º¶ÅÁÚZg5¹?‰‡s‰ÆàžfƧsˆ[Ê<{oøñߣ†ÁqŠ8¼Æ}©.df67×Î)|Ì”Ëò…„;nU?›ìŽ"†Wo4•À÷ïçP‡Çùç%9šÕol±ùÚ v“`À¬ô¯a0ìÕ|¸2x ”çt²µÀ2:è"$¬jë¼ ¡`Ýä:»Èlø\¶> €£ŒÇœz‰o+àZÂîÎZ ô´ª3D·X¡è ÑSÓqGР~o¼Âð97«Ü̦°—Æò¸Íܘe¬t&ÚÉß#¹<`5­_ )¾Ô*wú¯îº©¸½Š±M‚ nAÈ:¤ ìÁ<çÜ]ø E|8¾LoˆìF _ËŒ>µÜ$33$„HÀå õ{ƃ:Þ¡™¾ŠÍë˜5}w*ðM‚d/œ+,-SÄ“òpY“ â(tjŸ$0èÔ^WáB/$7€ríPóâƒ-àSBë2¥E&ìôRí© ²YOG ›óòñJ÷$As³jô$ìäõ:½ X_šÞ:bâž”wgçîn¤Íh89N?ýÒ³4yKÃ`œ¤ð7ÒTÔttŠw« ð ¦xª"Á£²­…ÃyK³¯(ùeËY¬)É_³a%cRÔ½¡|1X¨”îÑM £ú{ÅGˆ–NŠ‘øP‡÷¹b)?™‚V.ïøº_e*±ÂöÀvoØ¢“¥±ç ë+ä¸9Ó<ñ´Ýr»xd´1vfH>ÐmŽ›nœ~ñ:n1íˆxÎ@‹^00j2²æK²{{g4„2ê™,Í`ýª:3~Év&UÓwMz*²*”‚·R¤ˆ){Š¨hgd+lMaía+/‡Ä‘B,°ëžð‚$ ´)ùŒw<¤¸GpØ÷'UXiM€. ’ÔŒZíþ×y,ù¯9ZÓ16µ|‚¬„9Ȳt¢ó“—Å<ž-Ã.ü;æÑûŽ ʽ 6S_ÃŒ* ¼¹ÔbúLë‡ïÒ’™d­Ó“+¥†|ç lš™Áñ†²º&ѼÂëìüš{ÈÛå~&*ДíLLéG%$ÍÓ`ÏŸ´§–äEêFœ½èNšû³ê‰Ö·¼§­{fH¤:•âÅ‹–|£–Qzõç •…( êa|0zÝ|µ•„I Öå–S9=±ÂcQ3^—áó“zþ;QßÇ@öÍIz;À”¾RÄÃëû®ÞJœ8=5­¼S»²­!°ôî^¨µê)Óú¥^9mH‚ñÏbWü}ý2¬žÅgcŠ#“pGœpg’®! #vö==X.ÏK¿{=Á!×bÝK]“1CÀ”Þzá—^êùmãÔ|ÜM D ÿÐÊž½y¡G<ÁB ½N1-ÆzªÏÅÁ[„l%¬ñïáÈ¿oßWL44Á6—=ô²\s¤<2¾-:*ï?UÊs xŽ.ñ®“è·F—ã#ßdÔ¦¯‰ø…öN(c ¼¨F® &üqFD˜5³+èÁ°ËÏkR×*…~¾‡Co}ucW)ÓoÁJÙŸk‡¼†’ÜȾ7W²¨œñc¹ I[}Æé”qD”~Ð4$­<ïj¶ÐM¡ƒ_]ù3ê~-4‹í@Í)–G •q­«2T›e@†‚´½*ݪr×=aΞۈ?ÁÛ$÷¦¥A[Ÿ>Z'.¬šÕ\P æÑ#^ûgßîiÐÎ@Ce±;`(y‰9 t™è=£Üîõ½—T“á}§¯¶ŠÐ{Ò.HE’Oe`ïy£Ÿêjʇ´HÄ8ßó&¶-RnOà†ÔʧsÂMœDÒ„sÄ@y~¯»qmêG¢*o-ðâãiõp)G¬Êƒ? ¨˜êèòµiÖÿ4øÀË&Èl× Wß·LÑÓ"¦k¹ ë@ÈèuÓ‡€0?Ò€¤-±Q˜¼³щ€ùy–RæýŠ€6ÕðÒ<ù“ŽË/»¨ÇK ¤²ÝyV¦ÖxÀ˜”B»qšÍœÂÝæΩÑ~‰ªñyÆ,e‘ΪÙ.Ô@ÌØM³ytÅ|Y6Ÿ¤ëЕœ`­,†ÎIç^Ó¸W¡+ä—¼‹Ÿqíˆ2‘…µ”¶JVêNèYÁâ–•Ë¥fw^ŒóåÎ2;=='\Ü‘áp|EàÕæ½!D7,EQPØo;b"QÇXbSl™x¾;kUR°EQøêíß:"À³›‹¦ÂE©î‰P¦\²=gÝ춳¶[¯MB…Â’Õ+e°£’»5ÊÓeE¥‚6!§ª#=³šÁù³+En¹Ò»¦[¯éáç*fï]öòe¯S›«ª–þîP{íýÖ×  œû5’¶¸–¶ÔÖ!ç8®ãBPü8îþ‘,íED×€ªæ~¡õAó¡MàUGš%B¤ØŒZìLÙVÜ;~À«ëgc¥{­5ÁÇJÕˆ'0›xýqóƒl62Ô‰Âý’ or¹ˆ6Y$L o$—A .^ÌÝíú0Âh¦+—#öÅQéä þ=FÀ±tð*˜vlgj]ÆÕ8ä6m §‚¥ë4›¸ ²l§Åé$ÜaÍ¢óû¯¢ü‡jé~“¥]K˜Xɾn (ˆß7fj%kùlq­$Εs’Ì1–¶b+:Î7ËWƒ¾D¬z¥»ß$Gm—uíUµü¡qÓÚsùñ Z°;²8\£ö…Ëyh1:[•É]¯}ãYÍK ÿ-‚ðƒÌy^v£ÿxMM ê‚Õe®íŠ»¬ÿ[Hé;ºCyº¦Öß@‡—1¶KIxr¹¬C_QõÞØé¦þŽ›‹©îA¡ƒ“tW.ý7Ðßä‹’žÎ.{3HÕÌJÐÁ>ˆ¢ê‘auK½|ÂŒäF°m×?'•Í‘\‡¯P¢Ã *‹„¦dò¤—»ágÞ‡ÔX2¶üz¿ÚÆpk¢Î2Œk»sÄ‚þ²Ï'wòˆ(ãEÄ´ü`´ð̤íOl|EЉë 2É ™ó¿ÓŸm;zU:BXÎ/;#;a±1¢çE£j†ˆ«nâ/±ÂÈ(Pß<¨ÊŸ)ï9;O²Rò•›nÇǤòñ¸l~ðI#›í*\=UÜB¦0‚FJ Yœh¶šíÊtÏ|«æð¬Ì`r}ö©Eh¶)L¡?¡\2áò¼•ïåþÀ9)þt—'çÛìÚ±j `ò,5-î¸Q·"Ie ºÍëå²bU7to4¢,÷VDDgEÍèµßŽ‹,Øÿ`·žû@¾¹‘oÆjç„J‡·™Uœ@>¾Q~,ÿF*’6—ëv×n2‰–³÷"h·¼7á]ÚÂÏÓâô¼dò’7A YòÎpç;Q7!°ï¤Ç"¾_Líl‰};ñ3¿³'ÒDir5'ùäM¨¨ÞJø6¦,¬à°lJC›âqEËc# &]S ^ïH{"&(7Öü"óÁìhV*ß¾³KH´ž/#ÝñŇî=òE˜¾‹¾àS5|¡ñð²Ðb6ÞZŸÔØk=á|ÄßípJU—ZàT÷Æçýz¡¦‘í–ì ¾ˆšA}¸xx—qØ‹rdºháÿäM{–îtSÁ‹¦jÀ8º'xÙï÷.C­Ñ š‚òïÆ6^èE”ñ6‡iz…Ég(µÍcBw_öÌGàͦní0&Õ\]#miOô ¼Êó‹`²ØKpÌ…­µ}aÎ3ØÿÁȶÂÜ3õóû0¬ÚHñÓÓJ .H’’hÑéˆÑßâMÈO¬xBf‹£,Ú¿ß ~×Û†È ³;tº¬ CfÞÖÅéÙNc»Ù{¡g›÷“>ÕÉ6暈õqy†¼ž£eVï«:ݽW|Èá g1¼n\lìH+ûÖ.Ä,B±GêðþÌÛ<ŒIjßÙÛ €õ²+yþC3n*éáË Ž^E¬Z„]Å¥é¨.Ù¹·t˜=à¬çÈпÛNƒD_T¦dˆÆ¥ÎT~þ÷)lQŒaô¢r;ý0¹g2FiŠ¨bYS ŸÍ:’¤Á”à+Wîò&–#‰ÓSG³qüIã5XðËrÖѺù^{ËÝ–<Õ“ôÐ ¶ï‘åˆï.*ìÂ5Ò“Kç‡ÖÔÏÎGHv«‰ß]ûü‰½23±l2tcwüGS ºÎQåÄŸ¡O˜Ë|9¯xï$ZÕ¸`Έf›—Ê_•ÌÛYÉ»cò[¿Ð3VX¥éô„->°ž_‚ãÌ„`RŒm©žRKP!+(9¨cÐιí!R{Èo`%­ýÌ[BFõ@H‘¹WÕ˜)ÿ(B¹kÃ%yÏ£­ß'Ó;J»s-fÏó;˜Òl¥JÝÑú[º?ÕARîNöa€}«ñ6¨vëÜr¦·ò–€#ì‚}¯¬7Hê>-ªs#…$H×ÒD7ùéà^ÿÍ*3ª¡»ÂÍŸns*¿þ”Hû[]hmO±RÂH3Ö”îAƒmŸÉ¡âÖþ—«P¡wa¤%I˜Vý2e²•þU(5:®ã1i$Øhœ¼w«h ’Û¨Vç]ô\F:ñTÚS(w¤GÍ+sÒÌ%¬¶1#'þâúéÇ·ÞÓ|j:ßèQl}«ÁDu(ÏäªÊúøŠ‡Mn}c?ÙIÿ;åœ v#«zä 8ÍJ¶SULÓTF&¸ y“Žz”ÏÈXÓÜaÞùMøŠ¾Úl]€ìô ‰w+Ì.,?XÐ…ÖÌ°ùüŽó9bý6«8+ÕÑÚÆáË$Ó‘Oiº~4~Ç :¥ûß=X§äÕ1op…}ùg\ß¹N‡‚]Ñr§T²†Í!:A¸0Ui²ƒ…>)rcÛ  `³0Ìú€jv6yÚ·Ñny¼ˆ5ù3 ÏÐuŠšÑV©ÒKgªß=°í4:~Ð0Ðó).fDæ7͸,{P‰Â|ÑlÚ-°Œ`véÖ aèN”™fÅWDk80ømªXä. ŒgÕH!/¼ZIVul¢H}Ú%¥+i]ä¥"µ^æàï>Ù_êê³ùóDHàRrô€oÌ•pñî8ˆ‰,wˆ˜>5ph¤>y„ÐoP„j• IUQX ‚NJˆU.½Gx)#ÕßK€ö4£;u*šø 0³šâD…ªÄ—¼0p»òí…”ì’Béò¥.5ÜÎ5“Ôú]ÔG¸â-žï i)ÅJ›Iñ6Q+§šô»qê¥þ©/-$VE öÓ´6¥ŒËe(Ô°†¥J;NƬU = zô*œ¡÷ìµ8£%ýIJꬌõÌï9:ZÔ¬û(²!Ì }-S,_ãûŸàn‡DZ Ý‹Ÿ„¦Eþ‚$¨Î…NL,)vð¦Ò»HQÐTWèƒsÄ’êQè;ENÎÓŒM‘I‰~º .ñØ4nH}k­§ dE­Áï-èf!êü)Üá‹!ç]È©ž?èð†QK´‰L+T﫧Ü.«XK99s]U•< ä‘­Ã™Ÿ‰+9".hÙZÔ0t~›RÈÇNå]ˆØ Á»Sè;ñO$J~Ë3Ÿž£í}=ƒã“R Ÿ¡dÜË=°nÄX<óŠÐvÉk×½täk厎{¡Àd´ÅêU:&ÃVvroªˆEv–$»óÝ<9tw•Â~Èøq8=YÔµw¿Ó|c½±)Ú8ÔÖWÜ=“ÞhïÄÍünýqɉÊÙR¡Ñƒ?góì³Ú¡ë¦ÙZT¾•ôøA ‰?ßÙ4«g…dR ë~c{ah©WuÝ]“Nf6¦r©F ÙìYJ¬þz™q깦´hÿ ðé÷² C3ëíøx¿;NDxçúh€ä (žfŒ¯õuÔTÍài –M•ŠÀh“mÐ}P’—{¯‡Ü(ù- îèv •«òCógÚìi+@*‰®“i¨ïLyn<^ËÂöi+7U/£C¤ QàÎÏŸà„Â~Œ4^§,#KˆEOŸq^Þ¹ÄG«üi™¡ìqÚÂJ¨äÊCyþÇF8ås9h'Wê"ï戇n=C…’P,´¸NÁäúwþt•ŒËŠ&ÊM?ع$M¯±WŽ¦L¶é&Öñv&4gË¡ÛKÅÍsª« ø¯*d{—™Œ|ŸyO›‡:"h5'1`=m(¢Guî{…rå,("èäÌ‚­LzpZ˜¤÷²)ÇOÖ2îjÏÈ.’¹îä ¶ß ¹ôÜ…>;¶š-Î[T[/nºF9}·¿®²ÉlŒ4LÜVðŽ˜åhÕOr’D ¯‚‡ð_þéÁ wøIRÙ¡^îT:¤»‰òò 8ý²éϺò¨¨×4`u1ÄÎÿÉ$éÁ'ežJL½¬ªçÍ+öéõ±ëv~4ââÃÍWÎ"¿¤U8ú#&ù cº€Ô¢@[¢’"4·ID€þa#_‡€Áþu;‘)ÙÁ‚¯ž[æéÒÑÛ`š*èi´ôsQ°PŒVŸô J±ŠVã¨Ogƒ ºÌu9_éÂÿÌ©Ò“Öd_€!^mV4…rçd…$˜¥™ÜšL÷&¤Þa‘zOP»,¸²S*'yUˆ­¶ä‘ìELﯶ~gûÛÂ,UšŠ6¾äÒÓµ#J'Ï ¬AÞRrà€Â©°;†NTJø×›œúÇåPÄoLÆ2–µâ–çJoJ×÷¡ân^9NG,›Š&“JŠd•Ìá. c“j›.’}ìíë·iЂ½#e\dKSÕ{ dÛ›Â)Â6],=ߦ#úÕw6Ûi8ñ/h~”N:‰›TÍ DmßLhñ…9Î% <ÇÃ8~frþj©h‚õ€íªo?§²öÁ¦¹$é‹t‡ä)ú2ÂtÂò¸UºœÁÀ‚ß¡oA§~ðÕÂéoC®üš›ô´ïÎ?–ãsü)õÜ$nKåÅGh=Ë€’¡X ùµ#0‚¸j”i3Wzb—¸"X¯Ä3ýÖØ¢•Sÿ1£ÏQZ•Ùì°­89¹$•”´¸Â7» I"-Ô†»sI“!ýýÜmän¿œ-í·[܇m›SN•ÿ9†ìéIað筒̯r„¿_Hàe"‹žƒ!ez­îk,6¸ã¶·}˜ñ¸íægž‰ÔéãÌѶøñäœt „ù¢m€®cVAì ”·îÏ8\ƒÙ%ˆðq„y]öoÌÚ=dô ±tŽlö78ÈxòZ)ñ,£´d³!z݇ã(]1)óAîæc­“Fó·þ©?K§l¨_@t.½ ‰4#o&~TV• áðëŸP¶URU®ë jÀÓ,>›$Q’6ʨ ×îÒTF¦È˜±µXEDÊгOýîB!á’yhÑú ˆ×pvKx/k|­©sWqF:†l”«êðRäj‹›ÕÕŸÊÀ¡^(Jí2Øô]fãæ9Î%ó±*o}8Iå§g"½Âû‚¥¢ž®5.ƒdﲕ lgñÞ‰“òèsg:kêŬNE‰[+¹‘CÿÆüüü³Ê3.Ý„^ø¯®­ˆaô6í:ÇËm¨nÓš½ÿ+A¢¶*äú¤¤âžÙ@é;•Ê¯zŽbWDÌ^5f5m:†-=ú £þØêÐÀÔŒ™šJ²ÒGs~Ùuœ]oðê°ôNª1X KŽ >-Äv‰[½ê¬}º±b•¬û“ÉÕÀc³>!ue²Ø¡wd“¿o?k_&JÝ®dÆË2"‚MÅ¥¸^MÂ|Ã& ¹Œ•¸Ÿš?X0+drMÍE°Ë ‡¼­Ãí‹3q•Ó4aÓ×Ì8!¦ö›@¯NŒÙÖžMC 6½äÝÏY’ 4Þü“ÄÝjovݵ£`RAÕi„‚vÄfòÙ¹4¿]ÃÇË;Y^$DŠáCýÙ ý%-Æv áÒõJ3ÚJq%r'Ÿ.7îÚeÕ~ñß 1NIØðp_Tªf—`FfÖæ2JzÔ>|x·_A lˆ@ÏHfIýmš|ÛQ¡Û„Ôpo·oûvÉûŸ@ÐçJæRgŒž‡‚:²[S.“-œànETÖÛ ­ºÍ§=¬MËi¡¸ó›4¿ÊêªðYõó4iaF å.?G¶ÌR‰þûR`Úï¢1ö…Nµyt£ G£-„Ÿ>y!fð‚‚d×)¦r¦{[I[JÚ—Tã7¯Ÿ£ëúõÍÖ²‘–×OMp;gA N‰‚åb_'ÐW.x^3öÚûÙ¡˜Í"7û»Ì$¸ÊIÔM¯O·xÂ9Ç€†åp½ÏiT¿biÂà88ûG—”/’'’ GhÂA9émÌÖ™8ŸP6pŽöv­ä¤º·(Ž._O°»- fžKQ7Óäîë\Òjðs8Ö\Sð–±çÕö`QðÂ÷­va•if<&6ôï„© Ñ endstream endobj 4602 0 obj << /Type /ObjStm /N 100 /First 1011 /Length 6267 /Filter /FlateDecode >> stream xÚí<ÙnÛÈ–ïþ >Π³öh\ Þ'm'±µ‘EVÝ–%·$w§ï×ÏYŠT‘K1ó0T,«êÔÙ2vQ¢ðÒÆ.ºî¡Ú²PÖªPNZ_-b¡…-¤…'Z‰Â8¡ ­ítL¡­Å[h§±ã í%v`r G¡ÐÑ`'Ö`GŠÂÚ€YH¥iHAÏ(ìièY›Kƒ=‡cÝšç ¥h[ ÇĽ¡KÂICÄ1G0Ñc6 4Oi„»(S8! ÀP@M0”bÜYùÂ[AkC$¡¥b‚FÐDð©–Eô1bÎ, PÃQ…4 ä‘ÀèXH) Žœ¥Ž¸•eÒ[ÄX!eDN8Ë”¤³›ˆT±8j‘TÎá–i!¨ Ë´"Zs¤¶Ä‘—Ïí`P7<¤Q1t° ¶EÀÀai¼¢¹°ÌD:$pPZ© ˬ!Âxoq®‡e6zÐ<,nàh€eΣи˼¸°Kzàva0ƒx  ëð=D˜Á…Òp°€Eƒ\q‘ÑZ³'i8UPEœe øH«€t@bçApaŽGÞÃn–¤ è€Àš=cQúp¢õ°›øØ ä ÀçAÅ=$…³ˆ HJ 8ƒËqP#ΔÀ)\ (²ðö”—¤[É`p)"|nÂØ€<ˆ“p$`L .„”ÜFFØ&Xˆ£Ás* #9¾kÚŒ‚æ‡umÆp uËÒ—?Mû`%¨…× «æi­Už P4­m·àç?ðâˆ\º0ݸÍW9âu· IÛm¥òxˆt R-©/‡?pìȹmãmšŸö®aDnƒÖ$Õtî¸n-•‡ÀùÓeÓ (eÓ¼k_+ Me* ¯ˆLî[!:½‡´àn-ÙnÙ6¥fýho5’M^ÝçT_;#2žÙÃk´Ìny¡Š®¦j³C24Ñ&8ëH È&x´0¬^rOác,µŽ÷ðß•Á=>¨»À "*–‹$Ú’ ¶‘˜ãp–"µL+|NrY…Lw‰g>c=÷q š7I%"kšO˜hбR ÐȺýêùÁ¬~ĉك§„ô£{‰u( lx!E˜žAtÁsÑ’ãº4¯^—úàiê½q¼:þÀïóÁ”Z}dvàºgÀyècå µÖɇz/ŸÖ¤Õ)(ÂP'yI^åè<Å)OíÀºÙ4×+ /u$Ó„Þ#qôd¸¼Ca ,~>Ré …Ž,h’’=B•ÊazG¡ÞÚ‹ö¨QÜö¥Û¶ùžÑUéèªç,)*DÚ s u¨.1ª½º5K‘£ÒÁ ÏÂG ƒq”#:Ip<î¦ …7Í:$`TD4K$ÒœX¢!õlG¤…HbŒ£"‡§’û¬mRÍ’R¢šÆt2 !‘$Ÿl‹€Ày>c–ÃÁª¤ ÁØDD+žÒ[mãq ›¸ÌY,Uf4Ú0|3"9ªè©À—|)­ÊýKîWy$&ÿMÝ*ÈÉݹ—F?Ÿ™;«<–IOÉIwØnm~¶<3\’áÒ  „ºçp—‘hÿ(”€gXOâ4çá[ KnWWþ>"Mx^—G[LX—vçyžUϺ}ÕbŸ“¡ÛoÉW‘÷0ÑÒdOyqŒbŸ,สžÉÏP”™ŠUõF€úu=5Š¡¬!—Iñ“'rRNIr8Å­b.H¡)öÔ—R‘.Ò¤T"¡.q#oÉŹ(Ð;§Ò¦¢¥ê"MÒ)°Á#÷¹pÍý4âÉÒÖVY21Ô7š¢|—ÖðhZIãN¡^ñH¤¨(­Ìæó(’s½9QÃã§L5îS‹‘W²"e‰‰b\SPЙSð‘êoÂ×O´EÀmVɺù<$QîWu´ÆSÊ®ò½~¦ÍOÆ-òžyRW%܃åØœ°–d¹9¦!zGƒ”晆 ‡KŽ!_ã8*ŠzRÚš¶H}Nè½­Á$ÀÔ‚dµ‡¼-ztû jÑÖ‰‡Y_ƒUÖ9i-s¼G#Ì;š’M!A¯Øï)±×÷K®(w¼›¦oØ"]Öæû¯ ºKRDÉQyßí,UïT»0 ÌVìUJ=ÓÜòœTÎŽ”R[>ÅäUພǢ@t˜ø;/)׋ä!ÛíHµ{J VUDð…4r,çX]Øç—©œHPèà¥è¨.O áæSlƒm ùA:§õ† í6gI£dQ¾´T “\ö{h*Š;J¡#E3‘_× Äœ(VóC `–‡@E6Kù±­Œ¾ÌAÃÞÓòË#1'"™E dhM¤q^öÒec|Ô¢¯”cÉÍUœâ6©$W=ãLN>C"¨¬Dô§R ÛŽ";2rjžÃx^+©€æ=:ªÊDâZÄøÑòZ¢f0p&*a:ŠOò˜‹Û&Ý y].’#R%öÐTà"cb V,•ðUѽDÓõß¿¡+0›Ê£T3–Js)e<Ñ8›¤"¨¡sbjã(uq$M gbxZ½€dM§ “)ìãOP‹ŸUp’¦C¤œ#zþÑs‡”å>àQ'd”DfûW B¨æãµJ>ò«öÁ=ªÕÎyfþ¥D·º¯’^:_JX«$7Ÿ[]«$µº§y8^%¢!2ÝàjRZá†?„Q]sÜêÄ8·’×ô¶"ÖûW{8ú\…¤‰aÒ^–®ÖÈŒÕÉCˆ ŠÕ¯£ðsöœ…5Z6±-±=Q‹¡šË£Ýʸ­!x‡÷®fv5F ¨Æp.ÏGÑLg¨DáuE߈šM$y5kmó•\È䲦~˜ó“²I/2ª…‰¢.˜¬-À$YâW ¡.¬Ô˜¬PƒDÊ÷áׄ٦Öt ›Â‰_S_óñzMêט¬bS  ÎžåBLÏé;$AW«D[8ÛïFWÒ™*] GÓ%Ö„÷ÊÃÁÝóÑøæÛ²pÁí•Ÿ=‘¶9]&ãáÓéÍd#0p¹ݾƒ˜~¯üVÕ`“oƒ9~·ø_å—ù`8šŒ¾.¹7Ç9ÿÍç9Ã.Ò7’Õ——?BðÝÁ‡§/ÁR¬GXú‰&¥ÃœX!è‡#(*ô¤ìÇïi ³ 2Ç'oNÏß2n=.Ò3.ÚQmãçqÑ¢—«rXŽÊ¯³ûyù­¼ ç³i9›ŽÊ»r^.¿ÍG£rù÷¬üÞÂØmƒñÁé룯ãñ´¡â^´Ä=ßϽò <*OËßÊóòuù¦¼(/Ë·å‡rP~)¿—ÿ´0 Û`úÛñ›ƒ§€éq¯ *¨F0ÒX,F«®¦¡‰"CüV¢&ÇSËÏ»Á|4E-<ßܬî¾4ï–«þèûª¿¼ã>éîjºýÒº]f7Õtƒ›Ìg×÷Ãåõxq7üS.îooË1cô½eŒØ†ÒgÇ—Ï?]¥ÏNû( 6†…J˜ð¡Ò´y^õRûi9˜Ü}Cº™ËѼ—“ÑbQÎnG7P¦– ™­,à‹OgÇWŒ®êAWVè*÷Hè:Ûn ›­LàÓwïß\½ lÖ›@Yᢌ|$\Â\Êc2WÀ¼a9œˆ–×£Ér†ñ°ñßå夼-§då²ÃË­Ìá»w——Ÿ {¿ž•öÒ?ö²ûJ\QX[hmeûÞ|¸¸x{Nhõ!•_Þ>–Bš \=(ÁЗÏË—ÉØ£©¿"cÿ‰Ì}Ííšß£»Åx.0]eySh% ¤×à&“nƒ•ƒgvM±˜ ß@Dî˿Л”ÿiÒÔneåÞŸ|¸x…þä¢ÏÈÕL4ñghZ;{)zÄ4úó~0á¡r™É/ï&÷ þ3šÏZ¸oeò...Ï_¡‘¸è “”¨ƒý(¨ã´Ô‡3 Býëø¯0ý»0­¥Çbü=‹£Öe+ËyòñÙñë·Hßè3Q0Q{¢ø~y@¬©>[Ù«ó—/14¼=^ÍÕ6C<>n>-\¶2€>¾8|~„¸ôØ?]Û?í—~ë7 ÔëѲNàϹ^–o+YžŽ­ýê=šã©XÍ£¿FÓ–„_#ãn+£wyqþöék ãåÇÞ (I14¤{øІtö¡žÄˆ^Z~Ì+'ÀTCûϽÛñô¾å5ÝVVîèðù«—O Y»WÁ^¤Á(6ÊG@Õö«Àxúu</[IÛÊF½¸<¼|q@(õ%¸ˆþOmà£î1PR›¸wýeRcÆ,+oï'ËñݤèVÆëýųW/O Ѿ@Φôž-~p¦CNãL‡pø±®³VV·2pWg‡Gg„oŸµˆ/~ZŠ_?ûøøö ë„üV–æÙé»Ã‹w„І5âÒ–†ÞÇ>BýQÆ`>ŸýÍÌB›“$w-3¿ÜO&£ey=ÜΦ×S+aÎ-šæM¦ª–ûr ‘+&â,0Àâáa!²ƒëñp0iÑv+Ãöéýù³ã@Û««ÞØÜ!Ö<5}‰ŸyC)¤ÅÛš´J©í#×ÃTî¹"ÇÖuP~+÷æèêýá³_Î.ÎzË‘ øøšYi£ñ½oVäq-WWÈõyrßätŽÙE ‘­ ØÇ·ï.?ür>¾ýr¿8›M{r1º¹ï1eXMANAd憜²9BÖú\°>µ§<#Un}ævR>ƒìí´|AÜpðU]²Ã<î]ùr¹”Í nAˆƒéu9X€@‚÷“Ø#•Ãñ|xûu2úž¦*S„‘¦°V¾'ƒÛòkIåã·î¾AˆÔH±@AÖôþö y|C©d QÇ\œeRèõgùçýl9Bû@žI èèvÌ'^…gURº ÓîËûé5Îæ#ÈTÿæ\ujlç">½9‹¿=9]{pÏûD›êM×ÈšŽ%æ…`%b_Å»i$ä#(ÔJ†-¸žM&à jU˜^£|¥”T¡¡ ™Tu´mÅõg’îM2½IÃVîëôãááÙQ‹Ÿdù©BÅOe2~úÐà§mx3é ˆbŸeçð~9ê±’}f0EÀ~d`y[ Æ-,Æ‹• ܲ ôÈÃde ºæ±Ÿ0‡4»ºát·¯Lå|<½ÙÂ^n”­­â‡Ó‹oO×È BŸ|aíÀcí@¶åË5å o³@T·Q[WBþŠl+ƒÑ”¯Z¶ Qq¬¹ôdþµåbN‚Ú’“ûÏ¥`Mðu<ήAЀ'ã¯_A]¦ÃѲzÂgRD’ÂB F¨ÐºÂ¸vï™™Lf·R€•.g(¬E¸æ ¡ÌO”K´`\§ª¬—Ð&zå‰$DæѹҜJ‡(ÂaÖ¥(,ÞN«!B0®&ˆò(f¥æ\ÚG‰úJþ'—püÉ•,ì¬ãCLÖ³ßÂg2‹fl“­I³’a²‡øWßj[‰_ ±¾@ÏT†õs×v€šÞYÒ-‚~ #úR/>¦†ÿ’Jby2ž/–¨ÖøVp¯ümPßYx?¾^~[ð»[k½6 ýIFç¶}|™XoVðÍöð[_QtÀû6xÕÀ_‰ ¾ŒÛÃo}ÓÐ7¢/•Ìà«ðoiÐ>}Õ”€³Îþ;Ào¿ïÀïJ ìg€ßþí7âl!€Ro¿õ»¾#€XêÁ_©°ù¹¿+€"G_åú·ú­·½mðVþý¾Úý­7£ø]ñ˱ϵOî`ýšï&;Àífã#ÈÛíÁ7ßvÀwDkÆ5x›KžØÁô5ßÙu ÇÐMÃðÈí¡7ß²µ¡;¹…ÝW;È}ûåTçÁ ¿ërôw`}ë}Q¼}8õÅ.V·ùn§ÞoÆÞçÔßAïZo\:àãFð²ásÄ’ß|Òïå&ð à;üÖËŠð͂װ92l¾]ÏïÀïJ^#à0¹äí¿]tïÀïˆ^È5?4ÞŠ×[+ï¤#„ZçœÐ¹ Ð,…ušÈQx{Áì+»¶:"Šï×úü²|”Ãm*vÎבâ†ùnø.åx›*}ãÙÇk¹~êý¨XÔ9¢ß|ÄÃŽøzp3Z앇³{,7íÁýœßd…´þåøzQÔ]ØòçEr0EúØ¿Ho×±š×Ï;ñ*m®ÿô_™ÜEàà«̪݀D>a9ŠÇ?Ãׄ¡ *äÑrw0RØ´Ÿâ”¿wMÆSj›F “sGP¦‚`NÒð‡*øÇÒw¬L¬ý I›þ–µLÿM:.ApéÏkK_áéà Ôÿ"hÄn endstream endobj 4690 0 obj << /Type /ObjStm /N 100 /First 908 /Length 2010 /Filter /FlateDecode >> stream xÚ¥YÑŠd¹ }¯¯¸?Æ’lÙ†ea ä%! !o! i–effCò÷9nËWeãöd·Üu­s¤sdëV )W¸8¨\òÅÂñbÂ?ÅB˜..®Èå’ò•$áÓ\/|IÂóë%šõ*I/©R¯ªòˆB©"4bQÎWLZ/ⱪù"©tE-墨ÜVxšûHsj+¾(i+$XRl«xQåòˆÛjAÀ9$peAòü £¦‹YJ‘FTÁ‘Z:ØQJDœ*öDlÖ̈}œd’MÁæRJ`smù2”P¯Õ'° P {H°@Â1@I@Ïû$L*Ôj¤‚¡0 „äö áB 6W£ܤEq’¹a5ÅAL-E–è!Úl‚nmö´’36'$&ñU{ÆФÁ#Áæ¬-Ml..Xkh¥`s-òW ÐF$E|%fà„‚EmÍÑ€(0Ex‘®”X±Àæ„â ß•rhBbsÎõÁ(0èÃ(0Uiªó¥¡5" Ôç*%¨beô£@ÈÂ(P¥yŽ5¶G(PS FªH“Q *Cg_šÑŒµ$„£@´ÂQ ÖöæÐ!2“"y˜[#ot„<¨Vô|@wüÜ{§* ?ó•)òÎ9(z› Ê!ts® $8]DBƒc¡­Óå*Äòøæ›Ç‡¿þ÷_/ׇ?ÿÃËçLJßþó矾\úÀߟ^°z="áúËãÃï?þãóõ7*°·ƒQlQí“ÊÕ¥ÂÝ‚Åßß~ûË©pA„C¢/4õES­/pl^Ò÷üJªÖo&^¤j µbZcõ…ê;¨tP©[¨•—ƒ‘gŸ¤ú*xÝaJ4¼R¼òš{pÿj*\ÔÑ`ŠáE"[”ΉSþ‹¬4Qµƒû #4ÖŠ"¥÷M°E¡wP%2à³-¬?$Y׋ŠÕ©ïªJÕ`²™&æ=®d2ªb"¥ÆwPU1†jÝ€«¥ë)Ù',b‹*¿ž*Š¥ÇÔ0à6ú"Ý‹üªh^aøG[X¿aűŸôCýSñDe@›ë4i,ª-ŠŒÅW«â•µ_½ dJY&œÞ0˜+=½Ê½Ÿ)X“Q÷zªú"*ãb ãVóãõõ®ßBd§3|Ýñ×ëKa?Œl§RÇÝPíT¾¾Z[|õ&(oë—tøZ¿š2‘Þq:zÐ.Ì»oo«¤?ýüåÇ?5°ß}üôùË•{øk»Ìn¹C?~ùñ­w¾»b¶ëÙë‰öÁ§—¿¾½¶¿æð\<<Ó‰óÇ—ÿxV Xt0šÁFtÇê®ÑáŽÖ|ŒNÏ™dÙ`õÃÚ±äˆEÏXÛ¼ÔNõ„•ò„•6XÉåNieÑ;}“ë›èhV¬“D–Xï®;ÏÞ_¦Ÿõ×oÒÊé®Ä|ääIÊ´³%º-q±eD[þ»ò£!õ-“qg„¸’ŽX“-Û¼Äm:añäŠìΣ¸ÜœXÓ!Úìjój÷hÞµ=»Út¾Xh–»NÍ6òìÍf^ŒfÓ…“Ü:ßF!Nìl!·…[ÂŒµ+ŸÜˆ ûèÎM;éCòh>"¥L`óIµÌL<šO*¯œ48¥–‰ó&é”}ØÏÑR³GÇc4?'ÂK+ì±^£÷™Œoßµ—ß“v”§ó4léÚÝyví,Ï¡¬œÉ9g¿n’^}ÚfìÊçEù¤ÏÑy]ùÑÏÊ·m6X®|',|Øæ¥îƒê+NX¼Ãr}•Xá˲\°\íô†Ú7ÑÉÕNñätœ2)ss4_›kXñÆ­&ÉMI‹)ƒÄ(wåF·!ê1z²!ílˆnCä=VÞgâÂK9IÇÖ0Ťivé,Í·Î¥¸[²œ žŠ—]¹âÂK8EótdwØm`=bM6lób·yÕ£yg» t²§›ú6ØlàÉ+yØJrh¶á&éÅÓ®\r(œ¢ÃdílnÃ2–W¬É†m^>¤eÒ+ÖdJØ™â×—á;cq®¨°¹¢ØG1×7Զ谋§ö˜G1Oíq§ÙÛƒôtÁ±Ol^&öJùlÊ(fÁJŽÅG¬gSF1 –›’'%넵3ŧ4çxÄâ kg‘OiÎG‹¦)Í»)Í>¥YÚOSšwSš}J³µŸ¦4ï¦4û”ætÔ>N5îf6ûÌæefßÑk7ôØÇ//ãwáÞ½Û±_ŽG}eê!Sz~Do¼È³Oi^¦ôMbÒíšË§4/SzI1î¤öËrló鮾…´rãóëÑ z«\ŸÒ¼L雤Sîû\æe.ýÍ»r}ó2‰×è©ãws™}.ó2—o,‹Þeâ#–×»¨0Ý/ö~1„çIøñZ³¹bŸËLoßI¶Âû$æBE¦„§·Á»šž°ß9D§œ¿Ñß$²Ö]Â÷7zªùýüã‡Í÷{ªêXóO+#zÙÿ˜B¥ž¸Ëóo)£«ýO°‹uÿebÑBYŠS¦=¥‘ì.Ñ£iï®É3ü;ÿîgÓk%w$çó7ý4}[8eú26ß6”ÒìÖe9‘NuŽª,·Ug[ç#vÁêébPš¢u×ê)í£{âzÿÌø?DÔ„ endstream endobj 4695 0 obj << /Type /ObjStm /N 100 /First 939 /Length 3706 /Filter /FlateDecode >> stream xÚ}Z[s· ~ׯØÇh:ny¿h2™*²ë8ÕmŽìxÚº“‘­“XÉJ¤4ͯ/^–Xòìƒí%>€ w¥“˜¤µ“”þ•“ q’ÆOÊÁØèIkÃóÚN絜,Î+?9œWzòÒH'óÒN祜"Î ЀÐð4"*9=Ep¬”š"8VAL5ÌÐ3Nøˆ ÂäAÏWzæèy'À;F4 …š0èõ(r D*7A Js`”2j‚@”¶bÂ_ g¢á¤,=§‘˜Èü rP €Á¸è&U<€'?iaÊØäð7 n½Æ"!Ák°øþ½øükðÉL:†€O œàPÖÀ“‡"­«ÈäÄyô!a" _0­ +¸P½I`“O²fiÖN6(Zá&'„r)#ÉðêÐà¬C,×yƒÞÀ¹‹±H)‡'`FEz2“7žžìä]Zë *Œ@sð<…)@†ð ³MèÁh°žž$T‚£'5…H i¨ièÉ@Ua)zø+ZbR»)º À‡öS †Ö¨3â€jPjtl Ü$¡˜„±ô¨àÑÃK×£¡jE k@ÝÀ‚„š à Ê ö#…€mI‹;(„ % QÖqo)IAY…[†b±à *ŽhC9tŒe¬¢CÁ"l7g¾þúà/ooŸî¶°lÚÍÁ_Ž¡>}z¼¼Þm¿æánûmko‚ý"Óèo·»Ç'ÜNixzM£lçäá̼Pß|ÓzÕ£^ó([6Í-L©jÊÄSÆ3Sv` 8¯¦ìš)ÍLÉ‘)3›’+¦tlMeŒ SsvôZv4ËNÆÈMé™v½F»f´ëíz¦]­Ñ®ízD»šiWk´+F»Ñ®fÚÕí’Ñ®F´«™v¹F»d´«ír¦]®Ñ.írD»œik´ F»Ñ.fÚÅí‚Ñ.G´‹™v±B{dñ‰뢲9éem24ˆ'V’£®$¯q@j¬œ†Jc´’š_Æ“z_v±§õ…ÊzX!=´œÇå¡2Æ„ÓÊ0 8T†=g®†U#kö¶7°^_‚°ŒÜ¡¯‰ñ<1¶M©ékb\Ü¿Òµ‰ñƒÊp•rgWÌ´”иJ¹“ûÍØ–7à>lg-7Óv7h*ó jǬÒÊщ9˜‹óR¶ÊÁ”nÛ/µóí¸ùù]œ¡º-ðÑñ4Ÿ™‹#“’£3r>"'$©åÔ²Û‹i Ú¬Þ]æ3tq„r_mFè|~ª•,°ÓstxÎgçâèäfÚÚœó¹¹86™vjŽÍæÌ\É;1‡fsMšI=it>VVãZocƒºl ÝòÆ´VëWùÀlQž_ßo§}õ§C(¹tO_ýIÒÈä‘¢‘Í#C#—GF>^¼€…Ú'¶þ ˜oïoŸ²ušü÷Ò-Åaz“-з°¡ŽckpÜ=ùëó—Ûÿ|zqõt½ƒVeúÎÓxo4;¯Nß^¾ÝP³ËYÉÇI’™ü‡§/OÔý‚¡“‡N.I;9ÝAEwç,X¸jyžÅý˜o(í"Me`—bÜ‹Öº¥˜ša9f1µBÑÅJý¬‡Î01õø°”u=‘XËQ½Ée¤l¹Žƒ[IË®H“n“cH˜vºLÒV "r´W¤)™"¦âóq!uTçÁ,@†áÒH–EÿžÆ1õ}ØôrK/B‘úÁB*SGÐô¡E¯Õ ú|Ãp†£Ï7ŒúE»ˆmj!Î,^h:³lx¡é¼ï;ÚÑšÁkðK—åiO5"‡™;}ä$çN9Ç º7ÜBÈ›AìC[äkÀsuÔmµùî*½¿UEç8¬Øœ—üÂòÕÅ)‰”ªÍ}÷ùñòi"éÕŒbÖìñÁÄկ׻Ç-Y)eñ´½Ç·_W› ðÛ“¨ý›DôÕIÛVDŸjo"}0êßÈZçU³‡Hø9_–/2IdIÄ:™F¤0ŠŒFoï¸ýÞ*^‹Ò—ÅÅ­5üBd[ñÛP=QPˆÅvM$I®ÓïOR!„!"ðG–‚ÉŒ|ñ-}0ÈvO7¯^BÙašE屛ǩÄdéΧsÕ©îØ->«V‡êôöñé·ëÝÕ§ÏÏ;Ú`Åìy÷¸EQ,?žœ_^¾9M_b2gßž^œüýÿ£lNéÙ«·o®>|øñâò훋ó+j‹¹&Îþñæ%}/êú ‘;¤çxȦÎg¿Üù«Ó·„¬hœÿ“’dë0“_~œ;¿<¹8% Ý«%xÊÓ=ˆËÍÅ{ZUüP†B9l²×œ.$?gÐg~ÎÿØ|~$A.‚‹‡O—»íO·¿ãŒÝ̵L½½ÿõævG²ëKüd‹“ËíîþÍ|Ë0.oûò|w‡ÄÓ—¿\oMfšš‚ëv`ã¸èuà6Í+\š3k›æ E׶álä&K-“æ7ln ½+÷W¡K«»t¾$—·úMsKÖ¾d|ÓÞˆuPKqzß åØØ°Û¤¬?ÇoØW ~oAqõ1þz1Võwñ »+/ãBžé´ q&ti%¿}uÖóûWÿZËqñ{ƒP™Xɽè‚?“i]hç;¿S\ì²Øp±Ïb»/Åðû5ø!ÛZ³¸dàâ}ùº^$ìØÏá\|÷nCí'›kš¿Ø6]>÷WÿHñ‹Áë߶/qG«úåE¥E©úå…šõéÝ ¡‰ì,2Ê7Âó"ìMòß(õoÿØÎÇSù¿{ìit¼d?ï¾ XA0?ÛÇ£è1ÝŠwjGÕæïæææóQ×X¶®—Dy[7Ï¿> stream xÚ…\Ms$¹½÷¯Èã”7FN‚?_|r¬Ã‡½­}ÐôÈmŨÇm©kï¯_à±2+™DfÝRIàá‘’ÉgÉÓÿòXëE—xÊ[Íóûc`G]ÚJÿõù1‰·Ã¿¾üüüõëóë/ºèªQÕ_?ýöO/__¾;¾ þúé÷¿Á¼¾¨Ï³º¬¡¸ÙúúôöïÇ/˜Åù·ç××çÇ9ÄmûooO¯³!)i#~ûÇÇó÷+”¸•¼üß#ÍsP‰ƒ‹dqlßÇñþùi ³9¶ñ|ÿüwI0qÝŠ_~~½F+þßç—÷Ÿž?ÿòüö¢)¯€žÿùñôýå¿>„*åyÌìƒéÝë; €6Zs —Á’9ëN‚†K“RáÒ²Õ  Sèš Ù£é}Ûõ8F¢jÆ€i°$—©”2ˆÓeª$ƒ8›x¤¨x`$>TÀžA4·úˆ¿½|ùx{~@åêèUfÑ#æNm•Sìdj„c˜;™˜L¤“)hf¢½¿7n ÜÔ±ðu ¼¾}yÿþòë—‡Í" DÑuÍOÜ·œT—S»UŒü²œ¬Ý¤ˆuØÇšë°5!Öa¿6w.uͽ'D9ì£LˆrØG™å°2!ÊaeB”Ã~¾Fó¡û¸é½m~ì~KÙû©eÚG9"Ê´rD”iåˆ(Ó06Frè}7s¼[Ü7%‚Lû G™ïd¼GyðAæ½÷Œx8/—®õ±óŒó~âàd+îp;ÙĸY$ƒ—xå®û%%p>:‹Ø›ÖÇÎ'Œ´ŸÆÒý,.î'1Â;÷â; >\•C—Ó¥k{äñõ›í· æ½E iÙ9†ß3ö"m–{¨¸ÊŸv•vâÖôÐU¼mîF¶¥ôáÆÑÝÜOÚí6¹-ÕÜûÇO7wpô&GÓŸèöíG§»„Ï”u9è56U——£^cõÊòAv£i%;rciœ*{÷}Î0]kÇ–mÉ‘[5:;rcÐóÙJÍâÈ•I™O°\ „¾Ë\9.#”ëï{0×ø:p®¿ðu]âë@ºþV—é|:ÝA…c,×û„£'OcÇ/âzã*×ûŠƒ!Gc‡”é•\†>ç¨ì˜Ó³…Ÿ;{$Zf/ „à e1^ ,§ë(îç^¼;÷p~ô_¸Cq8†¨ž§ÑÓ hÌž¦•|§ êeìt†ª}0^ðÐkðBîjl'XnGõì.Èy° Õxaðqßé•mmìY³úATGœGßÅ×Ýxè?¸Sº j·WáQm8ªñŽÂײ‚ÔCµ žîOöŽ*¼]+qçC',>ù‚M,‡jœl ¼®†#­- w᧵Üw¿‹¾½[ÅÚúõH‹ïtSsŸŽ¨ÇÔ_.üýé§W\B)±ÜCÛÞ¹–À¦À¼YN™š¨}Lj[QûŽ1”ëk³Õʾü¬-xùÇQú—‡²<´hñòO·øú{ká?tìŒy8_·R¾~^´^dyHËÃpaM-»:C—¥ÛâaX<¼Î@}Ẋ8ÿØõ‡?ÿ÷ŸþòCüËe4OÃâiX<½¶òòÏ»øúﺶÚȬ#O?ü±ýA¼Øùc(È endstream endobj 4890 0 obj << /Producer (pdfTeX-1.40.20) /Author()/Title(MUMPS Users' guide)/Subject()/Creator(LaTeX with hyperref)/Keywords() /CreationDate (D:20210803114946+02'00') /ModDate (D:20210803114946+02'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.20 (TeX Live 2019/Debian) kpathsea version 6.3.1) >> endobj 4859 0 obj << /Type /ObjStm /N 31 /First 298 /Length 974 /Filter /FlateDecode >> stream xÚ•—QoÛ6…ßý+ø˜®˜ÌK^’‡EQ è°­X›I÷ÔöÁI´Ì˜g±ý°þú’RNKª¾]ÑÔýιTtE€±F­j!ÆI·âŒ©…7jS-Ô„þ§`¢t›£INk‘ |·&k˜•"׆¹,¥ÒZ’¯•qˆµrFÔÖ^å R{$5¥»#IR‘)A‡JÉHî×`œuR)­e Ö8§uŠ~ºÊ§¶ûÕle@‹ Á¸Ô߃VñHÆåN`¼µ®0KåtöòålþÇòjc>ir¶ÌìÌ”BX8ž…²µø2›¿[Þ,·åþ“·oN?¾û|âÂçgÏÌÉÛÓ_?” _.¾Ì^½ÚE6I,À"?žb¼Œ@}k}äüV®ÒÈS¿§~Oý>° Ÿ¦@µ7zÒ¶½itBížÚ•Ú•ƒT Q?‚Ô¶¡ô?ûý|µ¾÷WJVJVJVÎO©Aó°ÿY?.é<œ_þ³»?ÄŠ(:pzRÂèôÏ—_Û®{¡\.·msµûwýÂʈêÕ.RC¤†è† §æ9/ ¬ýo·Ø.×·oò)=Rzä#uDêˆÂþ^^ïîÛF gµÙÞîn.Úûæg×&Pt‘è"ÑEâ$å$¢öûç!1Ø11ÑJ¢•D+‰D¢*؃Ä0ðè‰c"èt: ªB<@,ýÓ¨:Ž2眩*»ƒÄ°ÔÆ»10ÓP¦¡LC™cΕqXúû}bhÄO ÁZ±ð,=8¥¿‰:>FØÀn‘EbT%ö Që1Þ-®Ûf­ß=~F'`t‚щqt>ŸjùK»)?v_øe;W?þךù›Åv±Z_Ïæ–PÙû`›Í?춫åm¿¤ýÒéâ¦Ýôÿt×õ–÷ë«vþצåörã]{ûº³Xß$~Éû0[ endstream endobj 4891 0 obj << /Type /XRef /Index [0 4892] /Size 4892 /W [1 3 1] /Root 4889 0 R /Info 4890 0 R /ID [<97BFCA5649B0E7A6B429BDE73A818C48> <97BFCA5649B0E7A6B429BDE73A818C48>] /Length 11450 /Filter /FlateDecode >> stream xÚ%Üy+ï~×÷éÙÏ}ß÷}ß÷uÎ>gÓœeξý懰¯,0^°‡%\ãLˆä8È"‚”*eÊEqË#¨„-”‰â„º‰ƒ©’ Äæ–ŒR>ÇU7z}ïüñ®îGR«ûyžžî~===}ç¾ÛÛ³ìs? À`oOÏ@OÒÓ³¤§·§w¶ûÂò‰ÝÊèU¶VÙ.«}Яl›²V`PÙve;¬Á°²ʶ[]#ÊÆ”m³ºRÊî+Ûju,Vö@Ù«K`©²wÊ6[]Ë•½W¶Éê X©ì“²VWÁêÞž¾ÑÅÊ6X]k•-Q¶Þê:X¯l©²X7oT¶LÙZ«ñE›•-W›ŠÜªl…²ÕVã·+; ,v#*g§²ƒÊVZŠÝ­ì²8„=°WÙ eË­îƒýÊž*‹Ã?•=S¶Ôê!8¬,ê%ªîí–ÍÄ>/¶z Ž+‹}Žj?'•­T–²z N+[¥,”³ÊV+±zÎ+Û£,t_€‹Êö)¶z .+Û¯,¢r®*;£,2y ®+;«,b6 7”SÖoõ&ÜRv^YDô6ÜQvOY¯Õ»pOYä*â=÷•}TÖcõ<ìíé¯h ã_Y}•ÉÁø'«iW¦NÇ?Z}O•©ÓñVŸÁóÞ®ÎÇß[€Ê8gõ%¼RvXÙ[«¯á²·ÊÞXºŸ˜^¤,Þý LÆÇ_Yú¤LžÇcóf¾ÛØ½Ç ±“/”©ù^eÄÛ¿y59߯L€ÇŸ[ea~P)ãŽmžÁùaeçøS«ìÏwc1ÐŽ/W/ó’3ŸRvLÙ¸U©›_¬ì‘2u:/±óÝ ~ßIe­Jûüre§•ñ1¯¥Ì¯T& ã­jeóÝL66*ãr^ _«ì¦²ûVµîùõÊn+“ƒy}¾û±¡£{•Ý³ª±ÏoVï“¡y}~«2'²ñ;V5öùncÊ…(ù›×Øç»}xéze·¬jìó»•ÅþÉî¼Æ>¿WÙUe7¬jìóÝö1œpÉý¼Æ>PÙ5e×­jìó‡•}P¦ÍÌkìóÝÆ>\‹p]µª±ÏW6®L{›×Øç»U¼àÖ&e—­jìó§•mV¦­Îkìóg•=VvѪÆ>ßmo JáW;Ÿ\Tû|Þjl »å‘‘øŽøX|ùUeñg­ÆŽwh$Ý«,¾2ú†²>e§­F…ÝR3v7*ûŽ²+ÊNZ Q]ƒ#õØ¿8Ô|_Y4âãV# •E"\•9áµÁWv]YTq„º›ö…ÛbŸ[ñ\Yìsè‰ÆôBYìóA«Zãü+eqRµZòüeám¿U}¾Û¬u†”E,4öùÊ¢}쵪±Ïwûâ·ƒÊ"RÝÆžü|·±ïúÐã…ØÀne t÷yq5Ó.«}ÐÝ¿%“΢ã;­@w{K‹Ñ8wX‚ae¯•m·ºF”½Q¶ÍêBH)‹±Õê"è6ö¥­¨œ-V—ÀReQ9›­.ƒåÊ”m²ºV*‹Ühu¬V¶NÙ«k`­²htë­®ƒõÊbŸc5ÞÜÝʲ©8ÞµV㋺{°l.¥,6;¹UÙVe«­ÆnW¢b7¢rv*‹³÷J«Q±Qã{`/HzýH¥}°ß%Øx ¯á-¼óê!8 Gà(ƒãpNÂ)8 gà,œƒóp.Â%¸ Wà*\ƒë0 7à&Ü‚ÛpîÂ=ƒûðÂ#x i‡§ð žÃ¼€—ð ^Ãx qÐÛp0éY~'êê=|P/cðâË»K½_»pý:—«_÷‹Ô¯À¥é×Cà‚ôëà2ôë…àâóëEà’óë%àBóëeàòòëà¢òëU°ÖÀZX`#l‚-°¶ÁvØ;aì†=°öÁ~8á†#pŽÁq8 gà,D>%=öFmœPC7-­‡ÍIÏõ‹ÎÁy¸á\†+p®Áu…Û»·áÜ…18•ôiÆw܃ðÁcHÃ8„·§ð žÃ¼€—ð ^Ãx ïà=|€ð ¾rÍ70r0·-qAèlÜ9:ºï'=':ñæ>Õd×fEevЪ#š²ô ùlÜÊHÎlÜÀ,ÔÎÏÁy¸ à1LÀ{xÏá&„”K×AžçNA´ý^K·À÷Î}o’žŸùáØӸёÄÙ¸½‘ÄYIœ½YÑ›½ÙÍ “³‹’žÿo|vÍ'¶w4¡¹»ð ÞjŸÛYÁœÌYa]Ÿô¼üíØŠ“àgu?+±³;+±³;+±³;+±³;+±³;+±³'à$œžàYžÌYÁœÌYÁœÌYÁœÌYÁœÌYÁœÌÙÐ#˜³‚9+˜³‚9C­ÔÍJâ쮤gr4FE|~îz-þ¹nó2ÝCX²iúyNº¶ð¾–6»ÜZáz×ÅØÒkþÉõÃ]Ûëù’æRÿHoX›[‘ŸùY‘ŸùY‘ŸùÙ¨{‘ŸùY‘ŸùÙõ£¤çGžÄ>k³r?ûÑntë%µòˆ}q——Ù¡svÜ=Ýh)è…>臄!†°¦§gð?|×RÜÀBX« {1ñs?Øci¬Lzþ§ßêq!¼ Ž)‹Ô¸‹Þqï¼ âŽy Ä}ò6ˆ»ã÷Ä» î„÷@ÜÿÆìꤧðKñ½ûx» ÷](Â%¸×ÔÁïs¯;;µqÜ׎žw³£ñ>÷°£çÀëèp¿:z Ü¥Ž^÷¦£×Àé¨ÛÍÑ#IÏ/•c¯Fá¦;‘óðÚ}ÅÍê,œ´zË=NœîÃïÓ.çú¬[ÕÑ»àut Ü–Ž>€xË#x i‡Op;éùÕ¿»ñžÃ¼€—ð âÚ">ûÞÂ;ø½g¤¸m¶½šŸñ™Ÿñ™Ÿñ™Ÿñ™‘—y™‘º™Y K`)D¾Jzjÿ$6¿ ÖÀÚ$ÙâĘj<êxA|fÄgF|fÄgF|fÄgF|fÄgF|fÄgF|f@÷¤õ<‰ï¦™½šn\¯E@–+;Â5sâÙˆ¼ÌˆÊL<•9˜‹™îÕÈï};6CŽ‹|ÔU<Ë’™x‚!%3ñÜB,fâiÅMˆg·!>FÅ 3ÔÎ\Lzþp66ïÔüÙ?‚ÏwÀ?‘Ïñ±˜‰§x6¹%s ;7j)¶'3OáÃŒ0ÌÃL7 ý&àÄê+x b1#R3“døUì‹ä̼†xUhf„fæ=|p·%IìI’‰_豕·ðÞÃøŸà+ÏF¼¯’ÀD¤¾J’U+â…^ï[f)þ;ÇgcË>q 7IŽüZ÷ÛŽ­Š²>èO’_.Äê &Éñïï¾åÄÝ(J’“7ci8INýX÷…3›º8û*ÊÀ,„T’œûùxaQ’\_K‹a ,…å°VÂ*X k`-¬ƒõ°6Â&Ø [`+lK’·?ÙÝ—wÿs¶uññ‡»øôO»˜\ßÅײ‹?ö»øþå]üÀ×]üàLbaò]êWºø¡ïÆžn‡°vÁnØ{aì‡pÁa8GáO’ÿ,ÝÝüŸÙÚÅŸÝØÅ/îâGzà?vñÛEæïâGÿEÙÙ.þÜÿÐÅŸ/uñc£‹¿ðÓ]üøÇþH’Ÿøó±t2I~òïw_ø‹’óÓ¬‹Ÿñ‰©ßéâ/oéâ¯8¶¿ú‹]üçßîâ›ëºøÙ]üõî-mòsÿ[Ó«ºø/uñ7þZlôœ†3pÎÁy¸á\†+p®Áu…pnÁm¸wáŒÁ}xžxžHÃx’üWó±kO’ä¿GO<ƒ¸0< îøæÎ$É·$ZÀ0fE0+‚YIÁ"ÇŠ8VH®tÓþþV|L:+2Y‘ÉŠLVd²"“™¬ÈdE&+2Y‘ÉŠLVd²"“•m H•ž;JDE†*âSÙ•$¿ñ'âÛöxu9h •}IòÏ·Æ ÂU®ŠpU„«"\•Ø”pU„«rNÀI ¯B^…¼ yò*äUÈ«W!¯rÙ™!ž³2Xa°Â`…Á ƒ+ V¬0Xa°Â`…Á ƒ+ Vâ™/ƒ•xÒË`%žï>ø6Þ*ÏÁY´â,Zq­8‹VœE+oÀI°â$Xq¬8 VœÈ*N‚•¯Ôš°‡ðØõPxØzh¶¼ VÃX ë`=l€° 6ÃØ Û`;DvÂ.Ø !~/ìƒýpNÂ1X™$ÿænìÆ8ê¿n\ŸÚ«éØÝSpÎÀY8çá\„Kp®ÀUð_üÐu…p\dº wà.܃1¸à!<‚džqxOáÄSû ˆgõ/!žÐ¿ÏÛ}OÙ±:ÕYŽ‡é¬N‡UìuϧírÔË7ñfº§ã‰:ÝÓñîiº§éžï»[ý£øDJø?¹Ò_ì÷æOzÂWO0=Íô4ÓÓLO3=Íô4ÓÓLO3=Íô4ÓÓLO3=Íô4ÓÓLO3=Íôô8k’Þõ?û²ßõÚ¸}é0-ÓÇ!ÊÄbšîiò¦ãŒ¼iV§'½ûǦ„ašýiö§ÙŸfšäi’§Iž&yšäi’§Iž&yšäi’§Iž&yšäi’§Iž&yšäi’§Iž&yšäi’§Iž&yšä6—m.Ûá2$_IzO~#öY×Ìô[xÑ#ÓÑ&¾Ío›ß6¿m~Ûü¶£w„ßvô‰hÎm¤Ý“ô>~cóíèY’ôþì/Ǫºo*Ú*»í>´½´­¶¨´µø¶´å -m ±- mah C[ÚÂІ¶0´…¡- mah C[ÚÂІ¶0´5û6µíåIï‡Ç±øv<éˆCeµ­‰·5ñ¶&Þ&¹Mr›ä6Émahkâm)iKI[JÚì·Ùo³ßŽû(öÛì·Ùo³ßf¿Í~›ý6Ém’Û$·In“Ü&¹Mr›ävH¦±- íSIÄÁKDC6±$ ±hˆEC,báÄ`ã™#nðC”¨4ØoÄ“hˆ@CïATA|_ùl<K ú ` ¬…p9‘ôþ›oÇ'a@ìÆBHÁ"X K`©c›°´V@ôdöx0x5éÛ¦Y-ÙtÚ ë`=l€èêÞÑÁ½¢[{èÌ>ºvÂ.Ø '!ž~tÏ%ø,öyìƒèзtÂ!8 Gà(œ‚Ø«3pÎÁy¸á\†+p®ÁuÏYÞ„‡ðCîɤoðpìi§ð <>û^Â+x oà-¼ƒ÷ð>Â'œ¯Ì‰@Nr"œä˜Î1ºstç¨Í…éIߪ_Œ­,ôÈgƒË¼è¹ÕU»é Ä?¥¸üÊì3^Jú^þµ8ËÃðP{2j“—[ žÛæ$''9¹•° VƒˆæD4'99ÉÉINNrr’““œœää$''9¹!99ÉÉINNrrR’Û ¢’ÛR’“’œ”äN€„å$' ¹c°8é;øÛQ‚”“¡ 9ñɉON|râ“ŸœøäÄ''>9ñɉON|r"Ÿ\<¦ŸÜ-¸ w ç Hn )÷Ä,'f91ˉYN†r2”“¡œ å¢A†r2”“¡œ å$'/¹ãIߥ_Ã’«Ü{'ž4ÕÙøŠxÍyi½Ðý0ƒ0ðF B“‚Eà~aéX Ë`9¬€•° VÃX [!LLúîÿ±/Ñãž$}ñiœ_† ²û² ¶ÃˆA0» †¾ìð² sYz¢?åÒ²TçÆRY–ÃW–ž€“p NÃ8 çà<\€‹p .à ¸ ·à6\‡-Iß×'â°®8m¾÷Xó9ÀGørÓºdå +Y9ÈÊAVÝgå +Y9ÈÊAV²r•ƒ¬då +Yº³tgéήƒõ°6Â&ˆŽ¯-QMúþìíØ¡eNª/’¾¿û¿Æjì©}®ÅªC¨Z#´FhV¤²R’•’¬”d¥$+%Y)ÉJIVJ²R’ÁPR’!PR’OÑ•’¬”d¥$+%Y)ÉJIVJ²R’•’¬”d¥$+%Y)ÉJIVJ²R’•’¬”dE +YÈ MvUÒ÷ׯÆ^ñøýl86)ÉJIVJ²R’•’¬”d¥$+%Y)ÉJIVJ²R’•’¬”d¥$+%Y)ÉJI-ìwë¾ð÷âËß&}ÿ~½¥š0Ô„¡& 5a¨ CMjÂP†š0Ô„¡& µxˆ 5a¨9)ÔœjN 5¦kN 5)©IIMJjRR“’š”Ô¤¤&%5)©IIMEÔH®‘\#¹FräÉ5’k$×H®‘\#¹F^¼y5òjäÕÈ«‘W#¯F^¼y5í·v®QµQˆ±o½I߯‰º’¡Ó5¦kLט®1]cºÆtÆ5k4Öh¬ÑX#¯Ö½¶øçc£iÍ`Ô‰±×y<ªÕ«5Vk¬ÖX­±ZcµVµýš¶_ÓökÚ~-N´£¯äÊ…ú­z¡úaa†aŒÀBHÁ"X .÷o-…e°VÀJX«a ¬…u°vÀNµO“¾õ»±k’þ•K»`7ì½°öÃ8‡à0£p ŽÃ ˆñ‰§ F%ž‹xŒ@¼uŒ;¼u .C4É«p ®Cô’Ý€›p nø ÷` îÃx Ï`¶'}ÿéaåC÷Lj­¤ÖJj­¤ÖJê´äc%+=÷æÀ¼€—ð ^Ãx ïà=|€ð D ÷j"P’”D $%(‰@IJ"P’”D Dc‰ÆÒØ!ùIÒß:6¿(é¿öÍXÒÁXÚ Îk¥­° ¶ƒ”ä Dw‰îÝ%ºKt—è.Ñ]¢»Dw‰îÝ%ºKt—è.Ñ]¢»Dw‰îÝ%ºKt—bÀ)Ý¥fJw‰îÝ%ºKt—è.Ñ]¢»Dw‰îÝ%ºKt—è.Ñ]¢»Dw)¬:™—Cˆ/QV¢¬DY‰²e%VKk“þ­;jí ÐX¢±Dc‰Æ¥¯\Vô@½Ðý0`†` <é¾»‹…‚E°–ÀRXËa¬„U°ÖÀZXëaì…Pû"é?¶5öo#lMú¿‘‹Õ}°ÀA8‡á…cpN$ý¯êñYhFNÁi8gᜇ p.A ¾1Pø<2 ÜCGnƒÀ#wÁ°ß‘10Øwäâ;ò ìIƒá¼#/ἆ7ð&`{Òÿ7㞀^Œ‡­°vÁî¤ÿýï{qãFêŒ|âÓÞ’µÝzþ¾Å±š$ýßzKL§cˆÓi¦ÓL§™N3f:Ítšé4Ói¦ÓL§™N3f:Ítšé4Ói¹Jo¡¤ÿ§ÿY|%ÉéMªÄô6Ø0íÓ0½D%-*iaH CZÒ†´0¤…!- iaH CúÄ@*9HËAZÒr–ƒ´¤å -é Nw:Æ€Ó†t7“Óñ÷—ÜuÄÅð8„.i9HËAZÒ"¾–ôÿâÍøì7+ ¹'Ž‘SQ÷’´€¤‰O?…gච-é >iñI‹OZ|Òâ“–ƒ´¤å #¶ä -Ñ*êNu'€ºHÕêNu©kûu‰¨Û«ºDÔ%¢.u‰¨KDä:Éu’ëaÿQÒÿw¾ß!/u)©¯Húç—£LêÄ×7Áf‹úVºÔE .u¨‹@]ê"PºÔE .u¨‹@]êÌÔE .u¨‹@]ê"PºÔE .u¨‹@Ý© îTPw*¨³_gºÎt],êk’þͪîQ«¯~cÁb7„¡. õø-€0ÔãN õ÷ï¤PÑþœ×cŒ?çuÎëœ×9¯s^ç¼Îyó:çuÎëœ×9¯s^ç¼ÎyóúWv¨†!üÞLúë'¢,7ýÇ„pI2°`2^X#°R°ÃX Ë`9¬€•° VÃX ë`=l€° 6ÃØ Û`;쀰 vÃØ û`?ƒãpNÂ)8ÝÓÍïýAѸ—á*\‡®Ë…eQ¶½òÝŠKa9‚ïfÁbX·†pŽ‚7ÇÝËKa9\„KÐÝE…!8 Çà1¤íÕi8gᜇÛpîÂ=ƒ›p4éÿƒ¿Ç{Á¦Æá‰;‚~ˆ¤ƒ^!Œà!<‚Ç_>O ~cò â—%¿'y ñ+’׿y ïà=|€ð $±¬}”Àn”‡@0ËW¸²À•{}âVÒÿG)SîI®.‰%I,KbYË’X–IJ$–%±,‰eI,KbYË’X–IJ$–%±,‰eI,KbYËVDz8–ű,Že©+ËdY&Ë2Y–ÉòQ8 }ÉÀÊ籓ÒY¸òA8rZ–Ó²œ–å´,§e¦ËL—™.3]fº|$¶l˜iYlËÆš–e·| ¸l$j9R,å[ %e))KIYJÊRR&¾L|™ø2ñeâËÄ—é.Iv¥ã8â[a‹ý2ûeöËì—Ù/³_f¿Ì~™ý2ûeöËì—Ù/¥õg¹2^èƒ~€Ai¥Æ´rB ´¼•ZÞÊU¦Ÿ%'ÇcËÝÓןÙK«a ¬…u°6ÀFØ›a l…m°vÀNØ»aì…ãpNÂ)8 g@Û_¹2¸ÿÿľìƒ¬pÂY8çá\„Kë¯ÀU¸×anÀM¸Î>+ïÀ]¸cpÀCxÏ!ºK^þ~ìßcgþþ„£ x/ἆ7ðÞÁ{øáØ@ÆF3$gHÎœ!9Cr†ä É’3$gHÎœqÊͬ€•@r†Ë —™8+wuß½øŽT2ðß|‰%’3$gHÎœ!9Cr†ä É’3$gHÎœ!9Cr†ä É’3¼exËð–á-ã¿AƃŒ³|†éÌ1ˆŒDd$"#‰ÈHD†î ݺ3tgèÎС;Cw†î ݺ3tgèÎС6Cm†Ú µj3Ôfƒd–%áŒzŒÿ[™qˆ^ìgž0dèÎС;Cw†î ݺ3tgèÎС;Cw†îFŒ¦[¿sJ¿sJ¿sJ¿sJ¿sª~ï&ßüÑxsüp0˜ÿ+±ªaë|Né|Né|Né|Né|Né|Né|Né|Né|Né|Né|Né|Né|N5ˆ7ð=å×·)]â)]Ωñº¦Sº¦Sº¦Sº¦Sº¦Sº¦SºœSºœSºœSºœSºœSºœSºœSºœSú˜S…É@ùçcÇå@osJosJosJosJosJosJosJosJosJosJosªÁ¹žå”Žæ”Žæ”>æ”>æ”þä”_ §ŒÝO5âƒZÝË)ÝË)ÝË)ÝË)=Ë)=Ë)=Ë)=Ë)=Ë)=Õ)È)È)È)È)È)È)ýØ©Æñdà[¯âˆ¤D§rJ§rJ§rJ§rJ§ò¢Ë=€gŒ—ûÀeÅe——ÁåÌåaX#°R°Ã*X k üN$¿VŽïXâÖ¨ºÿRÿ eka¬‡ °6ÁfØ[al‡°vÁnØæ_Þûá„CpŽ€k³Ë®Í.‡pNÁi8gᜇkpFá tÿ%|ûûã`\›]¾7á܆;pîÁ܇ðëÄËip…wÙÞå§W›Ïa^ÀKx¯á ¼…øñŽ~¿Ë~Ò{ù#|ºj_T »@wîݺ Ô¨-P[ ¶@ma ¸Þ-,½…HÄÕdàß&ƒ;7ÅÒ X Qˆ‚Dè.Ð] »@wîݺ tè.Ð] »@wîݺ tè.Ð] »@wîݺ ¬X-°Z`µÀyaA2ØóØÝ#Î\qÉNwîÝ…¸Øvi_pi_ˆK{Î WA ÂP†ñâ Ĉ/_ ¾@|øñâ ÄX-\8‘ .Ӧ L˜.0]`ºÀtéÓ¦ L˜.0í÷ˆ‹:Lw¢ó€Ë—.;\vÂô³dpý·âÍ}Éàd:–HîÜá²Ãe‡Ë—.;\v¸ìpÙá²Ãe‡Ë—.;luÈ뤒Á#­ØüV'1RÌu¸ìÄoj¸ìpÙá²Ãe‡²3f:Ìt˜é0Óa¦ÃL‡™3f:Ìt˜é0Ó‘ˆ=z:·{ºßµÄQGT:Î R:t´ÆŽÖØÑ;q¿ET'óðÖqé8tDªCYGÖ:»’Á‹¹8T§–û1cq¯&ÓÉàØÃx‹€t˜î0ÝaºõÂt‡éNü¦0úòãgúLw˜îÄø5~Fr¼íƒ%°–AØ >ÿãñæ~†0 5ƒádðçžÆ[ŽÃrX+a¬†5°ÖÁz0–äíFØ›a l…øEävˆá;aì†=°öÁ~8ç`q2øCߊ½:‡áø5åÛ“p Nƒá+“%,ÿ\„Kp®ÀU¸×anÀM¸·áÜ…{ïÃxà1¤ažÀSxÏa^ÀKx¯á ¼…wðÞÄÅ@cÕqTãǤç“Áÿͨˆ¸´ÿ&i¨Æpm¨²_õð§:$WI®.T%ñTò<¼…wÉàÌ`|VJªtWé®Ò]¥»Jw•î*ÝUº«tWcèÝUº«tWé®Ò]¥»Jw•î*ÝUº«tWé®Ò]¥»Jw•î*¿U¶ªlUÙª²Ue«ÊVõ<,Jásìø!ˆªDTÂ1ˆj ^: $WI®’\%¹Jr•ä*ÉU’«$WI®’\%¹Jr•ä*ÉU’«$WI®’\%¹Jr•ä*ÉU’«$WI®’\%¹Jr5$ÓX¥±¿"%Æ¿x¼ÉÕÒ¦>ˆÑY¢.$ƒÿýÇû!‹ ðI{m¼°VÂ*X k`-¬ƒõ°6Â&Ø û` Ä™zl‡°vÁnØ{!žž/Oí{»¶ÀAˆBû1ó¦x*yNÁˆ{®Â5¸£pnÂ-¸ wà.܃1¸Äoz î„Ó?+xOá<‡ x/á¼v‰Š½œ 6^ÅÅl$ ’¡¾­1ÎðÖɸ¬Ÿg/ƒå î'Õý¤ºŸT÷“ê~RÝOªûIu?©î'Õý¤ºŸT÷“ª}RµOªöIÕ>©Ú'Uû¤jŸT퓪}RµO²5©²'Uö¤ÊžTÙ“‡AOü5©Ú'à `’€ÉÓ`èßdœ;Õî¤ÚT»“jwRíN0Ùmyÿ÷`¾sÉ$y“ÄO^'œdp’ÁI'™™Œ.f&™™df’™If&™™df’™If&™™df’™If&ÃLüÞÅ9lòÄ°éðŒ^œÔ˜Ì±¤©155¦¦ÆÔÔ˜šS“™&3MfšÌ4™i2Ód¦ÉL“™&3MfšÌ4™i2Ód¦ÉL“™&3MfšÌ4™i2Ód¦±¸• v~ vMûmçÖ4¦²é$Ý”ºf4g kJXS¸šÂÕ\‘ mü_â³$7InÆ1Âä&ÉM’›$7In’Ü$¹Ir“¼¦M›š_“Æ&M›46ilÒؤ±©!6å ©!6E¥)*MQiŠJSTšt7énÒݤ»Iw“î&ÝMº›t7énÒݤ»Iw“î&ÝMº›t7énÒݤ»Iw“î&ÝÍ®î¥c=@/ô©ÆÀÔCcC`¡±`š¡±…`r¡±E°vÂ.Ø {`/ìƒýpÂ!ˆX¬J†ý­Ø -Ó-“­S­­Ó ­“ m€° 6ÃØš ;ßqŽÀQ8ÇᜄSpÎÀY8çá\„Kp®ÀU0ÅØu…pnÁm¸wáŒÁ}xá<†4ŒÃx Ïà9LÀ x ¯à5¼·ðÞÃøŸ€ý¢*)ªÉ¢š,ªÉ¢š,ªÉbTöödhÏ¿Ž÷IIQJŠRRbÌM% Ř‘J@Š1•€cö))R[¤¶Hm‘Ú"µEj‹+“¡Ì¯ÆwW$¯H^‘¼âVØÛAÖŠ²V”µ¢¬e­(kEY+ÊZQÖŠ²V”µ"ñEâ‹Ä‰/_$¾H|‘ø"ñEâ‹Ä‰/_$¾H|‘ø"ñEâ‹TÙ*®N†FëqÂPŒyI„¡( Ea( CQŠÂP†¢å (E9(ÆŸ¢b‰/_L'CO*±ù葈z¢E HwñY2ôæx¼O"ŠÄ‰/_$Þ]åÒ¡-ÊZ6Õ¢¬_ù>úÁ­ñ–ÞdhîÿŒ%.[\¶b®°ádè§~4^ˆéÄ–¸7µ“­˜5ŒÕVÌ&C-ij-K†þ‹_OÄ„aR׊iÂä¹¥[“¡âÍx‹´D %-h‰@KZ"Ж´D %-h‰@KZ"Ж´D %-h‰@KZ"Ж´D %-h‰@KZ"Ж´D %-º[t·ènÑÝ¢»Ew‹îÝ-º[Ú~‹óç-Î[œ·´ý–¶ß’¦–¶ßÒö["ЊÚeºÅtKoM$C÷g¢Â^I„Y‘¦Ìg4‡ð6ú{ß“'-g–0´„¡% -sM™iÊìDSf@š2éÔéi§ü@mÊ”LSfcš†0ñm~ ;µƒLùIÌ”ÉSËa¬„U°L¼2µÖÁz0_ËTLg8Ì”iশ€y¦¶)D¦v€‰Þ¦vÁnØ{Áü4S~3uÂ!8 Gà(ƒã৒S'“¡ù¨ˆ˜1&ŽòL2ôß23MM]€‹p ü~ê ˜}jêškR£)SKM 0ñÔ”½L™5gÊŒ"S&™Š7› jÊ€f?e"«)3ÕLÏ:5&\›z f#™2sÁ”i®¦^€é«¦LZ5eŽ™)ÓÙM™Ò`ÊÔRSfš2³Ì”GHS朚ŠÉ­b&¬˜–*¦¾"~Žø¹øe"ñsÄÏ 'Ãûÿ0ÞÌôÜH2ôíïÄjLÃE÷Üâdèw–DYœ ˆŸ#~Žø9â爟‹wˆŸ#~Žø¹˜¨'†@uÏÍ'±•˜U…ó¹ÍÉÐï-2.ps1Í_÷?Sû?Å 1's»’¡ÎïE™XÌÉÁÜÞdèó?Œ2Ù˜¹ÉÐý@” ȵsG“ᾯ£L6ædcŽ€¹‹Éðâ/?Gü\Lt©6>G­'Û®Ç[ž$©{Fƒ/û,CŸµ”Ϫésüh<>¡¥|VMŸãÇc1v_…}VaŸUØgöY…}Ž©ÃTØgö9b¦Ö>«µÏªé³ªû¬¹|Ö\>Ç4aªî³æòYå|Þ™ ûK±W»’á {biw2üü7ciO2œýïbio2\úÝXÚ— ÿú¿¥ýÉðï6bé@² ù•X:˜,8r(–% Æ–ÇÒádÁÏ~¯ìH²àWÆÒÑdÁo…¼ÏÇ’ßYKÇ“‘ßK'’‘Óÿu,LFžü_±t*ù¡ïíËédä›ÿ,–Î$#¿ô½ï8›ŒüÆX,KFþÝŒ¥óÉ¡ӱt!Y¸ôD,]L¾ù;±t)Yø§^ÅÒådáßÿW±t%IõÿÍXŠù^cÆÞ%Iê+cÚ–Ç|¥1AiÌ¢º"IýqOø–OĬÊf¦ˆ¹”còä˜Y:¦’Ž¹£M=9áùøÄQ0ÍîÄq8f 8¦ýœˆ™–cjå˜K9&O¾á\Y›°§¦0ÿé„aV15µ)u'n r'îÀ]ˆ‰—c¦ï˜Ú;æ\~æ0“ìD\LL<˜Ö:æ±~ð^‚1æïœp[?aVщ˜ O|žø<ñyâóÄç‰ÏŸ'>O|žø<ñyâóÄç‰ÏŸ'>O|žø<ñyâóÄç‰ÏŸ'>O|žø<ñyâóÄç‰ÏŸ'>O|žø<ñyâóÄç‰ÏŸ'>O|žø<ñyâóÄç‰ÏŸ'>O|žø<ñyâóÄç‰ÏŸ'>Oü—®øŸÍÿ…ø/Ä!þ ñ_ˆÿBüâ¿ÿ…ø/Ä!þ ñ_ˆÿBüâ¿ÿ…ø/Ä!þ ñ_ˆÿBüâ¿ÿ…ø/Ä!þ ñ_ˆÿ²9I}ózwÿ¦ÿeÏÿ³“‰£ endstream endobj startxref 823765 %%EOF MUMPS_5.4.1/doc/CeCILL-C_V1-fr.txt0000664000175000017500000005314614102210467016370 0ustar jylexceljylexcel CONTRAT DE LICENCE DE LOGICIEL LIBRE CeCILL-C Avertissement Ce contrat est une licence de logiciel libre issue d'une concertation entre ses auteurs afin que le respect de deux grands principes préside à sa rédaction: * d'une part, le respect des principes de diffusion des logiciels libres: accès au code source, droits étendus conférés aux utilisateurs, * d'autre part, la désignation d'un droit applicable, le droit français, auquel elle est conforme, tant au regard du droit de la responsabilité civile que du droit de la propriété intellectuelle et de la protection qu'il offre aux auteurs et titulaires des droits patrimoniaux sur un logiciel. Les auteurs de la licence CeCILL-C (pour Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) sont: Commissariat à l'Energie Atomique - CEA, établissement public de recherche à caractère scientifique, technique et industriel, dont le siège est situé 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris. Centre National de la Recherche Scientifique - CNRS, établissement public à caractère scientifique et technologique, dont le siège est situé 3 rue Michel-Ange, 75794 Paris cedex 16. Institut National de Recherche en Informatique et en Automatique - INRIA, établissement public à caractère scientifique et technologique, dont le siège est situé Domaine de Voluceau, Rocquencourt, BP 105, 78153 Le Chesnay cedex. Préambule Ce contrat est une licence de logiciel libre dont l'objectif est de conférer aux utilisateurs la liberté de modifier et de réutiliser le logiciel régi par cette licence. L'exercice de cette liberté est assorti d'une obligation de remettre à la disposition de la communauté les modifications apportées au code source du logiciel afin de contribuer à son évolution. L'accessibilité au code source et les droits de copie, de modification et de redistribution qui découlent de ce contrat ont pour contrepartie de n'offrir aux utilisateurs qu'une garantie limitée et de ne faire peser sur l'auteur du logiciel, le titulaire des droits patrimoniaux et les concédants successifs qu'une responsabilité restreinte. A cet égard l'attention de l'utilisateur est attirée sur les risques associés au chargement, à l'utilisation, à la modification et/ou au développement et à la reproduction du logiciel par l'utilisateur étant donné sa spécificité de logiciel libre, qui peut le rendre complexe à manipuler et qui le réserve donc à des développeurs ou des professionnels avertis possédant des connaissances informatiques approfondies. Les utilisateurs sont donc invités à charger et tester l'adéquation du logiciel à leurs besoins dans des conditions permettant d'assurer la sécurité de leurs systèmes et/ou de leurs données et, plus généralement, à l'utiliser et l'exploiter dans les mêmes conditions de sécurité. Ce contrat peut être reproduit et diffusé librement, sous réserve de le conserver en l'état, sans ajout ni suppression de clauses. Ce contrat est susceptible de s'appliquer à tout logiciel dont le titulaire des droits patrimoniaux décide de soumettre l'exploitation aux dispositions qu'il contient. Article 1 - DEFINITIONS Dans ce contrat, les termes suivants, lorsqu'ils seront écrits avec une lettre capitale, auront la signification suivante: Contrat: désigne le présent contrat de licence, ses éventuelles versions postérieures et annexes. Logiciel: désigne le logiciel sous sa forme de Code Objet et/ou de Code Source et le cas échéant sa documentation, dans leur état au moment de l'acceptation du Contrat par le Licencié. Logiciel Initial: désigne le Logiciel sous sa forme de Code Source et éventuellement de Code Objet et le cas échéant sa documentation, dans leur état au moment de leur première diffusion sous les termes du Contrat. Logiciel Modifié: désigne le Logiciel modifié par au moins une Contribution Intégrée. Code Source: désigne l'ensemble des instructions et des lignes de programme du Logiciel et auquel l'accès est nécessaire en vue de modifier le Logiciel. Code Objet: désigne les fichiers binaires issus de la compilation du Code Source. Titulaire: désigne le ou les détenteurs des droits patrimoniaux d'auteur sur le Logiciel Initial. Licencié: désigne le ou les utilisateurs du Logiciel ayant accepté le Contrat. Contributeur: désigne le Licencié auteur d'au moins une Contribution Intégrée. Concédant: désigne le Titulaire ou toute personne physique ou morale distribuant le Logiciel sous le Contrat. Contribution Intégrée: désigne l'ensemble des modifications, corrections, traductions, adaptations et/ou nouvelles fonctionnalités intégrées dans le Code Source par tout Contributeur. Module Lié: désigne un ensemble de fichiers sources y compris leur documentation qui, sans modification du Code Source, permet de réaliser des fonctionnalités ou services supplémentaires à ceux fournis par le Logiciel. Logiciel Dérivé: désigne toute combinaison du Logiciel, modifié ou non, et d'un Module Lié. Parties: désigne collectivement le Licencié et le Concédant. Ces termes s'entendent au singulier comme au pluriel. Article 2 - OBJET Le Contrat a pour objet la concession par le Concédant au Licencié d'une licence non exclusive, cessible et mondiale du Logiciel telle que définie ci-après à l'article 5 pour toute la durée de protection des droits portant sur ce Logiciel. Article 3 - ACCEPTATION 3.1 L'acceptation par le Licencié des termes du Contrat est réputée acquise du fait du premier des faits suivants: * (i) le chargement du Logiciel par tout moyen notamment par téléchargement à partir d'un serveur distant ou par chargement à partir d'un support physique; * (ii) le premier exercice par le Licencié de l'un quelconque des droits concédés par le Contrat. 3.2 Un exemplaire du Contrat, contenant notamment un avertissement relatif aux spécificités du Logiciel, à la restriction de garantie et à la limitation à un usage par des utilisateurs expérimentés a été mis à disposition du Licencié préalablement à son acceptation telle que définie à l'article 3.1 ci dessus et le Licencié reconnaît en avoir pris connaissance. Article 4 - ENTREE EN VIGUEUR ET DUREE 4.1 ENTREE EN VIGUEUR Le Contrat entre en vigueur à la date de son acceptation par le Licencié telle que définie en 3.1. 4.2 DUREE Le Contrat produira ses effets pendant toute la durée légale de protection des droits patrimoniaux portant sur le Logiciel. Article 5 - ETENDUE DES DROITS CONCEDES Le Concédant concède au Licencié, qui accepte, les droits suivants sur le Logiciel pour toutes destinations et pour la durée du Contrat dans les conditions ci-après détaillées. Par ailleurs, si le Concédant détient ou venait à détenir un ou plusieurs brevets d'invention protégeant tout ou partie des fonctionnalités du Logiciel ou de ses composants, il s'engage à ne pas opposer les éventuels droits conférés par ces brevets aux Licenciés successifs qui utiliseraient, exploiteraient ou modifieraient le Logiciel. En cas de cession de ces brevets, le Concédant s'engage à faire reprendre les obligations du présent alinéa aux cessionnaires. 5.1 DROIT D'UTILISATION Le Licencié est autorisé à utiliser le Logiciel, sans restriction quant aux domaines d'application, étant ci-après précisé que cela comporte: 1. la reproduction permanente ou provisoire du Logiciel en tout ou partie par tout moyen et sous toute forme. 2. le chargement, l'affichage, l'exécution, ou le stockage du Logiciel sur tout support. 3. la possibilité d'en observer, d'en étudier, ou d'en tester le fonctionnement afin de déterminer les idées et principes qui sont à la base de n'importe quel élément de ce Logiciel; et ceci, lorsque le Licencié effectue toute opération de chargement, d'affichage, d'exécution, de transmission ou de stockage du Logiciel qu'il est en droit d'effectuer en vertu du Contrat. 5.2 DROIT DE MODIFICATION Le droit de modification comporte le droit de traduire, d'adapter, d'arranger ou d'apporter toute autre modification au Logiciel et le droit de reproduire le logiciel en résultant. Il comprend en particulier le droit de créer un Logiciel Dérivé. Le Licencié est autorisé à apporter toute modification au Logiciel sous réserve de mentionner, de façon explicite, son nom en tant qu'auteur de cette modification et la date de création de celle-ci. 5.3 DROIT DE DISTRIBUTION Le droit de distribution comporte notamment le droit de diffuser, de transmettre et de communiquer le Logiciel au public sur tout support et par tout moyen ainsi que le droit de mettre sur le marché à titre onéreux ou gratuit, un ou des exemplaires du Logiciel par tout procédé. Le Licencié est autorisé à distribuer des copies du Logiciel, modifié ou non, à des tiers dans les conditions ci-après détaillées. 5.3.1 DISTRIBUTION DU LOGICIEL SANS MODIFICATION Le Licencié est autorisé à distribuer des copies conformes du Logiciel, sous forme de Code Source ou de Code Objet, à condition que cette distribution respecte les dispositions du Contrat dans leur totalité et soit accompagnée: 1. d'un exemplaire du Contrat, 2. d'un avertissement relatif à la restriction de garantie et de responsabilité du Concédant telle que prévue aux articles 8 et 9, et que, dans le cas où seul le Code Objet du Logiciel est redistribué, le Licencié permette un accès effectif au Code Source complet du Logiciel pendant au moins toute la durée de sa distribution du Logiciel, étant entendu que le coût additionnel d'acquisition du Code Source ne devra pas excéder le simple coût de transfert des données. 5.3.2 DISTRIBUTION DU LOGICIEL MODIFIE Lorsque le Licencié apporte une Contribution Intégrée au Logiciel, les conditions de distribution du Logiciel Modifié en résultant sont alors soumises à l'intégralité des dispositions du Contrat. Le Licencié est autorisé à distribuer le Logiciel Modifié sous forme de code source ou de code objet, à condition que cette distribution respecte les dispositions du Contrat dans leur totalité et soit accompagnée: 1. d'un exemplaire du Contrat, 2. d'un avertissement relatif à la restriction de garantie et de responsabilité du Concédant telle que prévue aux articles 8 et 9, et que, dans le cas où seul le code objet du Logiciel Modifié est redistribué, le Licencié permette un accès effectif à son code source complet pendant au moins toute la durée de sa distribution du Logiciel Modifié, étant entendu que le coût additionnel d'acquisition du code source ne devra pas excéder le simple coût de transfert des données. 5.3.3 DISTRIBUTION DU LOGICIEL DERIVE Lorsque le Licencié crée un Logiciel Dérivé, ce Logiciel Dérivé peut être distribué sous un contrat de licence autre que le présent Contrat à condition de respecter les obligations de mention des droits sur le Logiciel telles que définies à l'article 6.4. Dans le cas où la création du Logiciel Dérivé a nécessité une modification du Code Source le licencié s'engage à ce que: 1. le Logiciel Modifié correspondant à cette modification soit régi par le présent Contrat, 2. les Contributions Intégrées dont le Logiciel Modifié résulte soient clairement identifiées et documentées, 3. le Licencié permette un accès effectif au code source du Logiciel Modifié, pendant au moins toute la durée de la distribution du Logiciel Dérivé, de telle sorte que ces modifications puissent être reprises dans une version ultérieure du Logiciel, étant entendu que le coût additionnel d'acquisition du code source du Logiciel Modifié ne devra pas excéder le simple coût du transfert des données. 5.3.4 COMPATIBILITE AVEC LA LICENCE CeCILL Lorsqu'un Logiciel Modifié contient une Contribution Intégrée soumise au contrat de licence CeCILL, ou lorsqu'un Logiciel Dérivé contient un Module Lié soumis au contrat de licence CeCILL, les stipulations prévues au troisième item de l'article 6.4 sont facultatives. Article 6 - PROPRIETE INTELLECTUELLE 6.1 SUR LE LOGICIEL INITIAL Le Titulaire est détenteur des droits patrimoniaux sur le Logiciel Initial. Toute utilisation du Logiciel Initial est soumise au respect des conditions dans lesquelles le Titulaire a choisi de diffuser son oeuvre et nul autre n'a la faculté de modifier les conditions de diffusion de ce Logiciel Initial. Le Titulaire s'engage à ce que le Logiciel Initial reste au moins régi par le Contrat et ce, pour la durée visée à l'article 4.2. 6.2 SUR LES CONTRIBUTIONS INTEGREES Le Licencié qui a développé une Contribution Intégrée est titulaire sur celle-ci des droits de propriété intellectuelle dans les conditions définies par la législation applicable. 6.3 SUR LES MODULES LIES Le Licencié qui a développé un Module Lié est titulaire sur celui-ci des droits de propriété intellectuelle dans les conditions définies par la législation applicable et reste libre du choix du contrat régissant sa diffusion dans les conditions définies à l'article 5.3.3. 6.4 MENTIONS DES DROITS Le Licencié s'engage expressément: 1. à ne pas supprimer ou modifier de quelque manière que ce soit les mentions de propriété intellectuelle apposées sur le Logiciel; 2. à reproduire à l'identique lesdites mentions de propriété intellectuelle sur les copies du Logiciel modifié ou non; 3. à faire en sorte que l'utilisation du Logiciel, ses mentions de propriété intellectuelle et le fait qu'il est régi par le Contrat soient indiqués dans un texte facilement accessible notamment depuis l'interface de tout Logiciel Dérivé. Le Licencié s'engage à ne pas porter atteinte, directement ou indirectement, aux droits de propriété intellectuelle du Titulaire et/ou des Contributeurs sur le Logiciel et à prendre, le cas échéant, à l'égard de son personnel toutes les mesures nécessaires pour assurer le respect des dits droits de propriété intellectuelle du Titulaire et/ou des Contributeurs. Article 7 - SERVICES ASSOCIES 7.1 Le Contrat n'oblige en aucun cas le Concédant à la réalisation de prestations d'assistance technique ou de maintenance du Logiciel. Cependant le Concédant reste libre de proposer ce type de services. Les termes et conditions d'une telle assistance technique et/ou d'une telle maintenance seront alors déterminés dans un acte séparé. Ces actes de maintenance et/ou assistance technique n'engageront que la seule responsabilité du Concédant qui les propose. 7.2 De même, tout Concédant est libre de proposer, sous sa seule responsabilité, à ses licenciés une garantie, qui n'engagera que lui, lors de la redistribution du Logiciel et/ou du Logiciel Modifié et ce, dans les conditions qu'il souhaite. Cette garantie et les modalités financières de son application feront l'objet d'un acte séparé entre le Concédant et le Licencié. Article 8 - RESPONSABILITE 8.1 Sous réserve des dispositions de l'article 8.2, le Licencié a la faculté, sous réserve de prouver la faute du Concédant concerné, de solliciter la réparation du préjudice direct qu'il subirait du fait du Logiciel et dont il apportera la preuve. 8.2 La responsabilité du Concédant est limitée aux engagements pris en application du Contrat et ne saurait être engagée en raison notamment: (i) des dommages dus à l'inexécution, totale ou partielle, de ses obligations par le Licencié, (ii) des dommages directs ou indirects découlant de l'utilisation ou des performances du Logiciel subis par le Licencié et (iii) plus généralement d'un quelconque dommage indirect. En particulier, les Parties conviennent expressément que tout préjudice financier ou commercial (par exemple perte de données, perte de bénéfices, perte d'exploitation, perte de clientèle ou de commandes, manque à gagner, trouble commercial quelconque) ou toute action dirigée contre le Licencié par un tiers, constitue un dommage indirect et n'ouvre pas droit à réparation par le Concédant. Article 9 - GARANTIE 9.1 Le Licencié reconnaît que l'état actuel des connaissances scientifiques et techniques au moment de la mise en circulation du Logiciel ne permet pas d'en tester et d'en vérifier toutes les utilisations ni de détecter l'existence d'éventuels défauts. L'attention du Licencié a été attirée sur ce point sur les risques associés au chargement, à l'utilisation, la modification et/ou au développement et à la reproduction du Logiciel qui sont réservés à des utilisateurs avertis. Il relève de la responsabilité du Licencié de contrôler, par tous moyens, l'adéquation du produit à ses besoins, son bon fonctionnement et de s'assurer qu'il ne causera pas de dommages aux personnes et aux biens. 9.2 Le Concédant déclare de bonne foi être en droit de concéder l'ensemble des droits attachés au Logiciel (comprenant notamment les droits visés à l'article 5). 9.3 Le Licencié reconnaît que le Logiciel est fourni "en l'état" par le Concédant sans autre garantie, expresse ou tacite, que celle prévue à l'article 9.2 et notamment sans aucune garantie sur sa valeur commerciale, son caractère sécurisé, innovant ou pertinent. En particulier, le Concédant ne garantit pas que le Logiciel est exempt d'erreur, qu'il fonctionnera sans interruption, qu'il sera compatible avec l'équipement du Licencié et sa configuration logicielle ni qu'il remplira les besoins du Licencié. 9.4 Le Concédant ne garantit pas, de manière expresse ou tacite, que le Logiciel ne porte pas atteinte à un quelconque droit de propriété intellectuelle d'un tiers portant sur un brevet, un logiciel ou sur tout autre droit de propriété. Ainsi, le Concédant exclut toute garantie au profit du Licencié contre les actions en contrefaçon qui pourraient être diligentées au titre de l'utilisation, de la modification, et de la redistribution du Logiciel. Néanmoins, si de telles actions sont exercées contre le Licencié, le Concédant lui apportera son aide technique et juridique pour sa défense. Cette aide technique et juridique est déterminée au cas par cas entre le Concédant concerné et le Licencié dans le cadre d'un protocole d'accord. Le Concédant dégage toute responsabilité quant à l'utilisation de la dénomination du Logiciel par le Licencié. Aucune garantie n'est apportée quant à l'existence de droits antérieurs sur le nom du Logiciel et sur l'existence d'une marque. Article 10 - RESILIATION 10.1 En cas de manquement par le Licencié aux obligations mises à sa charge par le Contrat, le Concédant pourra résilier de plein droit le Contrat trente (30) jours après notification adressée au Licencié et restée sans effet. 10.2 Le Licencié dont le Contrat est résilié n'est plus autorisé à utiliser, modifier ou distribuer le Logiciel. Cependant, toutes les licences qu'il aura concédées antérieurement à la résiliation du Contrat resteront valides sous réserve qu'elles aient été effectuées en conformité avec le Contrat. Article 11 - DISPOSITIONS DIVERSES 11.1 CAUSE EXTERIEURE Aucune des Parties ne sera responsable d'un retard ou d'une défaillance d'exécution du Contrat qui serait dû à un cas de force majeure, un cas fortuit ou une cause extérieure, telle que, notamment, le mauvais fonctionnement ou les interruptions du réseau électrique ou de télécommunication, la paralysie du réseau liée à une attaque informatique, l'intervention des autorités gouvernementales, les catastrophes naturelles, les dégâts des eaux, les tremblements de terre, le feu, les explosions, les grèves et les conflits sociaux, l'état de guerre... 11.2 Le fait, par l'une ou l'autre des Parties, d'omettre en une ou plusieurs occasions de se prévaloir d'une ou plusieurs dispositions du Contrat, ne pourra en aucun cas impliquer renonciation par la Partie intéressée à s'en prévaloir ultérieurement. 11.3 Le Contrat annule et remplace toute convention antérieure, écrite ou orale, entre les Parties sur le même objet et constitue l'accord entier entre les Parties sur cet objet. Aucune addition ou modification aux termes du Contrat n'aura d'effet à l'égard des Parties à moins d'être faite par écrit et signée par leurs représentants dûment habilités. 11.4 Dans l'hypothèse où une ou plusieurs des dispositions du Contrat s'avèrerait contraire à une loi ou à un texte applicable, existants ou futurs, cette loi ou ce texte prévaudrait, et les Parties feraient les amendements nécessaires pour se conformer à cette loi ou à ce texte. Toutes les autres dispositions resteront en vigueur. De même, la nullité, pour quelque raison que ce soit, d'une des dispositions du Contrat ne saurait entraîner la nullité de l'ensemble du Contrat. 11.5 LANGUE Le Contrat est rédigé en langue française et en langue anglaise, ces deux versions faisant également foi. Article 12 - NOUVELLES VERSIONS DU CONTRAT 12.1 Toute personne est autorisée à copier et distribuer des copies de ce Contrat. 12.2 Afin d'en préserver la cohérence, le texte du Contrat est protégé et ne peut être modifié que par les auteurs de la licence, lesquels se réservent le droit de publier périodiquement des mises à jour ou de nouvelles versions du Contrat, qui posséderont chacune un numéro distinct. Ces versions ultérieures seront susceptibles de prendre en compte de nouvelles problématiques rencontrées par les logiciels libres. 12.3 Tout Logiciel diffusé sous une version donnée du Contrat ne pourra faire l'objet d'une diffusion ultérieure que sous la même version du Contrat ou une version postérieure. Article 13 - LOI APPLICABLE ET COMPETENCE TERRITORIALE 13.1 Le Contrat est régi par la loi française. Les Parties conviennent de tenter de régler à l'amiable les différends ou litiges qui viendraient à se produire par suite ou à l'occasion du Contrat. 13.2 A défaut d'accord amiable dans un délai de deux (2) mois à compter de leur survenance et sauf situation relevant d'une procédure d'urgence, les différends ou litiges seront portés par la Partie la plus diligente devant les Tribunaux compétents de Paris. Version 1.0 du 2006-09-05. MUMPS_5.4.1/doc/CeCILL-C_V1-en.txt0000664000175000017500000005254714102210467016367 0ustar jylexceljylexcel CeCILL-C FREE SOFTWARE LICENSE AGREEMENT Notice This Agreement is a Free Software license agreement that is the result of discussions between its authors in order to ensure compliance with the two main principles guiding its drafting: * firstly, compliance with the principles governing the distribution of Free Software: access to source code, broad rights granted to users, * secondly, the election of a governing law, French law, with which it is conformant, both as regards the law of torts and intellectual property law, and the protection that it offers to both authors and holders of the economic rights over software. The authors of the CeCILL-C (for Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) license are: Commissariat à l'Energie Atomique - CEA, a public scientific, technical and industrial research establishment, having its principal place of business at 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris, France. Centre National de la Recherche Scientifique - CNRS, a public scientific and technological establishment, having its principal place of business at 3 rue Michel-Ange, 75794 Paris cedex 16, France. Institut National de Recherche en Informatique et en Automatique - INRIA, a public scientific and technological establishment, having its principal place of business at Domaine de Voluceau, Rocquencourt, BP 105, 78153 Le Chesnay cedex, France. Preamble The purpose of this Free Software license agreement is to grant users the right to modify and re-use the software governed by this license. The exercising of this right is conditional upon the obligation to make available to the community the modifications made to the source code of the software so as to contribute to its evolution. In consideration of access to the source code and the rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the software's author, the holder of the economic rights, and the successive licensors only have limited liability. In this respect, the risks associated with loading, using, modifying and/or developing or reproducing the software by the user are brought to the user's attention, given its Free Software status, which may make it complicated to use, with the result that its use is reserved for developers and experienced professionals having in-depth computer knowledge. Users are therefore encouraged to load and test the suitability of the software as regards their requirements in conditions enabling the security of their systems and/or data to be ensured and, more generally, to use and operate it in the same conditions of security. This Agreement may be freely reproduced and published, provided it is not altered, and that no provisions are either added or removed herefrom. This Agreement may apply to any or all software for which the holder of the economic rights decides to submit the use thereof to its provisions. Article 1 - DEFINITIONS For the purpose of this Agreement, when the following expressions commence with a capital letter, they shall have the following meaning: Agreement: means this license agreement, and its possible subsequent versions and annexes. Software: means the software in its Object Code and/or Source Code form and, where applicable, its documentation, "as is" when the Licensee accepts the Agreement. Initial Software: means the Software in its Source Code and possibly its Object Code form and, where applicable, its documentation, "as is" when it is first distributed under the terms and conditions of the Agreement. Modified Software: means the Software modified by at least one Integrated Contribution. Source Code: means all the Software's instructions and program lines to which access is required so as to modify the Software. Object Code: means the binary files originating from the compilation of the Source Code. Holder: means the holder(s) of the economic rights over the Initial Software. Licensee: means the Software user(s) having accepted the Agreement. Contributor: means a Licensee having made at least one Integrated Contribution. Licensor: means the Holder, or any other individual or legal entity, who distributes the Software under the Agreement. Integrated Contribution: means any or all modifications, corrections, translations, adaptations and/or new functions integrated into the Source Code by any or all Contributors. Related Module: means a set of sources files including their documentation that, without modification to the Source Code, enables supplementary functions or services in addition to those offered by the Software. Derivative Software: means any combination of the Software, modified or not, and of a Related Module. Parties: mean both the Licensee and the Licensor. These expressions may be used both in singular and plural form. Article 2 - PURPOSE The purpose of the Agreement is the grant by the Licensor to the Licensee of a non-exclusive, transferable and worldwide license for the Software as set forth in Article 5 hereinafter for the whole term of the protection granted by the rights over said Software. Article 3 - ACCEPTANCE 3.1 The Licensee shall be deemed as having accepted the terms and conditions of this Agreement upon the occurrence of the first of the following events: * (i) loading the Software by any or all means, notably, by downloading from a remote server, or by loading from a physical medium; * (ii) the first time the Licensee exercises any of the rights granted hereunder. 3.2 One copy of the Agreement, containing a notice relating to the characteristics of the Software, to the limited warranty, and to the fact that its use is restricted to experienced users has been provided to the Licensee prior to its acceptance as set forth in Article 3.1 hereinabove, and the Licensee hereby acknowledges that it has read and understood it. Article 4 - EFFECTIVE DATE AND TERM 4.1 EFFECTIVE DATE The Agreement shall become effective on the date when it is accepted by the Licensee as set forth in Article 3.1. 4.2 TERM The Agreement shall remain in force for the entire legal term of protection of the economic rights over the Software. Article 5 - SCOPE OF RIGHTS GRANTED The Licensor hereby grants to the Licensee, who accepts, the following rights over the Software for any or all use, and for the term of the Agreement, on the basis of the terms and conditions set forth hereinafter. Besides, if the Licensor owns or comes to own one or more patents protecting all or part of the functions of the Software or of its components, the Licensor undertakes not to enforce the rights granted by these patents against successive Licensees using, exploiting or modifying the Software. If these patents are transferred, the Licensor undertakes to have the transferees subscribe to the obligations set forth in this paragraph. 5.1 RIGHT OF USE The Licensee is authorized to use the Software, without any limitation as to its fields of application, with it being hereinafter specified that this comprises: 1. permanent or temporary reproduction of all or part of the Software by any or all means and in any or all form. 2. loading, displaying, running, or storing the Software on any or all medium. 3. entitlement to observe, study or test its operation so as to determine the ideas and principles behind any or all constituent elements of said Software. This shall apply when the Licensee carries out any or all loading, displaying, running, transmission or storage operation as regards the Software, that it is entitled to carry out hereunder. 5.2 RIGHT OF MODIFICATION The right of modification includes the right to translate, adapt, arrange, or make any or all modifications to the Software, and the right to reproduce the resulting software. It includes, in particular, the right to create a Derivative Software. The Licensee is authorized to make any or all modification to the Software provided that it includes an explicit notice that it is the author of said modification and indicates the date of the creation thereof. 5.3 RIGHT OF DISTRIBUTION In particular, the right of distribution includes the right to publish, transmit and communicate the Software to the general public on any or all medium, and by any or all means, and the right to market, either in consideration of a fee, or free of charge, one or more copies of the Software by any means. The Licensee is further authorized to distribute copies of the modified or unmodified Software to third parties according to the terms and conditions set forth hereinafter. 5.3.1 DISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION The Licensee is authorized to distribute true copies of the Software in Source Code or Object Code form, provided that said distribution complies with all the provisions of the Agreement and is accompanied by: 1. a copy of the Agreement, 2. a notice relating to the limitation of both the Licensor's warranty and liability as set forth in Articles 8 and 9, and that, in the event that only the Object Code of the Software is redistributed, the Licensee allows effective access to the full Source Code of the Software at a minimum during the entire period of its distribution of the Software, it being understood that the additional cost of acquiring the Source Code shall not exceed the cost of transferring the data. 5.3.2 DISTRIBUTION OF MODIFIED SOFTWARE When the Licensee makes an Integrated Contribution to the Software, the terms and conditions for the distribution of the resulting Modified Software become subject to all the provisions of this Agreement. The Licensee is authorized to distribute the Modified Software, in source code or object code form, provided that said distribution complies with all the provisions of the Agreement and is accompanied by: 1. a copy of the Agreement, 2. a notice relating to the limitation of both the Licensor's warranty and liability as set forth in Articles 8 and 9, and that, in the event that only the object code of the Modified Software is redistributed, the Licensee allows effective access to the full source code of the Modified Software at a minimum during the entire period of its distribution of the Modified Software, it being understood that the additional cost of acquiring the source code shall not exceed the cost of transferring the data. 5.3.3 DISTRIBUTION OF DERIVATIVE SOFTWARE When the Licensee creates Derivative Software, this Derivative Software may be distributed under a license agreement other than this Agreement, subject to compliance with the requirement to include a notice concerning the rights over the Software as defined in Article 6.4. In the event the creation of the Derivative Software required modification of the Source Code, the Licensee undertakes that: 1. the resulting Modified Software will be governed by this Agreement, 2. the Integrated Contributions in the resulting Modified Software will be clearly identified and documented, 3. the Licensee will allow effective access to the source code of the Modified Software, at a minimum during the entire period of distribution of the Derivative Software, such that such modifications may be carried over in a subsequent version of the Software; it being understood that the additional cost of purchasing the source code of the Modified Software shall not exceed the cost of transferring the data. 5.3.4 COMPATIBILITY WITH THE CeCILL LICENSE When a Modified Software contains an Integrated Contribution subject to the CeCILL license agreement, or when a Derivative Software contains a Related Module subject to the CeCILL license agreement, the provisions set forth in the third item of Article 6.4 are optional. Article 6 - INTELLECTUAL PROPERTY 6.1 OVER THE INITIAL SOFTWARE The Holder owns the economic rights over the Initial Software. Any or all use of the Initial Software is subject to compliance with the terms and conditions under which the Holder has elected to distribute its work and no one shall be entitled to modify the terms and conditions for the distribution of said Initial Software. The Holder undertakes that the Initial Software will remain ruled at least by this Agreement, for the duration set forth in Article 4.2. 6.2 OVER THE INTEGRATED CONTRIBUTIONS The Licensee who develops an Integrated Contribution is the owner of the intellectual property rights over this Contribution as defined by applicable law. 6.3 OVER THE RELATED MODULES The Licensee who develops a Related Module is the owner of the intellectual property rights over this Related Module as defined by applicable law and is free to choose the type of agreement that shall govern its distribution under the conditions defined in Article 5.3.3. 6.4 NOTICE OF RIGHTS The Licensee expressly undertakes: 1. not to remove, or modify, in any manner, the intellectual property notices attached to the Software; 2. to reproduce said notices, in an identical manner, in the copies of the Software modified or not; 3. to ensure that use of the Software, its intellectual property notices and the fact that it is governed by the Agreement is indicated in a text that is easily accessible, specifically from the interface of any Derivative Software. The Licensee undertakes not to directly or indirectly infringe the intellectual property rights of the Holder and/or Contributors on the Software and to take, where applicable, vis-à-vis its staff, any and all measures required to ensure respect of said intellectual property rights of the Holder and/or Contributors. Article 7 - RELATED SERVICES 7.1 Under no circumstances shall the Agreement oblige the Licensor to provide technical assistance or maintenance services for the Software. However, the Licensor is entitled to offer this type of services. The terms and conditions of such technical assistance, and/or such maintenance, shall be set forth in a separate instrument. Only the Licensor offering said maintenance and/or technical assistance services shall incur liability therefor. 7.2 Similarly, any Licensor is entitled to offer to its licensees, under its sole responsibility, a warranty, that shall only be binding upon itself, for the redistribution of the Software and/or the Modified Software, under terms and conditions that it is free to decide. Said warranty, and the financial terms and conditions of its application, shall be subject of a separate instrument executed between the Licensor and the Licensee. Article 8 - LIABILITY 8.1 Subject to the provisions of Article 8.2, the Licensee shall be entitled to claim compensation for any direct loss it may have suffered from the Software as a result of a fault on the part of the relevant Licensor, subject to providing evidence thereof. 8.2 The Licensor's liability is limited to the commitments made under this Agreement and shall not be incurred as a result of in particular: (i) loss due the Licensee's total or partial failure to fulfill its obligations, (ii) direct or consequential loss that is suffered by the Licensee due to the use or performance of the Software, and (iii) more generally, any consequential loss. In particular the Parties expressly agree that any or all pecuniary or business loss (i.e. loss of data, loss of profits, operating loss, loss of customers or orders, opportunity cost, any disturbance to business activities) or any or all legal proceedings instituted against the Licensee by a third party, shall constitute consequential loss and shall not provide entitlement to any or all compensation from the Licensor. Article 9 - WARRANTY 9.1 The Licensee acknowledges that the scientific and technical state-of-the-art when the Software was distributed did not enable all possible uses to be tested and verified, nor for the presence of possible defects to be detected. In this respect, the Licensee's attention has been drawn to the risks associated with loading, using, modifying and/or developing and reproducing the Software which are reserved for experienced users. The Licensee shall be responsible for verifying, by any or all means, the suitability of the product for its requirements, its good working order, and for ensuring that it shall not cause damage to either persons or properties. 9.2 The Licensor hereby represents, in good faith, that it is entitled to grant all the rights over the Software (including in particular the rights set forth in Article 5). 9.3 The Licensee acknowledges that the Software is supplied "as is" by the Licensor without any other express or tacit warranty, other than that provided for in Article 9.2 and, in particular, without any warranty as to its commercial value, its secured, safe, innovative or relevant nature. Specifically, the Licensor does not warrant that the Software is free from any error, that it will operate without interruption, that it will be compatible with the Licensee's own equipment and software configuration, nor that it will meet the Licensee's requirements. 9.4 The Licensor does not either expressly or tacitly warrant that the Software does not infringe any third party intellectual property right relating to a patent, software or any other property right. Therefore, the Licensor disclaims any and all liability towards the Licensee arising out of any or all proceedings for infringement that may be instituted in respect of the use, modification and redistribution of the Software. Nevertheless, should such proceedings be instituted against the Licensee, the Licensor shall provide it with technical and legal assistance for its defense. Such technical and legal assistance shall be decided on a case-by-case basis between the relevant Licensor and the Licensee pursuant to a memorandum of understanding. The Licensor disclaims any and all liability as regards the Licensee's use of the name of the Software. No warranty is given as regards the existence of prior rights over the name of the Software or as regards the existence of a trademark. Article 10 - TERMINATION 10.1 In the event of a breach by the Licensee of its obligations hereunder, the Licensor may automatically terminate this Agreement thirty (30) days after notice has been sent to the Licensee and has remained ineffective. 10.2 A Licensee whose Agreement is terminated shall no longer be authorized to use, modify or distribute the Software. However, any licenses that it may have granted prior to termination of the Agreement shall remain valid subject to their having been granted in compliance with the terms and conditions hereof. Article 11 - MISCELLANEOUS 11.1 EXCUSABLE EVENTS Neither Party shall be liable for any or all delay, or failure to perform the Agreement, that may be attributable to an event of force majeure, an act of God or an outside cause, such as defective functioning or interruptions of the electricity or telecommunications networks, network paralysis following a virus attack, intervention by government authorities, natural disasters, water damage, earthquakes, fire, explosions, strikes and labor unrest, war, etc. 11.2 Any failure by either Party, on one or more occasions, to invoke one or more of the provisions hereof, shall under no circumstances be interpreted as being a waiver by the interested Party of its right to invoke said provision(s) subsequently. 11.3 The Agreement cancels and replaces any or all previous agreements, whether written or oral, between the Parties and having the same purpose, and constitutes the entirety of the agreement between said Parties concerning said purpose. No supplement or modification to the terms and conditions hereof shall be effective as between the Parties unless it is made in writing and signed by their duly authorized representatives. 11.4 In the event that one or more of the provisions hereof were to conflict with a current or future applicable act or legislative text, said act or legislative text shall prevail, and the Parties shall make the necessary amendments so as to comply with said act or legislative text. All other provisions shall remain effective. Similarly, invalidity of a provision of the Agreement, for any reason whatsoever, shall not cause the Agreement as a whole to be invalid. 11.5 LANGUAGE The Agreement is drafted in both French and English and both versions are deemed authentic. Article 12 - NEW VERSIONS OF THE AGREEMENT 12.1 Any person is authorized to duplicate and distribute copies of this Agreement. 12.2 So as to ensure coherence, the wording of this Agreement is protected and may only be modified by the authors of the License, who reserve the right to periodically publish updates or new versions of the Agreement, each with a separate number. These subsequent versions may address new issues encountered by Free Software. 12.3 Any Software distributed under a given version of the Agreement may only be subsequently distributed under the same version of the Agreement or a subsequent version. Article 13 - GOVERNING LAW AND JURISDICTION 13.1 The Agreement is governed by French law. The Parties agree to endeavor to seek an amicable solution to any disagreements or disputes that may arise during the performance of the Agreement. 13.2 Failing an amicable solution within two (2) months as from their occurrence, and unless emergency proceedings are necessary, the disagreements or disputes shall be referred to the Paris Courts having jurisdiction, by the more diligent Party. Version 1.0 dated 2006-09-05. MUMPS_5.4.1/PORD/0000775000175000017500000000000014102210467013467 5ustar jylexceljylexcelMUMPS_5.4.1/PORD/README0000664000175000017500000000307514102210467014354 0ustar jylexceljylexcelACKNOWLEDGEMENT: This directory contains an implementation of the PORD algorithm, as described in: "Towards a tighter coupling of bottom-up and top-down sparse matrix ordering methods, J. Schulze, BIT, 41:4, pp 800, 2001." It is extracted from the SPACE-1.0 package developed at the University of Paderborn by Juergen Schulze (js@juergenschulze.de). A lot of the code in SPACE-1.0 was itself based on the SPOOLES package by Cleve Ashcraft. We are grateful to Juergen Schulze for letting us distribute PORD. SPACE-1.0 (which includes PORD) is in the public domain, see http://www2.cs.uni-paderborn.de/cs/ag-monien/PERSONAL/SCHLUNZ/vrp.html "The fill-reducing ordering algorithm has been integrated in a software package called SPACE (SPArse Cholesky Elimination). The package not only provides an easy to use interface to the ordering algorithm, it also offers functions for the symbolical/numerical factorization steps and for the solution of the triangular systems. The factorizations and solves may be computed in serial or in parallel using MPI. In all cases, the important computational kernels are based on BLAS-3 like operations. Although all functions are completely written in C code, the design of the library follows object-oriented principles; there are objects and methods that can be applied to the objects (i.e. object creation, object manipulation). The SPACE library is totally within the public domain; there are absolutely no licensing restrictions. The web page http://www.pc2.de/software/space contains the latest release of the package (full source code). " MUMPS_5.4.1/PORD/include/0000775000175000017500000000000014102210467015112 5ustar jylexceljylexcelMUMPS_5.4.1/PORD/include/types.h0000664000175000017500000002053514102210467016434 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: types.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains the fundamental data structures / ******************************************************************************/ /***************************************************************************** A macro defining the size of integers (modified for compatibility with MUMPS) ******************************************************************************/ #if defined(INTSIZE64) || defined(PORD_INTSIZE64) #include #define PORD_INT int64_t #else #define PORD_INT int #endif typedef double FLOAT; typedef PORD_INT options_t; typedef FLOAT timings_t; /***************************************************************************** Graph object ******************************************************************************/ typedef struct _graph { PORD_INT nvtx; PORD_INT nedges; PORD_INT type; PORD_INT totvwght; PORD_INT *xadj; PORD_INT *adjncy; PORD_INT *vwght; } graph_t; /***************************************************************************** Graph bisection object ******************************************************************************/ typedef struct _gbisect { graph_t *G; PORD_INT *color; PORD_INT cwght[3]; } gbisect_t; /***************************************************************************** Domain decomposition object ******************************************************************************/ typedef struct _domdec { graph_t *G; PORD_INT ndom; PORD_INT domwght; PORD_INT *vtype; PORD_INT *color; PORD_INT cwght[3]; PORD_INT *map; struct _domdec *prev, *next; } domdec_t; /***************************************************************************** Bipartite graph object ******************************************************************************/ typedef struct _gbipart { graph_t *G; PORD_INT nX; PORD_INT nY; } gbipart_t; /***************************************************************************** Recursive nested dissection object ******************************************************************************/ typedef struct _nestdiss { graph_t *G; PORD_INT *map; PORD_INT depth; PORD_INT nvint; PORD_INT *intvertex; PORD_INT *intcolor; PORD_INT cwght[3]; struct _nestdiss *parent, *childB, *childW; } nestdiss_t; /***************************************************************************** Multisector object ******************************************************************************/ typedef struct _multisector { graph_t *G; PORD_INT *stage; PORD_INT nstages; PORD_INT nnodes; PORD_INT totmswght; } multisector_t; /***************************************************************************** Elimination graph object ******************************************************************************/ typedef struct _gelim { graph_t *G; PORD_INT maxedges; PORD_INT *len; PORD_INT *elen; PORD_INT *parent; PORD_INT *degree; PORD_INT *score; } gelim_t; /***************************************************************************** Bucket structure object ******************************************************************************/ typedef struct _bucket { PORD_INT maxbin, maxitem; PORD_INT offset; PORD_INT nobj; PORD_INT minbin; PORD_INT *bin; PORD_INT *next; PORD_INT *last; PORD_INT *key; } bucket_t; /***************************************************************************** Minimum priority object ******************************************************************************/ typedef struct _stageinfo stageinfo_t; typedef struct _minprior { gelim_t *Gelim; multisector_t *ms; bucket_t *bucket; stageinfo_t *stageinfo; PORD_INT *reachset; PORD_INT nreach; PORD_INT *auxaux; PORD_INT *auxbin; PORD_INT *auxtmp; PORD_INT flag; } minprior_t; struct _stageinfo { PORD_INT nstep; PORD_INT welim; PORD_INT nzf; FLOAT ops; }; /***************************************************************************** Elimination tree object ******************************************************************************/ typedef struct _elimtree { PORD_INT nvtx; PORD_INT nfronts; PORD_INT root; PORD_INT *ncolfactor; PORD_INT *ncolupdate; PORD_INT *parent; PORD_INT *firstchild; PORD_INT *silbings; PORD_INT *vtx2front; } elimtree_t; /***************************************************************************** Input matrix object ******************************************************************************/ typedef struct _inputMtx { PORD_INT neqs; PORD_INT nelem; FLOAT *diag; FLOAT *nza; PORD_INT *xnza; PORD_INT *nzasub; } inputMtx_t; /***************************************************************************** Dense matrix object ******************************************************************************/ typedef struct _workspace workspace_t; typedef struct _denseMtx { workspace_t *ws; PORD_INT front; PORD_INT owned; PORD_INT ncol; PORD_INT nrow; PORD_INT nelem; PORD_INT nfloats; PORD_INT *colind; PORD_INT *rowind; PORD_INT *collen; FLOAT *entries; FLOAT *mem; struct _denseMtx *prevMtx, *nextMtx; } denseMtx_t; struct _workspace { FLOAT *mem; PORD_INT size; PORD_INT maxsize; PORD_INT incr; denseMtx_t *lastMtx; }; /***************************************************************************** Compressed subscript structure object ******************************************************************************/ typedef struct _css { PORD_INT neqs; PORD_INT nind; PORD_INT owned; PORD_INT *xnzl; PORD_INT *nzlsub; PORD_INT *xnzlsub; } css_t; /***************************************************************************** Front subscript object ******************************************************************************/ typedef struct _frontsub { elimtree_t *PTP; PORD_INT nind; PORD_INT *xnzf; PORD_INT *nzfsub; } frontsub_t; /***************************************************************************** Factor matrix object ******************************************************************************/ typedef struct _factorMtx { PORD_INT nelem; PORD_INT *perm; FLOAT *nzl; css_t *css; frontsub_t *frontsub; } factorMtx_t; /***************************************************************************** Mapping object ******************************************************************************/ typedef struct _groupinfo groupinfo_t; typedef struct { elimtree_t *T; PORD_INT dimQ; PORD_INT maxgroup; PORD_INT *front2group; groupinfo_t *groupinfo; } mapping_t; struct _groupinfo { FLOAT ops; PORD_INT nprocs; PORD_INT nfronts; }; /***************************************************************************** Topology object ******************************************************************************/ typedef struct { PORD_INT nprocs; PORD_INT mygridId; PORD_INT dimX; PORD_INT dimY; PORD_INT myQId; PORD_INT dimQ; PORD_INT *cube2grid; #ifdef PARIX LinkCB_t **link; #endif #ifdef MPI MPI_Comm comm; MPI_Status status; #endif } topology_t; /***************************************************************************** Communication buffer object ******************************************************************************/ typedef struct { char *data; size_t len; size_t maxlen; } buffer_t; /***************************************************************************** Bit mask object ******************************************************************************/ typedef struct { PORD_INT dimQ; PORD_INT maxgroup; PORD_INT mygroupId; PORD_INT offset; PORD_INT *group; PORD_INT *colbits, *colmask; PORD_INT *rowbits, *rowmask; } mask_t; MUMPS_5.4.1/PORD/include/macros.h0000664000175000017500000000434014102210467016550 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: macros.h / / author J"urgen Schulze, University of Paderborn / created 99jan24 / / This file contains some useful macros / ******************************************************************************/ /* Some compilers (VC++ for instance) define a min and a max in the stdlib */ #ifdef min # undef min #endif #ifdef max # undef max #endif #define min(a,b) ((a) < (b) ? (a) : (b)) #define max(a,b) ((a) > (b) ? (a) : (b)) #define mymalloc(ptr, nr, type) \ if (!(ptr = (type*)malloc((max(nr,1)) * sizeof(type)))) \ { printf("malloc failed on line %d of file %s (nr=%d)\n", \ __LINE__, __FILE__, nr); \ exit(ERR); \ } #define myrealloc(ptr, nr, type) \ if (!(ptr = (type*)realloc(ptr, (nr) * sizeof(type)))) \ { printf("realloc failed on line %d of file %s (nr=%d)\n", \ __LINE__, __FILE__, nr); \ exit(ERR); \ } #define myrandom(range) \ rand() % (range); #define swap(a, b, tmp) \ { (tmp) = (a); (a) = (b); (b) = (tmp); } #define seed() \ srand((PORD_INT)time(0) % 10000); #define bit(var, d) \ ((var) & (1 << (d))) #define negbit(var, d) \ ((var) ^ (1 << (d))) #define waitkey() \ { char _s[MAX_LINE_LEN]; printf("\n"); gets(_s); } #define pord_resettimer(var) \ var = 0; #define pord_starttimer(var) \ var -= ((FLOAT)clock()/CLOCKS_PER_SEC); #define pord_stoptimer(var) \ var += ((FLOAT)clock()/CLOCKS_PER_SEC); #define quit() \ exit(ERR); #ifdef PARIX #undef pord_starttimer(var) #ifdef __EPX #define pord_starttimer(var) \ var -= ((FLOAT)TimeNow()/CLOCK_TICK); #else #define pord_starttimer(var) \ var -= ((FLOAT)TimeNowHigh()/CLK_TCK_HIGH); #endif #undef pord_stoptimer(var) #ifdef __EPX #define pord_stoptimer(var) \ var += ((FLOAT)TimeNow()/CLOCK_TICK); #else #define pord_stoptimer(var) \ var += ((FLOAT)TimeNowHigh()/CLK_TCK_HIGH); #endif #undef quit() #define quit() \ exit(ERR); #endif MUMPS_5.4.1/PORD/include/const.h0000664000175000017500000001027414102210467016415 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: const.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains constant definitions / ******************************************************************************/ /* matrix types */ #define GRID 0 #define MESH 1 #define TORUS 2 #define HB 3 /* graph types */ #define UNWEIGHTED 0 #define WEIGHTED 1 /* type of ordering */ #define MINIMUM_PRIORITY 0 #define INCOMPLETE_ND 1 #define MULTISECTION 2 #define TRISTAGE_MULTISECTION 3 /* fill-reducing node selection strategies */ #define AMD 0 #define AMF 1 #define AMMF 2 #define AMIND 3 /* node selection strategies for generating the domain decompositions */ #define QMD 0 #define QMRDV 1 #define QRAND 2 /* default options for SPACE */ #define SPACE_ORDTYPE MULTISECTION #define SPACE_NODE_SELECTION1 AMMF #define SPACE_NODE_SELECTION2 AMMF #define SPACE_NODE_SELECTION3 QMRDV #define SPACE_DOMAIN_SIZE 200 #define SPACE_MSGLVL 2 #define SPACE_ETREE_NONZ 256 #define SPACE_ETREE_BAL 5 #define SPACE_MASK_OFFSET 2 /* misc. constants */ #define TRUE 1 #define FALSE 0 #define ERR -1 #define NOERR 0 #define MAX_LINE_LEN 255 #define MAX_INT ((1<<30)-1) #define MAX_FLOAT 1e31 #define EPS 0.001 /* constants used in color array */ /* these constants are also used as an index (do not change) */ #define GRAY 0 #define BLACK 1 #define WHITE 2 /* constants for the Dulmage-Mendelsohn decomposition (dmflags) */ /* these constants are also used as an index (do not change) */ #define SI 0 /* node e X is reachable via exposed node e X */ #define SX 1 /* node e X is reachable via exposed node e Y */ #define SR 2 /* SR = X - (SI u SX) */ #define BI 3 /* node e Y is reachable via exposed node e Y */ #define BX 4 /* node e Y is reachable via exposed node e X */ #define BR 5 /* BR = Y - (BI u BX) */ /* size/indices of option array (do not change) */ #define ORD_OPTION_SLOTS 7 #define OPTION_ORDTYPE 0 #define OPTION_NODE_SELECTION1 1 #define OPTION_NODE_SELECTION2 2 #define OPTION_NODE_SELECTION3 3 #define OPTION_DOMAIN_SIZE 4 #define OPTION_MSGLVL 5 #define OPTION_ETREE_NONZ 6 /* size/indices for timing array in ordering computation */ #define ORD_TIME_SLOTS 12 #define TIME_COMPRESS 0 /* 0. TIME_COMPRESS */ #define TIME_MS 1 /* 1. TIME_MS */ #define TIME_MULTILEVEL 2 /* 1.1 TIME_MULTILEVEL */ #define TIME_INITDOMDEC 3 /* 1.1.1 TIME_INITDOMDEC */ #define TIME_COARSEDOMDEC 4 /* 1.1.2 TIME_COARSEDOMDEC */ #define TIME_INITSEP 5 /* 1.1.3 TIME_INITSEP */ #define TIME_REFINESEP 6 /* 1.1.4 TIME_REFINESEP */ #define TIME_SMOOTH 7 /* 1.2 TIME_SMOOTH */ #define TIME_BOTTOMUP 8 /* 2. TIME_BOTTOMUP */ #define TIME_UPDADJNCY 9 /* 2.1 TIME_UPDADJNCY */ #define TIME_FINDINODES 10 /* 2.2 TIME_FINDINODES */ #define TIME_UPDSCORE 11 /* 2.3 TIME_UPDSCORE */ /* size/indices for timing array in sequential numerical factorization */ #define NUMFAC_TIME_SLOTS 4 #define TIME_INITFRONT 0 #define TIME_EXADD 1 #define TIME_KERNEL 2 #define TIME_INITUPD 3 /* size/indices for timing array in parallel numerical factorization */ #define NUMFACPAR_TIME_SLOTS 9 #define TIME_INITFRONT 0 #define TIME_EXADD 1 #define TIME_KERNEL 2 #define TIME_INITUPD 3 #define TIME_EXCHANGE 4 #define TIME_INITFRONTPAR 5 #define TIME_EXADDPAR 6 #define TIME_KERNELPAR 7 #define TIME_INITUPDPAR 8 /* size/indices for timing array in parallel kernel */ #define KERNELPAR_TIME_SLOTS 4 #define TIME_PIVOT 0 #define TIME_PIVOT_WAIT 1 #define TIME_CMOD 2 #define TIME_CMOD_WAIT 3 MUMPS_5.4.1/PORD/include/protos.h0000664000175000017500000003223614102210467016617 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: protos.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains the prototypes of all non-static functions / ******************************************************************************/ /* functions in lib/greg_pord.h */ PORD_INT greg_pord(PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, PORD_INT *, PORD_INT *, PORD_INT *); /* functions in lib/graph.c */ graph_t* newGraph(PORD_INT, PORD_INT); void freeGraph(graph_t*); void printGraph(graph_t*); void randomizeGraph(graph_t*); graph_t* setupSubgraph(graph_t*, PORD_INT*, PORD_INT, PORD_INT*); graph_t* setupGraphFromMtx(inputMtx_t*); graph_t* setupGridGraph(PORD_INT, PORD_INT, PORD_INT); PORD_INT connectedComponents(graph_t*); graph_t* compressGraph(graph_t*, PORD_INT*); /* functions in lib/gbisect.c */ gbisect_t* newGbisect(graph_t*); void freeGbisect(gbisect_t*); void printGbisect(gbisect_t*); void checkSeparator(gbisect_t*); void constructSeparator(gbisect_t*, options_t*, timings_t*); PORD_INT smoothBy2Layers(gbisect_t*, PORD_INT*, PORD_INT*, PORD_INT, PORD_INT); void smoothSeparator(gbisect_t*, options_t*); /* functions in lib/ddcreate.c */ domdec_t* newDomainDecomposition(PORD_INT, PORD_INT); void freeDomainDecomposition(domdec_t*); void printDomainDecomposition(domdec_t*); void checkDomainDecomposition(domdec_t*); void buildInitialDomains(graph_t*, PORD_INT*, PORD_INT*, PORD_INT*); void mergeMultisecs(graph_t *G, PORD_INT*, PORD_INT*); domdec_t* initialDomainDecomposition(graph_t*, PORD_INT*, PORD_INT*, PORD_INT*); domdec_t* constructDomainDecomposition(graph_t*, PORD_INT*); void computePriorities(domdec_t*, PORD_INT*, PORD_INT*, PORD_INT); void eliminateMultisecs(domdec_t*, PORD_INT*, PORD_INT*); void findIndMultisecs(domdec_t*, PORD_INT*, PORD_INT*); domdec_t* coarserDomainDecomposition(domdec_t*, PORD_INT*); void shrinkDomainDecomposition(domdec_t*, PORD_INT); /* functions in lib/ddbisect.c */ void checkDDSep(domdec_t*); PORD_INT findPseudoPeripheralDomain(domdec_t*, PORD_INT); void constructLevelSep(domdec_t*, PORD_INT); void initialDDSep(domdec_t*); void updateB2W(bucket_t*, bucket_t*, domdec_t*, PORD_INT, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); void updateW2B(bucket_t*, bucket_t*, domdec_t*, PORD_INT, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); void improveDDSep(domdec_t*); /* functions in lib/gbipart.c */ gbipart_t* newBipartiteGraph(PORD_INT, PORD_INT, PORD_INT); void freeBipartiteGraph(gbipart_t*); void printGbipart(gbipart_t*); gbipart_t* setupBipartiteGraph(graph_t*, PORD_INT*, PORD_INT, PORD_INT, PORD_INT*); void maximumMatching(gbipart_t*, PORD_INT*); void maximumFlow(gbipart_t*, PORD_INT*, PORD_INT*); void DMviaMatching(gbipart_t*, PORD_INT*, PORD_INT*, PORD_INT*); void DMviaFlow(gbipart_t*, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); /* functions in lib/nestdiss.c */ nestdiss_t* newNDnode(graph_t*, PORD_INT*, PORD_INT); void freeNDnode(nestdiss_t*); nestdiss_t* setupNDroot(graph_t*, PORD_INT*); void splitNDnode(nestdiss_t*, options_t*, timings_t*); void buildNDtree(nestdiss_t*, options_t*, timings_t*); void freeNDtree(nestdiss_t*); /* functions in lib/multisector.c */ multisector_t* newMultisector(graph_t*); void freeMultisector(multisector_t*); multisector_t* trivialMultisector(graph_t*); multisector_t* constructMultisector(graph_t*, options_t*, timings_t*); multisector_t* extractMS2stage(nestdiss_t*); multisector_t* extractMSmultistage(nestdiss_t*); /* functions in lib/gelim.c */ gelim_t* newElimGraph(PORD_INT, PORD_INT); void freeElimGraph(gelim_t*); void printElimGraph(gelim_t*); gelim_t* setupElimGraph(graph_t*); PORD_INT crunchElimGraph(gelim_t*); void buildElement(gelim_t *Gelim, PORD_INT me); void updateAdjncy(gelim_t*, PORD_INT*, PORD_INT, PORD_INT*, PORD_INT*); void findIndNodes(gelim_t*, PORD_INT*, PORD_INT, PORD_INT*, PORD_INT*, PORD_INT*, PORD_INT*); void updateDegree(gelim_t*, PORD_INT*, PORD_INT, PORD_INT*); void updateScore(gelim_t*, PORD_INT*, PORD_INT, PORD_INT, PORD_INT*); elimtree_t* extractElimTree(gelim_t*); /* functions in lib/bucket.c */ bucket_t* newBucket(PORD_INT, PORD_INT, PORD_INT); void freeBucket(bucket_t*); bucket_t* setupBucket(PORD_INT, PORD_INT, PORD_INT); PORD_INT minBucket(bucket_t*); void insertBucket(bucket_t*, PORD_INT, PORD_INT); void removeBucket(bucket_t*, PORD_INT); /* functions in lib/minpriority.c */ minprior_t* newMinPriority(PORD_INT nvtx, PORD_INT nstages); void freeMinPriority(minprior_t*); minprior_t* setupMinPriority(multisector_t*); elimtree_t* orderMinPriority(minprior_t*, options_t*, timings_t*); void eliminateStage(minprior_t*, PORD_INT, PORD_INT, timings_t*); PORD_INT eliminateStep(minprior_t*, PORD_INT, PORD_INT); /* functions in lib/tree.c */ elimtree_t* newElimTree(PORD_INT, PORD_INT); void freeElimTree(elimtree_t*); void printElimTree(elimtree_t *); PORD_INT firstPostorder(elimtree_t*); PORD_INT firstPostorder2(elimtree_t*, PORD_INT); PORD_INT nextPostorder(elimtree_t*, PORD_INT); PORD_INT firstPreorder(elimtree_t*); PORD_INT nextPreorder(elimtree_t*, PORD_INT); elimtree_t* setupElimTree(graph_t*, PORD_INT*, PORD_INT*); void initFchSilbRoot(elimtree_t*); void permFromElimTree(elimtree_t*, PORD_INT*); elimtree_t* expandElimTree(elimtree_t*, PORD_INT*, PORD_INT); elimtree_t* permuteElimTree(elimtree_t*, PORD_INT*); elimtree_t* fundamentalFronts(elimtree_t*); elimtree_t* mergeFronts(elimtree_t*, PORD_INT); elimtree_t* compressElimTree(elimtree_t*, PORD_INT*, PORD_INT); PORD_INT justifyFronts(elimtree_t*); PORD_INT nWorkspace(elimtree_t*); PORD_INT nFactorIndices(elimtree_t*); PORD_INT nFactorEntries(elimtree_t*); FLOAT nFactorOps(elimtree_t*); void subtreeFactorOps(elimtree_t*, FLOAT*); FLOAT nTriangularOps(elimtree_t*); /* functions in lib/matrix.c */ inputMtx_t* newInputMtx(PORD_INT, PORD_INT); void freeInputMtx(inputMtx_t*); void printInputMtx(inputMtx_t*); denseMtx_t* newDenseMtx(workspace_t*, PORD_INT); void freeDenseMtx(denseMtx_t*); void printDenseMtx(denseMtx_t*); void checkDenseMtx(denseMtx_t*); workspace_t* initWorkspaceForDenseMtx(PORD_INT, PORD_INT); FLOAT* getWorkspaceForDenseMtx(workspace_t*, PORD_INT); void freeWorkspaceForDenseMtx(workspace_t*); inputMtx_t* setupInputMtxFromGraph(graph_t*); inputMtx_t* setupLaplaceMtx(PORD_INT, PORD_INT, PORD_INT); inputMtx_t* permuteInputMtx(inputMtx_t*, PORD_INT*); /* functions in lib/symbfac.c */ css_t* newCSS(PORD_INT, PORD_INT, PORD_INT); void freeCSS(css_t*); css_t* setupCSSFromGraph(graph_t*, PORD_INT*, PORD_INT*); css_t* setupCSSFromFrontSubscripts(frontsub_t*); frontsub_t* newFrontSubscripts(elimtree_t*); void freeFrontSubscripts(frontsub_t*); void printFrontSubscripts(frontsub_t*); frontsub_t* setupFrontSubscripts(elimtree_t*, inputMtx_t*); factorMtx_t* newFactorMtx(PORD_INT); void freeFactorMtx(factorMtx_t*); void printFactorMtx(factorMtx_t*); void initFactorMtx(factorMtx_t *L, inputMtx_t*); void initFactorMtxNEW(factorMtx_t *L, inputMtx_t*); /* functions in lib/numfac.c */ void numfac(factorMtx_t *L, timings_t *cpus); denseMtx_t* setupFrontalMtx(workspace_t*, factorMtx_t*, PORD_INT); void initLocalIndices(denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* extendedAdd(denseMtx_t*, denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* setupUpdateMtxFromFrontalMtx(denseMtx_t*, factorMtx_t*); /* functions in lib/kernel.c */ denseMtx_t* factorize1x1Kernel(denseMtx_t*, PORD_INT); denseMtx_t* factorize2x2Kernel(denseMtx_t*, PORD_INT); denseMtx_t* factorize3x3Kernel(denseMtx_t*, PORD_INT); /* functions in lib/triangular.c */ void forwardSubst1x1(factorMtx_t*, FLOAT*); void backwardSubst1x1(factorMtx_t*, FLOAT*); void forwardSubst1x1NEW(factorMtx_t*, FLOAT*); void backwardSubst1x1NEW(factorMtx_t*, FLOAT*); /* functions in lib/mapping.c */ mapping_t* newMapping(elimtree_t*, PORD_INT); void freeMapping(mapping_t*); void printMapping(mapping_t*); void listing(mapping_t*, PORD_INT, PORD_INT, PORD_INT, FLOAT*, FLOAT*); mapping_t* setupMapping(elimtree_t*, PORD_INT, PORD_INT); void split(mapping_t*, PORD_INT, PORD_INT, PORD_INT, PORD_INT*, PORD_INT*, FLOAT*, PORD_INT); /* functions in lib/interface.c */ elimtree_t* SPACE_ordering(graph_t*, options_t*, timings_t*); elimtree_t* SPACE_transformElimTree(elimtree_t*, PORD_INT); factorMtx_t* SPACE_symbFac(elimtree_t*, inputMtx_t*); void SPACE_numFac(factorMtx_t*, timings_t*); void SPACE_solveTriangular(factorMtx_t *L, FLOAT *rhs, FLOAT *xvec); void SPACE_solve(inputMtx_t*, FLOAT*, FLOAT*, options_t*, timings_t*); void SPACE_solveWithPerm(inputMtx_t*, PORD_INT*, FLOAT*, FLOAT*, options_t*, timings_t*); mapping_t* SPACE_mapping(graph_t*, PORD_INT*, options_t*, timings_t*); /* functions in lib/sort.c */ void insertUpInts(PORD_INT, PORD_INT*); void insertUpIntsWithStaticIntKeys(PORD_INT, PORD_INT*, PORD_INT*); void insertDownIntsWithStaticFloatKeys(PORD_INT, PORD_INT*, FLOAT*); void insertUpFloatsWithIntKeys(PORD_INT, FLOAT*, PORD_INT*); void qsortUpInts(PORD_INT, PORD_INT*, PORD_INT*); void qsortUpFloatsWithIntKeys(PORD_INT, FLOAT*, PORD_INT*, PORD_INT*); void distributionCounting(PORD_INT, PORD_INT*, PORD_INT*); /* functions in lib/read.c */ graph_t* readChacoGraph(char*); inputMtx_t* readHarwellBoeingMtx(char*); /* functions in libPAR/topology.c */ topology_t* newTopology(PORD_INT); void freeTopology(topology_t*); void printTopology(topology_t*); topology_t* setupTopology(void); void recMapCube(topology_t*, PORD_INT, PORD_INT, PORD_INT, PORD_INT, PORD_INT, PORD_INT); void sendCube(topology_t*, void*, size_t, PORD_INT); size_t recvCube(topology_t*, void*, size_t, PORD_INT); PORD_INT myrank(void); /* functions in libPAR/mask.c */ mask_t* newMask(PORD_INT); void freeMask(mask_t*); mask_t* setupMask(PORD_INT, PORD_INT, PORD_INT); /* functions in libPAR/broadcast.c */ void broadcastInputMtx(topology_t*, inputMtx_t**); void broadcastElimTree(topology_t*, elimtree_t**); void broadcastArray(topology_t*, char*, size_t); /* functions in libPAR/buffer.c */ buffer_t* newBuffer(size_t); void freeBuffer(buffer_t*); buffer_t* exchangeBuffer(topology_t*, buffer_t*, PORD_INT); buffer_t* setupSymbFacBuffer(frontsub_t*, PORD_INT*); void readoutSymbFacBuffer(buffer_t*, frontsub_t*, PORD_INT*); buffer_t* setupNumFacBuffer(workspace_t*, mask_t*, PORD_INT); void readoutNumFacBuffer(workspace_t*, buffer_t*, denseMtx_t**); buffer_t* setupTriangularBuffer(frontsub_t*, PORD_INT*, FLOAT*); void readoutTriangularBuffer(buffer_t*, frontsub_t*, PORD_INT*, FLOAT*); /* functions in libPAR/symbfacPAR.c */ frontsub_t* newFrontSubscriptsPAR(mask_t*, mapping_t*, elimtree_t*); frontsub_t* setupFrontSubscriptsPAR(topology_t*, mask_t*, mapping_t*, elimtree_t*, inputMtx_t*); css_t* setupCSSFromFrontSubscriptsPAR(mask_t*, mapping_t*, frontsub_t*); void initFactorMtxPAR(mask_t*, mapping_t*, factorMtx_t*, inputMtx_t*); /* functions in libPAR/numfacPAR.c */ void numfacPAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, PORD_INT msglvl, timings_t*); denseMtx_t* setupFrontalMtxPAR(mask_t*, PORD_INT, workspace_t*, factorMtx_t*, PORD_INT); void initLocalIndicesPAR(denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* extendedAddPAR(denseMtx_t*, denseMtx_t*, PORD_INT*, PORD_INT*); denseMtx_t* setupUpdateMtxFromFrontalMtxPAR(denseMtx_t*, factorMtx_t*); denseMtx_t* setupUpdateMtxFromBuffer(workspace_t*, FLOAT*); void splitDenseMtxColumnWise(denseMtx_t*, mask_t*, buffer_t*, PORD_INT); void splitDenseMtxRowWise(denseMtx_t*, mask_t*, buffer_t*, PORD_INT); /* functions in libPAR/kernelPAR.c */ denseMtx_t* factorize1x1KernelPAR(topology_t*, mask_t*, PORD_INT, denseMtx_t*, frontsub_t*, timings_t*); denseMtx_t* factorize2x2KernelPAR(topology_t*, mask_t*, PORD_INT, denseMtx_t*, frontsub_t*, timings_t*); denseMtx_t* factorize3x3KernelPAR(topology_t*, mask_t*, PORD_INT, denseMtx_t*, frontsub_t*, timings_t*); /* functions in libPAR/triangularPAR.c */ void forwardSubst1x1PAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*, FLOAT*); void backwardSubst1x1PAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*); void forwardSubst1x1KernelPAR(topology_t*, mask_t*, PORD_INT, PORD_INT, factorMtx_t*, FLOAT*, FLOAT*); void backwardSubst1x1KernelPAR(topology_t*, mask_t*, PORD_INT, PORD_INT, factorMtx_t*, FLOAT*); void accumulateVector(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*); /* functions in libPAR/interfacePAR.c */ topology_t* SPACE_setupTopology(void); mask_t* SPACE_setupMask(topology_t*, PORD_INT); void SPACE_cleanup(topology_t*, mask_t*); factorMtx_t* SPACE_symbFacPAR(topology_t*, mask_t*, mapping_t*, elimtree_t*, inputMtx_t*); void SPACE_numFacPAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, PORD_INT msglvl, timings_t*); void SPACE_solveTriangularPAR(topology_t*, mask_t*, mapping_t*, factorMtx_t*, FLOAT*, FLOAT*); void SPACE_solveWithPermPAR(topology_t *top, mask_t *mask, inputMtx_t *A, PORD_INT *perm, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus); MUMPS_5.4.1/PORD/include/params.h0000664000175000017500000000157014102210467016551 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: params.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains parameter definitions / ******************************************************************************/ /* default parameters */ #define MAX_BAD_FLIPS 100 /* interrupt/stop FM */ #define COMPRESS_FRACTION 0.75 /* node reduction in compressed graph */ #define MIN_NODES 100 /* stop recursive separator construction */ #define DEFAULT_SEPS 31 /* default number of separators */ #define MAX_SEPS 255 /* max. number of separators */ #define MIN_DOMAINS 100 /* min. number of domains in a decomp. */ #define MAX_COARSENING_STEPS 10 /* max. number of generated dom. decomp. */ MUMPS_5.4.1/PORD/include/eval.h0000664000175000017500000000427114102210467016216 0ustar jylexceljylexcel/***************************************************************************** / / PORD Ordering Library: eval.h / / author J"urgen Schulze, University of Paderborn / created 99mar30 / / This file contains the definition of various separator evaluation functions / ******************************************************************************/ #define F eval1 /* default separator evaluation function */ /* --------------------------------------------------------------------- */ /* SEPARATOR EVALUATION FUNCTION 1 */ /* Size of domains W and B is allowed to differ TOLERANCE * 100 percent. */ /* Within this tolerance the difference is not penalized and only the */ /* size of the separator is returned. Additionally, the mantissa of the */ /* returned value is set to (max-min)/max. */ /* --------------------------------------------------------------------- */ #define TOL1 0.50 /* tolerated imbalance induced by bisector */ #define PEN1 100 /* penalty in case of higher imbalance */ #define eval1(S, B, W) \ S + PEN1 * max(0, max(W,B) * (1-TOL1) - min(W,B)) \ + (FLOAT)(max(W,B)-min(W,B)) / (FLOAT)max(W,B) /* --------------------------------------------------------------------- */ /* SEPARATOR EVALUATION FUNCTION 2 */ /* Ashcraft and Liu (Using domain decomposition to find graph bisectors) */ /* --------------------------------------------------------------------- */ #define alpha 0.1 #define TOL2 0.70 #define PEN2 100 #define eval2(S, B, W) \ S * (1 + alpha * ((FLOAT)max(W,B)/(FLOAT)max(1,min(W,B)))) \ + PEN2 * max(0, max(W,B) * (1-TOL2) - min(W,B)) /* --------------------------------------------------------------------- */ /* SEPARATOR EVALUATION FUNCTION 3 */ /* Ashcraft and Liu (Generalized nested dissection:some recent progress) */ /* --------------------------------------------------------------------- */ #define alpha2 0.33 #define eval3(S, B, W) \ S * S + alpha2 * (max(W,B)-min(W,B)) * (max(W,B)-min(W,B)) MUMPS_5.4.1/PORD/include/space.h0000664000175000017500000000276414102210467016367 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: space.h / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file includes all necessary header files / ******************************************************************************/ #include #include #include #include #include #ifndef _WIN32 #include #endif #if defined(__MINGW32__) #include #endif #include #ifdef PARIX #ifdef __EPX #include #include #include #include #include #include #include #else #include #include #include #include #include #include #include #endif #include #endif #ifdef MPI #include "mpi.h" #endif #include "const.h" #include "params.h" #include "macros.h" #include "types.h" #include "protos.h" #include "eval.h" #define FORTRAN(nu,nl,pl,pc) \ void nu (); \ void nl pl \ { nu pc; } \ void nl##_ pl \ { nu pc; } \ void nl##__ pl \ { nu pc; } \ void nu pl MUMPS_5.4.1/PORD/lib/0000775000175000017500000000000014102210467014235 5ustar jylexceljylexcelMUMPS_5.4.1/PORD/lib/gelim.c0000664000175000017500000011777114102210467015514 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: gelim.c / / author J"urgen Schulze, University of Paderborn / created 01jan10 / / This file contains functions dealing with the elimination graph object / ****************************************************************************** Data type: struct gelim graph_t *G; pointer to graph object int maxedges; max number of edges that can be stored int *len; length of v's adjacency list int *elen; number of elements adjacent to v int *parent; parent in front tree / representative of v int *degree; boundary size / (approximate) degree int *score; holds the score of uneliminated vertex v Comments: o Structure used to hold the elimination graphs of a bottom-up ordering o G->totvwght: total weight of all uneliminated vertices o G->xadj[v] = -1 => there is no adjacency list for variable/element v => variable v has degree 0 (in this case G->vwght[v] > 0) => variable v istinguishable/removed by mass elimination or element v has been absorbed (in this case G->vwght[v] = 0) o G->vwght[v]: weight of the princial variable v; if v becomes an element, weight[v] remains unchanged for the rest of the elim. process = 0 => variable v is nonprincipal/removed by mass elimination o len[v], elen[v]: the adjacency list of vertex/element v contains len[v] entries; the first elen[v] entries are elements (if v is an element, then elen[v] = 0 will hold) o parent[v]: for an (absorbed) element, parent[v] points to the parent of element v in the front tree; for an indistinguishable vertex, parent[v] points to its representative vertex (which may have also found to be indistinguishable to another one) o degree[v]: for an uneliminated vertex, the (approximate) degree in Gelim; for an element, the weight of its boundary (i.e. degree[v] gives the exakt degree of v at the time of its elimination) o score[v]: vertices are eliminated according to their score value >= 0; additionally, the score vector is used to represent the status of a node in the actual stage: -1, iff variable v will be eliminated in an upcomming stage -2, iff variable v is nonprincipal/removed by mass elim. -3, iff variable v has been eliminated and now forms an element -4, iff element v has been absorbed Methods in lib/gelim.c - Gelim = newElimGraph(int nvtx, int nedges); - void freeElimGraph(gelim_t *Gelim); - void printElimGraph(gelim_t *Gelim); - Gelim = setupElimGraph(graph_t *G); o allocates memory for the elimination graph by calling newElimGraph and initializes the vectors, i.e. len[u] = xadj[u+1]-xadj[u]; elen[u] = 0; parent[u] = -1; degree[u] = exact (external) degree of vertex u; score[u] = -1; xadj[u] = -1, if len[u] = 0 - int crunchElimGraph(gelim_t *Gelim); o tries to compress the adjacency vector on success the function return TRUE, otherwise FALSE - void buildElement(gelim_t *Gelim, int me); o turns variable me into an element; if me is an leaf, the element is constructed in-place, otherwise its adjacency list is appended to G o all relevant vectors are updated, i.e. vwght[me] = 0, degree[me] = |Lme|, score[me] = -3 for all neighboring elements: parent[e] = me, score[e] = -4 - void updateAdjncy(gelim_t *Gelim, int *reachset, int nreach, int *tmp, int *pflag); o updates the adjacency structure of all vertices in reachset IMPORTANT REQUIREMENTS: (1) all values stored in tmp[u] are smaller than *pflag - void findIndNodes(gelim_t *Gelim, int *reachset, int nreach, int *bin, int *next, int *tmp, int *pflag); o searches reachset for indistinguishable vertices IMPORTANT REQUIREMENTS: (1) the adjacency lists of all vertices in reachset have been updated by a call to updateAdjncy (2) bin[i] = -1 for all 0 <= i < G->nvtx (3) all values stored in tmp[u] are smaller than *pflag o on return bin[i] = -1 holds again - void updateDegree(gelim_t *Gelim, int *reachset, int nreach, int *bin); o computes new approximate degrees for all vertices in reachset IMPORTANT REQUIREMENTS: (1) the adjacency lists of all vertices in reachset have been updated by a call to updateAdjncy (2) the boundary size of each newly formed element has been computed (3) bin[i] = -1 for all 0 <= i < G->nvtx o on return bin[i] = -1 holds again - void updateScore(gelim_t *Gelim, int *reachset, int nreach, int scoretype, int *bin); o updates the score of all vertices in reachset IMPORTANT REQUIREMENTS: (1) the approximate degrees are correctly computed (by updateDegree) (2) bin[i] = -1 for all 0 <= i < G->nvtx o on return bin[i] = -1 holds again - T = extractElimTree(gelim_t *Gelim); o uses the status of the nodes (stored in the score vector) and the parent vector to set up the elimination tree T; vectors T->ncolfactor and T->ncolupdate are initialized using vectors G->vwght and degree ******************************************************************************/ #include /* #define DEBUG */ /***************************************************************************** ******************************************************************************/ gelim_t* newElimGraph(PORD_INT nvtx, PORD_INT nedges) { gelim_t *Gelim; mymalloc(Gelim, 1, gelim_t); Gelim->G = newGraph(nvtx, nedges); Gelim->maxedges = nedges; mymalloc(Gelim->len, nvtx, PORD_INT); mymalloc(Gelim->elen, nvtx, PORD_INT); mymalloc(Gelim->parent, nvtx, PORD_INT); mymalloc(Gelim->degree, nvtx, PORD_INT); mymalloc(Gelim->score, nvtx, PORD_INT); return(Gelim); } /***************************************************************************** ******************************************************************************/ void freeElimGraph(gelim_t *Gelim) { freeGraph(Gelim->G); free(Gelim->len); free(Gelim->elen); free(Gelim->parent); free(Gelim->degree); free(Gelim->score); free(Gelim); } /***************************************************************************** ******************************************************************************/ void printElimGraph(gelim_t *Gelim) { graph_t *G; PORD_INT count, u, v, i, istart; G = Gelim->G; for (u = 0; u < G->nvtx; u++) { istart = G->xadj[u]; /* --------------------------------------------------------------- case 1: u is a principal variable => vwght[u]: weight of all mapped indistinguishable variables => degree[u]: approximate degree ---------------------------------------------------------------- */ if ((Gelim->score[u] == -1) || (Gelim->score[u] >= 0)) { printf("--- adjacency list of variable %d (weight %d, degree %d, " "score %d):\n", u, G->vwght[u], Gelim->degree[u], Gelim->score[u]); printf("elements:\n"); count = 0; for (i = istart; i < istart + Gelim->elen[u]; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); printf("variables:\n"); count = 0; for (i = istart + Gelim->elen[u]; i < istart + Gelim->len[u]; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } /* --------------------------------------------------------------- case 2: u is nonprincipal/removed by mass elimination ---------------------------------------------------------------- */ else if (Gelim->score[u] == -2) printf("--- variable %d is nonprincipal/removed by mass elim. " "(parent %d)\n", u, Gelim->parent[u]); /* ----------------------------------------------- case 3: u is an element: => degree[u]: weight of boundary ----------------------------------------------- */ else if (Gelim->score[u] == -3) { printf("--- boundary of element %d (degree %d, score %d):" "\n", u, Gelim->degree[u], Gelim->score[u]); count = 0; for (i = istart; i < istart + Gelim->len[u]; i++) { v = G->adjncy[i]; if (G->vwght[v] > 0) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } } if ((count % 16) != 0) printf("\n"); } /* -------------------------------- case 4: u is an absorbed element -------------------------------- */ else if (Gelim->score[u] == -4) printf("--- element %d has been absorbed (parent %d)\n", u, Gelim->parent[u]); /* ---------------------------------------- none of the above cases is true => error ---------------------------------------- */ else { fprintf(stderr, "\nError in function printElimGraph\n" " node %d has invalid score %d\n", u, Gelim->score[u]); quit(); } } } /***************************************************************************** ******************************************************************************/ gelim_t* setupElimGraph(graph_t *G) { gelim_t *Gelim; PORD_INT *xadj, *adjncy, *vwght, *xadjGelim, *adjncyGelim, *vwghtGelim; PORD_INT *len, *elen, *parent, *degree, *score; PORD_INT nvtx, nedges, deg, u, i, istart, istop; nvtx = G->nvtx; nedges = G->nedges; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; Gelim = newElimGraph(nvtx, nedges+nvtx); xadjGelim = Gelim->G->xadj; adjncyGelim = Gelim->G->adjncy; vwghtGelim = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; degree = Gelim->degree; score = Gelim->score; /* -------------- copy the graph -------------- */ Gelim->G->type = G->type; Gelim->G->totvwght = G->totvwght; for (u = 0; u < nvtx; u++) { xadjGelim[u] = xadj[u]; vwghtGelim[u] = vwght[u]; } xadjGelim[nvtx] = xadj[nvtx]; for (i = 0; i < nedges; i++) adjncyGelim[i] = adjncy[i]; Gelim->G->nedges = nedges; /* ---------------------- initialize all vectors ---------------------- */ for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; len[u] = istop - istart; elen[u] = 0; parent[u] = -1; deg = 0; switch(Gelim->G->type) /* compute the external degree of u */ { case UNWEIGHTED: deg = len[u]; break; case WEIGHTED: for (i = istart; i < istop; i++) deg += vwght[adjncy[i]]; break; default: fprintf(stderr, "\nError in function setupElimGraph\n" " unrecognized graph type %d\n", Gelim->G->type); } degree[u] = deg; if (len[u] == 0) /* len(u) = 0 => adjncy list of u not in use */ xadjGelim[u] = -1; /* mark with -1, otherwise crunchElimGraph fails */ score[u] = -1; } return(Gelim); } /***************************************************************************** ******************************************************************************/ PORD_INT crunchElimGraph(gelim_t *Gelim) { PORD_INT *xadj, *adjncy, *len; PORD_INT nvtx, nedges, u, i, isrc, idest; nvtx = Gelim->G->nvtx; nedges = Gelim->G->nedges; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; len = Gelim->len; /* --------------------------------------------- mark begining of u's adjacency list by -(u+1) --------------------------------------------- */ for (u = 0; u < nvtx; u++) { i = xadj[u]; /* is adjacency list of u still in use? */ if (i != -1) /* verify that list is non-empty */ { if (len[u] == 0) { fprintf(stderr, "\nError in function crunchElimGraph\n" " adjacency list of node %d is empty\n", u); quit(); } xadj[u] = adjncy[i]; /* if so, move first item to xadj[u] */ adjncy[i] = -(u+1); /* u's adjacency list is headed by -(u+1) */ if (len[u] == 0) printf("error: u %d, len %d\n", u, len[u]); } } /* -------------------------- crunch all adjacency lists -------------------------- */ idest = isrc = 0; while (isrc < Gelim->G->nedges) { u = adjncy[isrc++]; if (u < 0) /* a new adjacency list starts here */ { u = -u - 1; /* it's the adjacency list of u */ adjncy[idest] = xadj[u]; /* first item was stored in xadj[u] */ xadj[u] = idest++; for (i = 1; i < len[u]; i++) adjncy[idest++] = adjncy[isrc++]; } } Gelim->G->nedges = idest; /* ------------------ was it successful? ------------------ */ if (idest < nedges) return(TRUE); else return (FALSE); } /***************************************************************************** ******************************************************************************/ void buildElement(gelim_t *Gelim, PORD_INT me) { graph_t *G; PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *parent, *degree, *score; PORD_INT degme, elenme, vlenme, mesrcptr, medeststart, medeststart2; PORD_INT medestptr, ln, p, i, j, v, e; G = Gelim->G; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; degree = Gelim->degree; score = Gelim->score; /* --------------------------------- construct boundary of element Lme --------------------------------- */ degme = 0; G->totvwght -= vwght[me]; /* me eliminated => reduce weight of Gelim */ vwght[me] = -vwght[me]; score[me] = -3; /* variable me becomes an element */ elenme = elen[me]; vlenme = len[me] - elenme; mesrcptr = xadj[me]; /* ----------------------------------------------------------- if me is a leaf => its boundary can be constructed in-place ----------------------------------------------------------- */ if (elenme == 0) { medeststart = xadj[me]; /* Lme overwrites old variable */ medestptr = medeststart; /* boundary of Lme starts here */ for (i = 0; i < vlenme; i++) { v = adjncy[mesrcptr++]; if (vwght[v] > 0) /* v not yet placed in boundary */ { degme += vwght[v]; /* increase size of Lme */ vwght[v] = -vwght[v]; /* flag v as being in Lme */ adjncy[medestptr++] = v; } } } /* ------------------------------------------------------------------- me is not a leaf => its boundary must be constructed in empty space ------------------------------------------------------------------- */ else { medeststart = G->nedges; /* Lme appended to graph */ medestptr = medeststart; /* boundary of Lme starts here */ for (i = 0; i <= elenme; i++) { if (i < elenme) /* working on elements */ { len[me]--; e = adjncy[mesrcptr++]; /* merge boundary of element e with Lme */ p = xadj[e]; /* adjacency list of e starts here */ ln = len[e]; } else { e = me; /* merge uncovered variables with Lme */ p = mesrcptr; /* variables start here */ ln = vlenme; } for (j = 0; j < ln; j++) { len[e]--; /* pick next variable, decrease length */ v = adjncy[p++]; if (vwght[v] > 0) { degme += vwght[v]; /* increase size of Lme */ vwght[v] = -vwght[v]; /* flag v as being in Lme */ /* ------------------------------------------ add v to Lme, compress adjncy if necessary ------------------------------------------ */ if (medestptr == Gelim->maxedges) { if (len[me] == 0) xadj[me] = -1; else xadj[me] = mesrcptr; if (len[e] == 0) xadj[e] = -1; else xadj[e] = p; /* crunch adjacency list -- !!!we need more memory!!! */ if (!crunchElimGraph(Gelim)) { fprintf(stderr, "\nError in function buildElement\n" " unable to construct element (not enough memory)\n"); quit(); } /* crunch partially constructed element me */ medeststart2 = G->nedges; for (p = medeststart; p < medestptr; p++) adjncy[G->nedges++] = adjncy[p]; medeststart = medeststart2; medestptr = G->nedges; mesrcptr = xadj[me]; p = xadj[e]; } adjncy[medestptr++] = v; } } /* ---------------------- mark absorbed elements ---------------------- */ if (e != me) { xadj[e] = -1; parent[e] = me; score[e] = -4; } } G->nedges = medestptr; /* new element Lme ends here */ } /* ----------------------------------- element me successfully constructed ----------------------------------- */ degree[me] = degme; xadj[me] = medeststart; vwght[me] = -vwght[me]; elen[me] = 0; len[me] = medestptr - medeststart; if (len[me] == 0) xadj[me] = -1; /* --------------------------- unmark all variables in Lme --------------------------- */ mesrcptr = xadj[me]; vlenme = len[me]; for (i = 0; i < vlenme; i++) { v = adjncy[mesrcptr++]; vwght[v] = -vwght[v]; } } /***************************************************************************** ******************************************************************************/ void updateAdjncy(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT *tmp, PORD_INT *pflag) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *parent, *score; PORD_INT u, v, e, me, i, j, jj, jdest, jfirstolde, jfirstv, jstart, jstop; PORD_INT covered, marku; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; score = Gelim->score; /* ----------------------------------------------------------------- build the new element/variable list for each variable in reachset ----------------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; vwght[u] = -vwght[u]; /* mark all variables in reachset */ jstart = xadj[u]; jstop = xadj[u] + len[u]; jdest = jfirstolde = jstart; #ifdef DEBUG printf("Updating adjacency list of node %d\n", u); #endif /* -------------------------------------------------------- scan the list of elements associated with variable u place newly formed elements at the beginning of the list -------------------------------------------------------- */ for (j = jstart; j < jstart + elen[u]; j++) { e = adjncy[j]; #ifdef DEBUG printf(" >> element %d (score %d, parent %d)\n", e,score[e],parent[e]); #endif if (score[e] == -4) /* e has been absorbed in this elim. step */ { me = parent[e]; /* me is the newly formed element */ if (tmp[me] < *pflag) { adjncy[jdest++] = adjncy[jfirstolde]; /* move 1st old e to end */ adjncy[jfirstolde++] = me; /* append me at the beg. */ tmp[me] = *pflag; } } else /* e has not been absorbed, i.e. it is */ if (tmp[e] < *pflag) /* an old element */ { adjncy[jdest++] = e; tmp[e] = *pflag; } } jfirstv = jdest; /* list of variables starts here */ /* ------------------------------------------------------- scan the list of variables associated with variable u place newly formed elements at the begining of the list ------------------------------------------------------- */ for (j = jstart + elen[u]; j < jstop; j++) { v = adjncy[j]; #ifdef DEBUG printf(" >> variable %d (score %d)\n", v, score[v]); #endif if (score[v] == -3) /* v has been eliminated in this step */ { if (tmp[v] < *pflag) /* and, thus, forms a newly created elem. */ { adjncy[jdest++] = adjncy[jfirstv]; /* move 1st var. to end */ adjncy[jfirstv++] = adjncy[jfirstolde]; /* move 1st old e to end */ adjncy[jfirstolde++] = v; /* append v at the beg. */ tmp[v] = *pflag; } } else adjncy[jdest++] = v; /* v is still a variable */ } elen[u] = jfirstv - jstart; len[u] = jdest - jstart; (*pflag)++; /* clear tmp for next round */ #ifdef DEBUG printf(" node %d: neighboring elements:\n", u); for (j = jstart; j < jstart + elen[u]; j++) printf("%5d", adjncy[j]); printf("\n node %d: neighboring variables:\n", u); for (j = jstart + elen[u]; j < jstart + len[u]; j++) printf("%5d", adjncy[j]); printf("\n"); #endif } /* --------------------------------------------------------- remove from each list all covered edges between variables --------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; jstart = xadj[u]; jstop = jstart + len[u]; marku = FALSE; for (jdest = j = jstart + elen[u]; j < jstop; j++) { v = adjncy[j]; if (vwght[v] > 0) /* v does not belong to reachset */ adjncy[jdest++] = v; /* edge (u,v) not covered */ if (vwght[v] < 0) /* both vertices belong to reachset */ { covered = FALSE; /* check for a common element */ if (!marku) { for (jj = jstart; jj < jstart + elen[u]; jj++) /* mark elem. */ tmp[adjncy[jj]] = *pflag; /* of u */ marku = TRUE; } for (jj = xadj[v]; jj < xadj[v] + elen[v]; jj++) /* check elem. */ if (tmp[adjncy[jj]] == *pflag) /* of v */ { covered = TRUE; break; } if (!covered) adjncy[jdest++] = v; } } len[u] = jdest - jstart; (*pflag)++; /* clear tmp for next round */ #ifdef DEBUG printf(" node %d: neighboring uncovered variables:\n", u); for (j = jstart + elen[u]; j < jstart + len[u]; j++) printf("%5d", adjncy[j]); printf("\n"); #endif } /* -------------------------------- unmark all variables in reachset -------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; vwght[u] = -vwght[u]; } } /***************************************************************************** ******************************************************************************/ void findIndNodes(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT *bin, PORD_INT *next, PORD_INT *tmp, PORD_INT *pflag) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *parent, *score; PORD_INT nvtx, chk, keepon, u, v, w, wlast, i, j, jstart, jstop, jstep, jj, jjstop; nvtx = Gelim->G->nvtx; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; parent = Gelim->parent; score = Gelim->score; #ifdef DEBUG printf("Checking reachset for indistinguishable variables\n"); #endif /* ----------------------------------------------------------------------- compute checksums for all principal variables on reachset and fill bins NOTE: checksums are stored in parent vector ----------------------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; chk = 0; jstart = xadj[u]; jstop = jstart + len[u]; /* Modified by JYL: 16 march 2005: * This code was failing in case of * overflow. for (j = jstart; j < jstop; j++) chk += adjncy[j]; chk = chk % nvtx; */ jstep=max(1000000000/nvtx,1); for (j = jstart; j < jstop; j+=jstep) { jjstop = min(jstop, j+jstep); for (jj = j; jj < jjstop; jj++) chk += adjncy[jj]; chk = chk % nvtx; } parent[u] = chk; /* JYL: temporary: if (parent[u] < - 10) printf("Probleme %d \n",chk);*/ next[u] = bin[chk]; bin[chk] = u; } /* ----------------------- supervariable detection ----------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; if (vwght[u] > 0) /* u is a principal variable */ { chk = parent[u]; /* search bin[chk] for ind. nodes */ v = bin[chk]; /* okay, v is the first node in this bin */ bin[chk] = -1; /* no further examinations of this bin */ while (v != -1) { jstart = xadj[v]; jstop = xadj[v] + len[v]; for (j = jstart; j < jstop; j++) tmp[adjncy[j]] = *pflag; w = next[v]; /* v is principal and w is a potential */ wlast = v; /* nonprincipal variable */ while (w != -1) { keepon = TRUE; if ((len[w] != len[v]) || (elen[w] != elen[v]) || ((score[w] < 0) && (score[v] >= 0)) || ((score[w] >= 0) && (score[v] < 0))) keepon = FALSE; if (keepon) { for (jj = xadj[w]; jj < xadj[w] + len[w]; jj++) if (tmp[adjncy[jj]] < *pflag) { keepon = FALSE; break; } } if (keepon) /* found it! mark w as nonprincipal */ { parent[w] = v; /* representative of w is v */ /* Temporary JY if (parent[w] < - 10) printf("Probleme\n"); */ #ifdef DEBUG printf(" non-principal variable %d (score %d) mapped onto " "%d (score %d)\n", w, score[w], v, score[v]); #endif vwght[v] += vwght[w]; /* add weight of w */ vwght[w] = 0; xadj[w] = -1; /* w's adjacency list can be over- */ score[w] = -2; /* written during next crunch */ w = next[w]; next[wlast] = w; /* remove w from bin */ } else /* failed */ { wlast = w; w = next[w]; } } v = next[v]; /* no more variables can be absorbed by v */ (*pflag)++; /* clear tmp vector for next round */ } } } /* ------------------------------------------------------- re-initialize parent vector for all principal variables ------------------------------------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; if (vwght[u] > 0) parent[u] = -1; } } /***************************************************************************** ******************************************************************************/ void updateDegree(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT *bin) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *degree; PORD_INT totvwght, deg, vwghtv, u, v, w, e, me, r, i, istart, istop; PORD_INT j, jstart, jstop; totvwght = Gelim->G->totvwght; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; degree = Gelim->degree; /* ------------------------------------------------------------------- degree update only for those vertices in reachset that are adjacent to an element ------------------------------------------------------------------- */ for (r = 0; r < nreach; r++) { u = reachset[r]; if (elen[u] > 0) bin[u] = 1; } /* ----------------------------------------- and now do the approximate degree updates ----------------------------------------- */ for (r = 0; r < nreach; r++) { u = reachset[r]; if (bin[u] == 1) /* me is the most recently formed element */ { me = adjncy[xadj[u]]; /* in the neighborhood of u */ #ifdef DEBUG printf("Updating degree of all variables in L(%d) (initiated by %d)\n", me, u); #endif /* ---------------------------------------------------------------- compute in bin[e] the size of Le\Lme for all unabsorbed elements ---------------------------------------------------------------- */ istart = xadj[me]; istop = istart + len[me]; /* compute in bin[e] the size */ for (i = istart; i < istop; i++) /* of Le/Lme for all elements */ { v = adjncy[i]; /* e != me that are adjacent */ vwghtv = vwght[v]; /* to a principal var. e Lme */ if (vwghtv > 0) { jstart = xadj[v]; jstop = jstart + elen[v]; for (j = jstart; j < jstop; j++) { e = adjncy[j]; if (e != me) { if (bin[e] > 0) bin[e] -= vwghtv; else bin[e] = degree[e] - vwghtv; } } } } #ifdef DEBUG for (i = istart; i < istop; i++) { v = adjncy[i]; if (vwght[v] > 0) for (j = xadj[v]; j < xadj[v] + elen[v]; j++) { e = adjncy[j]; if (e != me) printf(" >> element %d: degree %d, outer degree %d\n", e, degree[e], bin[e]); } } #endif /* ------------------------------------------------------ update approx. degree for all v in Lme with bin[v] = 1 ------------------------------------------------------ */ for (i = istart; i < istop; i++) { v = adjncy[i]; /* update the upper bound deg. */ vwghtv = vwght[v]; /* of all principal variables */ deg = 0; /* in Lme that have not been */ if (bin[v] == 1) /* updated yet */ { jstart = xadj[v]; jstop = jstart + len[v]; /* scan the element list associated with principal v */ for (j = jstart; j < jstart + elen[v]; j++) { e = adjncy[j]; if (e != me) deg += bin[e]; } /* scan the supervariables in the list associated with v */ for (j = jstart + elen[v]; j < jstop; j++) { w = adjncy[j]; deg += vwght[w]; } /* compute the external degree of v (add size of Lme) */ deg = min(degree[v], deg); degree[v] = max(1, min(deg+degree[me]-vwghtv, totvwght-vwghtv)); bin[v] = -1; #ifdef DEBUG printf(" >> variable %d (totvwght %d, vwght %d): deg %d, " "degme %d, approx degree %d\n", v, totvwght, vwghtv, deg, degree[me], degree[v]); #endif } } /* ------------------------------------ clear bin[e] of all elements e != me ------------------------------------ */ for (i = istart; i < istop; i++) { v = adjncy[i]; vwghtv = vwght[v]; if (vwghtv > 0) { jstart = xadj[v]; jstop = jstart + elen[v]; for (j = jstart; j < jstop; j++) { e = adjncy[j]; if (e != me) bin[e] = -1; } } } } } } /***************************************************************************** ******************************************************************************/ void updateScore(gelim_t *Gelim, PORD_INT *reachset, PORD_INT nreach, PORD_INT scoretype, PORD_INT *bin) { PORD_INT *xadj, *adjncy, *vwght, *len, *elen, *degree, *score; PORD_INT vwghtv, deg, degme, u, v, me, r, i, istart, istop; /* Modified by JYL, 16 march 2005. * scr could overflow for quasi dense rows. * Use a double instead for large degrees * aset it near to MAX_INT in case of problem. */ double scr_dbl; PORD_INT scr; xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; elen = Gelim->elen; degree = Gelim->degree; score = Gelim->score; /* ------------------------------------------------------------------ score update only for those vertices in reachset that are adjacent to an element ------------------------------------------------------------------ */ for (r = 0; r < nreach; r++) { u = reachset[r]; if (elen[u] > 0) bin[u] = 1; } /* ---------------------------- and now do the score updates ---------------------------- */ scoretype = scoretype % 10; for (r = 0; r < nreach; r++) { u = reachset[r]; if (bin[u] == 1) /* me is the most recently formed element */ { me = adjncy[xadj[u]]; /* in the neighborhood of u */ #ifdef DEBUG printf("Updating score of all variables in L(%d) (initiated by %d)\n", me, u); #endif istart = xadj[me]; istop = xadj[me] + len[me]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* update score of all principal */ if (bin[v] == 1) /* variables in Lme that have not */ { vwghtv = vwght[v]; /* been updated yet */ deg = degree[v]; degme = degree[me] - vwghtv; if (deg > 40000 || degme > 40000) { switch(scoretype) { case AMD: scr_dbl = (double)deg; break; case AMF: scr_dbl = (double)deg*(double)(deg-1)/2 - (double)degme*(double)(degme-1)/2; break; case AMMF: scr_dbl = ((double)deg*(double)(deg-1)/2 - (double)degme*(double)(degme-1)/2) / (double)vwghtv; break; case AMIND: scr_dbl = max(0, ((double)deg*(double)(deg-1)/2 - (double)degme*(double)(degme-1)/2) - (double)deg*(double)vwghtv); break; default: fprintf(stderr, "\nError in function updateScore\n" " unrecognized selection strategy %d\n", scoretype); quit(); } /* Some buckets have offset nvtx / 2. * Using MAX_INT - nvtx should then be safe */ score[v] = (PORD_INT) (min(scr_dbl,MAX_INT-Gelim->G->nvtx)); } else { switch(scoretype) { case AMD: scr = deg; break; case AMF: scr = deg*(deg-1)/2 - degme*(degme-1)/2; break; case AMMF: scr = (deg*(deg-1)/2 - degme*(degme-1)/2) / vwghtv; break; case AMIND: scr = max(0, (deg*(deg-1)/2 - degme*(degme-1)/2) - deg*vwghtv); break; default: fprintf(stderr, "\nError in function updateScore\n" " unrecognized selection strategy %d\n", scoretype); quit(); } score[v] = scr; } bin[v] = -1; #ifdef DEBUG printf(" >> variable %d (me %d): weight %d, (ext)degme %d, " "degree %d, score %d\n", u, me, vwghtv, degme, degree[v], score[v]); #endif if (score[v] < 0) { fprintf(stderr, "\nError in function updateScore\n" " score[%d] = %d is negative\n", v, score[v]); quit(); } } } } } } /*****************************************************************************) ******************************************************************************/ elimtree_t* extractElimTree(gelim_t *Gelim) { elimtree_t *T; PORD_INT *vwght, *par, *degree, *score, *sib, *fch; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT nvtx, nfronts, root, u, v, front; nvtx = Gelim->G->nvtx; vwght = Gelim->G->vwght; par = Gelim->parent; degree = Gelim->degree; score = Gelim->score; /* ------------------------ allocate working storage ------------------------ */ mymalloc(sib, nvtx, PORD_INT); mymalloc(fch, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) sib[u] = fch[u] = -1; /* -------------------------------------------------------------- count fronts and create top-down view of the tree given by par -------------------------------------------------------------- */ nfronts = 0; root = -1; for (u = 0; u < nvtx; u++) switch(score[u]) { case -2: /* variable u is nonprincipal */ break; case -3: /* variable u has been elim. and now forms an elem. */ sib[u] = root; root = u; nfronts++; break; case -4: /* element u has been absorbed by par[u] */ v = par[u]; sib[u] = fch[v]; fch[v] = u; nfronts++; break; default: fprintf(stderr, "\nError in function extractElimTree\n" " ordering not complete (score[%d] = %d)\n", u, score[u]); quit(); } #ifdef DEBUG for (u = 0; u < nvtx; u++) printf("node %d: score %d, par %d, fch %d, sib %d\n", u, score[u], par[u], fch[u], sib[u]); #endif /* -------------------------------------- allocate space for the elimtree object -------------------------------------- */ T = newElimTree(nvtx, nfronts); ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; vtx2front = T->vtx2front; /* ------------------------------------------------------------- fill the vtx2front vector so that representative vertices are mapped in a post-order traversal ------------------------------------------------------------- */ nfronts = 0; u = root; while (u != -1) { while (fch[u] != -1) u = fch[u]; vtx2front[u] = nfronts++; while ((sib[u] == -1) && (par[u] != -1)) { u = par[u]; vtx2front[u] = nfronts++; } u = sib[u]; } /* --------------------------------------------------- fill in the vtx2front map for nonprincipal vertices --------------------------------------------------- */ for (u = 0; u < nvtx; u++) if (score[u] == -2) { v = u; while ((par[v] != -1) && (score[v] == -2)) v = par[v]; vtx2front[u] = vtx2front[v]; } /* ------------------------------------------------------------- set up the parent vector of T and fill ncolfactor, ncolupdate ------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) { front = vtx2front[u]; if (score[u] == -3) { parent[front] = -1; ncolfactor[front] = vwght[u]; ncolupdate[front] = degree[u]; } if (score[u] == -4) { parent[front] = vtx2front[par[u]]; ncolfactor[front] = vwght[u]; ncolupdate[front] = degree[u]; } } /* ---------------------------- set up all other arrays of T ---------------------------- */ initFchSilbRoot(T); /* ---------------------- free memory and return ---------------------- */ free(sib); free(fch); return(T); } MUMPS_5.4.1/PORD/lib/Makefile0000664000175000017500000000137414102210467015702 0ustar jylexceljylexcel # To compile directly, uncomment the line below. # include ../Make.in # # include $(BUILDDIR)/Makefile.inc # # Otherwise, adequate variables for CC, CFLAGS, AR and # RANLIB must be passed to make. # INCLUDES = -I../include COPTIONS = $(INCLUDES) $(CFLAGS) $(OPTFLAGS) OBJS = graph.o gbipart.o gbisect.o ddcreate.o ddbisect.o nestdiss.o \ multisector.o gelim.o bucket.o tree.o \ symbfac.o interface.o sort.o minpriority.o # Note: numfac.c read.c mapping.c triangular.c matrix.c kernel.c # were not direcly used by MUMPS and have been removed from the # original SPACE package. # OUTC = -o .c.o: $(CC) $(COPTIONS) -c $*.c $(OUTC)$*.o libpord$(LIBEXT):$(OBJS) $(AR)$@ $(OBJS) $(RANLIB) $@ clean: rm -f *.o realclean: rm -f *.o libpord.a MUMPS_5.4.1/PORD/lib/nestdiss.c0000664000175000017500000002531214102210467016240 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: nestdiss.c / / author J"urgen Schulze, University of Paderborn / created 00dec29 / / This file contains functions dealing with the rec. nested dissection object / ****************************************************************************** Data type: struct nestdiss graph_t *G; pointer to original graph int *map; maps nodes of G to constructed subgraph int depth; depth in nested dissection tree int nvint; number of vertices in subgraph int *intvertex; internal vertices of subgraph int *intcolor; color of vertices in intvertex int cwght[3]; weights of bisection struct nestdiss *parent; pointer to parent nd node struct nestdiss *childB; pointer to black descendant nd node struct nestdiss *childW; pointer to white descendand nd node Comments: o Structure used to build the nested dissection tree. Vector intvertex holds the vertices of the subgraph to be partitioned. Once a separator has been computed, the coloring of vertex u = intvertex[i] is stored in vector intcolor[i] and the partition weights are stored in cwght[GRAY], cwght[BLACK], and cwght[WHITE]. o Structure does not own graph object G => it will not be freed Note: G is the original graph o Structure does not own map array => it will not be freed Note: map is a "global" array that is used when constructing the subgraph induced by the vertices in intvertex. The array maps the vertices of the original graph G to the vertices of the subgraph. Methods in lib/nestdiss.c: - nd = newNDnode(graph_t *G, int *map, int nvint); o Initial: depth = 0, cwght[GRAY] = cwght[BLACK] = cwght[WHITE] = 0, and parent = childB = childW = NULL; - void freeNDnode(nestdiss_t *nd); - ndroot = setupNDroot(graph_t *G, int *map); o sets up the root of the nested dissection tree; the function first calls newNDnode to allocate memory for ndroot and, then, sets intvertex[i] = i for all 0 <= i < G->nvtx - void splitNDnode(nestdiss_t *nd, options_t *options, timings_t *cpus); o constructs the subgraph induced by nd->intvertex and computes a bisection for it by calling constructSeparator and smoothSeparator. Then, the nd object is splitted in a black one that holds the black partition and a white one that holds the white partition. o used options: (see constructSeparator and smoothSeparator) OPTION_MSGLVL, OPTION_NODE_SELECTION3 o returned timings: (also see constructSeparator) TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP TIME_MULTILEVEL, TIME_SMOOTH - void buildNDtree(nestdiss_t *ndroot, options_t *options, timings_t *cpus); o builds the nested dissection tree under root ndroot, i.e. it applies the nested dissection process to the (sub)graph induced by ndroot->intvertex by iteratively calling function splitNDnode. o used options: (also see splitNDnode) OPTION_DOMAIN_SIZE, OPTION_MSGLVL, OPTION_NODE_SELECTION3 o returned timings: (see splitNDnode) TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP TIME_MULTILEVEL, TIME_SMOOTH - void freeNDtree(nestdiss_t *ndroot); o removes the nested dissection tree under root ndroot Note: ndroot is not freed ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ nestdiss_t* newNDnode(graph_t *G, PORD_INT *map, PORD_INT nvint) { nestdiss_t *nd; mymalloc(nd, 1, nestdiss_t); mymalloc(nd->intvertex, nvint, PORD_INT); mymalloc(nd->intcolor, nvint, PORD_INT); nd->G = G; nd->map = map; nd->depth = 0; nd->nvint = nvint; nd->cwght[GRAY] = nd->cwght[BLACK] = nd->cwght[WHITE] = 0; nd->parent = nd->childB = nd->childW = NULL; return(nd); } /***************************************************************************** ******************************************************************************/ void freeNDnode(nestdiss_t *nd) { free(nd->intvertex); free(nd->intcolor); free(nd); } /***************************************************************************** ******************************************************************************/ nestdiss_t* setupNDroot(graph_t *G, PORD_INT *map) { nestdiss_t *ndroot; PORD_INT *intvertex, nvtx, i; nvtx = G->nvtx; ndroot = newNDnode(G, map, nvtx); intvertex = ndroot->intvertex; for (i = 0; i < nvtx; i++) intvertex[i] = i; return(ndroot); } /***************************************************************************** ******************************************************************************/ void splitNDnode(nestdiss_t *nd, options_t *options, timings_t *cpus) { nestdiss_t *b_nd, *w_nd; graph_t *Gsub; gbisect_t *Gbisect; PORD_INT *map, *intvertex, *intcolor, *b_intvertex, *w_intvertex; PORD_INT nvint, b_nvint, w_nvint, u, i; map = nd->map; nvint = nd->nvint; intvertex = nd->intvertex; intcolor = nd->intcolor; /* ------------------------------------------------------------- extract the subgraph for which a bisection has to be computed ------------------------------------------------------------- */ if (nd->G->nvtx == nd->nvint) { Gsub = nd->G; /* a hack to save time and space */ for (u = 0; u < nd->nvint; u++) /* but do not forget the map vector */ map[u] = u; } else Gsub = setupSubgraph(nd->G, intvertex, nvint, map); Gbisect = newGbisect(Gsub); /* --------------------------------- compute the bisection for Gbisect --------------------------------- */ pord_starttimer(cpus[TIME_MULTILEVEL]); constructSeparator(Gbisect, options, cpus); pord_stoptimer(cpus[TIME_MULTILEVEL]); pord_starttimer(cpus[TIME_SMOOTH]); if (Gbisect->cwght[GRAY] > 0) smoothSeparator(Gbisect, options); pord_stoptimer(cpus[TIME_SMOOTH]); /* ---------------------------------------- copy the bisection back to the nd object ---------------------------------------- */ b_nvint = w_nvint = 0; nd->cwght[GRAY] = Gbisect->cwght[GRAY]; nd->cwght[BLACK] = Gbisect->cwght[BLACK]; nd->cwght[WHITE] = Gbisect->cwght[WHITE]; for (i = 0; i < nvint; i++) { u = intvertex[i]; intcolor[i] = Gbisect->color[map[u]]; switch(intcolor[i]) { case GRAY: break; case BLACK: b_nvint++; break; case WHITE: w_nvint++; break; default: fprintf(stderr, "\nError in function splitNDnode\n" " node %d has unrecognized color %d\n", u, intcolor[i]); quit(); } } /* ------------------------------------------------------ and now split the nd object according to the bisection ------------------------------------------------------ */ b_nd = newNDnode(nd->G, map, b_nvint); b_intvertex = b_nd->intvertex; w_nd = newNDnode(nd->G, map, w_nvint); w_intvertex = w_nd->intvertex; b_nvint = w_nvint = 0; for (i = 0; i < nvint; i++) { u = intvertex[i]; if (intcolor[i] == BLACK) b_intvertex[b_nvint++] = u; if (intcolor[i] == WHITE) w_intvertex[w_nvint++] = u; } nd->childB = b_nd; b_nd->parent = nd; nd->childW = w_nd; w_nd->parent = nd; b_nd->depth = nd->depth + 1; w_nd->depth = nd->depth + 1; /* ----------------- free the subgraph ----------------- */ if (Gsub != nd->G) freeGraph(Gsub); freeGbisect(Gbisect); } /***************************************************************************** ******************************************************************************/ void buildNDtree(nestdiss_t *ndroot, options_t *options, timings_t *cpus) { nestdiss_t *nd; nestdiss_t *queue[2*MAX_SEPS+1]; PORD_INT maxseps, seps, domainsize, qhead, qtail; maxseps = MAX_SEPS; domainsize = options[OPTION_DOMAIN_SIZE]; if (domainsize == 1) maxseps = DEFAULT_SEPS; /* secret switch */ /* -------------------------------------------------- build the nested dissection tree under root ndroot -------------------------------------------------- */ queue[0] = ndroot; qhead = 0; qtail = 1; seps = 0; while ((qhead != qtail) && (seps < maxseps)) { seps++; nd = queue[qhead++]; splitNDnode(nd, options, cpus); if ((nd->childB == NULL) || (nd->childW == NULL)) { fprintf(stderr, "\nError in function buildNDtree\n" " recursive nested dissection process failed\n"); quit(); } if (options[OPTION_MSGLVL] > 1) printf("%4d. S %6d, B %6d, W %6d [bal %4.2f, rel %6.4f, cost %7.2f]\n", seps, nd->cwght[GRAY], nd->cwght[BLACK], nd->cwght[WHITE], (FLOAT)min(nd->cwght[BLACK], nd->cwght[WHITE]) / max(nd->cwght[BLACK], nd->cwght[WHITE]), (FLOAT)nd->cwght[GRAY] / (nd->cwght[GRAY] + nd->cwght[BLACK] + nd->cwght[WHITE]), F(nd->cwght[GRAY], nd->cwght[BLACK], nd->cwght[WHITE])); if ((nd->childB->nvint > MIN_NODES) && ((nd->cwght[BLACK] > domainsize) || (qtail < DEFAULT_SEPS))) queue[qtail++] = nd->childB; if ((nd->childW->nvint > MIN_NODES) && ((nd->cwght[WHITE] > domainsize) || (qtail < DEFAULT_SEPS))) queue[qtail++] = nd->childW; } } /***************************************************************************** ******************************************************************************/ void freeNDtree(nestdiss_t *ndroot) { nestdiss_t *nd, *parent; /* ------------------------------------------------------ to remove the nested dissection tree under root ndroot visit the nodes in post-order ------------------------------------------------------ */ for (nd = ndroot; nd->childB != NULL; nd = nd->childB); while (nd != ndroot) { parent = nd->parent; if ((parent == NULL) || (parent->childB == NULL) || (parent->childW == NULL)) { fprintf(stderr, "\nError in function removeNDtree\n" " nested dissection tree corrupted\n"); quit(); } if (parent->childB == nd) /* left subtree of parent visited */ { freeNDnode(nd); /* free root of left subtree and goto right */ for (nd = parent->childW; nd->childB != NULL; nd = nd->childB); } else /* right subtree of parent visited */ { freeNDnode(nd); /* free root of right subtree and goto parent */ nd = parent; } } } MUMPS_5.4.1/PORD/lib/minpriority.c0000664000175000017500000004151414102210467016773 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: minpriority.c / / author J"urgen Schulze, University of Paderborn / created 01jan15 / / This file contains functions dealing with the minimum priority object / ****************************************************************************** Data type: struct minprior gelim_t *Gelim; the elimination graph of G multisector_t *ms; the multisector for G bucket_t *bucket; holds unelim. vert. of actual stage stageinfo_t *stageinfo; contains statistics for each stage int *reachset; holds boundary vert. in each step int nreach; number of vertices in reachset int *auxaux; general purpose auxiliary vector int *auxbin; special auxiliary vector int *auxtmp; special auxiliary vector int flag; flag for vector auxtmp (see below) struct stageinfo int nstep; # of elim. steps in each stage int welim; weight of elim. vert. in each stage int nzf; # of factor entries in each stage FLOAT ops; # of factor ops. in each stage Comments: o Structure used to compute a minimum priority ordering for a graph G with multisector ms. The elimination process is organized in stages. The stages are given by the multisector (i.e. ms->stage). The vertices of a stage are eliminated in steps. In each elimination step a maximal independent set of vertices with minimum priority is eliminated o Structure does not own multisector object => it will not be freed o Three auxiliary vectors can be used by functions working on minprior IMPORTANT INVARIANTS for vectors auxbin, auxtmp auxbin[i] = -1 holds at start and at end of each function auxtmp[i] < flag holds at start and at end of each function Methods in lib/minpriority.c: - minprior = newMinPriority(int nvtx, int nstages); o Initial: Gelim = ms = bucket = NULL, nreach = 0, flag = 1; - void freeMinPriority(minprior_t *minprior); - minprior = setupMinPriority(multisector_t *ms); o allocates memory for the minprior object by calling newMinPriority and sets up the elimination graph by a call to setupElimGraph and the bucket by a call to setupBucket; finally, it initializes the vectors, i.e. auxbin[u] = -1, auxtmp[u] = 0 for all 0 <= u <= nvtx, and nstep = welim = nzf = ops = 0 for all stages - T = orderMinPriority(minprior_t *minprior options_t *options,timings_t *cpus); o MASTER_FUNCTION: computes a bottom-up ordering according to the specified ordtype e { MINIMUM_PRIORITY, INCOMPLETE_ND, MULTISECTION, TRISTAGE_MULTISECTION } o used options: OPTION_ORDTYPE, OPTION_NODE_SELECTION1, OPTION_NODE_SELECTION2 o returned timings: (see eliminateStage) TIME_UPDSCORE, TIME_UPDADJNCY, TIME_FINDINODES - void eliminateStage(minprior_t *minprior, int istage, int scoretype, timings_t *cpus); o eliminates all principal variables u with stage[u] <= istage using the score function given by scoretype o returned timings: TIME_UPDSCORE, TIME_UPDADJNCY, TIME_FINDINODES - int eliminateStep(minprior_t *minprior, int istage, int scoretype); o the variables u with stage[u] <= istage are eliminated in steps; in each step a maximal independet set of variables with minimum score is eliminated o the function returns the size of the independent set, i.e. the number of variables that have been eliminated in the actual step ******************************************************************************/ #include /* #define DEBUG */ /* #define BE_CAUTIOUS */ /***************************************************************************** ******************************************************************************/ minprior_t* newMinPriority(PORD_INT nvtx, PORD_INT nstages) { minprior_t *minprior; stageinfo_t *stageinfo; mymalloc(stageinfo, nstages, stageinfo_t); mymalloc(minprior, 1, minprior_t); minprior->Gelim = NULL; minprior->ms = NULL; minprior->bucket = NULL; minprior->stageinfo = stageinfo; mymalloc(minprior->reachset, nvtx, PORD_INT); mymalloc(minprior->auxaux, nvtx, PORD_INT); mymalloc(minprior->auxbin, nvtx, PORD_INT); mymalloc(minprior->auxtmp, nvtx, PORD_INT); minprior->nreach = 0; minprior->flag = 1; return(minprior); } /***************************************************************************** ******************************************************************************/ void freeMinPriority(minprior_t *minprior) { freeElimGraph(minprior->Gelim); freeBucket(minprior->bucket); free(minprior->stageinfo); free(minprior->reachset); free(minprior->auxaux); free(minprior->auxbin); free(minprior->auxtmp); free(minprior); } /***************************************************************************** ******************************************************************************/ minprior_t* setupMinPriority(multisector_t *ms) { minprior_t *minprior; stageinfo_t *stageinfo; PORD_INT *auxbin, *auxtmp; PORD_INT nvtx, nstages, istage, u; nvtx = ms->G->nvtx; nstages = ms->nstages; minprior = newMinPriority(nvtx, nstages); minprior->ms = ms; minprior->Gelim = setupElimGraph(ms->G); minprior->bucket = setupBucket(nvtx, nvtx, 0); auxbin = minprior->auxbin; auxtmp = minprior->auxtmp; for (u = 0; u < nvtx; u++) { auxbin[u] = -1; auxtmp[u] = 0; } for (istage = 0; istage < nstages; istage++) { stageinfo = minprior->stageinfo + istage; stageinfo->nstep = 0; stageinfo->welim = 0; stageinfo->nzf = 0; stageinfo->ops = 0.0; } return(minprior); } /***************************************************************************** ******************************************************************************/ elimtree_t* orderMinPriority(minprior_t *minprior, options_t *options, timings_t *cpus) { elimtree_t *T; PORD_INT nvtx, nstages, istage, scoretype, ordtype; nvtx = minprior->Gelim->G->nvtx; nstages = minprior->ms->nstages; ordtype = options[OPTION_ORDTYPE]; scoretype = options[OPTION_NODE_SELECTION2]; /* ------------------------------ check whether nstages is valid ------------------------------ */ if ((nstages < 1) || (nstages > nvtx)) { fprintf(stderr, "\nError in function orderMinPriority\n" " no valid number of stages in multisector (#stages = %d)\n", nstages); quit(); } if ((nstages < 2) && (ordtype != MINIMUM_PRIORITY)) { fprintf(stderr, "\nError in function orderMinPriority\n" " not enough stages in multisector (#stages = %d)\n", nstages); quit(); } /* -------------------------------------------------------------- first stage: eliminate all vertices in the remaining subgraphs -------------------------------------------------------------- */ scoretype = options[OPTION_NODE_SELECTION1]; eliminateStage(minprior, 0, scoretype, cpus); /* ------------------------------------------------------- other stages: eliminate all vertices in the multisector ------------------------------------------------------- */ switch(ordtype) { case MINIMUM_PRIORITY: break; case INCOMPLETE_ND: for (istage = 1; istage < nstages; istage++) eliminateStage(minprior, istage, scoretype, cpus); break; case MULTISECTION: eliminateStage(minprior, nstages-1, scoretype, cpus); break; default: fprintf(stderr, "\nError in function orderMinPriority\n" " unrecognized ordering type %d\n", ordtype); quit(); } /* ------------------------------------------- print statistics for the elimination stages ------------------------------------------- */ if ((ordtype != MINIMUM_PRIORITY) && (options[OPTION_MSGLVL] > 1)) for (istage = 0; istage < nstages; istage++) printf("%4d. stage: #steps %6d, weight %6d, nzl %8d, ops %e\n", istage, minprior->stageinfo[istage].nstep, minprior->stageinfo[istage].welim, minprior->stageinfo[istage].nzf, minprior->stageinfo[istage].ops); /* ----------------------------------- extract elimination tree and return ----------------------------------- */ T = extractElimTree(minprior->Gelim); return(T); } /***************************************************************************** ******************************************************************************/ void eliminateStage(minprior_t *minprior, PORD_INT istage, PORD_INT scoretype, timings_t *cpus) { gelim_t *Gelim; bucket_t *bucket; stageinfo_t *stageinfo; PORD_INT *stage, *reachset, *auxbin, *auxtmp, *auxaux; PORD_INT *degree, *score; PORD_INT *pflag, nreach, nvtx, r, u, i; Gelim = minprior->Gelim; bucket = minprior->bucket; stage = minprior->ms->stage; stageinfo = minprior->stageinfo + istage; reachset = minprior->reachset; auxaux = minprior->auxaux; auxbin = minprior->auxbin; auxtmp = minprior->auxtmp; pflag = &(minprior->flag); nvtx = Gelim->G->nvtx; degree = Gelim->degree; score = Gelim->score; #ifdef DEBUG printf("\nSTARTING NEW ELIMINATION STAGE (nedges %d, maxedges %d)\n\n", Gelim->G->nedges, Gelim->maxedges); if (istage> 0) printElimGraph(Gelim); /* waitkey(); */ #endif /* ------------------------------------------------------------- load reachset with all principal variables in stage <= istage ------------------------------------------------------------- */ nreach = 0; for (u = 0; u < nvtx; u++) if ((score[u] == -1) && (stage[u] <= istage)) { reachset[nreach++] = u; score[u] = degree[u]; /* score[u] = degree[u]*(degree[u]-1)/2; */ } /* ---------------------------------------------------------------- do an initial update of the vertices in reachset and fill bucket ---------------------------------------------------------------- */ pord_starttimer(cpus[TIME_UPDSCORE]); updateDegree(Gelim, reachset, nreach, auxbin); updateScore(Gelim, reachset, nreach, scoretype, auxbin); pord_stoptimer(cpus[TIME_UPDSCORE]); for (i = 0; i < nreach; i++) { u = reachset[i]; insertBucket(bucket, score[u], u); } /* ------------------------------------- and now start the elimination process ------------------------------------- */ while (TRUE) { if (eliminateStep(minprior, istage, scoretype) == 0) break; nreach = minprior->nreach; #ifdef BE_CAUTIOUS printf("checking arrays auxtmp and auxbin\n"); for (u = 0; u < nvtx; u++) if ((auxtmp[u] >= *pflag) || (auxbin[u] != -1)) { printf("ERROR: flag = %d, auxtmp[%d] = %d, auxbin[%d] = %d\n", *pflag, u, auxtmp[u], u, auxbin[u]); quit(); } #endif /* ---------------------------------------------------------- update the adjacency structure of all vertices in reachset ---------------------------------------------------------- */ pord_starttimer(cpus[TIME_UPDADJNCY]); updateAdjncy(Gelim, reachset, nreach, auxtmp, pflag); pord_stoptimer(cpus[TIME_UPDADJNCY]); /* ---------------------------------------- find indistinguishable nodes in reachset ---------------------------------------- */ pord_starttimer(cpus[TIME_FINDINODES]); findIndNodes(Gelim, reachset, nreach, auxbin, auxaux, auxtmp, pflag); pord_stoptimer(cpus[TIME_FINDINODES]); #ifdef BE_CAUTIOUS printf("checking arrays auxtmp and auxbin\n"); for (u = 0; u < nvtx; u++) if ((auxtmp[u] >= *pflag) || (auxbin[u] != -1)) { printf("ERROR: flag = %d, auxtmp[%d] = %d, auxbin[%d] = %d\n", *pflag, u, auxtmp[u], u, auxbin[u]); quit(); } #endif /* ---------------------------------------------------------------- clean reachset of nonprincipal nodes and nodes not in this stage ---------------------------------------------------------------- */ r = 0; for (i = 0; i < nreach; i++) { u = reachset[i]; if (score[u] >= 0) reachset[r++] = u; } nreach = r; /* --------------------------------------------------- update the degree/score of all vertices in reachset --------------------------------------------------- */ pord_starttimer(cpus[TIME_UPDSCORE]); updateDegree(Gelim, reachset, nreach, auxbin); updateScore(Gelim, reachset, nreach, scoretype, auxbin); pord_stoptimer(cpus[TIME_UPDSCORE]); /* ---------------------------- re-insert vertices in bucket ---------------------------- */ for (i = 0; i < nreach; i++) { u = reachset[i]; insertBucket(bucket, score[u], u); } stageinfo->nstep++; } } /***************************************************************************** ******************************************************************************/ PORD_INT eliminateStep(minprior_t *minprior, PORD_INT istage, PORD_INT scoretype) { gelim_t *Gelim; bucket_t *bucket; stageinfo_t *stageinfo; PORD_INT *stage, *reachset, *auxtmp; PORD_INT *xadj, *adjncy, *vwght, *len, *degree, *score; PORD_INT *pflag, *pnreach, nelim, minscr, vwghtu, u, v, i, istart, istop; FLOAT tri, rec; Gelim = minprior->Gelim; bucket = minprior->bucket; stage = minprior->ms->stage; stageinfo = minprior->stageinfo + istage; reachset = minprior->reachset; pnreach = &(minprior->nreach); auxtmp = minprior->auxtmp; pflag = &(minprior->flag); xadj = Gelim->G->xadj; adjncy = Gelim->G->adjncy; vwght = Gelim->G->vwght; len = Gelim->len; degree = Gelim->degree; score = Gelim->score; #ifdef DEBUG printf("\nStarting new elimination step (nedges %d, maxedges %d)\n", Gelim->G->nedges, Gelim->maxedges); /* waitkey(); */ #endif /* ---------------------- check for empty bucket ---------------------- */ if ((u = minBucket(bucket)) == -1) return(0); minscr = score[u]; /* ---------------------------------------- loop while nodes of minimum score remain ---------------------------------------- */ nelim = 0; *pnreach = 0; while (TRUE) { vwghtu = vwght[u]; /* -------------------------------------------------- increment welim and nelim and remove u from bucket -------------------------------------------------- */ removeBucket(bucket, u); stageinfo->welim += vwghtu; nelim++; /* ----------------------------------------------------------------- call buildElement to create element u and merge u's boundary with the nodes in reachset; remove any vertex from bucket that belongs to u's boundary and to the actual stage ----------------------------------------------------------------- */ buildElement(Gelim, u); istart = xadj[u]; istop = istart + len[u]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* v belongs to u's boundary */ if (auxtmp[v] < *pflag) /* v not yet in reachset */ { auxtmp[v] = *pflag; if (stage[v] <= istage) /* v belongs to actual stage */ removeBucket(bucket, v); reachset[(*pnreach)++] = v; } } #ifdef DEBUG printf("Node %d (weight %d, score %d) eliminated: (boundary weight %d)\n", u, vwghtu, minscr, degree[u]); for (i = istart; i < istop; i++) printf("%4d (degree %2d)", adjncy[i], degree[adjncy[i]]); printf("\n"); #endif /* --------------------------------------------------------------- increment the storage and operation counts for this elim. stage --------------------------------------------------------------- */ tri = vwghtu; rec = degree[u]; stageinfo->nzf += (PORD_INT)((tri * (tri+1)) / 2); stageinfo->nzf += (PORD_INT)(tri * rec); stageinfo->ops += (tri*tri*tri) / 3.0 + (tri*tri) / 2.0 - (5*tri) / 6.0; stageinfo->ops += (tri*tri*rec) + (rec*(rec+1)*tri); /* --------------------------------------------------------------- end this elim. step, if one of the following conditions is true (1) no multiple elimination (2) bucket empty (3) no further variable with minimum score ---------------------------------------------------------------- */ if (scoretype / 10 == 0) break; if ((u = minBucket(bucket)) == -1) break; if (score[u] > minscr) break; } /* ----------------------- clear auxtmp and return ----------------------- */ (*pflag)++; return(nelim); } MUMPS_5.4.1/PORD/lib/bucket.c0000664000175000017500000002006614102210467015662 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: bucket.c / / author J"urgen Schulze, University of Paderborn / created 12/06/00 / / This file contains functions dealing with buckets. / ****************************************************************************** Data type: struct bucket int maxbin; maximal bin in bucket int maxitem; maximal item that can be stored in bucket int offset; to store items with negative key-value int nobj; number of items in bucket int minbin; leftmost non-empty bin int *bin; there are maxbin+1 bins (bin[0]...bin[maxbin]) int *next; next[item] points to next item in bin int *last; last[item] points to previous item in bin int *key; holds key of item (MAX_INT if item not in bucket) Comments: o Any implementation of a bucket should enable insert/remove operations in constant time o There a two special bins: bin[0] contains all items u with key[u] + offset < 0 bin[maxbin] contains all items u with key[u] + offset > maxbin Methods in lib/bucket.c: - bucket = newBucket(int maxbin, int maxitem, int offset); o Initial: nobj = 0 and minbin = MAX_INT - void freeBucket(bucket_t *bucket); - bucket = setupBucket(int maxbin, int maxitem, int offset); o allocates memory for the bucket by calling newBucket and initializes the vectors, i.e. bin[i] = -1 for all 0 <= i <= maxbin, next[u] = last[u] = -1, and key[u] = MAX_INT for all 0 <= u <= maxitem - int minBucket(bucket_t *bucket); o returns the item whose key-value is minimal; this item is stored in bin[minbin]; if minbin = 0 or minbin = maxbin, the whole bin must be searched, since the items stored herein may have different keys o if nobj = 0, the function returns -1 - void insertBucket(bucket_t *bucket, int k, int item); o insert item with key k in bucket; if key[item] != MAX_INT (i.e. item already in bucket) or if item > maxitem the program terminates - void removeBucket(bucket_t *bucket, int item); o removes item from bucket; if key[item] == MAX_INT (i.e. item not in bucket) the program terminates ******************************************************************************/ #include /****************************************************************************** ******************************************************************************/ bucket_t* newBucket(PORD_INT maxbin, PORD_INT maxitem, PORD_INT offset) { bucket_t *bucket; mymalloc(bucket, 1, bucket_t); mymalloc(bucket->bin, (maxbin+1), PORD_INT); mymalloc(bucket->next, (maxitem+1), PORD_INT); mymalloc(bucket->last, (maxitem+1), PORD_INT); mymalloc(bucket->key, (maxitem+1), PORD_INT); bucket->maxbin = maxbin; bucket->maxitem = maxitem; bucket->offset = offset; bucket->nobj = 0; bucket->minbin = MAX_INT; return(bucket); } /****************************************************************************** ******************************************************************************/ void freeBucket(bucket_t *bucket) { free(bucket->bin); free(bucket->next); free(bucket->last); free(bucket->key); free(bucket); } /****************************************************************************** ******************************************************************************/ bucket_t* setupBucket(PORD_INT maxbin, PORD_INT maxitem, PORD_INT offset) { bucket_t *bucket; PORD_INT i, u; if (offset < 0) { fprintf(stderr, "\nError in function setupBucket\n" " offset must be >= 0\n"); quit(); } bucket = newBucket(maxbin, maxitem, offset); for (i = 0; i <= maxbin; i++) bucket->bin[i] = -1; for (u = 0; u <= maxitem; u++) { bucket->next[u] = bucket->last[u] = -1; bucket->key[u] = MAX_INT; } return(bucket); } /****************************************************************************** ******************************************************************************/ PORD_INT minBucket(bucket_t *bucket) { PORD_INT *bin, *next, *key, maxbin, minbin, nobj; PORD_INT item, bestitem, bestkey; maxbin = bucket->maxbin; nobj = bucket->nobj; minbin = bucket->minbin; bin = bucket->bin; next = bucket->next; key = bucket->key; if (nobj > 0) { /* --------------------------------------------- get the first item from leftmost nonempty bin --------------------------------------------- */ while (bin[minbin] == -1) minbin++; bucket->minbin = minbin; bestitem = bin[minbin]; bestkey = minbin; /* -------------------------------------------------- items in bins 0 and maxbin can have different keys => search for item with smallest key -------------------------------------------------- */ if ((minbin == 0) || (minbin == maxbin)) { item = next[bestitem]; while (item != -1) { if (key[item] < bestkey) { bestitem = item; bestkey = key[item]; } item = next[item]; } } /* --------------------------------- return the item with smallest key --------------------------------- */ return(bestitem); } else return(-1); } /****************************************************************************** ******************************************************************************/ void insertBucket(bucket_t *bucket, PORD_INT k, PORD_INT item) { PORD_INT s, nextitem; /* ------------------------------------ check whether there are any problems ------------------------------------ */ if (abs(k) >= MAX_INT - bucket->offset - 1) { fprintf(stderr, "\nError in function insertBucket\n" " key %d too large/small for bucket\n", k); quit(); } if (item > bucket->maxitem) { fprintf(stderr, "\nError in function insertBucket\n" " item %d too large for bucket (maxitem is %d)\n", item, bucket->maxitem); quit(); } if (bucket->key[item] != MAX_INT) { fprintf(stderr, "\nError in function insertBucket\n" " item %d already in bucket\n", item); quit(); } /* ------------------------------------- determine the bin that holds the item ------------------------------------- */ s = max(0, (k + bucket->offset)); s = min(s, bucket->maxbin); /* -------------------------------------------------------------- adjust minbin, increase nobj, and mark item as being in bucket -------------------------------------------------------------- */ bucket->minbin = min(bucket->minbin, s); bucket->nobj++; bucket->key[item] = k; /* ----------------------------- finally, insert item in bin s ----------------------------- */ nextitem = bucket->bin[s]; if (nextitem != -1) bucket->last[nextitem] = item; bucket->next[item] = nextitem; bucket->last[item] = -1; bucket->bin[s] = item; } /****************************************************************************** ******************************************************************************/ void removeBucket(bucket_t *bucket, PORD_INT item) { PORD_INT s, nextitem, lastitem; /* ---------------------------- check whether item in bucket ---------------------------- */ if (bucket->key[item] == MAX_INT) { fprintf(stderr, "\nError in function removeBucket\n" " item %d is not in bucket\n", item); quit(); } /* ----------------------- remove item from bucket ----------------------- */ nextitem = bucket->next[item]; lastitem = bucket->last[item]; if (nextitem != -1) bucket->last[nextitem] = lastitem; if (lastitem != -1) bucket->next[lastitem] = nextitem; else { s = max(0, (bucket->key[item] + bucket->offset)); s = min(s, bucket->maxbin); bucket->bin[s] = nextitem; } /* -------------------------------------------- decrease nobj and mark item as being removed -------------------------------------------- */ bucket->nobj--; bucket->key[item] = MAX_INT; } MUMPS_5.4.1/PORD/lib/gbisect.c0000664000175000017500000004254214102210467016030 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: gbisect.c / / author J"urgen Schulze, University of Paderborn / created 00dec29 / / This file contains functions dealing with the graph bisection object / ****************************************************************************** Data type: struct gbisect graph_t *G; pointer to graph that will be partitioned int *color; color of node (GRAY, BLACK, or WHITE) int cwght[3]; weights of GRAY, BLACK, WHITE partitions Comments: o Structure used to compute the bisection of a graph. Structure does not own graph object => it will not be freed. Methods in lib/gbisect.c: - Gbisect = newGbisect(graph_t *G); o Initial: cwght[GRAY] = cwght[BLACK] = cwght[WHITE] = 0 - void freeGbisect(gbisect_t *Gbisect); - void printGbisect(gbisect_t *Gbisect); - void checkSeparator(gbisect_t *Gbisect); - void constructSeparator(gbisect_t *Gbisect, options_t *options, timings_t *cpus); o constructs a vertex separator by applying the new multilevel approach; it first constructs an initial domain decomposition for Gbisect->G by calling constructDomainDecomposition; the dd is then coarsed by several calls to shrinkDomainDecomposition; the last dd is colored by a call to initialDDSep; this coloring is refined during the uncoarsening phase by several calls to improveDDSep o used options: OPTION_MSGLVL, OPTION_NODE_SELECTION3 returned timings: TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP - int smoothBy2Layers(gbisect_t *Gbisect, int *bipartvertex, int *pnX, int black, int white); o on start, bipartvertex contains the nodes of the separator; the separator is then paired with eiter the black or the white partition so that the nodes in bipartvertex induce a bipartite graph; this graph is constructed by setupBipartiteGraph; a Dulmage-Mendelsohn decomposition is computed and the separator is smoothed; the vertices of the smoothed separator are returned in bipartvertex - void smoothSeparator(gbisect_t *Gbisect, options_t *options); o smoothes a given separator by repeatedly calling smoothBy2Layers o used options: OPTION_MSGLVL ******************************************************************************/ #include /* #define DEBUG */ /* #define BE_CAUTIOUS */ /***************************************************************************** ******************************************************************************/ gbisect_t* newGbisect(graph_t *G) { gbisect_t *Gbisect; mymalloc(Gbisect, 1, gbisect_t); mymalloc(Gbisect->color, G->nvtx, PORD_INT); Gbisect->G = G; Gbisect->cwght[GRAY] = 0; Gbisect->cwght[BLACK] = 0; Gbisect->cwght[WHITE] = 0; return(Gbisect); } /***************************************************************************** ******************************************************************************/ void freeGbisect(gbisect_t *Gbisect) { free(Gbisect->color); free(Gbisect); } /***************************************************************************** ******************************************************************************/ void printGbisect(gbisect_t *Gbisect) { graph_t *G; PORD_INT count, u, v, i, istart, istop; G = Gbisect->G; printf("\n#nodes %d, #edges %d, totvwght %d\n", G->nvtx, G->nedges >> 1, G->totvwght); printf("partition weights: S %d, B %d, W %d\n", Gbisect->cwght[GRAY], Gbisect->cwght[BLACK], Gbisect->cwght[WHITE]); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of node %d (weight %d, color %d)\n", u, G->vwght[u], Gbisect->color[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { v = G->adjncy[i]; printf("%5d (color %2d)", v, Gbisect->color[v]); if ((++count % 4) == 0) printf("\n"); } if ((count % 4) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ void checkSeparator(gbisect_t *Gbisect) { PORD_INT *xadj, *adjncy, *vwght, *color, *cwght; PORD_INT nvtx, err, checkS, checkB, checkW, a, b, u, v, i, istart, istop; nvtx = Gbisect->G->nvtx; xadj = Gbisect->G->xadj; adjncy = Gbisect->G->adjncy; vwght = Gbisect->G->vwght; color = Gbisect->color; cwght = Gbisect->cwght; err = FALSE; printf("checking separator of induced subgraph (S %d, B %d, W %d)\n", cwght[GRAY], cwght[BLACK], cwght[WHITE]); checkS = checkB = checkW = 0; for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; switch(color[u]) { case GRAY: /* is it a minimal separator? */ checkS += vwght[u]; a = b = FALSE; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == WHITE) a = TRUE; if (color[v] == BLACK) b = TRUE; } if (!((a) && (b))) printf("WARNING: not a minimal separator (node %d)\n", u); break; case BLACK: /* is it realy a separator? */ checkB += vwght[u]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == WHITE) { printf("ERROR: white node %d adjacent to black node %d\n", u,v); err = TRUE; } } break; case WHITE: checkW += vwght[u]; break; default: printf("ERROR: node %d has unrecognized color %d\n", u, color[u]); err = TRUE; } } /* check cwght[GRAY], cwght[BLACK], cwght[WHITE] */ if ((checkS != cwght[GRAY]) || (checkB != cwght[BLACK]) || (checkW != cwght[WHITE])) { printf("ERROR in partitioning: checkS %d (S %d), checkB %d (B %d), " "checkW %d (W %d)\n", checkS, cwght[GRAY], checkB, cwght[BLACK], checkW, cwght[WHITE]); err = TRUE; } if (err) quit(); } /***************************************************************************** ******************************************************************************/ void constructSeparator(gbisect_t *Gbisect, options_t *options, timings_t *cpus) { domdec_t *dd, *dd2; PORD_INT *color, *cwght, *map, nvtx, u, i; nvtx = Gbisect->G->nvtx; color = Gbisect->color; cwght = Gbisect->cwght; /* -------------------------------------------------------------- map vector identifies vertices of Gbisect->G in domain decomp. -------------------------------------------------------------- */ mymalloc(map, nvtx, PORD_INT); /* -------------------------------------- construct initial domain decomposition -------------------------------------- */ pord_starttimer(cpus[TIME_INITDOMDEC]); dd = constructDomainDecomposition(Gbisect->G, map); #ifdef BE_CAUTIOUS checkDomainDecomposition(dd); #endif if (options[OPTION_MSGLVL] > 2) printf("\t 0. dom.dec.: #nodes %d (#domains %d, weight %d), #edges %d\n", dd->G->nvtx, dd->ndom, dd->domwght, dd->G->nedges >> 1); pord_stoptimer(cpus[TIME_INITDOMDEC]); /* --------------------------------------------------- construct sequence of coarser domain decompositions --------------------------------------------------- */ pord_starttimer(cpus[TIME_COARSEDOMDEC]); i = 0; while ((dd->ndom > MIN_DOMAINS) && (i < MAX_COARSENING_STEPS) && ((dd->G->nedges >> 1) > dd->G->nvtx)) { shrinkDomainDecomposition(dd, options[OPTION_NODE_SELECTION3]); dd = dd->next; i++; #ifdef BE_CAUTIOUS checkDomainDecomposition(dd); #endif if (options[OPTION_MSGLVL] > 2) printf("\t %2d. dom.dec.: #nodes %d (#domains %d, weight %d), #edges %d" "\n", i, dd->G->nvtx, dd->ndom, dd->domwght, dd->G->nedges >> 1); } pord_stoptimer(cpus[TIME_COARSEDOMDEC]); /* ----------------------------------------------- determine coloring of last domain decomposition ------------------------------------------------ */ pord_starttimer(cpus[TIME_INITSEP]); initialDDSep(dd); if (dd->cwght[GRAY] > 0) improveDDSep(dd); #ifdef BE_CAUTIOUS checkDDSep(dd); #endif if (options[OPTION_MSGLVL] > 2) printf("\t %2d. dom.dec. sep.: S %d, B %d, W %d [cost %7.2f]\n", i, dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE], F(dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE])); pord_stoptimer(cpus[TIME_INITSEP]); /* -------------- refine coloring --------------- */ pord_starttimer(cpus[TIME_REFINESEP]); while (dd->prev != NULL) { dd2 = dd->prev; dd2->cwght[GRAY] = dd->cwght[GRAY]; dd2->cwght[BLACK] = dd->cwght[BLACK]; dd2->cwght[WHITE] = dd->cwght[WHITE]; for (u = 0; u < dd2->G->nvtx; u++) dd2->color[u] = dd->color[dd2->map[u]]; freeDomainDecomposition(dd); if (dd2->cwght[GRAY] > 0) improveDDSep(dd2); #ifdef BE_CAUTIOUS checkDDSep(dd2); #endif dd = dd2; i--; if (options[OPTION_MSGLVL] > 2) printf("\t %2d. dom.dec. sep.: S %d, B %d, W %d [cost %7.2f]\n", i, dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE], F(dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE])); } pord_stoptimer(cpus[TIME_REFINESEP]); /* --------------------------------- copy coloring to subgraph Gbisect --------------------------------- */ cwght[GRAY] = dd->cwght[GRAY]; cwght[BLACK] = dd->cwght[BLACK]; cwght[WHITE] = dd->cwght[WHITE]; for (u = 0; u < nvtx; u++) color[u] = dd->color[map[u]]; freeDomainDecomposition(dd); free(map); } /***************************************************************************** ******************************************************************************/ PORD_INT smoothBy2Layers(gbisect_t *Gbisect, PORD_INT *bipartvertex, PORD_INT *pnX, PORD_INT black, PORD_INT white) { gbipart_t *Gbipart; PORD_INT *xadj, *adjncy, *color, *cwght, *map; PORD_INT *flow, *rc, *matching, *dmflag, dmwght[6]; PORD_INT nvtx, smoothed, nX, nX2, nY, x, y, u, i, j, jstart, jstop; nvtx = Gbisect->G->nvtx; xadj = Gbisect->G->xadj; adjncy = Gbisect->G->adjncy; color = Gbisect->color; cwght = Gbisect->cwght; nX = *pnX; /* ---------------------------------------------------- map vector identifies vertices of Gbisect in Gbipart ---------------------------------------------------- */ mymalloc(map, nvtx, PORD_INT); /* ---------------------------------- construct set Y of bipartite graph ---------------------------------- */ nY = 0; for (i = 0; i < nX; i++) { x = bipartvertex[i]; jstart = xadj[x]; jstop = xadj[x+1]; for (j = jstart; j < jstop; j++) { y = adjncy[j]; if (color[y] == black) { bipartvertex[nX+nY++] = y; color[y] = GRAY; } } } for (i = nX; i < nX+nY; i++) { y = bipartvertex[i]; color[y] = black; } /* -------------------------------------------- compute the Dulmage-Mendelsohn decomposition -------------------------------------------- */ Gbipart = setupBipartiteGraph(Gbisect->G, bipartvertex, nX, nY, map); mymalloc(dmflag, (nX+nY), PORD_INT); switch(Gbipart->G->type) { case UNWEIGHTED: mymalloc(matching, (nX+nY), PORD_INT); maximumMatching(Gbipart, matching); DMviaMatching(Gbipart, matching, dmflag, dmwght); free(matching); break; case WEIGHTED: mymalloc(flow, Gbipart->G->nedges, PORD_INT); mymalloc(rc, (nX+nY), PORD_INT); maximumFlow(Gbipart, flow, rc); DMviaFlow(Gbipart, flow, rc, dmflag, dmwght); free(flow); free(rc); break; default: fprintf(stderr, "\nError in function smoothSeparator\n" " unrecognized bipartite graph type %d\n", Gbipart->G->type); quit(); } #ifdef DEBUG printf("Dulmage-Mendelsohn decomp. computed\n" "SI %d, SX %d, SR %d, BI %d, BX %d, BR %d\n", dmwght[SI], dmwght[SX], dmwght[SR], dmwght[BI], dmwght[BX], dmwght[BR]); #endif /* ----------------------------------------------------------------------- 1st TEST: try to exchange SI with BX, i.e. nodes in SI are moved from the separator into white (white grows), and nodes in BX are moved from black into the separator (black shrinks) ----------------------------------------------------------------------- */ smoothed = FALSE; if (F(cwght[GRAY]-dmwght[SI]+dmwght[BX], cwght[black]-dmwght[BX], cwght[white]+dmwght[SI]) + EPS < F(cwght[GRAY], cwght[black], cwght[white])) { smoothed = TRUE; #ifdef DEBUG printf("exchange SI with BX\n"); #endif cwght[white] += dmwght[SI]; cwght[GRAY] -= dmwght[SI]; cwght[black] -= dmwght[BX]; cwght[GRAY] += dmwght[BX]; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if (dmflag[map[u]] == SI) color[u] = white; if (dmflag[map[u]] == BX) color[u] = GRAY; } } /* ----------------------------------------------------------------------- 2nd TEST: try to exchange SR with BR, i.e. nodes in SR are moved from the separator into white (white grows), and nodes in BR are moved from black into the separator (black shrinks) NOTE: SR is allowed to be exchanged with BR only if SI = BX = 0 or if SI has been exchanged with BX (Adj(SR) is a subset of BX u BR) ----------------------------------------------------------------------- */ if ((F(cwght[GRAY]-dmwght[SR]+dmwght[BR], cwght[black]-dmwght[BR], cwght[white]+dmwght[SR]) + EPS < F(cwght[GRAY], cwght[black], cwght[white])) && ((smoothed) || (dmwght[SI] == 0))) { smoothed = TRUE; #ifdef DEBUG printf("exchange SR with BR\n"); #endif cwght[white] += dmwght[SR]; cwght[GRAY] -= dmwght[SR]; cwght[black] -= dmwght[BR]; cwght[GRAY] += dmwght[BR]; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if (dmflag[map[u]] == SR) color[u] = white; if (dmflag[map[u]] == BR) color[u] = GRAY; } } /* ----------------------------------------------------- fill bipartvertex with the nodes of the new separator ----------------------------------------------------- */ nX2 = 0; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if (color[u] == GRAY) bipartvertex[nX2++] = u; } *pnX = nX2; /* ------------------------------- free working storage and return ------------------------------- */ free(map); free(dmflag); freeBipartiteGraph(Gbipart); return(smoothed); } /***************************************************************************** ******************************************************************************/ void smoothSeparator(gbisect_t *Gbisect, options_t *options) { PORD_INT *xadj, *adjncy, *vwght, *color, *cwght, *bipartvertex; PORD_INT nvtx, nX, nX2, u, x, y, a, b, i, j, jstart, jstop; nvtx = Gbisect->G->nvtx; xadj = Gbisect->G->xadj; adjncy = Gbisect->G->adjncy; vwght = Gbisect->G->vwght; color = Gbisect->color; cwght = Gbisect->cwght; mymalloc(bipartvertex, nvtx, PORD_INT); /* ---------------------------------------------------------- extract the separator (store its vertices in bipartvertex) ---------------------------------------------------------- */ nX = 0; for (u = 0; u < nvtx; u++) if (color[u] == GRAY) bipartvertex[nX++] = u; do { /* --------------------------------------------------------------- minimize the separator (i.e. minimize set X of bipartite graph) --------------------------------------------------------------- */ cwght[GRAY] = nX2 = 0; for (i = 0; i < nX; i++) { x = bipartvertex[i]; a = b = FALSE; jstart = xadj[x]; jstop = xadj[x+1]; for (j = jstart; j < jstop; j++) { y = adjncy[j]; if (color[y] == WHITE) a = TRUE; if (color[y] == BLACK) b = TRUE; } if ((a) && (!b)) { color[x] = WHITE; cwght[WHITE] += vwght[x]; } else if ((!a) && (b)) { color[x] = BLACK; cwght[BLACK] += vwght[x]; } else { bipartvertex[nX2++] = x; cwght[GRAY] += vwght[x]; } } nX = nX2; #ifdef BE_CAUTIOUS checkSeparator(Gbisect); #endif /* ------------------------------------------------------------------ smooth the unweighted/weighted separator first pair it with the larger set; if unsuccessful try the smaller ------------------------------------------------------------------ */ if (cwght[BLACK] >= cwght[WHITE]) { a = smoothBy2Layers(Gbisect, bipartvertex, &nX, BLACK, WHITE); if (!a) a = smoothBy2Layers(Gbisect, bipartvertex, &nX, WHITE, BLACK); } else { a = smoothBy2Layers(Gbisect, bipartvertex, &nX, WHITE, BLACK); if (!a) a = smoothBy2Layers(Gbisect, bipartvertex, &nX, BLACK, WHITE); } if ((options[OPTION_MSGLVL] > 2) && (a)) printf("\t separator smoothed: S %d, B %d, W %d [cost %7.2f]\n", cwght[GRAY], cwght[BLACK], cwght[WHITE], F(cwght[GRAY], cwght[BLACK], cwght[WHITE])); } while (a); free(bipartvertex); } MUMPS_5.4.1/PORD/lib/ddcreate.c0000664000175000017500000007447114102210467016171 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: ddcreate.c / / author J"urgen Schulze, University of Paderborn / created 00nov28 / / This file contains functions dealing with construction/coarsening / of a domain decomposition / ****************************************************************************** Data type: struct domdec graph_t *G; pointer to graph object int ndom; number of domains int domwght; total weight of domains int *vtype; type of node (see comment below) int *color; color of node (GRAY, BLACK, or WHITE) int cwght[3]; weights of GRAY, BLACK, WHITE partitions int *map; maps nodes to next coarser domain decomp. struct domdec *prev; pointer to previous finer domain decomp. struct domdec *next; pointer to next coarser domain decomp. Comments: o Structure holds the domain decompositions constructed by the coarsening process; it also holds the colorings of the domain decomp. computed by the refinement process o vtype[v]: represents the status of a node in the domain decomposition 0, iff status of v is unknown 1, iff v is a domain vertex 2, iff v is a multisector vertex 3, iff multisec v is eliminated and now forms a domain 4, iff multisec v is absorbed by another multisec/domain Methods in lib/ddcreate.c: - dd = newDomainDecomposition(int nvtx, int nedges); o Initial: ndom = domwght = 0, cwght[GRAY] = cwght[BLACK] = cwght[WHITE] = 0, and prev = next = NULL - void freeDomainDecomposition(domdec_t *dd); - void printDomainDecomposition(domdec_t *dd); - void checkDomainDecomposition(domdec_t *dd); - void buildInitialDomains(graph_t *G, int *vtxlist, int *vtype, int *rep); o determines initial domains according to the order of nodes in vtxlist; furthermore, it sets rep[u] = v for all multisecs u that are adjacent to only one domain v o on start vtype[u] = 0 for all 0 <= u < nvtx, on return vtype[u] = 1, iff u belongs to a domain (rep[u]=u => u is seed of domain) vtype[u] = 2, iff u belongs to a multisec (rep[u]=u => u is seed) - void mergeMultisecs(graph_t *G, int *vtype, int *rep); o merges all adjacent multisecs that do not share a common domain o on return vtype[w] = 4, iff multisec w belongs to multisec cluster u = rep[w] - dd = initialDomainDecomposition(graph_t *G, int *map, int *vtype, int *rep); o allocates memory for the initial domain decomposition of G by calling newDomainDecomposition and creates the domain decomposition according to the vectors vtype and rep; the map vector maps vertices of G onto vertices of dd - dd = constructDomainDecomposition(graph_t *G, int *map); o constructs an initial domain decomposition for the graph G by calling the functions (a) buildInitialDomains (b) mergeMultisecs (c) initialDomainDecomposition vextor map identifies vertices of G in the domain decomposition - void computePriorities(domdec_t *dd, int *msvtxlist, int *key, int scoretype); o computes for each multisec u in msvtxlist its priority key[u] according to the node selection strategy scoretype - void eliminateMultisecs(domdec_t *dd, int *msvtxlist, int *rep); o eliminates multisecs according to their order in msvtxlist; furthermore, it sets rep[u] = v for all multisecs u that are adjacent to only one newly formed domain v o on return dd->vtype[u] = 1, iff u is a domain (rep[u] = u) dd->vtype[u] = 2, iff u is an uneliminated multisec (rep[u] = u) dd->vtype[u] = 3, iff u is an eliminated multisec (rep[u] = u) dd->vtype[u] = 4, iff multisec u is absorbed by new domain v = rep[u]; - void findIndMultisecs(domdec_t *dd, int *msvtxlist, int *rep); o searches all unelim./unabsorbed multisecs in msnvtxlist for indistinguishable multisecs; sets dd->vtype[u] = 4 and rep[u] = v, iff u, v are indistinguishable and v is the representative of u - dd2 = coarserDomainDecomposition(domdec_t* dd1, int *rep); o allocates memory for the coarser domain decomposition by calling newDomainDecomposition and creates the domain decomposition according to the vectors dd1->vtype and rep; vector dd1->map identifies the vertices of dd1 in dd2 - void shrinkDomainDecomposition(domdec_t *dd, int scoretype); o shrinks dd according to a chosen node selection strategy by calling the functions (a) computePriorities (b) eliminateMultisecs (c) findIndMultisecs (d) coarserDomainDecomposition the coarser domain decomposition is appended to dd via prev/next pointers ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ domdec_t* newDomainDecomposition(PORD_INT nvtx, PORD_INT nedges) { domdec_t *dd; mymalloc(dd, 1, domdec_t); mymalloc(dd->vtype, nvtx, PORD_INT); mymalloc(dd->color, nvtx, PORD_INT); mymalloc(dd->map, nvtx, PORD_INT); dd->G = newGraph(nvtx, nedges); dd->ndom = dd->domwght = 0; dd->cwght[GRAY] = dd->cwght[BLACK] = dd->cwght[WHITE] = 0; dd->prev = dd->next = NULL; return(dd); } /***************************************************************************** ******************************************************************************/ void freeDomainDecomposition(domdec_t *dd) { freeGraph(dd->G); free(dd->vtype); free(dd->color); free(dd->map); free(dd); } /***************************************************************************** ******************************************************************************/ void printDomainDecomposition(domdec_t *dd) { graph_t *G; PORD_INT count, u, v, i, istart, istop; G = dd->G; printf("\n#nodes %d (#domains %d, weight %d), #edges %d, totvwght %d\n", G->nvtx, dd->ndom, dd->domwght, G->nedges >> 1, G->totvwght); printf("partition weights: S %d, B %d, W %d\n", dd->cwght[GRAY], dd->cwght[BLACK], dd->cwght[WHITE]); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of node %d (vtype %d, color %d, map %d\n", u, dd->vtype[u], dd->color[u], dd->map[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { v = G->adjncy[i]; printf("%5d (vtype %2d, color %2d)", v, dd->vtype[v], dd->color[v]); if ((++count % 3) == 0) printf("\n"); } if ((count % 3) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ void checkDomainDecomposition(domdec_t *dd) { PORD_INT *xadj, *adjncy, *vwght, *vtype; PORD_INT err, nvtx, ndom, domwght, dom, multi, u, v, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; err = FALSE; printf("checking domain decomposition (#nodes %d, #edges %d)\n", dd->G->nvtx, dd->G->nedges >> 1); ndom = domwght = 0; for (u = 0; u < nvtx; u++) { /* check node type */ if ((vtype[u] != 1) && (vtype[u] != 2)) { printf("ERROR: node %d is neither DOMAIN nor MULTISEC\n", u); err = TRUE; } /* count domains and sum up their weight */ if (vtype[u] == 1) { ndom++; domwght += vwght[u]; } /* check number of neighboring domains and multisecs */ dom = multi = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtype[v] == 1) dom++; if (vtype[v] == 2) multi++; } if ((vtype[u] == 1) && (dom > 0)) { printf("ERROR: domain %d is adjacent to other domain\n", u); err = TRUE; } if ((vtype[u] == 2) && (dom < 2)) { printf("ERROR: less than 2 domains adjacent to multisec node %d\n", u); err = TRUE; } if ((vtype[u] == 2) && (multi > 0)) { printf("ERROR: multisec %d is adjacent to other multisec nodes\n", u); err = TRUE; } } /* check number and weight of domains */ if ((ndom != dd->ndom) || (domwght != dd->domwght)) { printf("ERROR: number/size (%d/%d) of domains does not match with those in" " domain decomp. (%d/%d)\n", ndom, domwght, dd->ndom, dd->domwght); err = TRUE; } if (err) quit(); } /***************************************************************************** ******************************************************************************/ void buildInitialDomains(graph_t *G, PORD_INT *vtxlist, PORD_INT *vtype, PORD_INT *rep) { PORD_INT *xadj, *adjncy; PORD_INT nvtx, u, v, w, i, j, jstart, jstop; xadj = G->xadj; adjncy = G->adjncy; nvtx = G->nvtx; /* -------------------------------------------------------------------- determine initial domains according to the order of nodes in vtxlist -------------------------------------------------------------------- */ for (i = 0; i < nvtx; i++) { u = vtxlist[i]; if (vtype[u] == 0) { vtype[u] = 1; jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) { v = adjncy[j]; vtype[v] = 2; } } } /* ------------------------------------------------------------ eliminate all multisecs that are adjacent to only one domain ------------------------------------------------------------ */ for (i = 0; i < nvtx; i++) { u = vtxlist[i]; if (vtype[u] == 2) { v = -1; jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (vtype[w] == 1) { if (v == -1) v = rep[w]; /* u adjacent to domain v = rep[w] */ else if (v != rep[w]) { v = -1; /* u adjacent to another domain */ break; } } } if (v != -1) /* u absorbed by domain v */ { vtype[u] = 1; rep[u] = v; } } } } /***************************************************************************** ******************************************************************************/ void mergeMultisecs(graph_t *G, PORD_INT *vtype, PORD_INT *rep) { PORD_INT *xadj, *adjncy, *tmp, *queue; PORD_INT nvtx, qhead, qtail, flag, keepon, u, v, w, x; PORD_INT i, istart, istop, j, jstart, jstop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, PORD_INT); mymalloc(queue, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) tmp[u] = -1; /* ------------------------------------------------------- merge all adjacent multisecs that do not share a domain ------------------------------------------------------- */ flag = 1; for (u = 0; u < nvtx; u++) if (vtype[u] == 2) { qhead = 0; qtail = 1; queue[0] = u; vtype[u] = -2; /* multisec u is the seed of a new cluster, mark all adj. domains */ istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtype[v] == 1) tmp[rep[v]] = flag; } /* and now build the cluster */ while (qhead != qtail) { v = queue[qhead++]; istart = xadj[v]; istop = xadj[v+1]; for (i = istart; i < istop; i++) { keepon = TRUE; w = adjncy[i]; if (vtype[w] == 2) { jstart = xadj[w]; jstop = xadj[w+1]; for (j = jstart; j < jstop; j++) { x = adjncy[j]; if ((vtype[x] == 1) && (tmp[rep[x]] == flag)) { keepon = FALSE; break; } } if (keepon) /* multisecs v and w have no domain in common; mark */ /* all domains adjacent to w and put w in cluster u */ { for (j = jstart; j < jstop; j++) { x = adjncy[j]; if (vtype[x] == 1) tmp[rep[x]] = flag; } queue[qtail++] = w; rep[w] = u; vtype[w] = -2; } } } } /* clear tmp vector for next round */ flag++; } /* ------------------------------------ reset vtype and free working storage ------------------------------------ */ for (u = 0; u < nvtx; u++) if (vtype[u] == -2) vtype[u] = 2; free(tmp); free(queue); } /***************************************************************************** ******************************************************************************/ domdec_t* initialDomainDecomposition(graph_t *G, PORD_INT *map, PORD_INT *vtype, PORD_INT *rep) { domdec_t *dd; PORD_INT *xadj, *adjncy, *vwght, *xadjdd, *adjncydd, *vwghtdd, *vtypedd; PORD_INT *tmp, *bin, nvtx, nedges, nvtxdd, nedgesdd, ndom, domwght, flag; PORD_INT i, j, jstart, jstop, u, v, w; nvtx = G->nvtx; nedges = G->nedges; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, PORD_INT); mymalloc(bin, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { tmp[u] = -1; bin[u] = -1; } /* ------------------------------------------------------------- allocate memory for the dd using upper bounds nvtx and nedges ------------------------------------------------------------- */ dd = newDomainDecomposition(nvtx, nedges); xadjdd = dd->G->xadj; adjncydd = dd->G->adjncy; vwghtdd = dd->G->vwght; vtypedd = dd->vtype; /* ------------------------------------------------------- put all nodes u belonging to representative v in bin[v] ------------------------------------------------------- */ for (u = 0; u < nvtx; u++) { v = rep[u]; if (u != v) { bin[u] = bin[v]; bin[v] = u; } } /* ---------------------------------------------- and now build the initial domain decomposition ---------------------------------------------- */ flag = 1; nedgesdd = nvtxdd = 0; ndom = domwght = 0; for (u = 0; u < nvtx; u++) if (rep[u] == u) { xadjdd[nvtxdd] = nedgesdd; vtypedd[nvtxdd] = vtype[u]; vwghtdd[nvtxdd] = 0; tmp[u] = flag; /* find all cluster that are adjacent to u in dom. dec. */ v = u; do { map[v] = nvtxdd; vwghtdd[nvtxdd] += vwght[v]; jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if ((vtype[w] != vtype[u]) && (tmp[rep[w]] != flag)) { tmp[rep[w]] = flag; adjncydd[nedgesdd++] = rep[w]; } } v = bin[v]; } while (v != -1); if (vtypedd[nvtxdd] == 1) { ndom++; domwght += vwghtdd[nvtxdd]; } nvtxdd++; flag++; } /* -------------------------------------------- finalize the new domain decomposition object -------------------------------------------- */ xadjdd[nvtxdd] = nedgesdd; dd->G->nvtx = nvtxdd; dd->G->nedges = nedgesdd; dd->G->type = WEIGHTED; dd->G->totvwght = G->totvwght; for (i = 0; i < nedgesdd; i++) adjncydd[i] = map[adjncydd[i]]; for (u = 0; u < nvtxdd; u++) dd->color[u] = dd->map[u] = -1; dd->ndom = ndom; dd->domwght = domwght; /* ------------------------------- free working storage and return ------------------------------- */ free(tmp); free(bin); return(dd); } /***************************************************************************** ******************************************************************************/ domdec_t* constructDomainDecomposition(graph_t *G, PORD_INT *map) { domdec_t *dd; PORD_INT *xadj, *adjncy, *vwght, *vtxlist, *vtype, *key, *rep; PORD_INT nvtx, deg, u, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* --------------------------------------------------------- sort the vertices in G in ascending order of their degree --------------------------------------------------------- */ mymalloc(vtxlist, nvtx, PORD_INT); mymalloc(key, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { vtxlist[u] = u; istart = xadj[u]; istop = xadj[u+1]; switch(G->type) { case UNWEIGHTED: deg = istop - istart; break; case WEIGHTED: deg = 0; for (i = istart; i < istop; i++) deg += vwght[adjncy[i]]; break; default: fprintf(stderr, "\nError in function constructDomainDecomposition\n" " unrecognized graph type %d\n", G->type); quit(); } key[u] = deg; } distributionCounting(nvtx, vtxlist, key); free(key); /* ------------------------------------------------------------- build initial domains and cluster multisecs that do not share a common domain ------------------------------------------------------------- */ mymalloc(vtype, nvtx, PORD_INT); mymalloc(rep, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { vtype[u] = 0; rep[u] = u; } buildInitialDomains(G, vtxlist, vtype, rep); mergeMultisecs(G, vtype, rep); free(vtxlist); /* -------------------------------------------------- finally, build the domain decomposition and return -------------------------------------------------- */ dd = initialDomainDecomposition(G, map, vtype, rep); free(vtype); free(rep); return(dd); } /***************************************************************************** ******************************************************************************/ void computePriorities(domdec_t *dd, PORD_INT *msvtxlist, PORD_INT *key, PORD_INT scoretype) { PORD_INT *xadj, *adjncy, *vwght, *marker; PORD_INT nvtx, nlist, k, weight, deg, u, v, w; PORD_INT i, istart, istop, j, jstart, jstop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; marker = dd->map; nlist = nvtx - dd->ndom; switch(scoretype) { case QMRDV: /* maximal relative decrease of variables in quotient graph */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; weight = vwght[u]; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) weight += vwght[adjncy[i]]; key[u] = weight / vwght[u]; } break; case QMD: /* ----------------------- minimum degree in quotient graph */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; marker[u] = -1; } for (k = 0; k < nlist; k++) { u = msvtxlist[k]; marker[u] = u; deg = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (marker[w] != u) { marker[w] = u; deg += vwght[w]; } } } key[u] = deg; } break; case QRAND: /* ------------------------------------------------- random */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; key[u] = myrandom(nvtx); } break; default: fprintf(stderr, "\nError in internal function computePriorities\n" " unrecognized node selection strategy %d\n", scoretype); quit(); } } /***************************************************************************** ******************************************************************************/ void eliminateMultisecs(domdec_t *dd, PORD_INT *msvtxlist, PORD_INT *rep) { PORD_INT *xadj, *adjncy, *vtype; PORD_INT nvtx, nlist, keepon, u, v, w, k, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vtype = dd->vtype; nlist = nvtx - dd->ndom; /* ------------------------------------------------------- eliminate multisecs according to the order in msvtxlist ------------------------------------------------------- */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; istart = xadj[u]; istop = xadj[u+1]; keepon = TRUE; for (i = istart; i < istop; i++) { v = adjncy[i]; if (rep[v] != v) /* domain already absorbed by an eliminated */ { keepon = FALSE; /* multisec => multisec u cannot be deleted */ break; } } if (keepon) { vtype[u] = 3; for (i = istart; i < istop; i++) { v = adjncy[i]; rep[v] = u; } } } /* ------------------------------------------------------------ eliminate all multisecs that are adjacent to only one domain ------------------------------------------------------------ */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; if (vtype[u] == 2) { v = -1; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { w = adjncy[i]; if (v == -1) v = rep[w]; /* u adjacent to domain v = rep[w] */ else if (v != rep[w]) { v = -1; /* u adjacent to another domain */ break; } } if (v != -1) /* u absorbed by domain v */ { vtype[u] = 4; rep[u] = v; } } } } /***************************************************************************** ******************************************************************************/ void findIndMultisecs(domdec_t *dd, PORD_INT *msvtxlist, PORD_INT *rep) { PORD_INT *xadj, *adjncy, *vtype, *tmp, *bin, *checksum, *next, *key; PORD_INT nvtx, nlist, flag, keepon, deg, chk, ulast, u, v, k, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vtype = dd->vtype; nlist = nvtx - dd->ndom; checksum = dd->map; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtx, PORD_INT); mymalloc(bin, nvtx, PORD_INT); mymalloc(next, nvtx, PORD_INT); mymalloc(key, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { tmp[u] = -1; bin[u] = -1; } /* ------------------------------------------------------------------- compute checksums for all unelim./unabsorbed multisecs in msvtxlist ------------------------------------------------------------------- */ flag = 1; for (k = 0; k < nlist; k++) { u = msvtxlist[k]; if (vtype[u] == 2) { deg = chk = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (tmp[rep[v]] != flag) { tmp[rep[v]] = flag; chk += rep[v]; deg++; } } chk = chk % nvtx; checksum[u] = chk; key[u] = deg; next[u] = bin[chk]; bin[chk] = u; flag++; } } /* --------------------------------- merge indistinguishable multisecs --------------------------------- */ for (k = 0; k < nlist; k++) { u = msvtxlist[k]; if (vtype[u] == 2) { chk = checksum[u]; v = bin[chk]; /* examine all multisecs in bin[hash] */ bin[chk] = -1; /* do this only once */ while (v != -1) { istart = xadj[v]; istop = xadj[v+1]; for (i = istart; i < istop; i++) tmp[rep[adjncy[i]]] = flag; ulast = v; /* v is principal and u is a potiential */ u = next[v]; /* nonprincipal variable */ while (u != -1) { keepon = TRUE; if (key[u] != key[v]) keepon = FALSE; if (keepon) { istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) if (tmp[rep[adjncy[i]]] != flag) { keepon = FALSE; break; } } if (keepon) /* found it! mark u as nonprincipal */ { rep[u] = v; /* printf(" >> mapping %d onto %d\n", u, v); */ vtype[u] = 4; u = next[u]; next[ulast] = u; /* remove u from bin */ } else /* failed */ { ulast = u; u = next[u]; } } v = next[v]; /* no more variables can be absorbed by v */ flag++; /* clear tmp vector for next round */ } } } /* -------------------- free working storage -------------------- */ free(tmp); free(bin); free(next); free(key); } /***************************************************************************** ******************************************************************************/ domdec_t* coarserDomainDecomposition(domdec_t* dd1, PORD_INT *rep) { domdec_t *dd2; PORD_INT *xadjdd1, *adjncydd1, *vwghtdd1, *vtypedd1, *mapdd1; PORD_INT *xadjdd2, *adjncydd2, *vwghtdd2, *vtypedd2; PORD_INT *tmp, *bin, nvtxdd1, nedgesdd1, nvtxdd2, nedgesdd2; PORD_INT ndom, domwght, flag, u, v, w, i, istart, istop; nvtxdd1 = dd1->G->nvtx; nedgesdd1 = dd1->G->nedges; xadjdd1 = dd1->G->xadj; adjncydd1 = dd1->G->adjncy; vwghtdd1 = dd1->G->vwght; vtypedd1 = dd1->vtype; mapdd1 = dd1->map; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, nvtxdd1, PORD_INT); mymalloc(bin, nvtxdd1, PORD_INT); for (u = 0; u < nvtxdd1; u++) { tmp[u] = -1; bin[u] = -1; } /* ------------------------------------------------------------ allocate memory using the upper bounds nvtxdd1 and nedgesdd1 ------------------------------------------------------------ */ dd2 = newDomainDecomposition(nvtxdd1, nedgesdd1); xadjdd2 = dd2->G->xadj; adjncydd2 = dd2->G->adjncy; vwghtdd2 = dd2->G->vwght; vtypedd2 = dd2->vtype; /* ------------------------------------------------------- put all nodes u belonging to representative v in bin[v] ------------------------------------------------------- */ for (u = 0; u < nvtxdd1; u++) { v = rep[u]; if (u != v) { bin[u] = bin[v]; bin[v] = u; } } /* ---------------------------------------------- and now build the coarser domain decomposition ---------------------------------------------- */ flag = 1; nvtxdd2 = nedgesdd2 = 0; ndom = domwght = 0; for (u = 0; u < nvtxdd1; u++) if (rep[u] == u) { xadjdd2[nvtxdd2] = nedgesdd2; vwghtdd2[nvtxdd2] = 0; vtypedd2[nvtxdd2] = vtypedd1[u]; if (vtypedd2[nvtxdd2] == 3) vtypedd2[nvtxdd2] = 1; tmp[u] = flag; /* find all cluster that are adjacent to u in dom. dec. */ v = u; do { mapdd1[v] = nvtxdd2; vwghtdd2[nvtxdd2] += vwghtdd1[v]; if ((vtypedd1[v] == 1) || (vtypedd1[v] == 2)) { istart = xadjdd1[v]; istop = xadjdd1[v+1]; for (i = istart; i < istop; i++) { w = adjncydd1[i]; if (tmp[rep[w]] != flag) { tmp[rep[w]] = flag; adjncydd2[nedgesdd2++] = rep[w]; } } } v = bin[v]; } while (v != -1); if (vtypedd2[nvtxdd2] == 1) { ndom++; domwght += vwghtdd2[nvtxdd2]; } nvtxdd2++; flag++; } /* -------------------------------------------- finalize the new domain decomposition object -------------------------------------------- */ xadjdd2[nvtxdd2] = nedgesdd2; dd2->G->nvtx = nvtxdd2; dd2->G->nedges = nedgesdd2; dd2->G->type = WEIGHTED; dd2->G->totvwght = dd1->G->totvwght; for (i = 0; i < nedgesdd2; i++) adjncydd2[i] = mapdd1[adjncydd2[i]]; for (u = 0; u < nvtxdd2; u++) dd2->color[u] = dd2->map[u] = -1; dd2->ndom = ndom; dd2->domwght = domwght; /* -------------------------- set back node types in dd1 -------------------------- */ for (u = 0; u < nvtxdd1; u++) if ((vtypedd1[u] == 3) || (vtypedd1[u] == 4)) vtypedd1[u] = 2; /* ------------------------------- free working storage and return ------------------------------- */ free(tmp); free(bin); return(dd2); } /***************************************************************************** ******************************************************************************/ void shrinkDomainDecomposition(domdec_t* dd1, PORD_INT scoretype) { domdec_t *dd2; PORD_INT *msvtxlist, *rep, *key; PORD_INT nvtxdd1, nlist, u; nvtxdd1 = dd1->G->nvtx; mymalloc(msvtxlist, nvtxdd1, PORD_INT); mymalloc(rep, nvtxdd1, PORD_INT); mymalloc(key, nvtxdd1, PORD_INT); /* --------------- initializations --------------- */ nlist = 0; for (u = 0; u < nvtxdd1; u++) { if (dd1->vtype[u] == 2) msvtxlist[nlist++] = u; rep[u] = u; } /* ------------------------------------- compute priorities and sort multisecs ------------------------------------- */ computePriorities(dd1, msvtxlist, key, scoretype); distributionCounting(nlist, msvtxlist, key); /* ---------------------------------------------------------- eliminate multisecs and build coarser domain decomposition ---------------------------------------------------------- */ eliminateMultisecs(dd1, msvtxlist, rep); findIndMultisecs(dd1, msvtxlist, rep); dd2 = coarserDomainDecomposition(dd1, rep); /* ----------------------------------- append coarser domain decomposition ----------------------------------- */ dd1->next = dd2; dd2->prev = dd1; free(msvtxlist); free(rep); free(key); } MUMPS_5.4.1/PORD/lib/interface.c0000664000175000017500000006507514102210467016356 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: interface.c / / author J"urgen Schulze, University of Paderborn / created 01jan26 / / This file contains some high level interface functions (only these / functions should be called by a user). / ******************************************************************************/ #include /***************************************************************************** o Input: undirected graph G options -- if NULL, default options are used option[0] holds OPTION_ORDTYPE option[1] holds OPTION_NODE_SELECTION1 option[2] holds OPTION_NODE_SELECTION2 option[3] holds OPTION_NODE_SELECTION3 option[4] holds OPTION_DOMAIN_SIZE option[5] holds OPTION_MSGLVL o Output: elimination/front tree T reflecting the ordering of G cpus -- if NULL, no timing information is pulled back cpus[0] holds TIME_COMPRESS cpus[1] holds TIME_MS cpus[2] holds TIME_MULTILEVEL cpus[3] holds TIME_INITDOMDEC cpus[4] holds TIME_COARSEDOMDEC cpus[5] holds TIME_INITSEP cpus[6] holds TIME_REFINESEP cpus[7] holds TIME_SMOOTH cpus[8] holds TIME_BOTTOMUP cpus[9] holds TIME_UPDADJNCY cpus[10] holds TIME_FINDINODES cpus[11] holds TIME_UPDSCORE o Comments: this function computes an ordering for G; it returns an elimination tree T; permutation vectors perm, invp can be extracted from T by calling function permFromElimTree(T, perm, invp) ******************************************************************************/ elimtree_t* SPACE_ordering(graph_t *G, options_t *options, timings_t *cpus) { graph_t *Gc; multisector_t *ms; minprior_t *minprior; elimtree_t *T, *T2; timings_t cpusOrd[ORD_TIME_SLOTS]; options_t default_options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, SPACE_MSGLVL }; PORD_INT *vtxmap, istage, totnstep, totnzf; FLOAT totops; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; /* ---------------- reset all timers ---------------- */ pord_resettimer(cpusOrd[TIME_COMPRESS]); pord_resettimer(cpusOrd[TIME_MS]); pord_resettimer(cpusOrd[TIME_MULTILEVEL]); pord_resettimer(cpusOrd[TIME_INITDOMDEC]); pord_resettimer(cpusOrd[TIME_COARSEDOMDEC]); pord_resettimer(cpusOrd[TIME_INITSEP]); pord_resettimer(cpusOrd[TIME_REFINESEP]); pord_resettimer(cpusOrd[TIME_SMOOTH]); pord_resettimer(cpusOrd[TIME_BOTTOMUP]); pord_resettimer(cpusOrd[TIME_UPDADJNCY]); pord_resettimer(cpusOrd[TIME_FINDINODES]); pord_resettimer(cpusOrd[TIME_UPDSCORE]); /* ------------------ compress the graph ------------------ */ pord_starttimer(cpusOrd[TIME_COMPRESS]); mymalloc(vtxmap, G->nvtx, PORD_INT); Gc = compressGraph(G, vtxmap); pord_stoptimer(cpusOrd[TIME_COMPRESS]); if (Gc != NULL) { if (options[OPTION_MSGLVL] > 0) printf("compressed graph constructed (#nodes %d, #edges %d)\n", Gc->nvtx, Gc->nedges >> 1); } else { Gc = G; free(vtxmap); if (options[OPTION_MSGLVL] > 0) printf("no compressed graph constructed\n"); } /* ------------------- compute multisector ------------------- */ pord_starttimer(cpusOrd[TIME_MS]); ms = constructMultisector(Gc, options, cpusOrd); pord_stoptimer(cpusOrd[TIME_MS]); if (options[OPTION_MSGLVL] > 0) printf("quality of multisector: #stages %d, #nodes %d, weight %d\n", ms->nstages, ms->nnodes, ms->totmswght); /* --------------------------------- compute minimum priority ordering --------------------------------- */ pord_starttimer(cpusOrd[TIME_BOTTOMUP]) minprior = setupMinPriority(ms); T = orderMinPriority(minprior, options, cpusOrd); pord_stoptimer(cpusOrd[TIME_BOTTOMUP]); if (options[OPTION_MSGLVL] > 0) { totnstep = totnzf = 0; totops = 0.0; for (istage = 0; istage < ms->nstages; istage++) { totnstep += minprior->stageinfo[istage].nstep; totnzf += minprior->stageinfo[istage].nzf; totops += minprior->stageinfo[istage].ops; } printf("quality of ordering: #steps %d, nzl %d, ops %e\n", totnstep, totnzf, totops); } /* ----------------------- expand elimination tree ----------------------- */ if (Gc != G) { T2 = expandElimTree(T, vtxmap, G->nvtx); freeElimTree(T); freeGraph(Gc); free(vtxmap); } else T2 = T; /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = cpusOrd[TIME_COMPRESS]; cpus[1] = cpusOrd[TIME_MS]; cpus[2] = cpusOrd[TIME_MULTILEVEL]; cpus[3] = cpusOrd[TIME_INITDOMDEC]; cpus[4] = cpusOrd[TIME_COARSEDOMDEC]; cpus[5] = cpusOrd[TIME_INITSEP]; cpus[6] = cpusOrd[TIME_REFINESEP]; cpus[7] = cpusOrd[TIME_SMOOTH]; cpus[8] = cpusOrd[TIME_BOTTOMUP]; cpus[9] = cpusOrd[TIME_UPDADJNCY]; cpus[10] = cpusOrd[TIME_FINDINODES]; cpus[11] = cpusOrd[TIME_UPDSCORE]; } /* ---------------------- free memory and return ---------------------- */ freeMultisector(ms); freeMinPriority(minprior); return(T2); } #if defined(cleaned_version) /***************************************************************************** o Input: elimination/front tree T max. number of zeros that is allowed to be introduced in front o Output: transformed elimination/front tree T' o Comments: the goal is to make T (obtained by orderMinPriority or setupElimTree) more appropiate for the multifrontal algorithm ******************************************************************************/ elimtree_t* SPACE_transformElimTree(elimtree_t *T, PORD_INT maxzeros) { elimtree_t *T2, *T3; /* ----------------------------------------------------- 1st: determine the fundamental fronts this step significantly improves the cache reuse ----------------------------------------------------- */ T2 = fundamentalFronts(T); /* ----------------------------------------------------------------- 2nd: group together small subtrees into one front this step reduces the number of fronts and thus the overhead associated with them; the expense is added storage for the logically zero entries and the factor operations on them ------------------------------------------------------------------ */ T3 = mergeFronts(T2, maxzeros); freeElimTree(T2); /* -------------------------------------------------------------- 3rd: order the children of a front so that the working storage in the multifrontal algorithm is minimized -------------------------------------------------------------- */ (void)justifyFronts(T3); return(T3); } /***************************************************************************** o Input: transformed elimination/front tree T, input matrix A o Output: initial factor matrix L of the permuted input matrix PAP o Comments: L contains nonzeros of PAP; all other entries are set to 0.0 ******************************************************************************/ factorMtx_t* SPACE_symbFac(elimtree_t *T, inputMtx_t *A) { factorMtx_t *L; frontsub_t *frontsub; css_t *css; inputMtx_t *PAP; elimtree_t *PTP; PORD_INT *perm, neqs, nelem; /* ------------------------------------------------------ extract permutation vectors from T and permute T and A ------------------------------------------------------ */ neqs = A->neqs; mymalloc(perm, neqs, PORD_INT); permFromElimTree(T, perm); PTP = permuteElimTree(T, perm); PAP = permuteInputMtx(A, perm); /* ------------------------------------------------------------------- create factor matrix L of PAP, i.e. (1) create the subscript structure of the fronts, i.e. frontsub (2) use frontsub to create the compressed subscript structure of L (3) allocate memory for L and the nonzeros of L, i.e. L->nzl (4) init. L with the nonzeros of PAP ------------------------------------------------------------------- */ frontsub = setupFrontSubscripts(PTP, PAP); css = setupCSSFromFrontSubscripts(frontsub); nelem = css->xnzl[neqs]; L = newFactorMtx(nelem); L->perm = perm; L->frontsub = frontsub; L->css = css; initFactorMtx(L, PAP); /* ----------------------------------------------------- free permuted input matrix and return note: PTP and perm have been inherited by frontsub, L ----------------------------------------------------- */ freeInputMtx(PAP); return(L); } /***************************************************************************** o Input: transformed elimination/front tree initial factor matrix L of the permuted input matrix PAP o Output: factor matrix L of the permuted input matrix PAP cpus -- if NULL no timing information is pulled back cpus[0] holds TIME_INITFRONT cpus[1] holds TIME_EXPAND cpus[2] holds TIME_KERNEL cpus[3] holds TIME_INITUPD o Comments: this function does the actual numerical factorization; to improve register and cache reuse it uses a kernel of size 3x3 ******************************************************************************/ void SPACE_numFac(factorMtx_t *L, timings_t *cpus) { timings_t cpusFactor[NUMFAC_TIME_SLOTS]; /* ---------------- reset all timers ---------------- */ pord_resettimer(cpusFactor[TIME_INITFRONT]); pord_resettimer(cpusFactor[TIME_EXADD]); pord_resettimer(cpusFactor[TIME_KERNEL]); pord_resettimer(cpusFactor[TIME_INITUPD]); /* ------------------------- compute Cholesky factor L ------------------------- */ numfac(L, cpusFactor); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = cpusFactor[TIME_INITFRONT]; cpus[1] = cpusFactor[TIME_EXADD]; cpus[2] = cpusFactor[TIME_KERNEL]; cpus[3] = cpusFactor[TIME_INITUPD]; } } /***************************************************************************** o Input: transformed elimination/front tree factor matrix L of the permuted input matrix PAP right hand side vector rhs of the original system Ax = b o Output: solution vector xvec of the original system Ax = b o Comments: this function solves the remaining triangular systems; ******************************************************************************/ void SPACE_solveTriangular(factorMtx_t *L, FLOAT *rhs, FLOAT *xvec) { FLOAT *yvec; PORD_INT *perm; PORD_INT neqs, k; perm = L->perm; neqs = L->css->neqs; /* ------------------------------------------- set up permuted right hand side vector yvec ------------------------------------------- */ mymalloc(yvec, neqs, FLOAT); for (k = 0; k < neqs; k++) yvec[perm[k]] = rhs[k]; /* ------------------------- solve Ly = b and L^Tz = y ------------------------- */ forwardSubst1x1(L, yvec); backwardSubst1x1(L, yvec); /* --------------------------------------------------------------- extract from yvec the solution vector of the un-permuted system --------------------------------------------------------------- */ for (k = 0; k < neqs; k++) xvec[k] = yvec[perm[k]]; free(yvec); } /***************************************************************************** o Input: sparse matrix A, right hand side vector rhs options -- if NULL, default options are used option[0] holds OPTION_ORDTYPE option[1] holds OPTION_NODE_SELECTION1 option[2] holds OPTION_NODE_SELECTION2 option[3] holds OPTION_NODE_SELECTION3 option[4] holds OPTION_DOMAIN_SIZE option[5] holds OPTION_MSGLVL option[6] holds OPTION_ETREE_NONZ o Output: solution vector xvec of the original system Ax = b cpus -- if NULL, no timing information is pulled back cpus[0] holds time to construct the graph cpus[1] holds time to compute the ordering cpus[2] holds TIME_COMPRESS cpus[3] holds TIME_MS cpus[4] holds TIME_MULTILEVEL cpus[5] holds TIME_INITDOMDEC cpus[6] holds TIME_COARSEDOMDEC cpus[7] holds TIME_INITSEP cpus[8] holds TIME_REFINESEP cpus[9] holds TIME_SMOOTH cpus[10] holds TIME_BOTTOMUP cpus[11] holds TIME_UPDADJNCY; cpus[12] holds TIME_FINDINODES cpus[13] holds TIME_UPDSCORE cpus[14] holds time to transform the elimination tree cpus[15] holds time to compute the symbolical factorization cpus[16] holds time to compute the numerical factorization cpus[17] holds TIME_INITFRONT cpus[18] holds TIME_EXADD cpus[19] holds TIME_KERNEL cpus[20] holds TIME_INITUPD cpus[21] holds time to solve the triangular systems o Comments: this is the final topmost function that can be used as a black box in other algorithm; it provides a general purpose direct solver for large sparse positive definite systems ******************************************************************************/ void SPACE_solve(inputMtx_t *A, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus) { graph_t *G; elimtree_t *T, *T2; factorMtx_t *L; timings_t cpusOrd[ORD_TIME_SLOTS], cpusFactor[NUMFAC_TIME_SLOTS]; timings_t t_graph, t_ord, t_etree, t_symb, t_num, t_solvetri; options_t default_options[] = { SPACE_ORDTYPE, SPACE_NODE_SELECTION1, SPACE_NODE_SELECTION2, SPACE_NODE_SELECTION3, SPACE_DOMAIN_SIZE, SPACE_MSGLVL, SPACE_ETREE_NONZ }; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; /* ---------------- reset all timers ---------------- */ pord_resettimer(t_graph); pord_resettimer(t_ord); pord_resettimer(t_etree); pord_resettimer(t_symb); pord_resettimer(t_num); pord_resettimer(t_solvetri); /* ----------------- set up graph G(A) ----------------- */ pord_starttimer(t_graph); G = setupGraphFromMtx(A); pord_stoptimer(t_graph); if (options[OPTION_MSGLVL] > 0) printf("\ninduced graph constructed: #vertices %d, #edges %d, #components " "%d\n", G->nvtx, G->nedges >> 1, connectedComponents(G)); /* -------------------------------------------- construct ordering/elimination tree for G(A) -------------------------------------------- */ pord_starttimer(t_ord); T = SPACE_ordering(G, options, cpusOrd); pord_stoptimer(t_ord); freeGraph(G); if (options[OPTION_MSGLVL] > 0) printf("quality of initial elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T->nfronts, nFactorIndices(T), nFactorEntries(T), nFactorOps(T), nWorkspace(T)); /* ------------------------------- elimination tree transformation ------------------------------- */ pord_starttimer(t_etree); T2 = SPACE_transformElimTree(T, options[OPTION_ETREE_NONZ]); pord_stoptimer(t_etree); freeElimTree(T); if (options[OPTION_MSGLVL] > 0) printf("quality of transformed elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T2->nfronts, nFactorIndices(T2), nFactorEntries(T2), nFactorOps(T2), nWorkspace(T2)); /* ------------------------ symbolical factorization ------------------------ */ pord_starttimer(t_symb); L = SPACE_symbFac(T2, A); pord_stoptimer(t_symb); if (options[OPTION_MSGLVL] > 0) printf("quality of factor matrix:\n\tneqs %d, #indices %d, nzl %d\n", L->css->neqs, L->css->nind, L->nelem); /* ----------------------- numerical factorization ----------------------- */ pord_starttimer(t_num); SPACE_numFac(L, cpusFactor); pord_stoptimer(t_num); if (options[OPTION_MSGLVL] > 0) printf("performance of numerical factorization: %6.2f mflops\n", (double)nFactorOps(T2) / t_num / 1000000); /* ------------------------------ solution of triangular systems ------------------------------ */ pord_starttimer(t_solvetri); SPACE_solveTriangular(L, rhs, xvec); pord_stoptimer(t_solvetri); if (options[OPTION_MSGLVL] > 0) printf("performance of forward/backward solve: %6.2f mflops\n", (double)nTriangularOps(T2) / t_solvetri / 1000000); freeElimTree(T2); freeFactorMtx(L); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = t_graph; cpus[1] = t_ord; cpus[2] = cpusOrd[TIME_COMPRESS]; cpus[3] = cpusOrd[TIME_MS]; cpus[4] = cpusOrd[TIME_MULTILEVEL]; cpus[5] = cpusOrd[TIME_INITDOMDEC]; cpus[6] = cpusOrd[TIME_COARSEDOMDEC]; cpus[7] = cpusOrd[TIME_INITSEP]; cpus[8] = cpusOrd[TIME_REFINESEP]; cpus[9] = cpusOrd[TIME_SMOOTH]; cpus[10] = cpusOrd[TIME_BOTTOMUP]; cpus[11] = cpusOrd[TIME_UPDADJNCY]; cpus[12] = cpusOrd[TIME_FINDINODES]; cpus[13] = cpusOrd[TIME_UPDSCORE]; cpus[14] = t_etree; cpus[15] = t_symb; cpus[16] = t_num; cpus[17] = cpusFactor[TIME_INITFRONT]; cpus[18] = cpusFactor[TIME_EXADD]; cpus[19] = cpusFactor[TIME_KERNEL]; cpus[20] = cpusFactor[TIME_INITUPD]; cpus[21] = t_solvetri; } } /***************************************************************************** o Input: sparse matrix A with permutation vector perm right hand side vector rhs options -- if NULL, default options are used option[0] holds OPTION_MSGLVL option[1] holds OPTION_ETREE_NONZ o Output: solution vector xvec of the original system Ax = b cpus -- if NULL, no timing information is pulled back cpus[0] holds time to construct the graph cpus[1] holds time to construct the elimination tree cpus[2] holds time to transform the elimination tree cpus[3] holds time to compute the symbolical factorization cpus[4] holds time to compute the numerical factorization cpus[5] holds TIME_INITFRONT cpus[6] holds TIME_EXADD cpus[7] holds TIME_KERNEL cpus[8] holds TIME_INITUPD cpus[9] holds time to solve the triangular systems o Comments: this function can be used to solve an equation system using an externally computed permutation vector ******************************************************************************/ void SPACE_solveWithPerm(inputMtx_t *A, PORD_INT *perm, FLOAT *rhs, FLOAT *xvec, options_t *options, timings_t *cpus) { graph_t *G; elimtree_t *T, *T2; factorMtx_t *L; timings_t cpusFactor[NUMFAC_TIME_SLOTS], t_graph, t_etree_construct; timings_t t_etree_merge, t_symb, t_num, t_solvetri; options_t default_options[] = { SPACE_MSGLVL, SPACE_ETREE_NONZ }; PORD_INT *invp, i, msglvl, maxzeros; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; msglvl = options[0]; maxzeros = options[1]; /* ---------------- reset all timers ---------------- */ pord_resettimer(t_graph); pord_resettimer(t_etree_construct); pord_resettimer(t_etree_merge); pord_resettimer(t_symb); pord_resettimer(t_num); pord_resettimer(t_solvetri); /* ----------------- set up graph G(A) ----------------- */ pord_starttimer(t_graph); G = setupGraphFromMtx(A); pord_stoptimer(t_graph); if (msglvl > 0) printf("\ninduced graph constructed: #vertices %d, #edges %d, #components " "%d\n", G->nvtx, G->nedges >> 1, connectedComponents(G)); /* --------------------------------------------------- construct inital elimination tree according to perm --------------------------------------------------- */ pord_starttimer(t_etree_construct); mymalloc(invp, G->nvtx, PORD_INT); for (i = 0; i < G->nvtx; i++) invp[perm[i]] = i; T = setupElimTree(G, perm, invp); pord_stoptimer(t_etree_construct); freeGraph(G); free(invp); if (msglvl > 0) printf("quality of initial elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T->nfronts, nFactorIndices(T), nFactorEntries(T), nFactorOps(T), nWorkspace(T)); /* ------------------------------- elimination tree transformation ------------------------------- */ pord_starttimer(t_etree_merge); T2 = SPACE_transformElimTree(T, maxzeros); pord_stoptimer(t_etree_merge); freeElimTree(T); if (msglvl > 0) printf("quality of transformed elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T2->nfronts, nFactorIndices(T2), nFactorEntries(T2), nFactorOps(T2), nWorkspace(T2)); /* ------------------------ symbolical factorization ------------------------ */ pord_starttimer(t_symb); L = SPACE_symbFac(T2, A); pord_stoptimer(t_symb); if (msglvl > 0) printf("quality of factor matrix:\n\tneqs %d, #indices %d, nzl %d\n", L->css->neqs, L->css->nind, L->nelem); /* ----------------------- numerical factorization ----------------------- */ pord_starttimer(t_num); SPACE_numFac(L, cpusFactor); pord_stoptimer(t_num); if (msglvl > 0) printf("performance of numerical factorization: %6.2f mflops\n", (double)nFactorOps(T2) / t_num / 1000000); /* ------------------------------ solution of triangular systems ------------------------------ */ pord_starttimer(t_solvetri); SPACE_solveTriangular(L, rhs, xvec); pord_stoptimer(t_solvetri); if (msglvl > 0) printf("performance of forward/backward solve: %6.2f mflops\n", (double)nTriangularOps(T2) / t_solvetri / 1000000); freeElimTree(T2); freeFactorMtx(L); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = t_graph; cpus[1] = t_etree_construct; cpus[2] = t_etree_merge; cpus[3] = t_symb; cpus[4] = t_num; cpus[5] = cpusFactor[TIME_INITFRONT]; cpus[6] = cpusFactor[TIME_EXADD]; cpus[7] = cpusFactor[TIME_KERNEL]; cpus[8] = cpusFactor[TIME_INITUPD]; cpus[9] = t_solvetri; } } /***************************************************************************** o Input: graph G with permutation vector perm options -- if NULL, default options are used option[0] holds OPTION_MSGLVL option[1] holds OPTION_ETREE_NONZ option[2] holds OPTION_ETREE_BAL option[3] holds dimension of hypercube o Output: mapping object map cpus -- if NULL, no timing information is pulled back cpus[0] holds time to construct the elimination tree cpus[1] holds time to transform the elimination tree cpus[2] holds time to compute the mapping o Comments: this function can be used to obtain a mapping object for the parallel factorization ******************************************************************************/ mapping_t* SPACE_mapping(graph_t *G, PORD_INT *perm, options_t *options, timings_t *cpus) { mapping_t *map; elimtree_t *T, *T2; timings_t t_etree_construct, t_etree_merge, t_map; options_t default_options[] = { SPACE_MSGLVL, SPACE_ETREE_NONZ, SPACE_ETREE_BAL, 2 }; PORD_INT *invp, i, msglvl, maxzeros, bal, dimQ; /* -------------------------------------------------- set default options, if no other options specified -------------------------------------------------- */ if (options == NULL) options = default_options; msglvl = options[0]; maxzeros = options[1]; bal = options[2]; dimQ = options[3]; /* ---------------- reset all timers ---------------- */ pord_resettimer(t_etree_construct); pord_resettimer(t_etree_merge); pord_resettimer(t_map); /* --------------------------------------------------- construct inital elimination tree according to perm --------------------------------------------------- */ pord_starttimer(t_etree_construct); mymalloc(invp, G->nvtx, PORD_INT); for (i = 0; i < G->nvtx; i++) invp[perm[i]] = i; T = setupElimTree(G, perm, invp); pord_stoptimer(t_etree_construct); free(invp); if (msglvl > 0) printf("quality of initial elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T->nfronts, nFactorIndices(T), nFactorEntries(T), nFactorOps(T), nWorkspace(T)); /* ------------------------------- elimination tree transformation ------------------------------- */ pord_starttimer(t_etree_merge); T2 = SPACE_transformElimTree(T, maxzeros); pord_stoptimer(t_etree_merge); freeElimTree(T); if (msglvl > 0) printf("quality of transformed elim. tree: #fronts %d, #indices %d\n\t" "nzl %d, ops %e, wspace %d\n", T2->nfronts, nFactorIndices(T2), nFactorEntries(T2), nFactorOps(T2), nWorkspace(T2)); /* ------------------- compute the mapping ------------------- */ pord_starttimer(t_map); map = setupMapping(T2, dimQ, bal); pord_stoptimer(t_map); /* -------------------------------------------------- pull back timing results, if vector cpus available -------------------------------------------------- */ if (cpus != NULL) { cpus[0] = t_etree_construct; cpus[1] = t_etree_merge; cpus[2] = t_map; } /* -------------------------------------------------------------- return mapping object (don't free T2, since it belongs to map) -------------------------------------------------------------- */ return(map); } #endif MUMPS_5.4.1/PORD/lib/gbipart.c0000664000175000017500000005155314102210467016042 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: gbipart.c / / author J"urgen Schulze, University of Paderborn / created 00dec26 / / This file contains functions dealing with bipartite graphs / ****************************************************************************** Data type: struct gbipart graph_t *G; pointer to graph object with E c X x Y int nX; the vertices 0,...,nX-1 belong to X int nY; the vertices nX,...,nX+nY-1 belong to Y Comments: o Structure used to smooth a separator computed for a subgraph Gbisect. The separator is paired with the border vertices in black/white partition, thus, resulting in a bipartite graph. Methods in lib/gbipart.c: - Gbipart = newBipartiteGraph(int nX, int nY, int nedges); - void freeBipartiteGraph(gbipart_t *Gbipart); - void printGbipart(gbipart_t *Gbipart); - Gbipart = setupBipartiteGraph(graph_t *G, int *bipartvertex, int nX, int nY, int *vtxmap) o Gbipart is induced by the vertices in bipartvertex. The first nX vertices are the vertices 0...nX-1 and the last nY vertices are the vertices nX...nX+nY-1 of Gbipart. Vector vtxmap maps the vertices in bipartvertex to the vertices of the bipartite graph. - void maximumMatching(gbipart_t *Gbipart, int *matching); - void maximumFlow(gbipart_t *Gbipart, int *flow, int *rc) o flow[i] stores the flow over the edge in adjncy[i] of Gbipart. It is positive, if the edge is from X to Y, otherwise flow is negative. o rc[u] stores the residual capacity of edge (source,u), u e X, respectively (u,sink), u e Y. All edges between X and Y have infinite capacity, therefore, no rc value must be computed for them. - void DMviaMatching(gbipart_t *Gbipart, int *matching, int *dmflag, int *dmwght); o on return. vector dmflag is filled with the following values: / SI, iff x e X is reachable via exposed node e X dmflag[x] = < SX, iff x e X is reachable via exposed node e Y \ SR, iff x e X - (SI u SX) / BI, iff y e Y is reachable via exposed node e Y dmflag[y] = < BX, iff y e Y is reachable via exposed node e X \ BR, iff y e Y - (BI u BX) o on return, vector dmwght is filled with the following values: dmwght[SI] - weight of SI dmwght[BI] - weight of BI dmwght[SX] - weight of SX dmwght[BX] - weight of BX dmwght[SR] - weight of SR dmwght[BR] - weight of BR - void DMviaFlow(gbipart_t *Gbipart, int *flow, int *rc, int *dmflag, int *dmwght); o vectors dmflag and dmwght are filled as described above ******************************************************************************/ #include #define FREE -1 #define SOURCE -2 #define SINK -3 /***************************************************************************** ******************************************************************************/ gbipart_t* newBipartiteGraph(PORD_INT nX, PORD_INT nY, PORD_INT nedges) { gbipart_t *Gbipart; mymalloc(Gbipart, 1, gbipart_t); Gbipart->G = newGraph(nX+nY, nedges); Gbipart->nX = nX; Gbipart->nY = nY; return(Gbipart); } /***************************************************************************** ******************************************************************************/ void freeBipartiteGraph(gbipart_t *Gbipart) { freeGraph(Gbipart->G); free(Gbipart); } /***************************************************************************** ******************************************************************************/ void printGbipart(gbipart_t *Gbipart) { graph_t *G; PORD_INT count, u, i, istart, istop; G = Gbipart->G; printf("\n#vertices %d (nX %d, nY %d), #edges %d, type %d, totvwght %d\n", G->nvtx, Gbipart->nX, Gbipart->nY, G->nedges >> 1, G->type, G->totvwght); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of vertex %d (weight %d):\n", u, G->vwght[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ gbipart_t* setupBipartiteGraph(graph_t *G, PORD_INT *bipartvertex, PORD_INT nX, PORD_INT nY, PORD_INT *vtxmap) { gbipart_t *Gbipart; PORD_INT *xadj, *adjncy, *vwght, *xadjGb, *adjncyGb, *vwghtGb; PORD_INT nvtx, nedgesGb, totvwght, u, x, y, i, j, jstart, jstop, ptr; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* ---------------------------------------------------------------- compute number of edges and local indices of vertices in Gbipart ---------------------------------------------------------------- */ nedgesGb = 0; for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; if ((u < 0) || (u >= nvtx)) { fprintf(stderr, "\nError in function setupBipartiteGraph\n" " node %d does not belong to graph\n", u); quit(); } jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) vtxmap[adjncy[j]] = -1; nedgesGb += (jstop - jstart); } for (i = 0; i < nX+nY; i++) { u = bipartvertex[i]; vtxmap[u] = i; } Gbipart = newBipartiteGraph(nX, nY, nedgesGb); xadjGb = Gbipart->G->xadj; adjncyGb = Gbipart->G->adjncy; vwghtGb = Gbipart->G->vwght; /* --------------------------------- build the induced bipartite graph --------------------------------- */ totvwght = 0; ptr = 0; for (i = 0; i < nX; i++) { x = bipartvertex[i]; xadjGb[i] = ptr; vwghtGb[i] = vwght[x]; totvwght += vwght[x]; jstart = xadj[x]; jstop = xadj[x+1]; for (j = jstart; j < jstop; j++) { y = adjncy[j]; if (vtxmap[y] >= nX) adjncyGb[ptr++] = vtxmap[y]; } } for (i = nX; i < nX+nY; i++) { y = bipartvertex[i]; xadjGb[i] = ptr; vwghtGb[i] = vwght[y]; totvwght += vwght[y]; jstart = xadj[y]; jstop = xadj[y+1]; for (j = jstart; j < jstop; j++) { x = adjncy[j]; if ((vtxmap[x] >= 0) && (vtxmap[x] < nX)) adjncyGb[ptr++] = vtxmap[x]; } } xadjGb[nX+nY] = ptr; Gbipart->G->type = G->type; Gbipart->G->totvwght = totvwght; return(Gbipart); } /***************************************************************************** ******************************************************************************/ void maximumMatching(gbipart_t *Gbipart, PORD_INT *matching) { PORD_INT *xadj, *adjncy, *level, *marker, *queue, *stack; PORD_INT top, top2, u, x, x2, y, y2, nX, nY, i, istart, istop; PORD_INT qhead, qtail, max_level; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(level, (nX+nY), PORD_INT); mymalloc(marker, (nX+nY), PORD_INT); mymalloc(queue, nX, PORD_INT); mymalloc(stack, nY, PORD_INT); /* ------------------- initialize matching ------------------- */ for (u = 0; u < nX+nY; u++) matching[u] = FREE; /* --------------------------------------------------- construct maximal matching in bipartite graph (X,Y) --------------------------------------------------- */ for (x = 0; x < nX; x++) { istart = xadj[x]; istop = xadj[x+1]; for (i = istart; i < istop; i++) { y = adjncy[i]; if (matching[y] == FREE) { matching[x] = y; matching[y] = x; break; } } } /* -------------------------------------------------------------------- construct maximum matching in bipartite graph (X,Y) (Hopcroft, Karp) -------------------------------------------------------------------- */ while (TRUE) { for (u = 0; u < nX+nY; u++) level[u] = marker[u] = -1; qhead = qtail = 0; /* fill queue with free X nodes */ for (x = 0; x < nX; x++) if (matching[x] == FREE) { queue[qtail++] = x; level[x] = 0; } /* -------------------------------------------------------------- breadth first search to construct layer network containing all vertex disjoint augmenting paths of minimal length -------------------------------------------------------------- */ top = 0; max_level = MAX_INT; while (qhead != qtail) { x = queue[qhead++]; /* note: queue contains only */ if (level[x] < max_level) /* nodes from X */ { istart = xadj[x]; istop = xadj[x+1]; for (i = istart; i < istop; i++) { y = adjncy[i]; if (level[y] == -1) { level[y] = level[x] + 1; if (matching[y] == FREE) { max_level = level[y]; /* note: stack contains only */ stack[top++] = y; /* nodes form Y */ } else if (level[y] < max_level) { x2 = matching[y]; level[x2] = level[y] + 1; queue[qtail++] = x2; } } } } } if (top == 0) break; /* no augmenting path found */ /* ------------------------------------------------------------ restricted depth first search to construct maximal number of vertex disjoint augmenting paths in layer network ------------------------------------------------------------ */ while (top > 0) { top2 = top--; y = stack[top2-1]; /* get the next exposed node in Y */ marker[y] = xadj[y]; /* points to next neighbor of y */ while (top2 > top) { y = stack[top2-1]; i = marker[y]++; if (i < xadj[y+1]) /* not all neighbors of y visited */ { x = adjncy[i]; if ((marker[x] == -1) && (level[x] == level[y]-1)) { marker[x] = 0; if (level[x] == 0) /* augmenting path found */ while (top2 > top) /* pop stack */ { y2 = stack[--top2]; x2 = matching[y2]; /* / o == o */ matching[x] = y2; /* / */ matching[y2] = x; /* x -- y2 == x2 -- y */ x = x2; /* \ */ } /* \ o == o */ else { y2 = matching[x]; stack[top2++] = y2; marker[y2] = xadj[y2]; } } } else top2--; } } } /* ------------------------------- free working storage and return ------------------------------- */ free(level); free(marker); free(queue); free(stack); } /***************************************************************************** ******************************************************************************/ void maximumFlow(gbipart_t *Gbipart, PORD_INT *flow, PORD_INT *rc) { PORD_INT *xadj, *adjncy, *vwght, *parent, *marker, *queue; PORD_INT nedges, u, v, x, y, nX, nY, j, i, istart, istop; PORD_INT qhead, qtail, capacity; nedges = Gbipart->G->nedges; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; vwght = Gbipart->G->vwght; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(parent, (nX+nY), PORD_INT); mymalloc(marker, (nX+nY), PORD_INT); mymalloc(queue, (nX+nY), PORD_INT); /* ------------------------------------- initialize flow and residual capacity ------------------------------------- */ for (u = 0; u < nX+nY; u++) rc[u] = vwght[u]; for (i = 0; i < nedges; i++) flow[i] = 0; /* -------------------------------------------------- determine an initial flow in the bipartite network -------------------------------------------------- */ for (x = 0; x < nX; x++) { istart = xadj[x]; istop = xadj[x+1]; for (i = istart; i < istop; i++) { y = adjncy[i]; capacity = min(rc[x], rc[y]); if (capacity > 0) { rc[x] -= capacity; rc[y] -= capacity; flow[i] = capacity; for (j = xadj[y]; adjncy[j] != x; j++); flow[j] = -capacity; } if (rc[x] == 0) break; } } /* ----------------------------------------------------------- construct maximum flow in bipartite network (Edmonds, Karp) ----------------------------------------------------------- */ while (TRUE) { for (u = 0; u < nX+nY; u++) parent[u] = marker[u] = -1; qhead = qtail = 0; /* fill queue with free X nodes */ for (x = 0; x < nX; x++) if (rc[x] > 0) { queue[qtail++] = x; parent[x] = x; } /* --------------------------------------------------------- breadth first search to find the shortest augmenting path --------------------------------------------------------- */ capacity = 0; while (qhead != qtail) { u = queue[qhead++]; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if ((parent[v] == -1) && ((v >= nX) || (flow[i] < 0))) /* v >= nX => u->v is a forward edge having infty capacity */ /* otherwise u<-v is a backward edge and (v,u) must have */ /* positive capacity (i.e. (u,v) has neg. capacity) */ { parent[v] = u; marker[v] = i; queue[qtail++] = v; if ((v >= nX) && (rc[v] > 0)) /* found it! */ { u = v; /* (v,sink) is below capacity */ capacity = rc[u]; while (parent[u] != u) /* get minimal residual capa. */ { i = marker[u]; u = parent[u]; if (u >= nX) capacity = min(capacity, -flow[i]); } capacity = min(capacity, rc[u]); rc[v] -= capacity; /* augment flow by min. rc */ while (parent[v] != v) { i = marker[v]; u = parent[v]; flow[i] += capacity; for (j = xadj[v]; adjncy[j] != u; j++); flow[j] = -flow[i]; v = u; } rc[v] -= capacity; qhead = qtail; /* escape inner while loop */ break; } } } } if (capacity == 0) break; } free(parent); free(marker); free(queue); } /***************************************************************************** ******************************************************************************/ void DMviaMatching(gbipart_t *Gbipart, PORD_INT *matching, PORD_INT *dmflag, PORD_INT *dmwght) { PORD_INT *xadj, *adjncy, *vwght, *queue, qhead, qtail; PORD_INT u, x, nX, y, nY, i, istart, istop; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; vwght = Gbipart->G->vwght; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(queue, (nX+nY), PORD_INT); /* ---------------------------------------------------------------------- mark all exposed nodes of X with SI and all exposed nodes of Y with BI ---------------------------------------------------------------------- */ qhead = qtail = 0; for (x = 0; x < nX; x++) if (matching[x] == FREE) { queue[qtail++] = x; dmflag[x] = SI; } else dmflag[x] = SR; for (y = nX; y < nX+nY; y++) if (matching[y] == FREE) { queue[qtail++] = y; dmflag[y] = BI; } else dmflag[y] = BR; /* ------------------------------------------------------------------ construct Dulmage-Mendelsohn decomp. starting with SI and BI nodes ------------------------------------------------------------------ */ while (qhead != qtail) { u = queue[qhead++]; istart = xadj[u]; istop = xadj[u+1]; switch(dmflag[u]) { case SI: for (i = istart; i < istop; i++) { y = adjncy[i]; if (dmflag[y] == BR) { queue[qtail++] = y; dmflag[y] = BX; } } break; case BX: x = matching[u]; dmflag[x] = SI; queue[qtail++] = x; break; case BI: for (i = istart; i < istop; i++) { x = adjncy[i]; if (dmflag[x] == SR) { queue[qtail++] = x; dmflag[x] = SX; } } break; case SX: y = matching[u]; dmflag[y] = BI; queue[qtail++] = y; break; } } /* ---------------------- fill the dmwght vector ---------------------- */ dmwght[SI] = dmwght[SX] = dmwght[SR] = 0; for (x = 0; x < nX; x++) switch(dmflag[x]) { case SI: dmwght[SI] += vwght[x]; break; case SX: dmwght[SX] += vwght[x]; break; case SR: dmwght[SR] += vwght[x]; break; } dmwght[BI] = dmwght[BX] = dmwght[BR] = 0; for (y = nX; y < nX+nY; y++) switch(dmflag[y]) { case BI: dmwght[BI] += vwght[y]; break; case BX: dmwght[BX] += vwght[y]; break; case BR: dmwght[BR] += vwght[y]; break; } free(queue); } /***************************************************************************** ******************************************************************************/ void DMviaFlow(gbipart_t *Gbipart, PORD_INT *flow, PORD_INT *rc, PORD_INT *dmflag, PORD_INT *dmwght) { PORD_INT *xadj, *adjncy, *vwght, *queue, qhead, qtail; PORD_INT u, v, x, nX, y, nY, i, istart, istop; xadj = Gbipart->G->xadj; adjncy = Gbipart->G->adjncy; vwght = Gbipart->G->vwght; nX = Gbipart->nX; nY = Gbipart->nY; mymalloc(queue, (nX+nY), PORD_INT); /* ---------------------------------------------------------- mark all nodes reachable from source/sink with SOURCE/SINK ---------------------------------------------------------- */ qhead = qtail = 0; for (x = 0; x < nX; x++) if (rc[x] > 0) { queue[qtail++] = x; dmflag[x] = SOURCE; } else dmflag[x] = FREE; for (y = nX; y < nX+nY; y++) if (rc[y] > 0) { queue[qtail++] = y; dmflag[y] = SINK; } else dmflag[y] = FREE; /* -------------------------------------------------------------------- construct Dulmage-Mendelsohn decomp. starting with SOURCE/SINK nodes -------------------------------------------------------------------- */ while (qhead != qtail) { u = queue[qhead++]; istart = xadj[u]; istop = xadj[u+1]; switch(dmflag[u]) { case SOURCE: for (i = istart; i < istop; i++) { v = adjncy[i]; if ((dmflag[v] == FREE) && ((v >= nX) || (flow[i] < 0))) { queue[qtail++] = v; dmflag[v] = SOURCE; /* v reachable via forward edge u->v */ } /* or via backward edge u<-v */ } break; case SINK: for (i = istart; i < istop; i++) { v = adjncy[i]; if ((dmflag[v] == FREE) && ((v < nX) || (flow[i] > 0))) { queue[qtail++] = v; dmflag[v] = SINK; /* u reachable via forward edge v->u */ } /* or via backward edge v<-u */ } break; } } /* ----------------------------------------------------- all nodes x in X with dmflag[x] = SOURCE belong to SI all nodes x in X with dmflag[x] = SINK belong to SX all nodes x in X with dmflag[x] = FREE belong to SR ----------------------------------------------------- */ dmwght[SI] = dmwght[SX] = dmwght[SR] = 0; for (x = 0; x < nX; x++) switch(dmflag[x]) { case SOURCE: dmflag[x] = SI; dmwght[SI] += vwght[x]; break; case SINK: dmflag[x] = SX; dmwght[SX] += vwght[x]; break; default: dmflag[x] = SR; dmwght[SR] += vwght[x]; } /* ----------------------------------------------------- all nodes y in Y with dmflag[y] = SOURCE belong to BX all nodes y in Y with dmflag[y] = SINK belong to BI all nodes y in Y with dmflag[y] = FREE belong to BR ----------------------------------------------------- */ dmwght[BI] = dmwght[BX] = dmwght[BR] = 0; for (y = nX; y < nX+nY; y++) switch(dmflag[y]) { case SOURCE: dmflag[y] = BX; dmwght[BX] += vwght[y]; break; case SINK: dmflag[y] = BI; dmwght[BI] += vwght[y]; break; default: dmflag[y] = BR; dmwght[BR] += vwght[y]; } free(queue); } MUMPS_5.4.1/PORD/lib/sort.c0000664000175000017500000001410114102210467015365 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: sort.c / / author J"urgen Schulze, University of Paderborn / created 09/15/99 / / This file contains some sorting functions. the code is adopted from / the book "Algorithms in C" by R. Sedgewick. / ******************************************************************************/ #include #define THRES 10 /***************************************************************************** / insertion sort upwards (INTS, without keys) ******************************************************************************/ void insertUpInts(PORD_INT n, PORD_INT *array) { PORD_INT i, j, v; for (i = 1; i < n; i++) { v = array[i]; j = i; while ((j > 0) && (array[j-1] > v)) { array[j] = array[j-1]; j--; } array[j] = v; } } /***************************************************************************** / insertion sort upwards (INTS, with static INT keys) ******************************************************************************/ void insertUpIntsWithStaticIntKeys(PORD_INT n, PORD_INT *array, PORD_INT *key) { PORD_INT i, j, ke; PORD_INT e; for (i = 1; i < n; i++) { e = array[i]; ke = key[e]; j = i; while ((j > 0) && (key[array[j-1]] > ke)) { array[j] = array[j-1]; j--; } array[j] = e; } } /***************************************************************************** / insertion sort downwards (INTS, with static INT keys) ******************************************************************************/ void insertDownIntsWithStaticFloatKeys(PORD_INT n, PORD_INT *array, FLOAT *key) { PORD_INT i, j, e; FLOAT ke; for (i = 1; i < n; i++) { e = array[i]; ke = key[e]; j = i; while ((j > 0) && (key[array[j-1]] < ke)) { array[j] = array[j-1]; j--; } array[j] = e; } } /***************************************************************************** / insertion sort upwards (FLOATS, with INT keys) ******************************************************************************/ void insertUpFloatsWithIntKeys(PORD_INT n, FLOAT *array, PORD_INT *key) { PORD_INT i, j, ke; FLOAT e; for (i = 1; i < n; i++) { e = array[i]; ke = key[i]; j = i; while ((j > 0) && (key[j-1] > ke)) { array[j] = array[j-1]; key[j] = key[j-1]; j--; } array[j] = e; key[j] = ke; } } /***************************************************************************** / median-of-three quicksort upwards (INTS, without keys) ******************************************************************************/ void qsortUpInts(PORD_INT n, PORD_INT *array, PORD_INT *stack) { register PORD_INT i, j; PORD_INT t, l, m, r, p; l = 0; r = n-1; p = 2; while (p > 0) if ((r-l) > THRES) { m = l + ((r-l) >> 1); if (array[l] > array[r]) swap(array[l], array[r], t); if (array[l] > array[m]) swap(array[l], array[m], t); if (array[r] > array[m]) swap(array[m], array[r], t); m = array[r]; i = l-1; j = r; for (;;) { while (array[++i] < m); while (array[--j] > m); if (i >= j) break; swap(array[i], array[j], t); } swap(array[i], array[r], t); if ((i-l) > (r-i)) { stack[p++] = l; stack[p++] = i-1; l = i+1; } else { stack[p++] = i+1; stack[p++] = r; r = i-1; } } else { r = stack[--p]; l = stack[--p]; } if (THRES > 0) insertUpInts(n, array); } /***************************************************************************** / median-of-three quicksort upwards (FLOATS, with INT keys) ******************************************************************************/ void qsortUpFloatsWithIntKeys(PORD_INT n, FLOAT *array, PORD_INT *key, PORD_INT *stack) { register PORD_INT i, j; PORD_INT t, l, m, r, p; FLOAT e; l = 0; r = n-1; p = 2; while (p > 0) if ((r-l) > THRES) { m = l + ((r-l) >> 1); if (key[l] > key[r]) { swap(array[l], array[r], e); swap(key[l], key[r], t); } if (key[l] > key[m]) { swap(array[l], array[m], e); swap(key[l], key[m], t); } if (key[r] > key[m]) { swap(array[m], array[r], e); swap(key[m], key[r], t); } m = key[r]; i = l-1; j = r; for (;;) { while (key[++i] < m); while (key[--j] > m); if (i >= j) break; swap(array[i], array[j], e); swap(key[i], key[j], t); } swap(array[i], array[r], e); swap(key[i], key[r], t); if ((i-l) > (r-i)) { stack[p++] = l; stack[p++] = i-1; l = i+1; } else { stack[p++] = i+1; stack[p++] = r; r = i-1; } } else { r = stack[--p]; l = stack[--p]; } if (THRES > 0) insertUpFloatsWithIntKeys(n, array, key); } /***************************************************************************** / distribution counting (INTS, with static INT keys) ******************************************************************************/ void distributionCounting(PORD_INT n, PORD_INT *node, PORD_INT *key) { register PORD_INT i; PORD_INT *tmp, *count, minkey, maxkey, l, u, vk; /* determine maximal and minimal key */ minkey = MAX_INT; maxkey = 0; for (i = 0; i < n; i++) { u = node[i]; maxkey = max(key[u], maxkey); minkey = min(key[u], minkey); } l = maxkey-minkey; /* printf("minkey %d, maxkey %d, range %d\n", minkey, maxkey, l); */ mymalloc(count, (l+1), PORD_INT); mymalloc(tmp, n, PORD_INT); for (i = 0; i <= l; i++) count[i] = 0; /* scale down all key-values */ for (i = 0; i < n; i++) { u = node[i]; vk = key[u]-minkey; key[u] = vk; count[vk]++; } /* now do the sorting */ for (i = 1; i <= l; i++) count[i] += count[i-1]; for (i = n-1; i >= 0; i--) { u = node[i]; tmp[--count[key[u]]] = u; } for (i = 0; i < n; i++) node[i] = tmp[i]; /* for (i = 0; i < n; i++) { u = node[i]; printf(" node %d, key %d\n", u, key[u]); } */ free(count); free(tmp); } MUMPS_5.4.1/PORD/lib/symbfac.c0000664000175000017500000004453314102210467016036 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: symbfac.c / / author J"urgen Schulze, University of Paderborn / created 09/15/99 / / This file contains code for the symbolical factorization. / ****************************************************************************** Data type: struct css int neqs; number of equations int nind; number of row subscripts in compressed format int owned; does the object own vector nzlsub? int *xnzl; start of column int *nzlsub; row subscripts int *xnzlsub; start of column's row subscripts struct frontsub elimtree_t *PTP; permuted elimination tree int nind number of indices int *xnzf; start of front subscripts int *nzfsub front subscripts for permuted elimtree PTP struct factorMtx int nelem; number of nonzeros (incl. diagonal entries) int *perm; permutation vector FLOAT *nzl; vector of nonzeros (incl. diagonal entries) css_t *css; compressed subscript structure of factorMtx frontsub_t *frontsub; front subscripts Comments: Methods in lib/symbfac.c: - css = newCSS(int neqs, int nind, int owned); - void freeCSS(css_t *css); - css = setupCSSFromGraph(graph_t *G, int *perm, int *invp); - css = setupCSSFromFrontSubscripts(frontsub_t *frontsub); - frontsub = newFrontSubscripts(elimtree_t *PTP); - void freeFrontSubscripts(frontsub_t *frontsub); - void printFrontSubscripts(frontsub_t *frontsub); - frontsub = setupFrontSubscripts(elimtree_t *PTP, inputMtx_t *PAP); - L = newFactorMtx(int nelem); - void freeFactorMtx(factorMtx_t *L); - void printFactorMtx(factorMtx_t *L); - void initFactorMtx(factorMtx_t *L, inputMtx_t *PAP); - void initFactorMtxNEW(factorMtx_t *L, inputMtx_t *PAP); ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ css_t* newCSS(PORD_INT neqs, PORD_INT nind, PORD_INT owned) { css_t *css; mymalloc(css, 1, css_t); mymalloc(css->xnzl, (neqs+1), PORD_INT); mymalloc(css->xnzlsub, neqs, PORD_INT); if (owned) { mymalloc(css->nzlsub, nind, PORD_INT); } else { css->nzlsub = NULL; } css->neqs = neqs; css->nind = nind; css->owned = owned; return(css); } /***************************************************************************** ******************************************************************************/ void freeCSS(css_t *css) { free(css->xnzl); free(css->xnzlsub); if (css->owned) free(css->nzlsub); free(css); } /***************************************************************************** ******************************************************************************/ css_t* setupCSSFromGraph(graph_t *G, PORD_INT *perm, PORD_INT *invp) { css_t *css; PORD_INT *marker, *mergelink, *indices, *tmp, *xnzl, *xnzlsub, *nzlsub; PORD_INT neqs, maxmem, u, v, col, mergecol, knz, mrk, beg, end; PORD_INT fast, len, k, p, e, i, istart, istop; neqs = G->nvtx; maxmem = 2 * neqs; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(marker, neqs, PORD_INT); mymalloc(indices, neqs, PORD_INT); mymalloc(mergelink, neqs, PORD_INT); mymalloc(tmp, neqs, PORD_INT); for (k = 0; k < neqs; k++) marker[k] = mergelink[k] = -1; /* ------------------------------------------------------- allocate storage for the compressed subscript structure ------------------------------------------------------- */ css = newCSS(neqs, maxmem, TRUE); xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; /* ------------------------------------------------------------ main loop: determine the subdiag. row indices of each column ------------------------------------------------------------ */ xnzl[0] = 0; beg = end = 0; for (k = 0; k < neqs; k++) { indices[0] = k; knz = 1; if ((mergecol = mergelink[k]) != -1) /* is k a leaf ??? */ { mrk = marker[mergecol]; fast = TRUE; } else { mrk = k; fast = FALSE; } /* -------------------------- original columns (indices) -------------------------- */ u = invp[k]; istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { v = G->adjncy[i]; if ((col = perm[v]) > k) { indices[knz++] = col; if (marker[col] != mrk) fast = FALSE; } } /* -------------------------- external columns (indices) -------------------------- */ if ((fast) && (mergelink[mergecol] == -1)) { xnzlsub[k] = xnzlsub[mergecol] + 1; knz = xnzl[mergecol+1] - xnzl[mergecol] - 1; } else { for (i = 0; i < knz; i++) marker[indices[i]] = k; while (mergecol != -1) { len = xnzl[mergecol+1] - xnzl[mergecol]; istart = xnzlsub[mergecol]; istop = istart + len; for (i = istart; i < istop; i++) { col = nzlsub[i]; if ((col > k) && (marker[col] != k)) { indices[knz++] = col; marker[col] = k; } } mergecol = mergelink[mergecol]; } qsortUpInts(knz, indices, tmp); /* --------------------------------------------------- store indices in nzlsub; resize nzlsub if too small --------------------------------------------------- */ beg = end; xnzlsub[k] = beg; end = beg + knz; if (end > maxmem) { maxmem += neqs; myrealloc(nzlsub, maxmem, PORD_INT); } len = 0; for (i = beg; i < end; i++) nzlsub[i] = indices[len++]; } /* ---------------------------- append column k to mergelink ---------------------------- */ if (knz > 1) { p = xnzlsub[k]+1; e = nzlsub[p]; mergelink[k] = mergelink[e]; mergelink[e] = k; } xnzl[k+1] = xnzl[k] + knz; } /* ----------------------------- end of main loop: free memory ----------------------------- */ free(marker); free(indices); free(tmp); free(mergelink); /* ------------------------------------------------------ finalize the compressed subscript structure and return ------------------------------------------------------ */ css->nind = xnzlsub[neqs-1] + 1; myrealloc(nzlsub, css->nind, PORD_INT); css->nzlsub = nzlsub; return(css); } /***************************************************************************** ******************************************************************************/ css_t* setupCSSFromFrontSubscripts(frontsub_t *frontsub) { elimtree_t *PTP; css_t *css; PORD_INT *xnzf, *nzfsub, *ncolfactor, *xnzl, *xnzlsub; PORD_INT nind, nvtx, K, beg, knz, firstcol, col; PTP = frontsub->PTP; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; nind = frontsub->nind; nvtx = PTP->nvtx; ncolfactor = PTP->ncolfactor; /* ------------------------------------------------------- allocate storage for the compressed subscript structure ------------------------------------------------------- */ css = newCSS(nvtx, nind, FALSE); css->nzlsub = nzfsub; xnzl = css->xnzl; xnzlsub = css->xnzlsub; /* --------------------------------------- fill the compressed subscript structure --------------------------------------- */ xnzl[0] = 0; for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { beg = xnzf[K]; knz = xnzf[K+1] - beg; firstcol = nzfsub[beg]; for (col = firstcol; col < firstcol + ncolfactor[K]; col++) { xnzlsub[col] = beg++; xnzl[col+1] = xnzl[col] + knz--; } } return(css); } /***************************************************************************** ******************************************************************************/ frontsub_t* newFrontSubscripts(elimtree_t *PTP) { frontsub_t *frontsub; PORD_INT nfronts, nind; nfronts = PTP->nfronts; nind = nFactorIndices(PTP); mymalloc(frontsub, 1, frontsub_t); mymalloc(frontsub->xnzf, (nfronts+1), PORD_INT); mymalloc(frontsub->nzfsub, nind, PORD_INT); frontsub->PTP = PTP; frontsub->nind = nind; return(frontsub); } /***************************************************************************** ******************************************************************************/ void freeFrontSubscripts(frontsub_t *frontsub) { freeElimTree(frontsub->PTP); free(frontsub->xnzf); free(frontsub->nzfsub); free(frontsub); } /***************************************************************************** ******************************************************************************/ void printFrontSubscripts(frontsub_t *frontsub) { elimtree_t *PTP; PORD_INT *xnzf, *nzfsub, *ncolfactor, *ncolupdate, *parent; PORD_INT nfronts, root, K, count, i, istart, istop; PTP = frontsub->PTP; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; nfronts = PTP->nfronts; root = PTP->root; ncolfactor = PTP->ncolfactor; ncolupdate = PTP->ncolupdate; parent = PTP->parent; printf("#fronts %d, root %d\n", nfronts, root); for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { printf("--- front %d, ncolfactor %d, ncolupdate %d, parent %d\n", K, ncolfactor[K], ncolupdate[K], parent[K]); count = 0; istart = xnzf[K]; istop = xnzf[K+1]; for (i = istart; i < istop; i++) { printf("%5d", nzfsub[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ frontsub_t* setupFrontSubscripts(elimtree_t *PTP, inputMtx_t *PAP) { frontsub_t *frontsub; PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings, *vtx2front; PORD_INT *xnza, *nzasub, *xnzf, *nzfsub; PORD_INT *marker, *tmp, *first, *indices; PORD_INT nvtx, nfronts, col, firstcol, knz; PORD_INT u, i, istart, istop, K, J; nvtx = PTP->nvtx; nfronts = PTP->nfronts; ncolfactor = PTP->ncolfactor; ncolupdate = PTP->ncolupdate; firstchild = PTP->firstchild; silbings = PTP->silbings; vtx2front = PTP->vtx2front; xnza = PAP->xnza; nzasub = PAP->nzasub; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(marker, nvtx, PORD_INT); mymalloc(tmp, nvtx, PORD_INT); mymalloc(first, nfronts, PORD_INT); for (i = 0; i < nvtx; i++) marker[i] = -1; /* -------------------------------- find the first column of a front -------------------------------- */ for (u = nvtx-1; u >= 0; u--) { K = vtx2front[u]; first[K] = u; } /* ----------------------------------------- allocate storage for the front subscripts ----------------------------------------- */ frontsub = newFrontSubscripts(PTP); xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; knz = 0; for (K = 0; K < nfronts; K++) { xnzf[K] = knz; knz += (ncolfactor[K] + ncolupdate[K]); } xnzf[K] = knz; /* ------------------------------------------- postorder traversal of the elimination tree ------------------------------------------- */ for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { knz = 0; indices = nzfsub + xnzf[K]; firstcol = first[K]; /* ------------------------------------- internal columns (indices) of front K ------------------------------------- */ for (col = firstcol; col < firstcol + ncolfactor[K]; col++) { indices[knz++] = col; marker[col] = K; } /* ------------------------------------- external columns (indices) of front K ------------------------------------- */ for (J = firstchild[K]; J != -1; J = silbings[J]) { istart = xnzf[J]; istop = xnzf[J+1]; for (i = istart; i < istop; i++) { col = nzfsub[i]; if ((col > firstcol) && (marker[col] != K)) { marker[col] = K; indices[knz++] = col; } } } /* ------------------------------------- original columns (indices) of front K ------------------------------------- */ for (u = 0; u < ncolfactor[K]; u++) { istart = xnza[firstcol + u]; istop = xnza[firstcol + u + 1]; for (i = istart; i < istop; i++) { col = nzasub[i]; if ((col > firstcol) && (marker[col] != K)) { marker[col] = K; indices[knz++] = col; } } } /* ---------------- sort the indices ---------------- */ qsortUpInts(knz, indices, tmp); } /* ---------------------- free memory and return ---------------------- */ free(marker); free(tmp); free(first); return(frontsub); } /***************************************************************************** ******************************************************************************/ factorMtx_t* newFactorMtx(PORD_INT nelem) { factorMtx_t *L; mymalloc(L, 1, factorMtx_t); mymalloc(L->nzl, nelem, FLOAT); L->nelem = nelem; L->css = NULL; L->frontsub = NULL; L->perm = NULL; return(L); } /***************************************************************************** ******************************************************************************/ void freeFactorMtx(factorMtx_t *L) { freeCSS(L->css); freeFrontSubscripts(L->frontsub); free(L->nzl); free(L->perm); free(L); } /***************************************************************************** ******************************************************************************/ void printFactorMtx(factorMtx_t *L) { css_t *css; FLOAT *nzl; PORD_INT *xnzl, *nzlsub, *xnzlsub; PORD_INT neqs, nelem, nind, k, ksub, i, istart, istop; nelem = L->nelem; nzl = L->nzl; css = L->css; neqs = css->neqs; nind = css->nind; xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; printf("#equations %d, #elements (+diag.) %d, #indices (+diag.) %d\n", neqs, nelem, nind); for (k = 0; k < neqs; k++) { printf("--- column %d\n", k); ksub = xnzlsub[k]; istart = xnzl[k]; istop = xnzl[k+1]; for (i = istart; i < istop; i++) printf(" row %5d, entry %e\n", nzlsub[ksub++], nzl[i]); } } /***************************************************************************** ******************************************************************************/ void initFactorMtx(factorMtx_t *L, inputMtx_t *PAP) { elimtree_t *PTP; frontsub_t *frontsub; css_t *css; PORD_INT *ncolfactor; FLOAT *nzl, *nza, *diag; PORD_INT *xnzl, *nzlsub, *xnzlsub, *xnza, *nzasub, *xnzf, *nzfsub; PORD_INT nelem, K, k, kstart, h, hstart, dis, i, istart, istop; PORD_INT firstcol, lastcol; nelem = L->nelem; nzl = L->nzl; css = L->css; xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; frontsub = L->frontsub; PTP = frontsub->PTP; ncolfactor = PTP->ncolfactor; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; diag = PAP->diag; nza = PAP->nza; xnza = PAP->xnza; nzasub = PAP->nzasub; /* ------------------------------------ set all numerical values of L to 0.0 ------------------------------------ */ for (i = 0; i < nelem; i++) nzl[i] = 0.0; /* -------------------------------------------- init. factor matrix with the nonzeros of PAP -------------------------------------------- */ for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { firstcol = nzfsub[xnzf[K]]; lastcol = firstcol + ncolfactor[K]; for (k = firstcol; k < lastcol; k++) { istart = xnza[k]; istop = xnza[k+1]; kstart = xnzl[k]; hstart = xnzlsub[k]; h = hstart; for (i = istart; i < istop; i++) { for (; nzlsub[h] != nzasub[i]; h++); dis = h - hstart; nzl[kstart+dis] = nza[i]; } nzl[kstart] = diag[k]; } } } /***************************************************************************** ******************************************************************************/ void initFactorMtxNEW(factorMtx_t *L, inputMtx_t *PAP) { elimtree_t *PTP; frontsub_t *frontsub; css_t *css; PORD_INT *ncolfactor; FLOAT *nzl, *nza, *diag, *entriesL; PORD_INT *xnzl, *xnza, *nzasub, *xnzf, *nzfsub; PORD_INT *tmp, neqs, nelem, K, k, len, row, i, istart, istop; PORD_INT firstcol, lastcol; nelem = L->nelem; nzl = L->nzl; css = L->css; xnzl = css->xnzl; frontsub = L->frontsub; PTP = frontsub->PTP; ncolfactor = PTP->ncolfactor; xnzf = frontsub->xnzf; nzfsub = frontsub->nzfsub; neqs = PAP->neqs; diag = PAP->diag; nza = PAP->nza; xnza = PAP->xnza; nzasub = PAP->nzasub; /* ------------------------ allocate working storage ------------------------ */ mymalloc(tmp, neqs, PORD_INT); /* ------------------------------------ set all numerical values of L to 0.0 ------------------------------------ */ for (i = 0; i < nelem; i++) nzl[i] = 0.0; /* -------------------------------------------- init. factor matrix with the nonzeros of PAP -------------------------------------------- */ for (K = firstPostorder(PTP); K != -1; K = nextPostorder(PTP, K)) { len = 0; istart = xnzf[K]; istop = xnzf[K+1]; for (i = istart; i < istop; i++) tmp[nzfsub[i]] = len++; firstcol = nzfsub[istart]; lastcol = firstcol + ncolfactor[K]; entriesL = nzl + xnzl[firstcol]; for (k = firstcol; k < lastcol; k++) { istart = xnza[k]; istop = xnza[k+1]; for (i = istart; i < istop; i++) { row = nzasub[i]; entriesL[tmp[row]] = nza[i]; } entriesL[tmp[k]] = diag[k]; entriesL += --len; } } /* -------------------- free working storage -------------------- */ free(tmp); } MUMPS_5.4.1/PORD/lib/tree.c0000664000175000017500000007632514102210467015355 0ustar jylexceljylexcel/***************************************************************************** / / SPACE SPArse Cholesky Elimination) Library: tree.c / / author J"urgen Schulze, University of Paderborn / created 09/15/99 / / This file contains functions dealing with elimination/front tree object / ****************************************************************************** Data type: struct elimtree int nvtx; number of vertices in the tree int nfronts; number of fronts in the tree int root; root of the tree int *ncolfactor; number of factor columns in front int *ncolupdate; number of update columns for front int *parent; parent in front tree int *firstchild; first child in front tree int *silbings; silbings in front tree int *vtx2front; maps vertices to fronts Comments: o Structure used to hold the elimination/front tree; the tree is used to guide the symbolical and numerical factorization; a "node" in the tree can be a single vertex (in the context of an elimination tree) or a group of vertices (as for a front tree) o NOTE: Also the ordering can be expressed in terms of front trees; the permutation vector perm is then obtained by a post order traversal of the tree (see method permFromElimTree below) Methods in lib/tree.c: - T = newElimTree(int nvtx, int nfronts); o Initial: root = -1 - void freeElimTree(elimtree_t *T); - void printElimTree(elimtree_t *T); - int firstPostorder(elimtree_t *T); o returns the first front in a post order traversal of T - int firstPostorder2(elimtree_t *T, int root); o returns the first front in a post order traversal of T[root] - int nextPostorder(elimtree_t *T, int J); o returns the front that follows J in a post order traversal of T - int firstPreorder(elimtree_t *T); o returns the first front in a pre order traversal of T - int nextPreorder(elimtree_t *T, int J); o returns the front that follows J in a pre order traversal of T - T = setupElimTree(graph_t *G, int *perm, int *invp); o constructs an elimination tree for G with permutation vectors perm, invp; a union-find algorithm is used to set up the parent vector of T; T->root and vectors T->firstchild, T->silbings are initialized by calling initFchSilbRoot; vector T->ncolupdate is filled by calling function setupCSSFromGraph (see below) - void initFchSilbRoot(elimtree_t *T); o uses vector T->parent to initialize T->firstchild, T->silbings, T->root - void permFromElimTree(elimtree_t *T, int *perm); o fills vectors perm, invp according to a post order traversal of T - T2 = expandElimTree(elimtree_t *T, int *vtxmap, int nvtxorg) o creates and returns an elimtree object for the uncompressed graph; the map from original vertices to compressed vertices is found in vector vtxmap; the number of original vertices (i.e. the length of vector vtxmap) is nvtxorg o NOTE: the function only expands vector T->vtx2front and sets T2->nvtx to nvtxorg; all other vectors are copied from T to T2, i.e. the number of fronts and the tree structure are the same in T and T2 - PTP = permuteElimTree(elimtree_t *T, int *perm); o in T: vtx2front[u] points to front containing vertex u in PTP: vtx2front[k] points to front containing column k = perm[u] o NOTE: the function only permutes vector T->vtx2front; all other vectors are copied from T to PTP, i.e. the number of fronts and the tree structure are the same in T and PTP - T2 = fundamentalFronts(elimtree_t *T); o compresses chains of fronts to a single front; once a map from original fronts to compressed fronts is known, the compressed elimtree object T2 can be created by calling compressElimTree (see below) - T2 = mergeFronts(elimtree_t *T, int maxzeros); o merges small subtrees together in one front; it returns an elimtree object T2 where a front has either been merged with none or all of its children; the maximal number of zero entries that is allowed to be introduced when merging the fronts together is given by maxzeros - T2 = compressElimTree(elimtree_t *T, int *frontmap, int cnfronts); o creates a new front tree using frontmap; vector frontmap maps the original fronts of T to a smaller set of fronts; cnfronts is number of new fronts (i.e. the maximal entry in frontmap) - int justifyFronts(elimtree_t *T); o orders the children of a front so that the working storage in the multifrontal algorithm is minimized; the function returns the amount of extra working storage for the justified tree - int nWorkspace(elimtree_t *T); o returns the size of the working storage in the multifrontal algorithm (measured in terms of FLOATS, for BYTES multiply with sizeof(FLOAT)) - int nFactorIndices(elimtree_t *T); o returns the number of indices taken by the factor matrix represented by T - int nFactorEntries(elimtree_t *T); o returns the number of entries taken by the factor matrix represented by T - FLOAT nFactorOps(elimtree_t *T); o returns the number of operations required to compute the factor matrix represented by T - void subtreeFactorOps(elimtree *T, FLOAT *ops) o returns in ops[K] the number of operations required to factor the fronts in tree T(K) (this includes front K) - FLOAT nTriangularOps(elimtree_t *T); o returns the number of operations required to solve the triangular systems ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ elimtree_t* newElimTree(PORD_INT nvtx, PORD_INT nfronts) { elimtree_t *T; mymalloc(T, 1, elimtree_t); mymalloc(T->ncolfactor, nfronts, PORD_INT); mymalloc(T->ncolupdate, nfronts, PORD_INT); mymalloc(T->parent, nfronts, PORD_INT); mymalloc(T->firstchild, nfronts, PORD_INT); mymalloc(T->silbings, nfronts, PORD_INT); mymalloc(T->vtx2front, nvtx, PORD_INT); T->nvtx = nvtx; T->nfronts = nfronts; T->root = -1; return(T); } /***************************************************************************** ******************************************************************************/ void freeElimTree(elimtree_t *T) { free(T->ncolfactor); free(T->ncolupdate); free(T->parent); free(T->firstchild); free(T->silbings); free(T->vtx2front); free(T); } /***************************************************************************** ******************************************************************************/ void printElimTree(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate, *parent, *firstchild, *silbings, *vtx2front; PORD_INT *first, *link, nvtx, nfronts, root, J, K, u, count, child; nvtx = T->nvtx; nfronts = T->nfronts; root = T->root; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; vtx2front = T->vtx2front; printf("#fronts %d, root %d\n", nfronts, root); /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (J = 0; J < nfronts; J++) first[J] = -1; for (u = nvtx-1; u >= 0; u--) { J = vtx2front[u]; link[u] = first[J]; first[J] = u; } /* ----------------------------------------------------------- print fronts according to a postorder traversal of the tree ----------------------------------------------------------- */ for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { printf("--- front %d, ncolfactor %d, ncolupdate %d, parent %d\n", K, ncolfactor[K], ncolupdate[K], parent[K]); count = 0; printf("children:\n"); for (child = firstchild[K]; child != -1; child = silbings[child]) { printf("%5d", child); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); count = 0; printf("vertices mapped to front:\n"); for (u = first[K]; u != -1; u = link[u]) { printf("%5d", u); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); } /***************************************************************************** ******************************************************************************/ PORD_INT firstPostorder(elimtree_t *T) { PORD_INT *firstchild, J; firstchild = T->firstchild; if ((J = T->root) != -1) while (firstchild[J] != -1) J = firstchild[J]; return(J); } /***************************************************************************** ******************************************************************************/ PORD_INT firstPostorder2(elimtree_t *T, PORD_INT root) { PORD_INT *firstchild, J; firstchild = T->firstchild; if ((J = root) != -1) while (firstchild[J] != -1) J = firstchild[J]; return(J); } /***************************************************************************** ******************************************************************************/ PORD_INT nextPostorder(elimtree_t *T, PORD_INT J) { PORD_INT *parent, *firstchild, *silbings; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; if (silbings[J] != -1) { J = silbings[J]; while (firstchild[J] != -1) J = firstchild[J]; } else J = parent[J]; return(J); } /***************************************************************************** ******************************************************************************/ PORD_INT firstPreorder(elimtree_t *T) { return(T->root); } /***************************************************************************** ******************************************************************************/ PORD_INT nextPreorder(elimtree_t *T, PORD_INT J) { PORD_INT *parent, *firstchild, *silbings; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; if (firstchild[J] != -1) J = firstchild[J]; else { while ((silbings[J] == -1) && (parent[J] != -1)) J = parent[J]; J = silbings[J]; } return(J); } /***************************************************************************** ******************************************************************************/ elimtree_t* setupElimTree(graph_t *G, PORD_INT *perm, PORD_INT *invp) { elimtree_t *T; css_t *css; PORD_INT *xadj, *adjncy, *vwght, *ncolfactor, *ncolupdate, *parent; PORD_INT *vtx2front, *realroot, *uf_father, *uf_size; PORD_INT *xnzl, *nzlsub, *xnzlsub; PORD_INT nvtx, front, front2, froot, f, r, u, v, i, istart, istop; PORD_INT prevlen, len, h, hsub; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* -------------------------- set up the working storage -------------------------- */ mymalloc(realroot, nvtx, PORD_INT); mymalloc(uf_father, nvtx, PORD_INT); mymalloc(uf_size, nvtx, PORD_INT); /* ------------------------------------------------ allocate storage for the elimination tree object ------------------------------------------------ */ T = newElimTree(nvtx, nvtx); ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; vtx2front = T->vtx2front; /* ----------------------------- set up the parent vector of T ----------------------------- */ for (front = 0; front < nvtx; front++) { parent[front] = -1; u = invp[front]; /* only vertex u belongs to this front */ uf_father[front] = front; /* front forms a set in union-find structure */ uf_size[front] = 1; /* the set consists of a single front */ realroot[front] = front; froot = front; /* run through the adjacency list of u */ istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; front2 = perm[v]; if (front2 < front) { r = front2; while (uf_father[r] != r) /* find root of front2 in union-find */ r = uf_father[r]; while (front2 != r) /* path compression */ { f = front2; front2 = uf_father[front2]; uf_father[f] = r; } f = realroot[r]; /* merge union-find sets */ if ((parent[f] == -1) && (f != front)) { parent[f] = front; if (uf_size[froot] < uf_size[r]) { uf_father[froot] = r; uf_size[r] += uf_size[froot]; froot = r; } else { uf_father[r] = froot; uf_size[froot] += uf_size[r]; } realroot[froot] = front; } } } } /* --------------------------------------------- set the vectors T->firstchild and T->silbings --------------------------------------------- */ initFchSilbRoot(T); /* ---------------------------------------------------------- set the vectors T->vtx2front, T->ncolfactor, T->ncolupdate ---------------------------------------------------------- */ css = setupCSSFromGraph(G, perm, invp); xnzl = css->xnzl; nzlsub = css->nzlsub; xnzlsub = css->xnzlsub; prevlen = 0; for (front = 0; front < nvtx; front++) { u = invp[front]; ncolfactor[front] = vwght[u]; ncolupdate[front] = 0; vtx2front[u] = front; len = xnzl[front+1] - xnzl[front]; if (prevlen - 1 == len) ncolupdate[front] = ncolupdate[front-1] - vwght[u]; else { h = xnzlsub[front] + 1; for (i = 1; i < len; i++) { hsub = nzlsub[h++]; v = invp[hsub]; ncolupdate[front] += vwght[v]; } } prevlen = len; } /* ---------------------- free memory and return ---------------------- */ free(css); free(realroot); free(uf_father); free(uf_size); return(T); } /***************************************************************************** ******************************************************************************/ void initFchSilbRoot(elimtree_t *T) { PORD_INT *parent, *firstchild, *silbings, nfronts, J, pJ; nfronts = T->nfronts; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; for (J = 0; J < nfronts; J++) silbings[J] = firstchild[J] = -1; for (J = nfronts-1; J >= 0; J--) if ((pJ = parent[J]) != -1) { silbings[J] = firstchild[pJ]; firstchild[pJ] = J; } else { silbings[J] = T->root; T->root = J; } } /***************************************************************************** ******************************************************************************/ void permFromElimTree(elimtree_t *T, PORD_INT *perm) { PORD_INT *vtx2front, *first, *link; PORD_INT nvtx, nfronts, K, u, count; nvtx = T->nvtx; nfronts = T->nfronts; vtx2front = T->vtx2front; /* ----------------------------------------------------------- store the vertices/columns of a front in a bucket structure ----------------------------------------------------------- */ mymalloc(first, nfronts, PORD_INT); mymalloc(link, nvtx, PORD_INT); for (K = 0; K < nfronts; K++) first[K] = -1; for (u = nvtx-1; u >= 0; u--) { K = vtx2front[u]; link[u] = first[K]; first[K] = u; } /* ----------------------------------------------------- postorder traversal of the elimination tree to obtain the permutation vectors perm, invp ----------------------------------------------------- */ count = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) for (u = first[K]; u != -1; u = link[u]) { perm[u] = count; count++; } /* ---------------------- free memory and return ---------------------- */ free(first); free(link); } /***************************************************************************** ******************************************************************************/ elimtree_t* permuteElimTree(elimtree_t *T, PORD_INT *perm) { elimtree_t *PTP; PORD_INT nvtx, nfronts, J, u; nvtx = T->nvtx; nfronts = T->nfronts; /* -------------------------------------------------------------- allocate space for the new elimtree object and copy front data the permuted tree has the same number of fronts/tree structure -------------------------------------------------------------- */ PTP = newElimTree(nvtx, nfronts); PTP->root = T->root; for (J = 0; J < nfronts; J++) { PTP->ncolfactor[J] = T->ncolfactor[J]; PTP->ncolupdate[J] = T->ncolupdate[J]; PTP->parent[J] = T->parent[J]; PTP->firstchild[J] = T->firstchild[J]; PTP->silbings[J] = T->silbings[J]; } /* --------------------------------------------------------------------- set up the new vtx2front vector; the trees only differ in this vector --------------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) PTP->vtx2front[perm[u]] = T->vtx2front[u]; return(PTP); } /***************************************************************************** ******************************************************************************/ elimtree_t* expandElimTree(elimtree_t *T, PORD_INT *vtxmap, PORD_INT nvtxorg) { elimtree_t *T2; PORD_INT *vtx2front, *vtx2front2; PORD_INT nfronts, J, u; nfronts = T->nfronts; /* -------------------------------------------------------------- allocate space for the new elimtree object and copy front data the expanded tree has the same number of fronts/tree structure -------------------------------------------------------------- */ T2 = newElimTree(nvtxorg, nfronts); T2->root = T->root; for (J = 0; J < nfronts; J++) { T2->ncolfactor[J] = T->ncolfactor[J]; T2->ncolupdate[J] = T->ncolupdate[J]; T2->parent[J] = T->parent[J]; T2->firstchild[J] = T->firstchild[J]; T2->silbings[J] = T->silbings[J]; } /* --------------------------------------------------------------------- set up the new vtx2front vector; the trees only differ in this vector --------------------------------------------------------------------- */ vtx2front = T->vtx2front; vtx2front2 = T2->vtx2front; for (u = 0; u < nvtxorg; u++) vtx2front2[u] = vtx2front[vtxmap[u]]; return(T2); } /***************************************************************************** ******************************************************************************/ elimtree_t* fundamentalFronts(elimtree_t *T) { elimtree_t *T2; PORD_INT *ncolfactor, *ncolupdate, *parent, *firstchild, *silbings; PORD_INT *frontmap, nfronts, cnfronts, J, child; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(frontmap, nfronts, PORD_INT); /* ----------------------------- search the fundamental fronts ----------------------------- */ cnfronts = 0; J = T->root; while (J != -1) { while (firstchild[J] != -1) J = firstchild[J]; frontmap[J] = cnfronts++; while ((silbings[J] == -1) && (parent[J] != -1)) { J = parent[J]; child = firstchild[J]; if ((silbings[child] != -1) || (ncolupdate[child] != ncolfactor[J] + ncolupdate[J])) frontmap[J] = cnfronts++; else frontmap[J] = frontmap[child]; } J = silbings[J]; } /* ------------------------------ construct new elimination tree ------------------------------ */ T2 = compressElimTree(T, frontmap, cnfronts); /* ---------------------- free memory and return ---------------------- */ free(frontmap); return(T2); } /***************************************************************************** ******************************************************************************/ elimtree_t* mergeFronts(elimtree_t *T, PORD_INT maxzeros) { elimtree_t *T2; PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings; PORD_INT *frontmap, *newncolfactor, *nzeros, *rep; PORD_INT nfronts, cnfronts, K, ncolfrontK, J, Jall, cost; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(frontmap, nfronts, PORD_INT); mymalloc(newncolfactor, nfronts, PORD_INT); mymalloc(nzeros, nfronts, PORD_INT); mymalloc(rep, nfronts, PORD_INT); for (K = 0; K < nfronts; K++) { newncolfactor[K] = ncolfactor[K]; nzeros[K] = 0; rep[K] = K; } /* ----------------------------------------------------- perform a postorder traversal of the elimination tree ----------------------------------------------------- */ for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) if (firstchild[K] != -1) { ncolfrontK = newncolfactor[K] + ncolupdate[K]; Jall = 0; cost = 0; for (J = firstchild[K]; J != -1; J = silbings[J]) { Jall += newncolfactor[J]; cost -= newncolfactor[J] * newncolfactor[J]; cost += 2*newncolfactor[J] * (ncolfrontK - ncolupdate[J]); cost += 2*nzeros[J]; } cost += Jall * Jall; cost = cost / 2; if (cost < maxzeros) { for (J = firstchild[K]; J != -1; J = silbings[J]) { rep[J] = K; newncolfactor[K] += newncolfactor[J]; } nzeros[K] = cost; } } /* ---------------------------------- construct frontmap from vector rep ---------------------------------- */ cnfronts = 0; for (K = 0; K < nfronts; K++) if (rep[K] == K) frontmap[K] = cnfronts++; else { for (J = K; rep[J] != J; J = rep[J]); rep[K] = J; } for (K = 0; K < nfronts; K++) if ((J = rep[K]) != K) frontmap[K] = frontmap[J]; /* ------------------------------ construct new elimination tree ------------------------------ */ T2 = compressElimTree(T, frontmap, cnfronts); /* ---------------------- free memory and return ---------------------- */ free(frontmap); free(newncolfactor); free(nzeros); free(rep); return(T2); } /***************************************************************************** ******************************************************************************/ elimtree_t* compressElimTree(elimtree_t *T, PORD_INT *frontmap, PORD_INT cnfronts) { elimtree_t *T2; PORD_INT *ncolfactor, *ncolupdate, *parent, *vtx2front; PORD_INT nvtx, nfronts, u, K, pK, newfront, pnewfront; nvtx = T->nvtx; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; parent = T->parent; vtx2front = T->vtx2front; /* -------------------------------------------- allocate memory for the new elimtree T2 and init. ncolfactor, ncolupdate, and parent -------------------------------------------- */ T2 = newElimTree(nvtx, cnfronts); for (K = 0; K < cnfronts; K++) { T2->ncolfactor[K] = T2->ncolupdate[K] = 0; T2->parent[K] = -1; } /* -------------------------------------------------------------- set the new vectors T2->ncolfactor, T2->ncolupdate, T2->parent -------------------------------------------------------------- */ for (K = 0; K < nfronts; K++) { newfront = frontmap[K]; T2->ncolfactor[newfront] += ncolfactor[K]; if (((pK = parent[K]) != -1) && ((pnewfront = frontmap[pK]) != newfront)) { T2->parent[newfront] = pnewfront; T2->ncolupdate[newfront] = ncolupdate[K]; } } /* --------------------------------------------------- set the new vectors T2->firstchild and T2->silbings --------------------------------------------------- */ initFchSilbRoot(T2); /* ------------------------------------ set the the new vector T2->vtx2front ------------------------------------ */ for (u = 0; u < nvtx; u++) T2->vtx2front[u] = frontmap[vtx2front[u]]; return(T2); } /***************************************************************************** ******************************************************************************/ PORD_INT justifyFronts(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings, *minWspace, *list; PORD_INT nfronts, K, ncolfrontK, frontsizeK, wspace, child, nxtchild; PORD_INT count, m, s, i; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(minWspace, nfronts, PORD_INT); mymalloc(list, nfronts, PORD_INT); /* --------------------------------------------------------- postorder traversal of the elimination tree to obtain the optimal justification of the children of each front ---------------------------------------------------------- */ wspace = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { ncolfrontK = ncolfactor[K] + ncolupdate[K]; frontsizeK = (ncolfrontK * (ncolfrontK + 1)) >> 1; if ((child = firstchild[K]) == -1) minWspace[K] = frontsizeK; else { count = 0; /* sort children according to their minWspace value */ while (child != -1) { list[count++] = child; child = silbings[child]; } insertUpIntsWithStaticIntKeys(count, list, minWspace); firstchild[K] = -1; for (i = 0; i < count; i++) { child = list[i]; silbings[child] = firstchild[K]; firstchild[K] = child; } /* compute minWspace[K] */ child = firstchild[K]; nxtchild = silbings[child]; m = s = minWspace[child]; while (nxtchild != -1) { s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + minWspace[nxtchild]; m = max(m, s); child = nxtchild; nxtchild = silbings[nxtchild]; } s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + frontsizeK; minWspace[K] = max(m, s); } wspace = max(wspace, minWspace[K]); } /* ---------------------- free memory and return ---------------------- */ free(minWspace); free(list); return(wspace); } /***************************************************************************** ******************************************************************************/ PORD_INT nWorkspace(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate, *firstchild, *silbings, *minWspace; PORD_INT nfronts, K, ncolfrontK, frontsizeK, wspace, child, nxtchild, m, s; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; firstchild = T->firstchild; silbings = T->silbings; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(minWspace, nfronts, PORD_INT); /* ------------------------------------------- postorder traversal of the elimination tree ------------------------------------------- */ wspace = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { ncolfrontK = ncolfactor[K] + ncolupdate[K]; frontsizeK = (ncolfrontK * (ncolfrontK + 1)) >> 1; if ((child = firstchild[K]) == -1) minWspace[K] = frontsizeK; else { child = firstchild[K]; nxtchild = silbings[child]; m = s = minWspace[child]; while (nxtchild != -1) { s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + minWspace[nxtchild]; m = max(m, s); child = nxtchild; nxtchild = silbings[nxtchild]; } s = s - minWspace[child] + ((ncolupdate[child] * (ncolupdate[child] + 1)) >> 1) + frontsizeK; minWspace[K] = max(m, s); } wspace = max(wspace, minWspace[K]); } /* ---------------------- free memory and return ---------------------- */ free(minWspace); return(wspace); } /***************************************************************************** ******************************************************************************/ PORD_INT nFactorIndices(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; PORD_INT nfronts, ind, K; nfronts = T->nfronts; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ind = 0; for (K = 0; K < nfronts; K++) ind += (ncolfactor[K] + ncolupdate[K]); return(ind); } /***************************************************************************** ******************************************************************************/ PORD_INT nFactorEntries(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; PORD_INT ent, tri, rec, K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ent = 0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ent += (tri * (tri+1)) / 2; ent += (tri * rec); } return(ent); } /***************************************************************************** ******************************************************************************/ FLOAT nFactorOps(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; FLOAT ops, tri, rec; PORD_INT K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ops = 0.0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ops += (tri*tri*tri) / 3.0 + (tri*tri) / 2.0 - (5*tri) / 6.0; ops += (tri*tri*rec) + (rec*(rec+1)*tri); } return(ops); } /***************************************************************************** ******************************************************************************/ void subtreeFactorOps(elimtree_t *T, FLOAT *ops) { PORD_INT *ncolfactor, *ncolupdate; FLOAT tri, rec; PORD_INT J, K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ops[K] = (tri*tri*tri) / 3.0 + (tri*tri) / 2.0 - (5*tri) / 6.0; ops[K] += (tri*tri*rec) + (rec*(rec+1)*tri); for (J = T->firstchild[K]; J != -1; J = T->silbings[J]) ops[K] += ops[J]; } } /***************************************************************************** ******************************************************************************/ FLOAT nTriangularOps(elimtree_t *T) { PORD_INT *ncolfactor, *ncolupdate; FLOAT ops, tri, rec; PORD_INT K; ncolfactor = T->ncolfactor; ncolupdate = T->ncolupdate; ops = 0.0; for (K = firstPostorder(T); K != -1; K = nextPostorder(T, K)) { tri = ncolfactor[K]; rec = ncolupdate[K]; ops += (tri*tri) + 2.0*tri*rec; /* forward ops */ ops += (tri*tri) + 2.0*tri*rec; /* backward ops */ } return(ops); } MUMPS_5.4.1/PORD/lib/multisector.c0000664000175000017500000002653114102210467016762 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: ms.c / / author J"urgen Schulze, University of Paderborn / created 01jan04 / / This file contains functions dealing with the multisector object / ****************************************************************************** Data type: struct multisector graph_t *G; pointer to original graph int *stage; stage[u]=i => node u will be elim. in stage i int nstages; number of stages int nnodes; number of nodes in multisector int totmswght; weigth of nodes in multisector Comments: o Structure does not own graph object G => it will not be freed Note: G is the original graph Methods in lib/multisector.c: - ms = newMultisector(graph_t *G); o Initial: nstages = nnodes = totmswght = 0; - void freeMultisector(ms_t *ms); - ms = trivialMultisector(graph_t *G); o allocates memory for the multisector object by a call to newMultisector and sets stage[u] = 0 for all vertices u and nstages = 1; the trivial multisector can be used for pure bottom-up orderings - ms = constructMultisector(graph_t *G, options_t* options, timings_t *cpus); o MASTER_FUNCTION: computes a multisector for G according to the specified ordtype e { MINIMUM_PRIORITY, INCOMPLETE_ND, MULTISECTION, TRISTAGE_MULTISECTION } MINIMUM_PRIORTY: return the multisector obtained by a call to trivialMultisector INCOMPLETE_ND, MULTISECTION, TRISTAGE_MULTISECTION: build separator tree by calling buildNDtree and extract multisector by calling extractMS2stage (MULTISECTION) or extractMSmultistage (INCOMPLETE_ND, TRISTAGE_MULTISECTION) o used options: (also see buildNDtree) OPTION_ORDTYPE, OPTION_DOMAIN_SIZE, OPTION_MSGLVL, OPTION_NODE_SELECTION3 o returned timings: (see buildNDtree) TIME_INITDOMDEC, TIME_COARSEDOMDEC, TIME_INITSEP, TIME_REFINESEP TIME_MULTILEVEL, TIME_SMOOTH - ms = extractMS2stage(nestdiss_t *ndroot); o extracts a 2-stage multisector from the nested dissection tree with root ndroot: stage[u] = 0 => u belongs to a domain stage[u] = 1 => u belongs to the multisector and nstages = 2; the 2-stage multisector can be used for classical multisection orderings - ms = extractMSmultistage(nestdiss_t *ndroot); o extracts a multi-stage multisector from the nested dissection tree at ndroot: stage[u] = 0 => u belongs to a domain stage[u] = i, i > 0 => u belongs to the multisector, i.e.: stage[u] = 1 => u belongs to a leaf separator : stage[u] = nstages-1 => u belongs to the root separator the multisector can be used for incomplete nested dissection orderings or for three-stage multisection orderings ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ multisector_t* newMultisector(graph_t *G) { multisector_t *ms; mymalloc(ms, 1, multisector_t); mymalloc(ms->stage, G->nvtx, PORD_INT); ms->G = G; ms->nstages = 0; ms->nnodes = 0; ms->totmswght = 0; return(ms); } /***************************************************************************** ******************************************************************************/ void freeMultisector(multisector_t *ms) { free(ms->stage); free(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* trivialMultisector(graph_t *G) { multisector_t *ms; PORD_INT *stage, nvtx, u; /* ----------------------------------------------------------------- allocate memory for the multisector object and init. stage vector ----------------------------------------------------------------- */ nvtx = G->nvtx; ms = newMultisector(G); stage = ms->stage; for (u = 0; u < nvtx; u++) stage[u] = 0; /* no vertex belongs to a separator */ /* ------------------------------- finalize the multisector object ------------------------------- */ ms->nstages = 1; ms->nnodes = 0; ms->totmswght = 0; return(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* constructMultisector(graph_t *G, options_t* options, timings_t *cpus) { multisector_t *ms; nestdiss_t *ndroot; PORD_INT *map, nvtx, ordtype; nvtx = G->nvtx; /* ------------------------------ check number of nodes in graph ------------------------------ */ /* ----------------------------------- JY: inserted the condition "&& (options[OPTION_MSGLVL] > 0)" below, to avoid systematic printing ----------------------------------- */ if ((nvtx <= MIN_NODES) && (options[OPTION_ORDTYPE] != MINIMUM_PRIORITY) && (options[OPTION_MSGLVL] > 0)) { printf("\nWarning in constructMultisector\n" " graph has less than %d nodes, skipping separator construction\n\n", MIN_NODES); options[OPTION_ORDTYPE] = MINIMUM_PRIORITY; } /* -------------------------------------------------------- determine the multisector according to the ordering type -------------------------------------------------------- */ ordtype = options[OPTION_ORDTYPE]; switch(ordtype) { case MINIMUM_PRIORITY: ms = trivialMultisector(G); break; case INCOMPLETE_ND: case MULTISECTION: case TRISTAGE_MULTISECTION: mymalloc(map, nvtx, PORD_INT); ndroot = setupNDroot(G, map); buildNDtree(ndroot, options, cpus); if (ordtype == MULTISECTION) ms = extractMS2stage(ndroot); else ms = extractMSmultistage(ndroot); freeNDtree(ndroot); freeNDnode(ndroot); free(map); break; default: fprintf(stderr, "\nError in function constructMultisector\n" " unrecognized ordering type %d\n", ordtype); quit(); } return(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* extractMS2stage(nestdiss_t *ndroot) { multisector_t *ms; nestdiss_t *nd, *parent; PORD_INT *stage, *intvertex, *intcolor; PORD_INT nvint, nnodes, totmswght, i; /* ----------------------------------------------------------------- allocate memory for the multisector object and init. stage vector ----------------------------------------------------------------- */ ms = trivialMultisector(ndroot->G); stage = ms->stage; /* ------------------------------------------------------------ extract the stages of the separator vertices: stage[u] = 1, iff u belongs to a separator ------------------------------------------------------------ */ nnodes = totmswght = 0; for (nd = ndroot; nd->childB != NULL; nd = nd->childB); while (nd != ndroot) { parent = nd->parent; if ((parent == NULL) || (parent->childB == NULL) || (parent->childW == NULL)) { fprintf(stderr, "\nError in function extractMS2stage\n" " nested dissection tree corrupted\n"); quit(); } if (parent->childB == nd) /* left subtree of parent visited */ for (nd = parent->childW; nd->childB != NULL; nd = nd->childB); else /* right subtree of parent visited */ { nd = parent; /* extract the separator of parent */ totmswght += nd->cwght[GRAY]; nvint = nd->nvint; intvertex = nd->intvertex; intcolor = nd->intcolor; for (i = 0; i < nvint; i++) if (intcolor[i] == GRAY) { nnodes++; stage[intvertex[i]] = 1; } } } /* ------------------------------------------ finalize the multisector object and return ------------------------------------------ */ ms->nstages = 2; ms->nnodes = nnodes; ms->totmswght = totmswght; return(ms); } /***************************************************************************** ******************************************************************************/ multisector_t* extractMSmultistage(nestdiss_t *ndroot) { multisector_t *ms; nestdiss_t *nd, *parent; PORD_INT *stage, *intvertex, *intcolor; PORD_INT nvtx, nvint, maxstage, istage, nnodes, totmswght, i, u; /* ----------------------------------------------------------------- allocate memory for the multisector object and init. stage vector ----------------------------------------------------------------- */ ms = trivialMultisector(ndroot->G); stage = ms->stage; /* ------------------------------------------------------------ extract the stages of the separator vertices: stage[u] = i, i>0, iff u belongs to a separator in depth i-1 ------------------------------------------------------------ */ maxstage = nnodes = totmswght = 0; for (nd = ndroot; nd->childB != NULL; nd = nd->childB); while (nd != ndroot) { parent = nd->parent; if ((parent == NULL) || (parent->childB == NULL) || (parent->childW == NULL)) { fprintf(stderr, "\nError in function extractMSmultistage\n" " nested dissection tree corrupted\n"); quit(); } if (parent->childB == nd) /* left subtree of parent visited */ for (nd = parent->childW; nd->childB != NULL; nd = nd->childB); else /* right subtree of parent visited */ { nd = parent; /* extract the separator of parent */ istage = nd->depth + 1; /* sep. vertices belong to this stage */ maxstage = max(maxstage, istage); totmswght += nd->cwght[GRAY]; nvint = nd->nvint; intvertex = nd->intvertex; intcolor = nd->intcolor; for (i = 0; i < nvint; i++) if (intcolor[i] == GRAY) { nnodes++; stage[intvertex[i]] = istage; } } } /* -------------------------------------------------------------------- we have: stage[u] = 0 => u belongs to a domain stage[u] = 1 => u belongs to the root separator (depth = 0) : stage[u] = maxstage => u belongs to a leaf separator but we must eliminate the separators in a bottom-up fashion; we like to have: stage[u] = 0 => u belongs to a domain stage[u] = 1 => u belongs to a leaf separator : stage[u] = maxstage => u belongs to the root separator -------------------------------------------------------------------- */ nvtx = ndroot->G->nvtx; for (u = 0; u < nvtx; u++) if (stage[u] > 0) stage[u] = maxstage - stage[u] + 1; /* ------------------------------------------ finalize the multisector object and return ------------------------------------------ */ ms->nstages = maxstage + 1; ms->nnodes = nnodes; ms->totmswght = totmswght; return(ms); } MUMPS_5.4.1/PORD/lib/graph.c0000664000175000017500000004031614102210467015506 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: graph.c / / author J"urgen Schulze, University of Paderborn / created 99sep14 / / This file contains functions dealing with the graph object. / ****************************************************************************** Data type: struct graph int nvtx; number of vertices int nedges; number of edges int type; vertices can be UNWEIGTHED or WEIGTHED int totvwght; total vertex weight int *xadj; xadj[u] points to start of u's adjacency list int *adjncy; holds the adjacency lists int *vwght; holds the vertex weights Comments: o no edge weights are stored. In our application weighted graphs re- present compressed unweighted graphs and, therefore, ewght[(u,v)] = vwght[u] * vwght[v]. Methods in lib/graph.c: - G = newGraph(int nvtx, int nedges); o Initial: we assume that G is unweighted, therefore: type = UNWEIGTHED, totvwght = nvtx, and vwght[u] = 1 - void freeGraph(graph_t *G); - void printGraph(graph_t *G); - void randomizeGraph(graph_t *G); - Gsub = setupSubgraph(graph_t *G, int *intvertex, int nvint, int *vtxmap); o extracts the subgraph induced by the vertices in array intvertex from G. vtxmap maps the vertices in intvertex to the vertices of the subgraph. - G = setupGraphFromMtx(inputMtx_t *A); - G = setupGridGraph(int dimX, int dimY, int type); o type e {GRID, MESH, TORUS} - int connectedComponents(graph_t *G); - cG = compressGraph(graph_t *G, int *vtxmap) o cG = NULL, if there are not enough ind. vertices (see COMPRESS_FRACTION) o for u in G vtxmap[u] points to representative of u in cG ******************************************************************************/ #include /***************************************************************************** ******************************************************************************/ graph_t* newGraph(PORD_INT nvtx, PORD_INT nedges) { graph_t *G; PORD_INT i; mymalloc(G, 1, graph_t); mymalloc(G->xadj, (nvtx+1), PORD_INT); mymalloc(G->adjncy, nedges, PORD_INT); mymalloc(G->vwght, nvtx, PORD_INT); G->nvtx = nvtx; G->nedges = nedges; G->type = UNWEIGHTED; G->totvwght = nvtx; for (i = 0; i < nvtx; i++) G->vwght[i] = 1; return(G); } /***************************************************************************** ******************************************************************************/ void freeGraph(graph_t *G) { free(G->xadj); free(G->adjncy); free(G->vwght); free(G); } /***************************************************************************** ******************************************************************************/ void printGraph(graph_t *G) { PORD_INT count, u, i, istart, istop; printf("\n#vertices %d, #edges %d, type %d, totvwght %d\n", G->nvtx, G->nedges >> 1, G->type, G->totvwght); for (u = 0; u < G->nvtx; u++) { count = 0; printf("--- adjacency list of vertex %d (weight %d):\n", u, G->vwght[u]); istart = G->xadj[u]; istop = G->xadj[u+1]; for (i = istart; i < istop; i++) { printf("%5d", G->adjncy[i]); if ((++count % 16) == 0) printf("\n"); } if ((count % 16) != 0) printf("\n"); } } /***************************************************************************** ******************************************************************************/ void randomizeGraph(graph_t *G) { PORD_INT *xadj, *adjncy, nvtx, u, v, len, j, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; if ((len = istop - istart) > 1) for (i = istart; i < istop; i++) { j = myrandom(len); swap(adjncy[i], adjncy[i+j], v); len--; } } } /***************************************************************************** ******************************************************************************/ graph_t* setupSubgraph(graph_t *G, PORD_INT *intvertex, PORD_INT nvint, PORD_INT *vtxmap) { graph_t *Gsub; PORD_INT *xadj, *adjncy, *vwght, *xadjGsub, *adjncyGsub, *vwghtGsub; PORD_INT nvtx, nedgesGsub, totvwght, u, v, i, j, jstart, jstop, ptr; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* ------------------------------------------------------------- compute number of edges and local indices of vertices in Gsub ------------------------------------------------------------- */ nedgesGsub = 0; for (i = 0; i < nvint; i++) { u = intvertex[i]; if ((u < 0) || (u >= nvtx)) { fprintf(stderr, "\nError in function setupSubgraph\n" " node %d does not belong to graph\n", u); quit(); } jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) vtxmap[adjncy[j]] = -1; nedgesGsub += (jstop - jstart); } for (i = 0; i < nvint; i++) { u = intvertex[i]; vtxmap[u] = i; } Gsub = newGraph(nvint, nedgesGsub); xadjGsub = Gsub->xadj; adjncyGsub = Gsub->adjncy; vwghtGsub = Gsub->vwght; /* -------------------------- build the induced subgraph -------------------------- */ totvwght = 0; ptr = 0; for (i = 0; i < nvint; i++) { u = intvertex[i]; xadjGsub[i] = ptr; vwghtGsub[i] = vwght[u]; totvwght += vwght[u]; jstart = xadj[u]; jstop = xadj[u+1]; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtxmap[v] >= 0) adjncyGsub[ptr++] = vtxmap[v]; } } xadjGsub[nvint] = ptr; Gsub->type = G->type; Gsub->totvwght = totvwght; return(Gsub); } /***************************************************************************** ******************************************************************************/ graph_t* setupGraphFromMtx(inputMtx_t *A) { graph_t *G; PORD_INT *xnza, *nzasub, *xadj, *adjncy; PORD_INT neqs, nelem, nvtx, k, h1, h2, j, i, istart, istop; neqs = A->neqs; nelem = A->nelem; xnza = A->xnza; nzasub = A->nzasub; /* ------------------------------------ allocate memory for unweighted graph ------------------------------------ */ G = newGraph(neqs, 2*nelem); nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ----------------------------------------- determine the size of each adjacency list ----------------------------------------- */ for (k = 0; k < neqs; k++) xadj[k] = xnza[k+1] - xnza[k]; for (k = 0; k < nelem; k++) xadj[nzasub[k]]++; /* ------------------------------------------------------------- determine for each vertex where its adjacency list will start ------------------------------------------------------------- */ h1 = xadj[0]; xadj[0] = 0; for (k = 1; k <= nvtx; k++) { h2 = xadj[k]; xadj[k] = xadj[k-1] + h1; h1 = h2; } /* ------------------------ fill the adjacency lists ------------------------ */ for (k = 0; k < neqs; k++) { istart = xnza[k]; istop = xnza[k+1]; for (i = istart; i < istop; i++) { j = nzasub[i]; adjncy[xadj[k]++] = j; /* store {k,j} in adjacency list of k */ adjncy[xadj[j]++] = k; /* store {j,k} in adjacency list of j */ } } /* -------------------------------------------- restore startpoint of each vertex and return -------------------------------------------- */ for (k = nvtx-1; k > 0; k--) xadj[k] = xadj[k-1]; xadj[0] = 0; return(G); } /***************************************************************************** ******************************************************************************/ graph_t* setupGridGraph(PORD_INT dimX, PORD_INT dimY, PORD_INT type) { graph_t *G; PORD_INT *xadj, *adjncy, nvtx, nedges, knz, k; /* --------------- initializations --------------- */ G = NULL; knz = 0; nvtx = dimX * dimY; /* --------------------------------- create unweighted grid/mesh graph --------------------------------- */ if ((type == GRID) || (type == MESH)) { nedges = 8 /* for edge vertices */ + 6 * (dimX-2 + dimY-2) /* for border vertices */ + 4 * (dimX-2) * (dimY-2); /* for interior vertices */ if (type == MESH) nedges += 4 * (dimX-1) * (dimY-1); /* diagonals */ G = newGraph(nvtx, nedges); xadj = G->xadj; adjncy = G->adjncy; for (k = 0; k < nvtx; k++) { xadj[k] = knz; if ((k+1) % dimX > 0) /* / k+1-dimX (MESH) */ { adjncy[knz++] = k+1; /* k - k+1 (GRID) */ if (type == MESH) /* \ k+1+dimX (MESH) */ { if (k+1+dimX < nvtx) adjncy[knz++] = k+1+dimX; if (k+1-dimX >= 0) adjncy[knz++] = k+1-dimX; } } if (k % dimX > 0) /* k-1-dimX \ (MESH) */ { adjncy[knz++] = k-1; /* k-1 - k (GRID) */ if (type == MESH) /* k-1+dimX / (MESH) */ { if (k-1+dimX < nvtx) adjncy[knz++] = k-1+dimX; if (k-1-dimX >= 0) adjncy[knz++] = k-1-dimX; } } if (k+dimX < nvtx) /* k-dimX (GRID) */ adjncy[knz++] = k+dimX; /* | */ if (k-dimX >= 0) /* k */ adjncy[knz++] = k-dimX; /* | */ } /* k+dimX (GRID) */ xadj[nvtx] = knz; } /* ----------------------------- create unweighted torus graph ----------------------------- */ if (type == TORUS) { nedges = 4 * dimX * dimY; G = newGraph(nvtx, nedges); xadj = G->xadj; adjncy = G->adjncy; for (k = 0; k < nvtx; k++) { xadj[k] = knz; if (((k+1) % dimX) == 0) /* k -- k+1 */ adjncy[knz++] = k+1-dimX; else adjncy[knz++] = k+1; if ((k % dimX) == 0) /* k-1 -- k */ adjncy[knz++] = k-1+dimX; else adjncy[knz++] = k-1; adjncy[knz++] = (k+dimX) % nvtx; /* k-dimX */ adjncy[knz++] = (k+dimX*(dimY-1)) % nvtx; /* | */ } /* k */ xadj[nvtx] = knz; /* | */ } /* k+dimX */ return(G); } /***************************************************************************** ******************************************************************************/ PORD_INT connectedComponents(graph_t *G) { PORD_INT *xadj, *adjncy, *marker, *queue; PORD_INT nvtx, u, v, w, qhead, qtail, comp, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------ allocate working storage ------------------------ */ mymalloc(marker, nvtx, PORD_INT); mymalloc(queue, nvtx, PORD_INT); /* --------------- initializations --------------- */ comp = 0; for (u = 0; u < nvtx; u++) marker[u] = -1; /* -------------------------------------- get the number of connected components -------------------------------------- */ for (u = 0; u < nvtx; u++) if (marker[u] == -1) { comp++; qhead = 0; qtail = 1; queue[0] = u; marker[u] = 0; while (qhead != qtail) /* breadth first search in each comp. */ { v = queue[qhead++]; istart = xadj[v]; istop = xadj[v+1]; for (i = istart; i < istop; i++) { w = adjncy[i]; if (marker[w] == -1) { queue[qtail++] = w; marker[w] = 0; } } } } /* ------------------------------- free working storage and return ------------------------------- */ free(marker); free(queue); return(comp); } /***************************************************************************** private function of compressGraph ******************************************************************************/ static PORD_INT indNodes(graph_t *G, PORD_INT *vtxmap) { PORD_INT *xadj, *adjncy, *deg, *checksum, *tmp; PORD_INT nvtx, cnvtx, u, v, i, istart, istop, j, jstart, jstop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; /* ------------------------- set up the working arrays ------------------------- */ mymalloc(deg, nvtx, PORD_INT); mymalloc(checksum, nvtx, PORD_INT); mymalloc(tmp, nvtx, PORD_INT); /* ------------------------------------------------- compute for each vertex u its degree and checksum ------------------------------------------------- */ for (u = 0; u < nvtx; u++) { istart = xadj[u]; istop = xadj[u+1]; deg[u] = istop - istart; checksum[u] = u; tmp[u] = -1; vtxmap[u] = u; for (i = istart; i < istop; i++) checksum[u] += adjncy[i]; } /* ------------------------------------- search for indistinguishable vertices ------------------------------------- */ cnvtx = nvtx; for (u = 0; u < nvtx; u++) if (vtxmap[u] == u) { tmp[u] = u; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) tmp[adjncy[i]] = u; /* scan adjacency list of vertex u for indistinguishable vertices */ for (i = istart; i < istop; i++) { v = adjncy[i]; if ((v > u) && (checksum[v] == checksum[u]) && (deg[v] == deg[u]) && (vtxmap[v] == v)) { jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) if (tmp[adjncy[j]] != u) goto FAILURE; /* found it!!! map v onto u */ vtxmap[v] = u; cnvtx--; FAILURE: ; } } } /* ---------------------- free memory and return ---------------------- */ free(deg); free(checksum); free(tmp); return(cnvtx); } /***************************************************************************** ******************************************************************************/ graph_t* compressGraph(graph_t* G, PORD_INT* vtxmap) { graph_t *Gc; PORD_INT *xadj, *adjncy, *vwght, *xadjGc, *adjncyGc, *vwghtGc, *perm; PORD_INT nvtx, nvtxGc, nedgesGc, u, v, i, istart, istop; nvtx = G->nvtx; xadj = G->xadj; adjncy = G->adjncy; vwght = G->vwght; /* -------------------------------------------------------------- compressed graph small enough? if so, allocate working storage -------------------------------------------------------------- */ /* avoid print statement * printf("indNodes(G, vtxmap) = %d",indNodes(G, vtxmap)); */ if ((nvtxGc = indNodes(G, vtxmap)) > COMPRESS_FRACTION * nvtx) return(NULL); mymalloc(perm, nvtx, PORD_INT); /* ----------------------------------- count edges of the compressed graph ----------------------------------- */ nedgesGc = 0; for (u = 0; u < nvtx; u++) if (vtxmap[u] == u) { istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtxmap[v] == v) nedgesGc++; } } /* --------------------------------------------------------- allocate memory for the compressed graph and construct it --------------------------------------------------------- */ Gc = newGraph(nvtxGc, nedgesGc); xadjGc = Gc->xadj; adjncyGc = Gc->adjncy; vwghtGc = Gc->vwght; nvtxGc = nedgesGc = 0; for (u = 0; u < nvtx; u++) if (vtxmap[u] == u) { istart = xadj[u]; istop = xadj[u+1]; xadjGc[nvtxGc] = nedgesGc; vwghtGc[nvtxGc] = 0; perm[u] = nvtxGc++; for (i = istart; i < istop; i++) { v = adjncy[i]; if (vtxmap[v] == v) adjncyGc[nedgesGc++] = v; } } xadjGc[nvtxGc] = nedgesGc; for (i = 0; i < nedgesGc; i++) adjncyGc[i] = perm[adjncyGc[i]]; for (u = 0; u < nvtx; u++) { vtxmap[u] = perm[vtxmap[u]]; vwghtGc[vtxmap[u]] += vwght[u]; } Gc->type = WEIGHTED; Gc->totvwght = G->totvwght; /* ---------------------- free memory and return ---------------------- */ free(perm); return(Gc); } MUMPS_5.4.1/PORD/lib/ddbisect.c0000664000175000017500000007230414102210467016170 0ustar jylexceljylexcel/***************************************************************************** / / SPACE (SPArse Cholesky Elimination) Library: ddbisect.c / / author J"urgen Schulze, University of Paderborn / created 00mar09 / / This file contains code for the construction/improvement of a vertex / separator for a domain decomposition / ****************************************************************************** Data type: struct domdec graph_t *G; pointer to graph object int ndom; number of domains int domwght; total weight of domains int *vtype; type of node (DOMAIN or MULTISEC) int *color; color of node (GRAY, BLACK, or WHITE) int cwght[3]; weights of GRAY, BLACK, WHITE partitions int *map; maps nodes to next coarser domain decomp. struct domdec *prev; pointer to previous finer domain decomp. struct domdec *next; pointer to next coarser domain decomp. Comments: o Structure holds the domain decompositions constructed by the coarsening process; it also holds the colorings of the domain decomp. computed by the refinement process o vtype[v]: represents the status of a node in the domain decomposition 0, iff status of v is unknown 1, iff v is a domain vertex 2, iff v is a multisector vertex 3, iff multisec v is eliminated and now forms a domain 4, iff multisec v is absorbed by another multisec/domain Methods in lib/ddbisect.c: - void checkDDSep(domdec_t *dd); - int findPseudoPeripheralDomain(domdec_t *dd, int domain); o returns a domain with maximal excentricity by repeated breadth first search; first bfs starts at node domain - void constructLevelSep(domdec_t *dd, int domain); o determines a vertex separator by breadth first search starting at node domain; - void initialDDSep(domdec_t *dd); o computes an initial separator for the domain decomposition dd; initially, all domains/multisecs are colored black; the function scans over all connected components of dd; it first calls findPseudoPeripheral- Domain to obtain a domain with maximal excentricity and then it calls constructLevelSep for that domain. - void updateB2W(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, int domain, int *tmp_color, int *deltaW, int *deltaB, int *deltaS); o if domain flips its color from BLACK to WHITE, all neighboring domains that share a common variable have to be updated (see my PhD thesis) - void updateW2B(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, int domain, int *tmp_color, int *deltaW, int *deltaB, int *deltaS); o if domain flips its color from WHITE to BLACK, all neighboring domains that share a common variable have to be updated (see my PhD thesis) - void improveDDSep(domdec_t *dd); o Fiducia-Mattheyses variant to improve the coloring/separator of a domain decomposition (see my PhD thesis) ******************************************************************************/ #include /* #define DEBUG */ /****************************************************************************** ******************************************************************************/ void checkDDSep(domdec_t *dd) { PORD_INT *xadj, *adjncy, *vwght, *vtype, *color, *cwght; PORD_INT nvtx, err, u, v, i, istart, istop, nBdom, nWdom; PORD_INT checkS, checkB, checkW; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; err = FALSE; printf("checking separator of domain decomposition (S %d, B %d, W %d)\n", cwght[GRAY], cwght[BLACK], cwght[WHITE]); checkS = checkB = checkW = 0; for (u = 0; u < nvtx; u++) /* check neighborhood of multisector nodes */ if (vtype[u] == 2) { nBdom = nWdom = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == BLACK) nBdom++; if (color[v] == WHITE) nWdom++; } switch(color[u]) { case GRAY: checkS += vwght[u]; if ((nBdom == 0) || (nWdom == 0)) printf("WARNING: multisec %d belongs to S, but nBdom = %d and " "nWdom = %d\n", u, nBdom, nWdom); break; case BLACK: checkB += vwght[u]; if (nWdom > 0) { printf("ERROR: black multisec %d adjacent to white domain\n", u); err = TRUE; } break; case WHITE: checkW += vwght[u]; if (nBdom > 0) { printf("ERROR: white multisec %d adjacent to black domain\n", u); err = TRUE; } break; default: printf("ERROR: multisec %d has unrecognized color %d\n", u, color[u]); err = TRUE; } } /* sum up size of white/black domains */ else /* if (vtype[u] == 1) */ switch(color[u]) { case BLACK: checkB += vwght[u]; break; case WHITE: checkW += vwght[u]; break; default: printf("ERROR: domain %d has unrecognized color %d\n", u, color[u]); err = TRUE; } /* check cwght[GRAY], cwght[BLACK], cwght[WHITE] */ if ((checkS != cwght[GRAY]) || (checkB != cwght[BLACK]) || (checkW != cwght[WHITE])) { printf("ERROR in partitioning: checkS %d (S %d), checkB %d (B %d), " "checkW %d (W %d)\n", checkS, cwght[GRAY], checkB, cwght[BLACK], checkW, cwght[WHITE]); err = TRUE; } if (err) quit(); } /***************************************************************************** ******************************************************************************/ PORD_INT findPseudoPeripheralDomain(domdec_t* dd, PORD_INT domain) { PORD_INT *xadj, *adjncy, *vtype, *level, *queue; PORD_INT nvtx, qhead, qtail, nlev, lastdomain, u, v, i, istart, istop; nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vtype = dd->vtype; /* ------------------------ allocate working storage ------------------------ */ mymalloc(level, nvtx, PORD_INT); mymalloc(queue, nvtx, PORD_INT); /* --------------------------------------- find a domain with maximal excentricity --------------------------------------- */ nlev = 0; lastdomain = domain; while (TRUE) { for (u = 0; u < nvtx; u++) level[u] = -1; queue[0] = domain; level[domain] = 0; qhead = 0; qtail = 1; while (qhead != qtail) { u = queue[qhead++]; if (vtype[u] == 1) /* remember last domain */ lastdomain = u; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (level[v] == -1) { queue[qtail++] = v; level[v] = level[u] + 1; } } } if (level[lastdomain] > nlev) { nlev = level[lastdomain]; domain = lastdomain; } else break; } /* ------------------------------- free working storage and return ------------------------------- */ free(level); free(queue); return(domain); } /***************************************************************************** *****************************************************************************/ void constructLevelSep(domdec_t* dd, PORD_INT domain) { PORD_INT *xadj, *adjncy, *vwght, *vtype, *color, *cwght; PORD_INT *queue, *deltaS, *deltaB, *deltaW; PORD_INT nvtx, bestvalue, weight, qhead, qtail, qopt, q, dS, dB, dW; PORD_INT u, v, w, i, istart, istop, j, jstart, jstop; /* ====================================================================== vtype[u]: (u domain) 1 => domain u has not been touched yet (not in queue, no color flip) -1 => domain u is in queue and its deltaS, deltaB, deltaW values have to be updated -2 => domain u is in queue and no update necessary -3 => domain u has flipped its color to black deltaS[u], deltaB[u], deltaW[u]: u domain: denotes the change in partition size, if u flips its color u multisec: deltaB/deltaW denote number of adj. black/white domains ====================================================================== */ nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; /* ------------------------------------------ allocate working storage + initializations ------------------------------------------ */ mymalloc(queue, nvtx, PORD_INT); mymalloc(deltaS, nvtx, PORD_INT); mymalloc(deltaB, nvtx, PORD_INT); mymalloc(deltaW, nvtx, PORD_INT); for (u = 0; u < nvtx; u++) { deltaS[u] = deltaB[u] = deltaW[u] = 0; if (vtype[u] == 2) deltaW[u] = xadj[u+1] - xadj[u]; } /* --------------------------------------------- build a BFS tree rooted at domain the separator is given by the level structure --------------------------------------------- */ queue[0] = domain; qhead = 0; qtail = 1; vtype[domain] = -1; while ((cwght[BLACK] < cwght[WHITE]) && (qhead != qtail)) { qopt = 0; bestvalue = MAX_INT; /* -------------------------------------------------------------------- run through queue, update domains if necessary, and find best domain -------------------------------------------------------------------- */ for (q = qhead; q < qtail; q++) { u = queue[q]; if (vtype[u] == -1) { dB = vwght[u]; dW = -dB; dS = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* color of multisec v */ weight = vwght[v]; /* is GRAY or WHITE */ if (color[v] == WHITE) { dW -= weight; dS += weight; } /* multisec will move to S */ else if (deltaW[v] == 1) { dB += weight; dS -= weight; } /* multisec will move to B */ } deltaS[u] = dS; deltaB[u] = dB; deltaW[u] = dW; vtype[u] = -2; } if (cwght[GRAY] + deltaS[u] < bestvalue) { bestvalue = cwght[GRAY] + deltaS[u]; qopt = q; } } /* ---------------------------------------------------- move best domain to head of queue and color it black ---------------------------------------------------- */ u = queue[qopt]; swap(queue[qopt], queue[qhead], v); qhead++; color[u] = BLACK; cwght[GRAY] += deltaS[u]; cwght[BLACK] += deltaB[u]; cwght[WHITE] += deltaW[u]; vtype[u] = -3; /* ------------------------------------------------------------ update all multisecs that are adjacent to domain u and check domains adjacent to the multisecs ------------------------------------------------------------ */ istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; deltaB[v]++; deltaW[v]--; if (deltaW[v] == 0) /* color of multisec v changed to BLACK */ color[v] = BLACK; else if (deltaB[v] == 1) /* color of multisec v changed to GRAY */ { color[v] = GRAY; jstart = xadj[v]; jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (vtype[w] == 1) /* a new domain enters the queue */ { queue[qtail++] = w; vtype[w] = -1; } else if (vtype[w] == -2) /* update (old) domain in queue */ vtype[w] = -1; } } else if (deltaW[v] == 1) /* color of multisec v remains GRAY for */ { jstart = xadj[v]; /* the last time */ jstop = xadj[v+1]; for (j = jstart; j < jstop; j++) { w = adjncy[j]; if (vtype[w] == -2) vtype[w] = -1; } } } } /* --------------------------- reset vtype and free memory --------------------------- */ for (i = 0; i < qtail; i++) { u = queue[i]; vtype[u] = 1; } free(queue); free(deltaS); free(deltaB); free(deltaW); } /***************************************************************************** ******************************************************************************/ void initialDDSep(domdec_t *dd) { PORD_INT *vtype, *color, *cwght; PORD_INT nvtx, totvwght, domain, u; nvtx = dd->G->nvtx; totvwght = dd->G->totvwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; /* -------------------------------------------------------- initializations (all nodes are colored white by default) -------------------------------------------------------- */ cwght[GRAY] = 0; cwght[BLACK] = 0; cwght[WHITE] = totvwght; for (u = 0; u < nvtx; u++) color[u] = WHITE; /* ---------------------------------------------------------------------- scan over connected components and create level based vertex separator ---------------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) if ((vtype[u] == 1) && (color[u] == WHITE)) { domain = findPseudoPeripheralDomain(dd, u); constructLevelSep(dd, domain); if (cwght[BLACK] >= cwght[WHITE]) break; } } /***************************************************************************** *****************************************************************************/ void updateB2W(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, PORD_INT domain, PORD_INT *tmp_color, PORD_INT *deltaW, PORD_INT *deltaB, PORD_INT *deltaS) { PORD_INT *xadj, *adjncy, *vwght, *vtype; PORD_INT weight, u, v, i, istart, istop, j, jstart, jstop; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; istart = xadj[domain]; istop = xadj[domain+1]; for (i = istart; i < istop; i++) { u = adjncy[i]; weight = vwght[u]; jstart = xadj[u]; jstop = xadj[u+1]; /* --------------------------------------------------------------- subcase (1): before flipping domain to WHITE there was only one other WHITE domain v. update deltaB[v] and deltaS[v] --------------------------------------------------------------- */ if (deltaW[u] < 0) { v = -(deltaW[u]+1); deltaW[u] = 1; #ifdef DEBUG printf(" B2W case (1): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaB[v] -= weight; deltaS[v] += weight; insertBucket(w_bucket, deltaS[v], v); } /* --------------------------------------------------------------- subcase (2): all other domains are BLACK. update deltaB, deltaS of these BLACK domains. NOTE: subcase (3) may directly follow --------------------------------------------------------------- */ if (deltaW[u] == 0) { tmp_color[u] = GRAY; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" B2W case (2): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaB[v] += weight; deltaS[v] -= weight; insertBucket(b_bucket, deltaS[v], v); } } } if (deltaB[u] < 0) deltaB[u] = 1; /* the unique BLACK dom. flipped */ deltaB[u]--; deltaW[u]++; /* ------------------------------------------------------------- subcase (3): after flipping domain to WHITE there is only one remaining BLACK domain. search it and update deltaW, deltaS furthermore, store the remaining BLACK domain in deltaB[u] ------------------------------------------------------------- */ if (deltaB[u] == 1) { for (j = jstart; j < jstop; j++) { v = adjncy[j]; if ((tmp_color[v] == BLACK) && (vtype[v] == 1)) { #ifdef DEBUG printf(" B2W case (3): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaW[v] += weight; deltaS[v] -= weight; deltaB[u] = -(v+1); insertBucket(b_bucket, deltaS[v], v); } } } /* ------------------------------------------------------------- subcase (4): after flipping domain to WHITE there is no other BLACK domain. update deltaW, deltaS of the WHITE domains ------------------------------------------------------------- */ if (deltaB[u] == 0) { tmp_color[u] = WHITE; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" B2W case (4): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaW[v] -= weight; deltaS[v] += weight; insertBucket(w_bucket, deltaS[v], v); } } } } } /***************************************************************************** *****************************************************************************/ void updateW2B(bucket_t *w_bucket, bucket_t *b_bucket, domdec_t *dd, PORD_INT domain, PORD_INT *tmp_color, PORD_INT *deltaW, PORD_INT *deltaB, PORD_INT *deltaS) { PORD_INT *xadj, *adjncy, *vwght, *vtype; PORD_INT weight, u, v, i, istart, istop, j, jstart, jstop; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; istart = xadj[domain]; istop = xadj[domain+1]; for (i = istart; i < istop; i++) { u = adjncy[i]; weight = vwght[u]; jstart = xadj[u]; jstop = xadj[u+1]; /* --------------------------------------------------------------- subcase (1): before flipping domain to BLACK there was only one other BLACK domain v. update deltaW[v] and deltaS[v] --------------------------------------------------------------- */ if (deltaB[u] < 0) { v = -(deltaB[u]+1); deltaB[u] = 1; #ifdef DEBUG printf(" W2B case (1): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaW[v] -= weight; deltaS[v] += weight; insertBucket(b_bucket, deltaS[v], v); } /* --------------------------------------------------------------- subcase (2): all other domains are WHITE. update deltaW, deltaS of these WHITE domains. NOTE: subcase (3) may directly follow --------------------------------------------------------------- */ if (deltaB[u] == 0) { tmp_color[u] = GRAY; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" W2B case (2): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaW[v] += weight; deltaS[v] -= weight; insertBucket(w_bucket, deltaS[v], v); } } } if (deltaW[u] < 0) deltaW[u] = 1; /* the unique WHITE dom. flipped */ deltaB[u]++; deltaW[u]--; /* ------------------------------------------------------------- subcase (3): after flipping domain to BLACK there is only one remaining WHITE domain. search it and update deltaB, deltaS furthermore, store the remaining WHITE domain in deltaW[u] ------------------------------------------------------------- */ if (deltaW[u] == 1) { for (j = jstart; j < jstop; j++) { v = adjncy[j]; if ((tmp_color[v] == WHITE) && (vtype[v] == 1)) { #ifdef DEBUG printf(" W2B case (3): (via multisec %d) removing domain %d from " "w_bucket\n", u, v); #endif removeBucket(w_bucket, v); deltaB[v] += weight; deltaS[v] -= weight; deltaW[u] = -(v+1); insertBucket(w_bucket, deltaS[v], v); } } } /* --------------------------------------------------------------- subcase (4): after flipping domain to BLACK there is no other WHITE domain. update deltaB, deltaS of the BLACK domains --------------------------------------------------------------- */ if (deltaW[u] == 0) { tmp_color[u] = BLACK; for (j = jstart; j < jstop; j++) { v = adjncy[j]; if (vtype[v] == 1) { #ifdef DEBUG printf(" W2B case (4): (via multisec %d) removing domain %d from " "b_bucket\n", u, v); #endif removeBucket(b_bucket, v); deltaB[v] -= weight; deltaS[v] += weight; insertBucket(b_bucket, deltaS[v], v); } } } } } /***************************************************************************** ******************************************************************************/ void improveDDSep(domdec_t *dd) { bucket_t *b_bucket, *w_bucket; PORD_INT *xadj, *adjncy, *vwght, *vtype, *color, *cwght; PORD_INT *tmp_color, *deltaS, *deltaB, *deltaW; PORD_INT nvtx, weight, tmp_S, tmp_B, tmp_W; PORD_INT pos, bestglobalpos, badflips, b_domain, w_domain, domain, nxtdomain; PORD_INT fhead, ftail, u, v, i, istart, istop; FLOAT bestglobalvalue, b_value, w_value, value; /* ====================================================================== vtype[u]: (u domain) 1 => color of domain u has not been changed < 0 => points to next domain in flipping list (fhead points to first, ftail points to last domain in list) = 0 => domain is last domain in flipping list ====================================================================== */ nvtx = dd->G->nvtx; xadj = dd->G->xadj; adjncy = dd->G->adjncy; vwght = dd->G->vwght; vtype = dd->vtype; color = dd->color; cwght = dd->cwght; mymalloc(tmp_color, nvtx, PORD_INT); mymalloc(deltaS, nvtx, PORD_INT); mymalloc(deltaB, nvtx, PORD_INT); mymalloc(deltaW, nvtx, PORD_INT); OUTER_LOOP_START: /* ---------------------------------------------------------------------- copy data of actual bisection and initialize buckets and flipping list ---------------------------------------------------------------------- */ tmp_S = cwght[GRAY]; tmp_B = cwght[BLACK]; tmp_W = cwght[WHITE]; bestglobalpos = badflips = 0; bestglobalvalue = F(tmp_S, tmp_B, tmp_W); b_bucket = setupBucket(nvtx, nvtx, (nvtx >> 1)); w_bucket = setupBucket(nvtx, nvtx, (nvtx >> 1)); fhead = 0; ftail = -1; pos = 0; /* ---------------------------------------------------------- initialize tmp_color, deltaB, and deltaW for all multisecs ---------------------------------------------------------- */ for (u = 0; u < nvtx; u++) if (vtype[u] == 2) { deltaB[u] = deltaW[u] = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; if (color[v] == BLACK) deltaB[u]++; else deltaW[u]++; } if ((deltaB[u] > 0) && (deltaW[u] > 0)) /* update multisec coloring */ tmp_color[u] = GRAY; else if (deltaB[u] > 0) tmp_color[u] = BLACK; else tmp_color[u] = WHITE; color[u] = tmp_color[u]; } /* ----------------------------------------------------------------- initialize tmp_color, deltaS,B,W for all domains and fill buckets ----------------------------------------------------------------- */ for (u = 0; u < nvtx; u++) if (vtype[u] == 1) { tmp_color[u] = color[u]; if (tmp_color[u] == BLACK) /* domain may be flipped to WHITE */ { deltaW[u] = vwght[u]; deltaB[u] = -deltaW[u]; deltaS[u] = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* tmp_color[v] e {GRAY, BLACK} */ weight = vwght[v]; if (tmp_color[v] == BLACK) /* multisec v will move into S */ { deltaB[u] -= weight; deltaS[u] += weight; } else if (deltaB[v] == 1) /* multisec v will move into W */ { deltaW[u] += weight; deltaS[u] -= weight; deltaB[v] = -(u+1); } } insertBucket(b_bucket, deltaS[u], u); } if (tmp_color[u] == WHITE) /* domain may be flipped to BLACK */ { deltaB[u] = vwght[u]; deltaW[u] = -deltaB[u]; deltaS[u] = 0; istart = xadj[u]; istop = xadj[u+1]; for (i = istart; i < istop; i++) { v = adjncy[i]; /* tmp_color[v] e {GRAY, WHITE} */ weight = vwght[v]; if (tmp_color[v] == WHITE) /* multisec v will move into S */ { deltaW[u] -= weight; deltaS[u] += weight; } else if (deltaW[v] == 1) /* multisec v will move into B */ { deltaB[u] += weight; deltaS[u] -= weight; deltaW[v] = -(u+1); } } insertBucket(w_bucket, deltaS[u], u); } } #ifdef DEBUG printf("starting inner loop: b_bucket->nobj %d, w_bucket->nobj %d\n", b_bucket->nobj, w_bucket->nobj); waitkey(); #endif INNER_LOOP_START: /* ------------------------------------------- extract best domain from b_bucket, w_bucket ------------------------------------------- */ b_value = w_value = MAX_FLOAT; if ((b_domain = minBucket(b_bucket)) != -1) { b_value = F((tmp_S+deltaS[b_domain]), (tmp_B+deltaB[b_domain]), (tmp_W+deltaW[b_domain])); #ifdef DEBUG printf("best black domain: %d, deltaS %d, deltaB %d, deltaW %d, " "cost %7.2f\n", b_domain, deltaS[b_domain], deltaB[b_domain], deltaW[b_domain], b_value); #endif } if ((w_domain = minBucket(w_bucket)) != -1) { w_value = F((tmp_S+deltaS[w_domain]), (tmp_B+deltaB[w_domain]), (tmp_W+deltaW[w_domain])); #ifdef DEBUG printf("best white domain: %d, deltaS %d, deltaB %d, deltaW %d, " "cost %7.2f\n", w_domain, deltaS[w_domain], deltaB[w_domain], deltaW[w_domain], w_value); #endif } if ((b_domain == ERR) && (w_domain == ERR)) goto INNER_LOOP_END; if (b_value + EPS < w_value) { domain = b_domain; value = b_value; removeBucket(b_bucket, domain); } else { domain = w_domain; value = w_value; removeBucket(w_bucket, domain); } #ifdef DEBUG printf(" domain %d removed from bucket\n", domain); #endif /* ------------------------------------------------------------------- flip the color of domain and put it in list of log. flipped domains ------------------------------------------------------------------- */ if (ftail != -1) vtype[ftail] = -(domain+1); /* append domain */ else fhead = -(domain+1); /* list starts with domain */ vtype[domain] = 0; /* mark end of list */ ftail = domain; /* domain is last element in list */ if (tmp_color[domain] == BLACK) { tmp_color[domain] = WHITE; updateB2W(w_bucket,b_bucket,dd,domain,tmp_color,deltaW,deltaB,deltaS); } else if (tmp_color[domain] == WHITE) { tmp_color[domain] = BLACK; updateW2B(w_bucket,b_bucket,dd,domain,tmp_color,deltaW,deltaB,deltaS); } tmp_S += deltaS[domain]; tmp_B += deltaB[domain]; tmp_W += deltaW[domain]; pos++; if (value + EPS < bestglobalvalue) { bestglobalvalue = value; bestglobalpos = pos; badflips = 0; } else badflips++; if (badflips < MAX_BAD_FLIPS) goto INNER_LOOP_START; INNER_LOOP_END: /* -------------------------------------------- end of inner loop: now do the physical flips -------------------------------------------- */ pos = 0; nxtdomain = fhead; while (nxtdomain != 0) { domain = -nxtdomain - 1; if (pos < bestglobalpos) { if (color[domain] == BLACK) color[domain] = WHITE; else color[domain] = BLACK; cwght[GRAY] += deltaS[domain]; cwght[BLACK] += deltaB[domain]; cwght[WHITE] += deltaW[domain]; pos++; } nxtdomain = vtype[domain]; vtype[domain] = 1; } /* ---------------------------------------------- partition improved => re-start the whole stuff ---------------------------------------------- */ #ifdef DEBUG printf(" INNER_LOOP_END (#pyhs. flips %d): S %d, B %d, W %d (%7.2f)\n", bestglobalpos, cwght[GRAY], cwght[BLACK], cwght[WHITE], bestglobalvalue); waitkey(); #endif /* JY: moved next instruction after the two * freeBucket instructions because * this was the cause of a memory leak. * if (bestglobalpos > 0) goto OUTER_LOOP_START; */ freeBucket(b_bucket); freeBucket(w_bucket); if (bestglobalpos > 0) goto OUTER_LOOP_START; free(tmp_color); free(deltaS); free(deltaB); free(deltaW); } MUMPS_5.4.1/ChangeLog0000664000175000017500000010343414102210467014502 0ustar jylexceljylexcel------------- = ChangeLog = ------------- Changes from 5.4.0 to 5.4.1 * Added feature to dump a matrix/rhs in binary form (see id%WRITE_PROBLEM) * Fixed error during constrained ordering (ICNTL(12)=3) leading to a segfault * Fixed type 2 assembly by pieces in case of huge blocks of delayed pivots * Avoid repeated small allocations in MUMPS_BUILD_SORT_INDEX * Fixed automatic choice for ICNTL(6) when values are not provided at analysis * Avoid an access to an unitialized value (FLOP_FRFRONTS, MPI only, LDLT) * Fixed error printing in case of error -53 * Fixed an erroneous -9 error in case of large Schur + discard factors * -DWORKAROUNDINTELILP64OPENMPLIMITATION avoids -i8 compilation warnings * Limited repeated amalgamations of large child with small parent Changes from 5.3.5 to 5.4.0 * Modified default threshold for null pivot detection (CNTL(3)) * Improved performance of Schur complement computations * Reduced memory of centralized analysis with distributed matrix * Improved BLR clustering time during analysis * Improved BLR performance when CNTL(1)=0.0 and ICNTL(36)=0 * Improved OOC performance in case CNTL(1)=0.0 or SYM=1 * Improved multitreaded performance on matrices with many 2x2 pivots * Fixed a problem with parallel compilation (in case of: make -j all) * Fixed some timings during solve that were printed as 0 when PAR=0 * Avoid possible integer overflow on INFOG(10) * Fixed type 1 assembly by pieces in case static CB moves to dynamic storage * Use with ITAC: avoid errors (e.g. in DMUMPS_UPPER_PREDICT...) due to MPI returning nonzero error codes when traces are activated * Add a JOB=-200 call (no MPI communications, clean local OOC files) * Fixed "Start processing the root ..." printing in case of Schur * Fixed SYM_PERM in case of Schur on reducible matrices Changes from 5.3.4 to 5.3.5 * Fixed 2x2 pivots bug from 5.3.4 release in MPI LDLT factorization * Fixed ICNTL(8)=-2 option during analysis (code and documentation) * Include basic fix for make -j Changes from 5.3.3 to 5.3.4 * Fixed a rare bug (segfault) related to dynamic storage management on numerically difficult matrices * Fixed a rare deadlock in BLR for symmetric matrices * Fixed an uninitialized variable (which could lead to incorrect -19 error) * Minor fix in userguide (CNTL(1) vs. ICNTL(1) in ICNTL(36) description) * Fixed a possible runtime issue during solve, related to "TO_PROCESS" array Changes from 5.3.1 to 5.3.3 * Assume ilp64 MPI interface only applies to Fortran in c_example.c * Note on gfortran-10 compilation added * Avoid intent on pointers (F2003-only) * More robust multithreading for matrix reformatting (arrowheads) * Fixed ICNTL(31) interpretation in case of repeated analysis * Fixed multiple mpif.h inclusion (distributed rhs, ifort+openmpi) * Fixed computation of effectively used memory statistics * Minor fix in userguide * Suppressed a !$OMP CRITICAL from solve phase (introduced in 5.3.0) Changes from 5.3.0 to 5.3.1 * Improved multithreaded performance of BLR backward solve * Fixed return code in build_mumps_int_def.c + openmp compilation (pgi) * Forbid a loop vectorization in [sdcz]sol_c.F (segfault with ifort) Changes from 5.2.1 to 5.3.0 * New feature: distributed right-hand sides * Improved time for arrowheads construction (single MPI case, mainly) * C interface: ability to know if MUMPS_INT is 64-bit from include file * Improved BLR performance when CNTL(1)=0.0 and ICNTL(36)=1 * Fixed INFO(34),INFO(35),INFO(37),INFO(38) on processes with rank > 0 * More portable MPI_IS_IN_PLACE feature in libseq * Fixed determinant computation when Cholesky ScaLapack is used * Information on advancement (flops done) on each MPI process * Allow rhs_sparse and irhs_sparse to be unassociated if nz_rhs=0 * Fixed INFO(30) and INFO(31) computation on MPI processes with rank > 0 * OMP collapsed loops: avoid FIRSTPRIVATE on internal loop bound (for pgi) * Fix for compilers not freeing local allocatable arrays (64-bit metis) * Fixed RINFO(5-6) and RINFOG(15-16) metrics (#entries=>#bytes) * C interface: A_ELT/SCHUR/RHS/REDRHS/RHS_loc/SOL_loc may exceed 2^31 entries * Local Schur (ICNTL(19)=2 or 3) may now exceed 2^31 entries * Fixed internal dynamic storage of blocks with more than 2^31 entries * Fixed a bug in the parallel analysis that limited scalability Changes from 5.2.0 to 5.2.1 * Fixed a minor "Internal error in CMUMPS_DM_FREEALLDYNAMICCB" * Default value of ICNTL(14) for MPI executions independent of SYM + slightly less aggressive than for 5.2.0 * Avoided accesses to uninitialized data in symmetric (2D root, BLR) * Fixed some incorrect "out" intents for routine arguments * Avoided CHUNK=0 in OMP loops even if loop not parallelized (pgi) * Fixed COLSCA&ROWSCA declarations in [SDCZ]MUMPS_ANA_F * Avoided a possible segfault in presence of NaN's in pivot search * Minor update to userguide * Fixed MPI_IN_PLACE usage in libseq (preventing compiler optimization) Changes from 5.1.2 to 5.2.0 * Memory gains due to low-rank factorization are now effective, low-rank solve * Internal dynamic storage possible in case static workspace too small * Improved distributed memory usage and MPI granularity (some sym. matrices) * Improved granularity (and performance) for symmetric matrices; ability to use [DSCZ]GEMMT kernel (BLAS extension) if available (see INSTALL) * A-1 functionality: improved performance due to solution gathering * Memory peak for analysis reduced (distributed-entry, 64-bit orderings) * Time for analysis reduced by avoiding some preprocessing (when possible) * More exploitation of RHS sparsity during forward substitution * Ability to save/restore an instance to/from disk * INFO and INFOG dimension extended from 40 to 80 * METIS_OPTIONS introduced for METIS users to define some specific Metis options * MUMPS can be asked to call omp_set_num_threads with a value provided in ICNTL(16) * Fixed: INFO(16)/INFOG(21)/INFOG(22) did not take into account the extra memory allocated due to memory allowed (ICNTL(23)>0); INFOG(8) was not correclty set * Initialize only lower-diagonal part for workers in symmetric type 2 fronts * Workaround a segfault at beg. of facto due to a gfortran-8 bug * Fixed a bug in weighted matching algorithm when all matrix values are 0 * Portability: include stdint.h instead of int_types.h * Forced some initializations to make C interface more valgrind-friendly * Workaround intel 2017 vectorization bug in pivot search (symmetric+MPI+large matrices) * Stop trying to send messages on COMM_LOAD in case of error (risk of deadlock) * Avoided most array creation by compiler due to Fortran pointers * Avoid two cases of int. overflow (KEEP(66), A-1 with large ICNTL(27)) * Fixed a bug with compressed ordering (ICNTL(12)=2) (regression from 5.0.0) and suppress compress ordering only in case of automatic setting Changes from 5.1.1 to 5.1.2 * Corrected an overestimation of memory (regression from 5.1.0) * Corrected/extended WORKAROUNDINTELILP64MPI2INTEGER mechanism (see INSTALL) * Parallel analysis: fixed a bug, limited number of MPI processes on small problems, and reverted to sequential analysis on tiny problems. This is to avoid erroneous behavior and failures in the parallel ordering tools. * Faster BLR clustering on matrices with quasi-dense rows (which are skipped) * Improved performance of solve phase on very small matrices * Solve phase with a single MPI process is more thread-safe * Fixed compilation issue with opensolaris ([SDCZ]MUMPS_TRUNCATED_RRQR) * Fixed minor bug in BLR factorization (uninitialized timer) * Corrected minor compiler warnings * Minor correction to userguide * Add -DBLR_MT in Intel example Makefile Changes from 5.1.0 to 5.1.1 * Fix in parallel analysis * Stabilization of 5.1.0: - Improved stability of Block-Low-Rank feature - Corrected an incorrect deallocation of POSINRHSCOMP_COL - Correction of a case of uninitialized data access in type 2 pivoting - Suppressed occasional debug trace "write(6,*) " KEEP265= ", KEEP265" Changes from 5.0.2 to 5.1.0 * New feature: selective 64-bit integers (introduced only where needed) to process matrices with more than 2^{31}-1 entries. -mixed 32/64 bit integers for API: NNZ/NNZ_loc 64-bit (NZ/NZ_LOC kept temporarily for backward compatibility) - both 32 or 64 bit integer versions of external orderings (Metis/ParMetis, SCOTCH/pt-SCOTCH, PORD), can be used - Error -51 when a 32-bit external ordering is invoked on a graph larger than 2^{31}-1 * New feature: (experimental) factorization based on Block-Low-Rank format, (ICNTL(35) to activate it and CNTL(7) for low-rank precision) * Improved performance on numerically hard matrices (LU and LDLt) * "-DALLOW_NON_INIT" flag has disappeared and needs no longer be used * Fixed incorrect deallocation in case of JOB=3/ICNTL(26)=1 followed by JOB=2 * Fixed compilation problem with Intel2017 + openMPI in [sdcz]ana_aux_par.F * Minor correction of memory statistics for solve * Use 64-bit integers where needed during the solve phase to enable large number of right-hand-sides (NRHS) in one block (i.e. ICNTL(27)xN can be larger than 2^{31}-1) * Improved performance of solve phase * Allow pivoting thresholds CNTL(1) equal to 1.0 * New error -52: when default Fortran integers are 64 bit, external orderings should also have 64-bit default integers * New error -22, INFO(2)=16 when IRN_loc or JCN_loc not associated while ICNTL(18) is set to 3 * Missing O_BINARY flag was added to open binary files on MINGW systems * New error -53 that could reflect a matrix structure change between analysis and factorization Changes from 5.0.1 to 5.0.2 * Suppress error on id%SCHUR_CINTERFACE in mumps_driver.F when bound check is enabled and when using 2D block cyclic Schur complement feature (ICNTL(19)=2 or 3) from C or Matlab interfaces * Problem of failed assertion in [SDCZ]MUMPS_TREAT_DESCBAND solved (static variable INODE_WAITED_FOR was not initialized and was not detected by valgrind) * Correction of very minor memory leaks and access to uninitialized data * A setting of INFO(1)=-1-17 should have been INFO(1)=-17 * Some settings of INFO(1)=-17 should have been INFO(1)=-20 * Suppress absolute tolerance 10^-20 in pivot selection for SYM=2; skip 2x2 pivot search if only 1 pivot candidate, avoid pivots that are subnormal numbers (their inverse is equal to infinity) * Warning +2 now only occurs when solution is really close to 0 * Occasional bug in OOC and multiple instances solved * Better selection of equations for bwd errors (W1 and W2) and better forward error estimates on some machines with 80-bit registers * Improved users' guide (OOC files cleaning, permutation details, usage of multithreading, clarification of MegaByte unit) * Cleaning of asynchronous messages after facto/solve was revisited and is more robust * More robust suppression of integer overflow risk during solve for huge ICNTL(23) * Improved performance of symbolic factorization in case of matrices with relatively dense rows and/or with large number of Lagrange multipliers * Improved performance of numerical factorization phase during pivot search for symmetric indefinite matrices * Use of -xcore-avx2 requires !DEC$ NOOPTIMIZE in MUMPS_BIT_GET4PROC with current versions of Intel compilers * Suppressed some temporary array creation and implicit conversions Changes from 5.0.0 to 5.0.1 * Iterative refinement convergence check corrected (problem introduced in 5.0.0) * Used communicator provided by user instead of MPI_COMM_WORLD in two places (parallel analysis only) * Matlab interface patched to avoid memory corruption in some situations (Schur, colsca/rowsca management) * Corrected a case of error not properly processed which could cause a segfault instead of a standard "-9" error, or an abort on "ERR: ERROR: NBROWS > NBROWF" * Amalgamation without fill forced for single children * (rare) segfault related to assemblies of delayed columns in scalapack root node corrected * Automatic strategy for ordering choice improved * Further improvements to userguide (mainly iterative refinement, error analysis, discard factors and forward elimination during factorization) * Error -51 also raised in case of integer overflow during parallel analysis Changes from 4.10.0 to 5.0.0 * Userguide revisited * Compatibility with Metis 5.1.0/ParMetis 4.0.3, and with SCOTCH/pt-SCOTCH 6.0 * Matlab interface updated (scaling vectors (COLSCA, ROWSCA) and A-1 feature ICNTL(30) are now available) * Improved sequential and parallel performance for computing selected entries of A-1 (ICNTL(30)) * Workspace for solve phase, of size B x N per processor (B: block size controlled by ICNTL(27)) divided by almost #procs. Default value of B increased. * Parallel symmetric indefinite elemental matrices: improved numerical behaviour * Performance of solve phase improved * Finer control of error analysis and iterative refinement (ICNTL(11)) * Memory for analysis phase (mapping) reduced. * Better support for 64-bit integers (see INSTALL file) * Error raised instead of silent integer overflow during analysis (but not during external orderings) * Improvements and corrections to parallel analysis (ICNTL(28)), deterministic graph construction forced with -DDETERMINISTIC_PARALLEL_GRAPH * Forward elimination (ICNTL(32)) can be done during factorization * Possibility to use a workspace (WK_USER, LWK_USER) allocated by user * Very occasional numerical bug in parallel out-of-core case corrected (thanks to EDF and Samtech for the validation) * More efficient processing of sparse right-hand-sides (see ICNTL(20)) * Count for entries in factors now include parallel root node * Amalgamation of the assembly tree revisited * Scaling arrays (COLSCA, ROWSCA) also returned at C interface level * OOC_NB_FILE_TYPE is part of the MUMPS structure, for a better management of multiple OOC instances * Warning +2 set only once (could lead to incorrect +4 in case of iterative refinement + error analysis) * Warning +4 has disappeared from documentation (since it was never occurring -- JCN never modified on exit) * Error code -16 now raised for the case N=0 even on distributed matrices (thanks to P. Jolivet for noticing this) * Use BLAS3 routines for efficiency even in case of BLAS2 operations (-DMUMPS_USE_BLAS2 allows the use of BLAS2 routines for such operations) * Message "problem with NIV2_FLOPS message" should no more occur (there was still an occasional problem in 4.10.0) * Improved determinant computation (ICNTL(33)) in case of singular matrix + scaling (where zero pivots are excluded) * Trace ' PANEL: INIT and force STRAT_IO=' suppressed * Some OpenMP directives added (multithreaded BLAS still needed) * Later allocation of strips of distributed fronts with improved locality * Front factorization algorithms redesigned (two levels of panels) * Null pivot (ICNTL(24)) and null space detection ICNTL(25)) improved for unsymmetric matrices * Fortran automatic arrays (e.g. in mumps_static_mapping.F) suppressed to avoid risks of stack overflows * Routine names and filenames changed Changes from 4.9.2 to 4.10.0 * Modified variable names and variable contents in Make.inc/Makefile* for Windows (Makefile.inc from an older version needs modifications, please do a diff) * Option to discard factors during factorization when not needed (ICNTL(31)) * Option to compute the determinant (ICNTL(33)) * Experimental "A-1" functionality (ICNTL(30)) * Matlab interface updated for 64-bit machines * Improved users' guide * Suppressed a memory leak occurring when Scalapack is used and user does loops on JOB=6 without JOB=-2/JOB=-1 in-between * Avoid occasional deadlock with huge values of ICNTL(14) * Avoid problem of -17 error code during solve phase * Avoid checking association of pointer arrays ISOL_loc and SOL_loc on procs with no components of solution (small problems) * Some data structures were not free at the end of the parallel analysis. Bug fixed. * Fixed unsafe test of overflow "IF (WFLG+N .LE. WFLG)" * Large Schur complements sent by blocks if ICNTL(19)=1 (but options ICNTL(19)=2 or 3 are recommended when Schur complement is large) * Corrected problem with sparse RHS + unsymmetric permutation + transpose solve (problem appeared in 4.9) * Case where ICNTL(19)=2 or 3 and small value of SIZE_SCHUR causing problems in parallel solved. * In case an error is detected, solved occasional problem of deallocating non-allocated local array PERM. * Correction in computation of matrix norm in complex arithmetic (MPI_COMPLEX was used in place of MPI_REAL in MPI_REDUCE) * Scaling works on singular matrices * Compilation problem with -i8 solved * MUMPS_INT used in OOC layer to facilitate compilation with 64 bit integers Changes from 4.9.1 to 4.9.2 * Compressed orderings (ICNTL(12)=2) are now compatible with PORD and PT-Scotch * Mapping problem on large numbers of MPI processes, leading to INFOG(1)=-135 on "special" matrices solved (problem appeared in 4.9.1) Changes from 4.9 to 4.9.1 * Balancing on the processors of both work and memory improved. In a parallel environment memory consumption should be reduced and performance improved * Modification of the amalgamation to solve both the problem of small root nodes and the problem of tiny nodes implying too many small MPI messages * Corrected bug occurring on big-endian environments when passing a 64-bit integer argument in place of 32-bit one. This was causing problems in parallel, when ScaLAPACK is used, on IBM machines. * Internal ERROR 2 in MUMPS_271 now impossible (was already not happening in practice) * Solved compiler warnings (or even errors) related to the order of the declarations of arrays and array sizes * Parallel analysis: fixed the problem due to the invocation of the size function on non-allocated pointers, corrected a bug due to initialization of pointers in the declaration statements, and improved the Makefiles * Corrected bug in the reallocation of arrays * Corrected several accesses to uninitialized variables * Internal Error (4) in OOC (MUMPS_597) no more occurs * Suppressed possible printing of "Internal WARNING 1 in CMUMPS_274" * (Minor) numerical pivoting problem in parallel LDLt solved * Estimated flops corrected when SYM=2 and Scalapack is used (because we use LU on the root node, not LDLt, in that case) * Scaling option effectively used is now returned in INFOG(33) and ICNTL(8) is no more modified by the package * INFO(25) is now correctly documented, new statistic INFO(27) added Changes from 4.8.4 to 4.9 * Parallel analysis available * Use of 64-bit integer addressing for large internal workarrays * overflow in computation of INFO(9) in out-of-core corrected * fixed Matlab and Scilab interfaces to sparse RHS functionality * time cost of analysis reduced for "optimisation" matrices * time to gather solution on processor 0 reduced and automatic copying of some routine arguments by some compilers resolved. * extern "C" added to header file mpi.h of libseq for C++ compilers * Problem with NZ_loc=0 and scaling with ifort 10 solved * Statistics about current state of the factorization produced/printed even in case of error. * Avoid using complex arrays as real workspace (complex versions) * New error code -40 (instead of -10) when SYM=1 is used and ScaLAPACK detects a negative pivot * Solved problem of "Internal error 1" in [SDCZ]MUMPS_264 and [SDCZ]MUMPS_274 * Solved undeterministic bug occurring with asynchronous OOC + panels when uninitialized memory access had value -7777 * Fixed a remaining problem with OOC filenames having more than 150 characters * Fixed some problems related to the usage of intrinsic functions inside PARAMETER statements (HP-UX compilers) * Fixed problem of explicit interface in [SDCZ]MUMPS_521 * Out-of-core strategy from 4.7.3 can be reactivated with -DOLD_OOC_NOPANEL * Message "problem with NIV2_FLOPS message" should no more occur * Avoid compilation problem with old versions of gfortran Changes from 4.8.3 to 4.8.4 * Absolute threshold criterion for null pivot detection added to CNTL(3) * Problems related to messages "Increase small buffer size ..." solved. * New option for ICNTL(8) to scale matrices. Default scaling cheaper to compute * Problem of filename clash with unsymmetric matrices on Windows platforms solved * Allow for longer filenames for temporary OOC files * Strategy to update blocksize during factorization of frontal matrices modified to avoid too large messages during pipelined factorization (that could lead to a -17 error code) * Messages corresponding to delayed pivots can now be sent in several packets. This avoids some other cases of error -17 * One rare case of deadlock solved * Corrected values and sign of INFO(8) and INFO(20) Changes from 4.8.2 to 4.8.3 * Fix compilation issues on Windows platforms * Fix ranlib issue with libseq on MacOSX platforms * Fix a few problems of uninitialized variables Changes from 4.8.1 to 4.8.2 * Problem of wrong argument in the call to [sdcz]mumps_246 solved * Limit occurrence of error -11 in the in-core case * Problem with the use of SIZE on an unassociated pointer solved * Problem with distributed solution combined with non-working host solved * Fix generation of MM matrices * Fix of a minor bug in OOC error management * Fix portability issues on usleep Changes from 4.8.0 to 4.8.1 * New distributed scaling is now on by default for distributed matrices * Error management corrected in case of 32-bit overflow during factorization * SEPARATOR is now defined as "\\" in Windows version * Bug fix in OOC panel version Changes from 4.7.3 to 4.8.0 * Parallel scalings algorithms available * Possibility to dump a matrix in matrix-market format from both C and Fortran interfaces * Correction when dumping a distributed matrix in matrix-market format * Minor numerical stability problem in some LDL^t parallel factorizations corrected. * Memory usage significantly reduced in both parallel and sequential (limit communication buffers, in-place assembly for assembled matrices, overlapping during stack). * Better alignment properties of mumps_struc.h * Reduced time for static mapping during the analysis phase. * Correction in dynamic scheduler * "Internal error 2 in DMUMPS_26" no more occurs, even if SIZE_SCHUR=0 * Corrections in the management of ICNTL(25), some useful code was protected with -Dtry_null_space and not compiled. * Scaling arrays are now declared real even in complex versions * Out-of-core functionality storing factors on disk * Possibility to tell MUMPS how much memory the package is allowed to allocate (ICNTL(23)) * Estimated and effective number of entries in factors returned to user * API change: MAXS and MAXIS have disappeared from the interface, please use ICNTL(14) and ICNTL(23) to control the memory usage * Error code -11 raised less often, especially in out-of-core executions * Error code -14 should no more occur * Memory used at the solve phase is now returned to the user * Possibility to control the blocking size for multiple right-hand sides (strong impact on performance, in particular for out-of-core executions) * Solved problems of 32-bit integer overflows during analysis related to memory estimations. * New error code -37 related to integer overflows during factorization * Compile one single arithmetic with make s, make d, make c or make z, examples are now in examples/, test/ has disappeared. * Arithmetic-independent parts are isolated into a libmumps_common.a, that must now be linked too (see examples/Makefile). Changes from 4.7.2 to 4.7.3 * detection of null pivots for unsymmetric matrices corrected * improved pivoting in parallel symmetric solver * possible problem when Schur on and out-of-core : Schur was splitted * type of parameters of intrinsic function MAX not compatible in single precision arithmetic versions. * minor changes for Windows * correction with reduced RHS functionality in parallel case Changes from 4.7.1 to 4.7.2 * negative loads suppressed in mumps distribution Changes from 4.7 to 4.7.1 * Release number in Fortran interface corrected * "Negative load !!" message replaced by a warning Changes from 4.6.4 to 4.7 * New functionality: build reduced RHS / use partial solution * New functionality: detection of zero pivots * Memory reduced (especially communication buffers) * Problem of integer overflow "MEMORY_SENT" corrected * Error code -20 used when receive buffer too small (instead of -17 in some cases) * Erroneous memory access with singular matrices (since 4.6.3) corrected * Minor bug correction in hybrid scheduler * Parallel solution step uses less memory * Performance and memory usage of solution step improved * String containing the version number now available as a component of the MUMPS structure * Case of error "-9964" has disappeared Changes from 4.6.3 to 4.6.4 * Avoid name clashes (F_INT, ...) when C interface is used and user wants to include, say, smumps_c.h, zmumps_c.h (etc.) at the same time * Avoid large array copies (by some compilers) in distributed matrix entry functionality * Default ordering less dependent on number of processors * New garbage collector for contribution blocks * Original matrix in "arrowhead form" on candidate processors only (assembled case) * Corrected bug occurring rarely, on large number of processors, and that depended on value of uninitialized data * Parallel LDL^t factorization numerically improved * Less memory allocation in mapping phase (in some cases) Changes from 4.6.2 to 4.6.3 * Reduced memory usage for symmetric matrices (compressed CB) * Reduced memory allocation for parallel executions * Scheduler parameters for parallel executions modified * Memory estimates (that were too large) corrected with 2Dcyclic Schur complement option * Portability improved (C/Fortran interfacing for strings) * The situation leading to Warning "RHS associated in MUMPS_301" no more occurs. * Parameters INFO/RINFO from the Scilab/Matlab API are now called INFOG/RINFOG in order to match the MUMPS user's guide. Changes from 4.6.1 to 4.6.2 * Metis ordering now available with Schur option * Schur functionality correctly working with Scilab interface * Occasional SIGBUS problem on single precision versions corrected Changes from 4.6 to 4.6.1 * Problem with hybrid scheduler and elemental matrix entry corrected * Improved numerical processing of symmetric matrices with quasi-dense rows * Better use of Blacs/Scalapack on processor grids smaller than MPI_COMM_WORLD * Block sizes improved for large symmetric matrices Changes from 4.5.6 to 4.6 * Official release with Scilab and Matlab interfaces available * Correction in 2x2 pivots for symmetric indefinite complex matrices * New hybrid scheduler active by default Changes from 4.5.5 to 4.5.6 * Preliminary developments for an out-of-core code (not yet available) * Improvement in parallel symmetric indefinite solver * Preliminary distribution of a SCILAB and a MATLAB interface to MUMPS. Changes from 4.5.4 to 4.5.5 * Improved tree management * Improved weighted matching preprocessing: duplicates allowed, overflow avoided, dense rows * Improved strategy for selecting default ordering * Improved node amalgamation Changes from 4.5.3 to 4.5.4 * Double complex version no more depends on double precision version. * Simplification of some complex indirections in mumps_cv.F that were causing difficultiels to some compilers. Changes from 4.5.2 to 4.5.3 * Correction of a minor problem leading to INFO(1)=-135 in some cases. Changes from 4.5.1 to 4.5.2 * correction of two uninitialized variables in proportional mapping Changes from 4.5.0 to 4.5.1 * better management of contribution messages * minor modifications in symmetric preprocessing step Changes from 4.4.0 to 4.5.0 * improved numerical features for symmetric indefinite matrices - two-by-two pivots - symmetric scaling - ordering based on compressed graph preserving two by two pivots - constrained ordering * 2D cyclic Schur better validated * problems resulting from automatic array copies done by compiler corrected * reduced memory requirement for maximum transversal features Changes from 4.3.4 to 4.4.0 * 2D block cyclic Schur complement matrix * symmetric indefinite matrices better handled * Right-hand side vectors can be sparse * Solution can be kept distributed on the processors * Metis allowed for element-entry * Parallel performance and memory usage improved: - load is updated more often for type 2 nodes - scheduling under memory constraints - reduced message sizes in symmetric case - some linear searches avoided when sending contributions * Avoid array copies in the call to the partial mapping routine (candidates); such copies appeared with intel compiler version 8.0. * Workaround MPI_AllReduce problem with booleans if mpich and MUMPS are compiled with different compilers * Reduced message sizes for CB blocks in symmetric case * Various minor improvements Changes from 4.3.3 to 4.3.4 * Copies of some large CB blocks suppressed in local assemblies from child to parent * gathering of solution optimized in solve phase Changes from 4.3.2 to 4.3.3 * Control parameters of symbolic factorization modified. * Global distribution time and arrowheads computation slightly optimized. * Multiple Right-Hand-Side implemented. Changes from 4.3.1 to 4.3.2 * Thresholds for symbolic factorization modified. * Use merge sort for candidates (faster) * User's communicator copied when entering MUMPS * Code to free CB areas factorized in various places * One array suppressed in solve phase Changes from 4.3 to 4.3.1 * Memory leaks in PORD corrected * Minor compilation problem on T3E solved * Avoid taking into account absolute criterion CNTL(3) for partial LDLt factorization when whole column is known (relative stability is enough). * Symbol MPI_WTICK removed from mpif.h * Bug wrt inertia computation INFOG(12) corrected Changes from 4.2beta to 4.3 * C INTERFACE CHANGE: comm_fortran must be defined from the calling program, since MUMPS uses a Fortran communicator (see user guide). * LAPACK library is no more required * User guide improved * Default ordering changed * Return number of negative diagonal elements in LDLt factorization (except for root node if treated in parallel) * Rank-revealing options no more available by default * Improved parallel performance - new incremental mechanism for load information - new communicator dedicated to load information - improved candidate strategy - improved management of SMP platforms * Include files can be used in both free and fixed forms * Bug fixes: - some uninitialized values - pbs with size of data on t3e - minor problems corrected with distributed matrix entry - count of negative pivots corrected - AMD for element entries - symbolic factorization - memory leak in tree reordering and in solve step * Solve step uses less memory (and should be more efficient) Changes from 4.1.6 to 4.2beta * More precisions available (single, double, complex, double complex). * Uniprocessor version available (doesn't require MPI installed) * Interface changes (Users of MUMPS 4.1.6 will have to slightly modify their codes): - MUMPS -> ZMUMPS, CMUMPS, SMUMPS, DMUMPS depending the precision - the Schur complement matrix should now be allocated by the user before the call to MUMPS - NEW: C interface available. - ICNTL(6)=6 in 4.1.6 (automatic choice) is now ICNTL(6)=7 in 4.2 * Tighter integration of new ordering packages (for assembled matrices), see the description of ICNTL(7): - AMF, - Metis, - PORD, * Memory usage decreased and memory scalability improved. * Problem when using multiple instances solved. * Various improvments and bug fixes. Changes from 4.1.4 to 4.1.6 * Modifications/Tuning done by P.Amestoy during his visit at NERSC. * Additional memory and communication statistics. * minor pbs solved. Changes from 4.0.4 to 4.1.4 * Tuning on Cray T3e (and minor debugging) * Improved strategy for asynchronous communications (irecv during factorization) * Improved Dynamic scheduling and splitting strategies * New maximal transversal strategies * New Option (default) automatic decision for scaling and maximum transversal ------------------- = Release history = ------------------- Release 5.4.1 : August 2021 Release 5.4.0 : April 2021 Release 5.3.5 : October 2020 Release 5.3.4 : September 2020 Release 5.3.3 : June 2020 Release 5.3.2[.x] : May 2020, internal/experimental Release 5.3.1 : April 2020 Release 5.3.0 : April 2020 Release 5.2.1 : June 2019 Release 5.2.0 : April 2019 Release 5.1.2 : October 2017 Release 5.1.1 : March 2017 Release 5.1.0 : Feb 2017, internal release (limited diffusion) Release 5.0.2 : July 2016 Release 5.0.1 : July 2015 Release 5.0.0 : February 2015 Release 4.10.0 : May 2011 Release 4.9.2 : November 2009 Release 4.9.1 : October 2009 Release 4.9 : July 2009 Release 4.8.4 : December 2008 Release 4.8.3 : September 2008 Release 4.8.2 : September 2008 Release 4.8.1 : August 2008 Release 4.8.0 : July 2008 Release 4.7.3 : May 2007 Release 4.7.2 : April 2007 Release 4.7.1 : April 2007 Release 4.7 : April 2007 Release 4.6.4 : January 2007 Release 4.6.3 : June 2006 Release 4.6.2 : April 2006 Release 4.6.1 : February 2006 Release 4.6 : January 2006 Release 4.5.6 : December 2005, internal release Release 4.5.5 : October 2005 Release 4.5.4 : September 2005 Release 4.5.3 : September 2005 Release 4.5.2 : September 2005 Release 4.5.1 : September 2005 Release 4.5.0 : July 2005 Releases 4.3.3 -- 4.4.3 : internal releases Release 4.3.2 : November 2003 Release 4.3.1 : October 2003 Release 4.3 : July 2003 Release 4.2 (beta) : December 2002 Release 4.1.6 : March 2000 Release 4.0.4 : Wed Sept 22, 1999 <-- Final version from PARASOL MUMPS_5.4.1/INSTALL0000664000175000017500000003576714102210467013776 0ustar jylexceljylexcel=========================================== MUMPS 5.4.1 INSTALLATION =========================================== Pre-requisites -------------- If you only want to use the sequential version, you need: -> an optimized sequential or multithreaded BLAS library -> the LAPACK library If you want to use MUMPS on a multicore machine, you need: -> a multithreaded BLAS library -> the LAPACK library -> additional gains can be expected compiling/linking with OpenMP (see userguide, sections "Combining MPI and multithreaded parallelism" and "Enabling the BLR functionality at installation") If you want to use the parallel (distributed memory MPI based) version, you need: -> MPI -> BLAS library -> BLACS library -> LAPACK and ScaLAPACK libraries For performance (time and memory issues) we very strongly recommend to install: -> SCOTCH and/or METIS for the sequential and parallel versions -> PT-SCOTCH and/or ParMetis to parallelize the analysis phase (parallel version only: ParMetis and PT-SCOTCH must be disabled for the sequential version as this would otherwise lead to undefined MPI symbols at the link phase) Installation ------------ The following steps can be applied. % tar zxvf MUMPS_5.4.1.tar.gz % cd MUMPS_5.4.1 You then need to build a file called Makefile.inc corresponding to your architecture. A few examples are available in the directory Make.inc : Makefile.debian.SEQ : default for debian systems with standard packages, sequential version Makefile.debian.PAR : default for debian systems with standard packages, parallel version Makefile.FREEBSD10.SEQ : default Makefile.inc for a FreeBSD system, sequential version. Makefile.FREEBSD10.PAR : default Makefile.inc for a FreeBSD system, parallel version. Makefile.G95.SEQ : default Makefile.inc for the G95 compiler, sequential version. Makefile.G95.PAR : default Makefile.inc for the G95 compiler, parallel version. Makefile.INTEL.SEQ : default for PC with the Intel suite (compilers and MKL), sequential. Makefile.INTEL.PAR : default for PC with the Intel suite (compilers, MPI and MKL), parallel. Makefile.NEC.SEQ : default Makefile.inc for a NEC, sequential version. Makefile.NEC.PAR : default Makefile.inc for a NEC, parallel version. Makefile.SGI.SEQ : default Makefile.inc for an Origin, sequential version. Makefile.SGI.PAR : default Makefile.inc for an Origin, parallel version. Makefile.SUN.SEQ : default Makefile.inc for a SUN, sequential version. Makefile.SUN.PAR : default Makefile.inc for a SUN, parallel version. Makefile.SP.SEQ : default for SP (32 bits), sequential version. Makefile.SP.PAR : default for SP (32 bits), parallel version. Makefile.SP64.SEQ : default for SP (64 bits), sequential version. Makefile.SP64.PAR : default for SP (64 bits), parallel version. Makefile.WIN.MS-Intel.SEQ : default for Windows with Intel compiler, sequential, with GNU make. Makefile.WIN.MS-G95.SEQ : default for Windows with g95 compiler, sequential, with GNU make. For example, a parallel version of MUMPS on a debian or ubuntu system and standard packages copy Make.inc/Makefile.debian.PAR into Makefile.inc: % cp Make.inc/Makefile.debian.PAR ./Makefile.inc However, in most cases, Makefile.inc should be adapted to fit with your architecture, libraries and compilers (see comments in the Makefile.inc.generic or Makefile.inc.generic.SEQ for details). The variables LIBBLAS (BLAS library), SCALAP (ScaLAPACK and LAPACK libraries), INCPAR (include files for MPI), LIBPAR (library files for MPI) are concerned. We also strongly recommend to install METIS and/or SCOTCH, see the ordering section of Makefile.inc. By default, only the double precision version of MUMPS will be installed. The command: % make will build the version for a specific arithmetic, where is one of 's', 'd','c','z' (for single precision real, double precision real, complex, and double complex). The command: % make all will compile versions of MUMPS for all 4 arithmetics. After issuing the command: % make all , ./lib will contain the mumps libraries libxmumps.a (with x = 'd', 'c', 's' or 'z') and libmumps_common.a. Both must be included at link time in an external program. A simple Fortran test driver in ./examples (see ./examples/README) will also be compiled as well as an example of using MUMPS from a C main program. Preprocessing constants (Makefile.inc) -------------------------------------- -DDETERMINISTIC_PARALLEL_GRAPH: When using several MPI processes, the order of the edges of the graphs constructed by MUMPS in parallel may vary between successive execuions. Ordering packages (e.g., SCOTCH, PT-SCOTCH, METIS, parMETIS) are sensitive to this order, possibly leading to different flops and memory estimates between executions. When compiling MUMPS with -DDETERMINISTIC_PARALLEL_GRAPH, the order of the edges of the graph passed to ordering packages will be identical for each run. -DMAIN_COMP: Note that some Fortran runtime libraries define the "main" symbol. This can cause problems when using MUMPS from C if Fortran is used for the link phase. One approach is to use a specific flag (such as -nofor_main for Intel ifort compiler). Another approach is to use the C linker (gcc, etc...) and add manually the Fortran runtime libraries (that should not define the symbol "main"). Finally, if the previous approaches do not work, compile the C example with "-DMAIN_COMP". This might not work well with some MPI implementations (see options in Makefiles and the FAQ page at http://mumps-solver.org). -DAdd_ , -DAdd__ and -DUPPER: These options are used for defining the calling convention from C to Fortran or Fortran to C. Some other preprocessing options correspond to default architectures and are defined in specific Makefiles. Sequential version ------------------ You can use the parallel MPI version of MUMPS on a single processor. If you only plan to use MUMPS on a uniprocessor machine, and do not want to install parallel libraries such as MPI, ScaLAPACK, etc... then it might be more convenient to use one of the Makefile..SEQ to build a sequential version of MUMPS instead of a parallel one. For that, a dummy MPI library (available in ./libseq) defining all symbols related to parallel libraries is used at the link phase. Note that you should use 'make clean' before building the MUMPS sequential library if you had previously built a parallel version. And vice versa. Compiling and linking your program with MUMPS --------------------------------------------- Basically, ./lib/lib[sdcz]mumps.a and ./lib/libmumps_common.a constitute the MUMPS library and ./include/*.h are the include files. Also, some BLAS, LAPACK, ScaLAPACK, BLACS, and MPI are needed. (Except for the sequential version where ./libseq/libmpiseq.a is used.) Please refer to the Makefile available in the directory ./examples for an example of how to link your program with MUMPS. We advise to use the same compiler alignment options for compiling your program as were used for compiling MUMPS. Otherwise some derived datatypes may not match. Using MUMPS from an existing project ------------------------------------ If you want to use MUMPS from outside the MUMPS installation directory, please make sure the ./lib/ and ./include/ directories can be accessed, and start from the Makefile.inc used at installation and the Makefile available in ./examples as models. Interface with the Metis and ParMetis orderings ----------------------------------------------- Since the release of MUMPS 4.10.0, the Metis API has changed. MUMPS 5.0 and later versions assume that Metis 5.1.0 or ParMetis 4.0.3 or later are installed, and that the newer versions of Metis/ParMetis are backward compatible with Metis 5.1.0/ParMetis 4.0.3. It is however still possible to continue using Metis versions 4.0.3 or lower by forcing the compilation flag -Dmetis4 in your Makefile.inc, and to continue using ParMetis versions 3.2.0 or lower by forcing the compilation flag -Dparmetis3. Note that Metis 5.0.3 and ParMetis 4.0.1/4.0.2 have never been supported in MUMPS. 32-bit versus 64-bit Fortran integers ------------------------------------- MUMPS uses a mix of 32-bit and 64-bit integers depending on the possible sizes of the integers that must be manipulated. Most integers at the MUMPS interface level are 32-bit integers: only NNZ and NNZ_loc are 64-bit integers, as the number of non-zeros in a matrix can exceed the 32-bit integer limit on large problems. Internally, MUMPS uses a mix of 32-bit and 64-bit integers. 64-bit integers are mainly used for data proportional to NNZ or NNZ_loc or to address large arrays. However, external libraries like BLAS, MPI, (Sca)LAPACK, can remain 32-bit. For each ordering, the user should decide at installation time if the ordering manipulates 32-bit or 64-bit indices. 64-bit integers are recommended if the number of nonzeros in the matrix becomes significant as compared to 2^31-1 - for PORD: by default, PORD is installed in a way compatible with standard integers (Fortran INTEGER). Installation of MUMPS with -DPORD_INTSIZE64 (i.e. adding the -DPORD_INTSIZE64 option to the OPTC variable from your Makefile.inc) will install PORD with 64-bit integers and MUMPS will also call PORD with 64-bit integers. Warning: if you activate or deactivate -DPORD_INTSIZE64 between two installations, the previously installed pord library should be cleaned before recompilation. This can be done with "make clean". - for METIS/parMETIS: in the file metis.h (assuming here a version of metis >= 5), it is possible to modify the line "#define IDXTYPEWIDTH 32" by "#define IDXTYPEWIDTH 64" in order to use 64-bit integers for indices (see comments in metis.h for more information). MUMPS will then check the value of IDXTYPE in metis.h in order to call METIS with integer parameters of the correct datatype. - for scotch/pt-SCOTCH: in scotch.h, you can compile SCOTCH either with -DINTSIZE32 (default) or with -DINTSIZE64, in order to process large graphs. MUMPS will then check the size of a SCOTCH integer in scotch.h in order to call SCOTCH with integer parameters of the correct datatype Finally, it is possible to force all integers to be 64-bit at installation. This can be useful, if, for example, MUMPS is called from an environment where all integers are 64-bit. This approach relies: i) on a Fortran compiler flag (e.g., -i8, -fdefault-integer-8, or something else, depending on your compiler) that should be added in the OPTF variable from the Makefile.inc corresponding to your local configuration. ii) on forcing a 64-bit default integer in C code, by adding the -DINTSIZE64 option to the OPTC variable from your Makefile.inc (remark that this option will also force an installation of PORD with 64-bit integers, since PORD installation is based on the same OPTC variable) iii) on the fact that all external libraries called by MUMPS should use 64-bit integers. In particular, all external orderings must have been compiled with 64-bit integers as we have not developed 64-bit to 32-bit wrappers. Furthermore: - for the MPI-free version, METIS, SCOTCH, BLAS, LAPACK should thus also rely on 64-bit integers. - for the MPI version, one also needs an MPI (and ScaLAPACK) implementation where all integers are 64-bit (both MPI_INTEGER and counts). Remark that for this latter point, Intel provides an ilp64 version of MPI where integers (counts, MPI_INTEGER, ...) are 64-bit. However, in the MPI versions we have tested, MPI_2INTEGER which could be expected to be 128-bit in that case is only 64-bit, see Intel documentation. In order to have MUMPS working correcly with such MPI versions, please try adding -DWORKAROUNDINTELILP64MPI2INTEGER to the OPTF variable of your Makefile.inc - The OpenMP runtime library should also rely on 64-bit integers. Adding -DWORKAROUNDINTELILP64OPENMPLIMITATION to the OPTF variable from the file Makefile.inc will use 32-bit integers during OpenMP calls and avoid warnings in an Intel environment. When including MUMPS headers files from a C application, one can check at compilation time the preprocessing constants MUMPS_INTSIZE32 and MUMPS_INTSIZE64 (see include/mumps_int_def.h generated during the build process and include/mumps_c_types.h) in order to see how MUMPS_INT was defined. At runtime, one can simply check sizeof(MUMPS_INT). Using BLAS extension GEMMT -------------------------- If the BLAS library includes the GEMMT level-3 BLAS extension, we strongly recommend to use it. -DGEMMT_AVAILABLE should then be added to the OPTF variable of your Makefile.inc. This can significantly improve the performance of the factorization of symmetric matrices. To be compatible, the GEMMT signature should be the same as the one described at https://software.intel.com/en-us/mkl-developer-reference-fortran-gemmt. Platform and software dependencies ---------------------------------- Versions of MUMPS have been tested on a large range of platforms. MUMPS is potentially portable to any platform having a C and Fortran 90 compiler as well as MPI, BLACS, and ScaLAPACK installed. * WINDOWS ------- Although the MUMPS development team is not using Windows, you may be interested by discussions on this topic in the archives of MUMPS users, or by links to contributions from users (see the MUMPS website, and follow "Links"). * FREEBSD AND SOLARIS ------------------- Under FreeBSD and Solaris, please check that the spaces are kept after the definition of commands. For example, use AR = ar -vr "" to force keeping the space after ar -vr See the example Makefile.FREEBSD10 in the Make.inc/ directory. Note that the absence of space in the main Makefile is motivated by portability on Windows environments. * gfortran-10 ----------- For MUMPS to compile with gfortran-10, the option '-fallow-argument-mismatch' should be added to OPTF in your Makefile.inc * MAC OSX ------- Dominique Orban has developed a Homebrew formula for MUMPS. Please check the "Links" page at http://mumps-solver.org and http://brew.sh * IBM SP ------ On SP machines, use of PESSL, BLACS, MPI and ESSL is made. Note that MUMPS requires PESSL release 2 or greater. The version of MUMPS based on PESSL release 1.1 (that used descriptors of size 8) is no longer available. If PESSL release 2 is not available on your system, the public domain version of ScaLAPACK should be used instead. PESSL usually does not include single precision versions of the ScaLAPACK routines required by MUMPS. If the single precision or single complex versions of MUMPS are needed, then ScaLAPACK should then be used in place of PESSL. * LAM --- lam version 6.5.6 or greater is required for the double complex version of MUMPS to work correctly. * MPICH ----- The double complex version does not work correctly with MPICH2 v 1.0.3, due to truncated messages when using double complex types. * CRAY ---- On the CRAY, we recommend to link with the standard BLACS library from netlib, based on MPI. We observed problems (deadlock) when using the CRAY BLACS in host-node mode or when MUMPS is used on a subcommunicator of MPI_COMM_WORLD of more than 1 processor.